diff --git a/HsVersions.h b/HsVersions.h
new file mode 100644
--- /dev/null
+++ b/HsVersions.h
@@ -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 */
+
diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -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.
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/Unique.h b/Unique.h
new file mode 100644
--- /dev/null
+++ b/Unique.h
@@ -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
diff --git a/autogen/CodeGen.Platform.hs b/autogen/CodeGen.Platform.hs
new file mode 100644
--- /dev/null
+++ b/autogen/CodeGen.Platform.hs
@@ -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
+
diff --git a/autogen/Config.hs b/autogen/Config.hs
new file mode 100644
--- /dev/null
+++ b/autogen/Config.hs
@@ -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
diff --git a/autogen/GHCConstantsHaskellExports.hs b/autogen/GHCConstantsHaskellExports.hs
new file mode 100644
--- /dev/null
+++ b/autogen/GHCConstantsHaskellExports.hs
@@ -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,
diff --git a/autogen/GHCConstantsHaskellType.hs b/autogen/GHCConstantsHaskellType.hs
new file mode 100644
--- /dev/null
+++ b/autogen/GHCConstantsHaskellType.hs
@@ -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
diff --git a/autogen/GHCConstantsHaskellWrappers.hs b/autogen/GHCConstantsHaskellWrappers.hs
new file mode 100644
--- /dev/null
+++ b/autogen/GHCConstantsHaskellWrappers.hs
@@ -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))
diff --git a/autogen/ghc_boot_platform.h b/autogen/ghc_boot_platform.h
new file mode 100644
--- /dev/null
+++ b/autogen/ghc_boot_platform.h
@@ -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__ */
diff --git a/autogen/primop-can-fail.hs-incl b/autogen/primop-can-fail.hs-incl
new file mode 100644
--- /dev/null
+++ b/autogen/primop-can-fail.hs-incl
@@ -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
diff --git a/autogen/primop-code-size.hs-incl b/autogen/primop-code-size.hs-incl
new file mode 100644
--- /dev/null
+++ b/autogen/primop-code-size.hs-incl
@@ -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
diff --git a/autogen/primop-commutable.hs-incl b/autogen/primop-commutable.hs-incl
new file mode 100644
--- /dev/null
+++ b/autogen/primop-commutable.hs-incl
@@ -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
diff --git a/autogen/primop-data-decl.hs-incl b/autogen/primop-data-decl.hs-incl
new file mode 100644
--- /dev/null
+++ b/autogen/primop-data-decl.hs-incl
@@ -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
diff --git a/autogen/primop-fixity.hs-incl b/autogen/primop-fixity.hs-incl
new file mode 100644
--- /dev/null
+++ b/autogen/primop-fixity.hs-incl
@@ -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
diff --git a/autogen/primop-has-side-effects.hs-incl b/autogen/primop-has-side-effects.hs-incl
new file mode 100644
--- /dev/null
+++ b/autogen/primop-has-side-effects.hs-incl
@@ -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
diff --git a/autogen/primop-list.hs-incl b/autogen/primop-list.hs-incl
new file mode 100644
--- /dev/null
+++ b/autogen/primop-list.hs-incl
@@ -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
+ ]
diff --git a/autogen/primop-out-of-line.hs-incl b/autogen/primop-out-of-line.hs-incl
new file mode 100644
--- /dev/null
+++ b/autogen/primop-out-of-line.hs-incl
@@ -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
diff --git a/autogen/primop-primop-info.hs-incl b/autogen/primop-primop-info.hs-incl
new file mode 100644
--- /dev/null
+++ b/autogen/primop-primop-info.hs-incl
@@ -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)
diff --git a/autogen/primop-strictness.hs-incl b/autogen/primop-strictness.hs-incl
new file mode 100644
--- /dev/null
+++ b/autogen/primop-strictness.hs-incl
@@ -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
diff --git a/autogen/primop-tag.hs-incl b/autogen/primop-tag.hs-incl
new file mode 100644
--- /dev/null
+++ b/autogen/primop-tag.hs-incl
@@ -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
diff --git a/autogen/primop-vector-tycons.hs-incl b/autogen/primop-vector-tycons.hs-incl
new file mode 100644
--- /dev/null
+++ b/autogen/primop-vector-tycons.hs-incl
@@ -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
diff --git a/autogen/primop-vector-tys-exports.hs-incl b/autogen/primop-vector-tys-exports.hs-incl
new file mode 100644
--- /dev/null
+++ b/autogen/primop-vector-tys-exports.hs-incl
@@ -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,
diff --git a/autogen/primop-vector-tys.hs-incl b/autogen/primop-vector-tys.hs-incl
new file mode 100644
--- /dev/null
+++ b/autogen/primop-vector-tys.hs-incl
@@ -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)
diff --git a/autogen/primop-vector-uniques.hs-incl b/autogen/primop-vector-uniques.hs-incl
new file mode 100644
--- /dev/null
+++ b/autogen/primop-vector-uniques.hs-incl
@@ -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
diff --git a/backpack/BkpSyn.hs b/backpack/BkpSyn.hs
new file mode 100644
--- /dev/null
+++ b/backpack/BkpSyn.hs
@@ -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
diff --git a/backpack/DriverBkp.hs b/backpack/DriverBkp.hs
new file mode 100644
--- /dev/null
+++ b/backpack/DriverBkp.hs
@@ -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=]@ in a
+-- unit file, return the 'UnitId' corresponding to @p[A=]@.
+-- The @include_sigs@ parameter controls whether or not we also
+-- include @dependency signature@ declarations in this calculation.
+--
+-- Invariant: this NEVER returns InstalledUnitId.
+hsunitDeps :: Bool {- include sigs -} -> HsUnit HsComponentId -> [(UnitId, ModRenaming)]
+hsunitDeps include_sigs unit = concatMap get_dep (hsunitBody unit)
+ where
+ get_dep (L _ (IncludeD (IncludeDecl (L _ hsuid) mb_lrn is_sig)))
+ | include_sigs || not is_sig = [(convertHsUnitId hsuid, go mb_lrn)]
+ | otherwise = []
+ where
+ go Nothing = ModRenaming True []
+ go (Just lrns) = ModRenaming False (map convRn lrns)
+ where
+ convRn (L _ (Renaming (L _ from) Nothing)) = (from, from)
+ convRn (L _ (Renaming (L _ from) (Just (L _ to)))) = (from, to)
+ get_dep _ = []
+
+buildUnit :: SessionType -> ComponentId -> [(ModuleName, Module)] -> LHsUnit HsComponentId -> BkpM ()
+buildUnit session cid insts lunit = do
+ -- NB: include signature dependencies ONLY when typechecking.
+ -- If we're compiling, it's not necessary to recursively
+ -- compile a signature since it isn't going to produce
+ -- any object files.
+ let deps_w_rns = hsunitDeps (session == TcSession) (unLoc lunit)
+ raw_deps = map fst deps_w_rns
+ dflags <- getDynFlags
+ -- The compilation dependencies are just the appropriately filled
+ -- in unit IDs which must be compiled before we can compile.
+ let hsubst = listToUFM insts
+ deps0 = map (renameHoleUnitId dflags hsubst) raw_deps
+
+ -- Build dependencies OR make sure they make sense. BUT NOTE,
+ -- we can only check the ones that are fully filled; the rest
+ -- we have to defer until we've typechecked our local signature.
+ -- TODO: work this into GhcMake!!
+ forM_ (zip [1..] deps0) $ \(i, dep) ->
+ case session of
+ TcSession -> return ()
+ _ -> compileInclude (length deps0) (i, dep)
+
+ dflags <- getDynFlags
+ -- IMPROVE IT
+ let deps = map (improveUnitId (getPackageConfigMap dflags)) deps0
+
+ mb_old_eps <- case session of
+ TcSession -> fmap Just getEpsGhc
+ _ -> return Nothing
+
+ conf <- withBkpSession cid insts deps_w_rns session $ do
+
+ dflags <- getDynFlags
+ mod_graph <- hsunitModuleGraph dflags (unLoc lunit)
+ -- pprTrace "mod_graph" (ppr mod_graph) $ return ()
+
+ msg <- mkBackpackMsg
+ ok <- load' LoadAllTargets (Just msg) mod_graph
+ when (failed ok) (liftIO $ exitWith (ExitFailure 1))
+
+ let hi_dir = expectJust (panic "hiDir Backpack") $ hiDir dflags
+ export_mod ms = (ms_mod_name ms, ms_mod ms)
+ -- Export everything!
+ mods = [ export_mod ms | ms <- mod_graph, ms_hsc_src ms == HsSrcFile ]
+
+ -- Compile relevant only
+ hsc_env <- getSession
+ let home_mod_infos = eltsUDFM (hsc_HPT hsc_env)
+ linkables = map (expectJust "bkp link" . hm_linkable)
+ . filter ((==HsSrcFile) . mi_hsc_src . hm_iface)
+ $ home_mod_infos
+ getOfiles (LM _ _ us) = map nameOfObject (filter isObject us)
+ obj_files = concatMap getOfiles linkables
+
+ let compat_fs = (case cid of ComponentId fs -> fs)
+ compat_pn = PackageName compat_fs
+
+ return InstalledPackageInfo {
+ -- Stub data
+ abiHash = "",
+ sourcePackageId = SourcePackageId compat_fs,
+ packageName = compat_pn,
+ packageVersion = makeVersion [0],
+ unitId = toInstalledUnitId (thisPackage dflags),
+ sourceLibName = Nothing,
+ componentId = cid,
+ instantiatedWith = insts,
+ -- Slight inefficiency here haha
+ exposedModules = map (\(m,n) -> (m,Just n)) mods,
+ hiddenModules = [], -- TODO: doc only
+ depends = case session of
+ -- Technically, we should state that we depend
+ -- on all the indefinite libraries we used to
+ -- typecheck this. However, this field isn't
+ -- really used for anything, so we leave it
+ -- blank for now.
+ TcSession -> []
+ _ -> map (toInstalledUnitId . unwireUnitId dflags)
+ $ deps ++ [ moduleUnitId mod
+ | (_, mod) <- insts
+ , not (isHoleModule mod) ],
+ abiDepends = [],
+ ldOptions = case session of
+ TcSession -> []
+ _ -> obj_files,
+ importDirs = [ hi_dir ],
+ exposed = False,
+ indefinite = case session of
+ TcSession -> True
+ _ -> False,
+ -- nope
+ hsLibraries = [],
+ extraLibraries = [],
+ extraGHCiLibraries = [],
+ libraryDynDirs = [],
+ libraryDirs = [],
+ frameworks = [],
+ frameworkDirs = [],
+ ccOptions = [],
+ includes = [],
+ includeDirs = [],
+ haddockInterfaces = [],
+ haddockHTMLs = [],
+ trusted = False
+ }
+
+
+ addPackage conf
+ case mb_old_eps of
+ Just old_eps -> updateEpsGhc_ (const old_eps)
+ _ -> return ()
+
+compileExe :: LHsUnit HsComponentId -> BkpM ()
+compileExe lunit = do
+ msgUnitId mainUnitId
+ let deps_w_rns = hsunitDeps False (unLoc lunit)
+ deps = map fst deps_w_rns
+ -- no renaming necessary
+ forM_ (zip [1..] deps) $ \(i, dep) ->
+ compileInclude (length deps) (i, dep)
+ withBkpExeSession deps_w_rns $ do
+ dflags <- getDynFlags
+ mod_graph <- hsunitModuleGraph dflags (unLoc lunit)
+ msg <- mkBackpackMsg
+ ok <- load' LoadAllTargets (Just msg) mod_graph
+ when (failed ok) (liftIO $ exitWith (ExitFailure 1))
+
+addPackage :: GhcMonad m => PackageConfig -> m ()
+addPackage pkg = do
+ dflags0 <- GHC.getSessionDynFlags
+ case pkgDatabase dflags0 of
+ Nothing -> panic "addPackage: called too early"
+ Just pkgs -> do let dflags = dflags0 { pkgDatabase =
+ Just (pkgs ++ [("(in memory " ++ showSDoc dflags0 (ppr (unitId pkg)) ++ ")", [pkg])]) }
+ _ <- GHC.setSessionDynFlags dflags
+ -- By this time, the global ref has probably already
+ -- been forced, in which case doing this isn't actually
+ -- going to do you any good.
+ -- dflags <- GHC.getSessionDynFlags
+ -- liftIO $ setUnsafeGlobalDynFlags dflags
+ return ()
+
+-- Precondition: UnitId is NOT InstalledUnitId
+compileInclude :: Int -> (Int, UnitId) -> BkpM ()
+compileInclude n (i, uid) = do
+ hsc_env <- getSession
+ let dflags = hsc_dflags hsc_env
+ msgInclude (i, n) uid
+ -- Check if we've compiled it already
+ case lookupPackage dflags uid of
+ Nothing -> do
+ case splitUnitIdInsts uid of
+ (_, Just indef) ->
+ innerBkpM $ compileUnit (indefUnitIdComponentId indef)
+ (indefUnitIdInsts indef)
+ _ -> return ()
+ Just _ -> return ()
+
+-- ----------------------------------------------------------------------------
+-- Backpack monad
+
+-- | Backpack monad is a 'GhcMonad' which also maintains a little extra state
+-- beyond the 'Session', c.f. 'BkpEnv'.
+type BkpM = IOEnv BkpEnv
+
+-- | Backpack environment. NB: this has a 'Session' and not an 'HscEnv',
+-- because we are going to update the 'HscEnv' as we go.
+data BkpEnv
+ = BkpEnv {
+ -- | The session
+ bkp_session :: Session,
+ -- | The filename of the bkp file we're compiling
+ bkp_filename :: FilePath,
+ -- | Table of source units which we know how to compile
+ bkp_table :: Map ComponentId (LHsUnit HsComponentId),
+ -- | When a package we are compiling includes another package
+ -- which has not been compiled, we bump the level and compile
+ -- that.
+ bkp_level :: Int
+ }
+
+-- Blah, to get rid of the default instance for IOEnv
+-- TODO: just make a proper new monad for BkpM, rather than use IOEnv
+instance {-# OVERLAPPING #-} HasDynFlags BkpM where
+ getDynFlags = fmap hsc_dflags getSession
+
+instance GhcMonad BkpM where
+ getSession = do
+ Session s <- fmap bkp_session getEnv
+ readMutVar s
+ setSession hsc_env = do
+ Session s <- fmap bkp_session getEnv
+ writeMutVar s hsc_env
+
+-- | Get the current 'BkpEnv'.
+getBkpEnv :: BkpM BkpEnv
+getBkpEnv = getEnv
+
+-- | Get the nesting level, when recursively compiling modules.
+getBkpLevel :: BkpM Int
+getBkpLevel = bkp_level `fmap` getBkpEnv
+
+-- | Apply a function on 'DynFlags' on an 'HscEnv'
+overHscDynFlags :: (DynFlags -> DynFlags) -> HscEnv -> HscEnv
+overHscDynFlags f hsc_env = hsc_env { hsc_dflags = f (hsc_dflags hsc_env) }
+
+-- | Run a 'BkpM' computation, with the nesting level bumped one.
+innerBkpM :: BkpM a -> BkpM a
+innerBkpM do_this = do
+ -- NB: withTempSession mutates, so we don't have to worry
+ -- about bkp_session being stale.
+ updEnv (\env -> env { bkp_level = bkp_level env + 1 }) do_this
+
+-- | Update the EPS from a 'GhcMonad'. TODO move to appropriate library spot.
+updateEpsGhc_ :: GhcMonad m => (ExternalPackageState -> ExternalPackageState) -> m ()
+updateEpsGhc_ f = do
+ hsc_env <- getSession
+ liftIO $ atomicModifyIORef' (hsc_EPS hsc_env) (\x -> (f x, ()))
+
+-- | Get the EPS from a 'GhcMonad'.
+getEpsGhc :: GhcMonad m => m ExternalPackageState
+getEpsGhc = do
+ hsc_env <- getSession
+ liftIO $ readIORef (hsc_EPS hsc_env)
+
+-- | Run 'BkpM' in 'Ghc'.
+initBkpM :: FilePath -> [LHsUnit HsComponentId] -> BkpM a -> Ghc a
+initBkpM file bkp m = do
+ reifyGhc $ \session -> do
+ let env = BkpEnv {
+ bkp_session = session,
+ bkp_table = Map.fromList [(hsComponentId (unLoc (hsunitName (unLoc u))), u) | u <- bkp],
+ bkp_filename = file,
+ bkp_level = 0
+ }
+ runIOEnv env m
+
+-- ----------------------------------------------------------------------------
+-- Messaging
+
+-- | Print a compilation progress message, but with indentation according
+-- to @level@ (for nested compilation).
+backpackProgressMsg :: Int -> DynFlags -> String -> IO ()
+backpackProgressMsg level dflags msg =
+ compilationProgressMsg dflags $ replicate (level * 2) ' ' ++ msg
+
+-- | Creates a 'Messager' for Backpack compilation; this is basically
+-- a carbon copy of 'batchMsg' but calling 'backpackProgressMsg', which
+-- handles indentation.
+mkBackpackMsg :: BkpM Messager
+mkBackpackMsg = do
+ level <- getBkpLevel
+ return $ \hsc_env mod_index recomp mod_summary ->
+ let dflags = hsc_dflags hsc_env
+ showMsg msg reason =
+ backpackProgressMsg level dflags $
+ showModuleIndex mod_index ++
+ msg ++ showModMsg dflags (hscTarget dflags)
+ (recompileRequired recomp) mod_summary
+ ++ reason
+ in case recomp of
+ MustCompile -> showMsg "Compiling " ""
+ UpToDate
+ | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg "Skipping " ""
+ | otherwise -> return ()
+ RecompBecause reason -> showMsg "Compiling " (" [" ++ reason ++ "]")
+
+-- | 'PprStyle' for Backpack messages; here we usually want the module to
+-- be qualified (so we can tell how it was instantiated.) But we try not
+-- to qualify packages so we can use simple names for them.
+backpackStyle :: DynFlags -> PprStyle
+backpackStyle dflags =
+ mkUserStyle dflags
+ (QueryQualify neverQualifyNames
+ alwaysQualifyModules
+ neverQualifyPackages) AllTheWay
+
+-- | Message when we initially process a Backpack unit.
+msgTopPackage :: (Int,Int) -> HsComponentId -> BkpM ()
+msgTopPackage (i,n) (HsComponentId (PackageName fs_pn) _) = do
+ dflags <- getDynFlags
+ level <- getBkpLevel
+ liftIO . backpackProgressMsg level dflags
+ $ showModuleIndex (i, n) ++ "Processing " ++ unpackFS fs_pn
+
+-- | Message when we instantiate a Backpack unit.
+msgUnitId :: UnitId -> BkpM ()
+msgUnitId pk = do
+ dflags <- getDynFlags
+ level <- getBkpLevel
+ liftIO . backpackProgressMsg level dflags
+ $ "Instantiating " ++ renderWithStyle dflags (ppr pk)
+ (backpackStyle dflags)
+
+-- | Message when we include a Backpack unit.
+msgInclude :: (Int,Int) -> UnitId -> BkpM ()
+msgInclude (i,n) uid = do
+ dflags <- getDynFlags
+ level <- getBkpLevel
+ liftIO . backpackProgressMsg level dflags
+ $ showModuleIndex (i, n) ++ "Including " ++
+ renderWithStyle dflags (ppr uid) (backpackStyle dflags)
+
+-- ----------------------------------------------------------------------------
+-- Conversion from PackageName to HsComponentId
+
+type PackageNameMap a = Map PackageName a
+
+-- For now, something really simple, since we're not actually going
+-- to use this for anything
+unitDefines :: LHsUnit PackageName -> (PackageName, HsComponentId)
+unitDefines (L _ HsUnit{ hsunitName = L _ pn@(PackageName fs) })
+ = (pn, HsComponentId pn (ComponentId fs))
+
+packageNameMap :: [LHsUnit PackageName] -> PackageNameMap HsComponentId
+packageNameMap units = Map.fromList (map unitDefines units)
+
+renameHsUnits :: DynFlags -> PackageNameMap HsComponentId -> [LHsUnit PackageName] -> [LHsUnit HsComponentId]
+renameHsUnits dflags m units = map (fmap renameHsUnit) units
+ where
+
+ renamePackageName :: PackageName -> HsComponentId
+ renamePackageName pn =
+ case Map.lookup pn m of
+ Nothing ->
+ case lookupPackageName dflags pn of
+ Nothing -> error "no package name"
+ Just cid -> HsComponentId pn cid
+ Just hscid -> hscid
+
+ renameHsUnit :: HsUnit PackageName -> HsUnit HsComponentId
+ renameHsUnit u =
+ HsUnit {
+ hsunitName = fmap renamePackageName (hsunitName u),
+ hsunitBody = map (fmap renameHsUnitDecl) (hsunitBody u)
+ }
+
+ renameHsUnitDecl :: HsUnitDecl PackageName -> HsUnitDecl HsComponentId
+ renameHsUnitDecl (DeclD a b c) = DeclD a b c
+ renameHsUnitDecl (IncludeD idecl) =
+ IncludeD IncludeDecl {
+ idUnitId = fmap renameHsUnitId (idUnitId idecl),
+ idModRenaming = idModRenaming idecl,
+ idSignatureInclude = idSignatureInclude idecl
+ }
+
+ renameHsUnitId :: HsUnitId PackageName -> HsUnitId HsComponentId
+ renameHsUnitId (HsUnitId ln subst)
+ = HsUnitId (fmap renamePackageName ln) (map (fmap renameHsModuleSubst) subst)
+
+ renameHsModuleSubst :: HsModuleSubst PackageName -> HsModuleSubst HsComponentId
+ renameHsModuleSubst (lk, lm)
+ = (lk, fmap renameHsModuleId lm)
+
+ renameHsModuleId :: HsModuleId PackageName -> HsModuleId HsComponentId
+ renameHsModuleId (HsModuleVar lm) = HsModuleVar lm
+ renameHsModuleId (HsModuleId luid lm) = HsModuleId (fmap renameHsUnitId luid) lm
+
+convertHsUnitId :: HsUnitId HsComponentId -> UnitId
+convertHsUnitId (HsUnitId (L _ hscid) subst)
+ = newUnitId (hsComponentId hscid) (map (convertHsModuleSubst . unLoc) subst)
+
+convertHsModuleSubst :: HsModuleSubst HsComponentId -> (ModuleName, Module)
+convertHsModuleSubst (L _ modname, L _ m) = (modname, convertHsModuleId m)
+
+convertHsModuleId :: HsModuleId HsComponentId -> Module
+convertHsModuleId (HsModuleVar (L _ modname)) = mkHoleModule modname
+convertHsModuleId (HsModuleId (L _ hsuid) (L _ modname)) = mkModule (convertHsUnitId hsuid) modname
+
+
+
+{-
+************************************************************************
+* *
+ Module graph construction
+* *
+************************************************************************
+-}
+
+-- | This is our version of GhcMake.downsweep, but with a few modifications:
+--
+-- 1. Every module is required to be mentioned, so we don't do any funny
+-- business with targets or recursively grabbing dependencies. (We
+-- could support this in principle).
+-- 2. We support inline modules, whose summary we have to synthesize ourself.
+--
+-- We don't bother trying to support GhcMake for now, it's more trouble
+-- than it's worth for inline modules.
+hsunitModuleGraph :: DynFlags -> HsUnit HsComponentId -> BkpM ModuleGraph
+hsunitModuleGraph dflags unit = do
+ let decls = hsunitBody unit
+ pn = hsPackageName (unLoc (hsunitName unit))
+
+ -- 1. Create a HsSrcFile/HsigFile summary for every
+ -- explicitly mentioned module/signature.
+ let get_decl (L _ (DeclD dt lmodname mb_hsmod)) = do
+ let hsc_src = case dt of
+ ModuleD -> HsSrcFile
+ SignatureD -> HsigFile
+ Just `fmap` summariseDecl pn hsc_src lmodname mb_hsmod
+ get_decl _ = return Nothing
+ nodes <- catMaybes `fmap` mapM get_decl decls
+
+ -- 2. For each hole which does not already have an hsig file,
+ -- create an "empty" hsig file to induce compilation for the
+ -- requirement.
+ let node_map = Map.fromList [ ((ms_mod_name n, ms_hsc_src n == HsigFile), n)
+ | n <- nodes ]
+ req_nodes <- fmap catMaybes . forM (thisUnitIdInsts dflags) $ \(mod_name, _) ->
+ let has_local = Map.member (mod_name, True) node_map
+ in if has_local
+ then return Nothing
+ else fmap Just $ summariseRequirement pn mod_name
+
+ -- 3. Return the kaboodle
+ return (nodes ++ req_nodes)
+
+summariseRequirement :: PackageName -> ModuleName -> BkpM ModSummary
+summariseRequirement pn mod_name = do
+ hsc_env <- getSession
+ let dflags = hsc_dflags hsc_env
+
+ let PackageName pn_fs = pn
+ location <- liftIO $ mkHomeModLocation2 dflags mod_name
+ (unpackFS pn_fs moduleNameSlashes mod_name) "hsig"
+
+ env <- getBkpEnv
+ time <- liftIO $ getModificationUTCTime (bkp_filename env)
+ hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file location)
+ let loc = srcLocSpan (mkSrcLoc (mkFastString (bkp_filename env)) 1 1)
+
+ mod <- liftIO $ addHomeModuleToFinder hsc_env mod_name location
+
+ extra_sig_imports <- liftIO $ findExtraSigImports hsc_env HsigFile mod_name
+
+ return ModSummary {
+ ms_mod = mod,
+ ms_hsc_src = HsigFile,
+ ms_location = location,
+ ms_hs_date = time,
+ ms_obj_date = Nothing,
+ ms_iface_date = hi_timestamp,
+ ms_srcimps = [],
+ ms_textual_imps = extra_sig_imports,
+ ms_parsed_mod = Just (HsParsedModule {
+ hpm_module = L loc (HsModule {
+ hsmodName = Just (L loc mod_name),
+ hsmodExports = Nothing,
+ hsmodImports = [],
+ hsmodDecls = [],
+ hsmodDeprecMessage = Nothing,
+ hsmodHaddockModHeader = Nothing
+ }),
+ hpm_src_files = [],
+ hpm_annotations = (Map.empty, Map.empty)
+ }),
+ ms_hspp_file = "", -- none, it came inline
+ ms_hspp_opts = dflags,
+ ms_hspp_buf = Nothing
+ }
+
+summariseDecl :: PackageName
+ -> HscSource
+ -> Located ModuleName
+ -> Maybe (Located (HsModule RdrName))
+ -> BkpM ModSummary
+summariseDecl pn hsc_src (L _ modname) (Just hsmod) = hsModuleToModSummary pn hsc_src modname hsmod
+summariseDecl _pn hsc_src lmodname@(L loc modname) Nothing
+ = do hsc_env <- getSession
+ let dflags = hsc_dflags hsc_env
+ -- TODO: this looks for modules in the wrong place
+ r <- liftIO $ summariseModule hsc_env
+ Map.empty -- GHC API recomp not supported
+ (hscSourceToIsBoot hsc_src)
+ lmodname
+ True -- Target lets you disallow, but not here
+ Nothing -- GHC API buffer support not supported
+ [] -- No exclusions
+ case r of
+ Nothing -> throwOneError (mkPlainErrMsg dflags loc (text "module" <+> ppr modname <+> text "was not found"))
+ Just (Left err) -> throwOneError err
+ Just (Right summary) -> return summary
+
+-- | Up until now, GHC has assumed a single compilation target per source file.
+-- Backpack files with inline modules break this model, since a single file
+-- may generate multiple output files. How do we decide to name these files?
+-- Should there only be one output file? This function our current heuristic,
+-- which is we make a "fake" module and use that.
+hsModuleToModSummary :: PackageName
+ -> HscSource
+ -> ModuleName
+ -> Located (HsModule RdrName)
+ -> BkpM ModSummary
+hsModuleToModSummary pn hsc_src modname
+ hsmod = do
+ let imps = hsmodImports (unLoc hsmod)
+ loc = getLoc hsmod
+ hsc_env <- getSession
+ -- Sort of the same deal as in DriverPipeline's getLocation
+ -- Use the PACKAGE NAME to find the location
+ let PackageName unit_fs = pn
+ dflags = hsc_dflags hsc_env
+ -- Unfortunately, we have to define a "fake" location in
+ -- order to appease the various code which uses the file
+ -- name to figure out where to put, e.g. object files.
+ -- To add insult to injury, we don't even actually use
+ -- these filenames to figure out where the hi files go.
+ -- A travesty!
+ location0 <- liftIO $ mkHomeModLocation2 dflags modname
+ (unpackFS unit_fs
+ moduleNameSlashes modname)
+ (case hsc_src of
+ HsigFile -> "hsig"
+ HsBootFile -> "hs-boot"
+ HsSrcFile -> "hs")
+ -- DANGEROUS: bootifying can POISON the module finder cache
+ let location = case hsc_src of
+ HsBootFile -> addBootSuffixLocn location0
+ _ -> location0
+ -- This duplicates a pile of logic in GhcMake
+ env <- getBkpEnv
+ time <- liftIO $ getModificationUTCTime (bkp_filename env)
+ hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file location)
+
+ -- Also copied from 'getImports'
+ let (src_idecls, ord_idecls) = partition (ideclSource.unLoc) imps
+
+ -- GHC.Prim doesn't exist physically, so don't go looking for it.
+ ordinary_imps = filter ((/= moduleName gHC_PRIM) . unLoc . ideclName . unLoc)
+ ord_idecls
+
+ implicit_prelude = xopt LangExt.ImplicitPrelude dflags
+ implicit_imports = mkPrelImports modname loc
+ implicit_prelude imps
+ convImport (L _ i) = (fmap sl_fs (ideclPkgQual i), ideclName i)
+
+ extra_sig_imports <- liftIO $ findExtraSigImports hsc_env hsc_src modname
+
+ let normal_imports = map convImport (implicit_imports ++ ordinary_imps)
+ required_by_imports <- liftIO $ implicitRequirements hsc_env normal_imports
+
+ -- So that Finder can find it, even though it doesn't exist...
+ this_mod <- liftIO $ addHomeModuleToFinder hsc_env modname location
+ return ModSummary {
+ ms_mod = this_mod,
+ ms_hsc_src = hsc_src,
+ ms_location = location,
+ ms_hspp_file = (case hiDir dflags of
+ Nothing -> ""
+ Just d -> d) ".." moduleNameSlashes modname <.> "hi",
+ ms_hspp_opts = dflags,
+ ms_hspp_buf = Nothing,
+ ms_srcimps = map convImport src_idecls,
+ ms_textual_imps = normal_imports
+ -- We have to do something special here:
+ -- due to merging, requirements may end up with
+ -- extra imports
+ ++ extra_sig_imports
+ ++ required_by_imports,
+ -- This is our hack to get the parse tree to the right spot
+ ms_parsed_mod = Just (HsParsedModule {
+ hpm_module = hsmod,
+ hpm_src_files = [], -- TODO if we preprocessed it
+ hpm_annotations = (Map.empty, Map.empty) -- BOGUS
+ }),
+ ms_hs_date = time,
+ ms_obj_date = Nothing, -- TODO do this, but problem: hi_timestamp is BOGUS
+ ms_iface_date = hi_timestamp
+ }
+
+-- | Create a new, externally provided hashed unit id from
+-- a hash.
+newInstalledUnitId :: ComponentId -> Maybe FastString -> InstalledUnitId
+newInstalledUnitId (ComponentId cid_fs) (Just fs)
+ = InstalledUnitId (cid_fs `appendFS` mkFastString "+" `appendFS` fs)
+newInstalledUnitId (ComponentId cid_fs) Nothing
+ = InstalledUnitId cid_fs
diff --git a/backpack/NameShape.hs b/backpack/NameShape.hs
new file mode 100644
--- /dev/null
+++ b/backpack/NameShape.hs
@@ -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 , given an export N of the form
+-- M.n or {m'.n} (where n is an OccName), the induced name
+-- substitution is from {m.n} to N. So, for example, if we have
+-- A=impl:B, and the exports of impl:B are impl:B.f and
+-- impl:C.g, then our name substitution is {A.f} to impl:B.f
+-- and {A.g} to impl:C.g
+
+
+
+
+-- The 'NameShape' type is defined in TcRnTypes, because TcRnTypes
+-- needs to refer to NameShape, and having TcRnTypes import
+-- NameShape (even by SOURCE) would cause a large number of
+-- modules to be pulled into the DynFlags cycle.
+{-
+data NameShape = NameShape {
+ ns_mod_name :: ModuleName,
+ ns_exports :: [AvailInfo],
+ ns_map :: OccEnv Name
+ }
+-}
+
+-- NB: substitution functions need 'HscEnv' since they need the name cache
+-- to allocate new names if we change the 'Module' of a 'Name'
+
+-- | Create an empty 'NameShape' (i.e., the renaming that
+-- would occur with an implementing module with no exports)
+-- for a specific hole @mod_name@.
+emptyNameShape :: ModuleName -> NameShape
+emptyNameShape mod_name = NameShape mod_name [] emptyOccEnv
+
+-- | Create a 'NameShape' corresponding to an implementing
+-- module for the hole @mod_name@ that exports a list of 'AvailInfo's.
+mkNameShape :: ModuleName -> [AvailInfo] -> NameShape
+mkNameShape mod_name as =
+ NameShape mod_name as $ mkOccEnv $ do
+ a <- as
+ n <- availName a : availNamesWithSelectors a
+ return (occName n, n)
+
+-- | Given an existing 'NameShape', merge it with a list of 'AvailInfo's
+-- with Backpack style mix-in linking. This is used solely when merging
+-- signatures together: we successively merge the exports of each
+-- signature until we have the final, full exports of the merged signature.
+--
+-- What makes this operation nontrivial is what we are supposed to do when
+-- we want to merge in an export for M.T when we already have an existing
+-- export {H.T}. What should happen in this case is that {H.T} should be
+-- unified with @M.T@: we've determined a more *precise* identity for the
+-- export at 'OccName' @T@.
+--
+-- Note that we don't do unrestricted unification: only name holes from
+-- @ns_mod_name ns@ are flexible. This is because we have a much more
+-- restricted notion of shaping than in Backpack'14: we do shaping
+-- *as* we do type-checking. Thus, once we shape a signature, its
+-- exports are *final* and we're not allowed to refine them further,
+extendNameShape :: HscEnv -> NameShape -> [AvailInfo] -> IO (Either SDoc NameShape)
+extendNameShape hsc_env ns as =
+ case uAvailInfos (ns_mod_name ns) (ns_exports ns) as of
+ Left err -> return (Left err)
+ Right nsubst -> do
+ as1 <- mapM (liftIO . substNameAvailInfo hsc_env nsubst) (ns_exports ns)
+ as2 <- mapM (liftIO . substNameAvailInfo hsc_env nsubst) as
+ let new_avails = mergeAvails as1 as2
+ return . Right $ ns {
+ ns_exports = new_avails,
+ -- TODO: stop repeatedly rebuilding the OccEnv
+ ns_map = mkOccEnv $ do
+ a <- new_avails
+ n <- availName a : availNames a
+ return (occName n, n)
+ }
+
+-- | The export list associated with this 'NameShape' (i.e., what
+-- the exports of an implementing module which induces this 'NameShape'
+-- would be.)
+nameShapeExports :: NameShape -> [AvailInfo]
+nameShapeExports = ns_exports
+
+-- | Given a 'Name', substitute it according to the 'NameShape' implied
+-- substitution, i.e. map @{A.T}@ to @M.T@, if the implementing module
+-- exports @M.T@.
+substNameShape :: NameShape -> Name -> Name
+substNameShape ns n | nameModule n == ns_module ns
+ , Just n' <- lookupOccEnv (ns_map ns) (occName n)
+ = n'
+ | otherwise
+ = n
+
+-- | Like 'substNameShape', but returns @Nothing@ if no substitution
+-- works.
+maybeSubstNameShape :: NameShape -> Name -> Maybe Name
+maybeSubstNameShape ns n
+ | nameModule n == ns_module ns
+ = lookupOccEnv (ns_map ns) (occName n)
+ | otherwise
+ = Nothing
+
+-- | The 'Module' of any 'Name's a 'NameShape' has action over.
+ns_module :: NameShape -> Module
+ns_module = mkHoleModule . ns_mod_name
+
+{-
+************************************************************************
+* *
+ Name substitutions
+* *
+************************************************************************
+-}
+
+-- | Substitution on @{A.T}@. We enforce the invariant that the
+-- 'nameModule' of keys of this map have 'moduleUnitId' @hole@
+-- (meaning that if we have a hole substitution, the keys of the map
+-- are never affected.) Alternately, this is isomorphic to
+-- @Map ('ModuleName', 'OccName') 'Name'@.
+type ShNameSubst = NameEnv Name
+
+-- NB: In this module, we actually only ever construct 'ShNameSubst'
+-- at a single 'ModuleName'. But 'ShNameSubst' is more convenient to
+-- work with.
+
+-- | Substitute names in a 'Name'.
+substName :: ShNameSubst -> Name -> Name
+substName env n | Just n' <- lookupNameEnv env n = n'
+ | otherwise = n
+
+-- | Substitute names in an 'AvailInfo'. This has special behavior
+-- for type constructors, where it is sufficient to substitute the 'availName'
+-- to induce a substitution on 'availNames'.
+substNameAvailInfo :: HscEnv -> ShNameSubst -> AvailInfo -> IO AvailInfo
+substNameAvailInfo _ env (Avail n) = return (Avail (substName env n))
+substNameAvailInfo hsc_env env (AvailTC n ns fs) =
+ let mb_mod = fmap nameModule (lookupNameEnv env n)
+ in AvailTC (substName env n)
+ <$> mapM (initIfaceLoad hsc_env . setNameModule mb_mod) ns
+ <*> mapM (setNameFieldSelector hsc_env mb_mod) fs
+
+-- | Set the 'Module' of a 'FieldSelector'
+setNameFieldSelector :: HscEnv -> Maybe Module -> FieldLabel -> IO FieldLabel
+setNameFieldSelector _ Nothing f = return f
+setNameFieldSelector hsc_env mb_mod (FieldLabel l b sel) = do
+ sel' <- initIfaceLoad hsc_env $ setNameModule mb_mod sel
+ return (FieldLabel l b sel')
+
+{-
+************************************************************************
+* *
+ AvailInfo merging
+* *
+************************************************************************
+-}
+
+-- | Merges to 'AvailInfo' lists together, assuming the 'AvailInfo's have
+-- already been unified ('uAvailInfos').
+mergeAvails :: [AvailInfo] -> [AvailInfo] -> [AvailInfo]
+mergeAvails as1 as2 =
+ let mkNE as = mkNameEnv [(availName a, a) | a <- as]
+ in nameEnvElts (plusNameEnv_C plusAvail (mkNE as1) (mkNE as2))
+
+{-
+************************************************************************
+* *
+ AvailInfo unification
+* *
+************************************************************************
+-}
+
+-- | Unify two lists of 'AvailInfo's, given an existing substitution @subst@,
+-- with only name holes from @flexi@ unifiable (all other name holes rigid.)
+uAvailInfos :: ModuleName -> [AvailInfo] -> [AvailInfo] -> Either SDoc ShNameSubst
+uAvailInfos flexi as1 as2 = -- pprTrace "uAvailInfos" (ppr as1 $$ ppr as2) $
+ let mkOE as = listToUFM $ do a <- as
+ n <- availNames a
+ return (nameOccName n, a)
+ in foldM (\subst (a1, a2) -> uAvailInfo flexi subst a1 a2) emptyNameEnv
+ (eltsUFM (intersectUFM_C (,) (mkOE as1) (mkOE as2)))
+ -- Edward: I have to say, this is pretty clever.
+
+-- | Unify two 'AvailInfo's, given an existing substitution @subst@,
+-- with only name holes from @flexi@ unifiable (all other name holes rigid.)
+uAvailInfo :: ModuleName -> ShNameSubst -> AvailInfo -> AvailInfo
+ -> Either SDoc ShNameSubst
+uAvailInfo flexi subst (Avail n1) (Avail n2) = uName flexi subst n1 n2
+uAvailInfo flexi subst (AvailTC n1 _ _) (AvailTC n2 _ _) = uName flexi subst n1 n2
+uAvailInfo _ _ a1 a2 = Left $ text "While merging export lists, could not combine"
+ <+> ppr a1 <+> text "with" <+> ppr a2
+ <+> parens (text "one is a type, the other is a plain identifier")
+
+-- | Unify two 'Name's, given an existing substitution @subst@,
+-- with only name holes from @flexi@ unifiable (all other name holes rigid.)
+uName :: ModuleName -> ShNameSubst -> Name -> Name -> Either SDoc ShNameSubst
+uName flexi subst n1 n2
+ | n1 == n2 = Right subst
+ | isFlexi n1 = uHoleName flexi subst n1 n2
+ | isFlexi n2 = uHoleName flexi subst n2 n1
+ | otherwise = Left (text "While merging export lists, could not unify"
+ <+> ppr n1 <+> text "with" <+> ppr n2 $$ extra)
+ where
+ isFlexi n = isHoleName n && moduleName (nameModule n) == flexi
+ extra | isHoleName n1 || isHoleName n2
+ = text "Neither name variable originates from the current signature."
+ | otherwise
+ = empty
+
+-- | Unify a name @h@ which 'isHoleName' with another name, given an existing
+-- substitution @subst@, with only name holes from @flexi@ unifiable (all
+-- other name holes rigid.)
+uHoleName :: ModuleName -> ShNameSubst -> Name {- hole name -} -> Name
+ -> Either SDoc ShNameSubst
+uHoleName flexi subst h n =
+ ASSERT( isHoleName h )
+ case lookupNameEnv subst h of
+ Just n' -> uName flexi subst n' n
+ -- Do a quick check if the other name is substituted.
+ Nothing | Just n' <- lookupNameEnv subst n ->
+ ASSERT( isHoleName n ) uName flexi subst h n'
+ | otherwise ->
+ Right (extendNameEnv subst h n)
diff --git a/backpack/RnModIface.hs b/backpack/RnModIface.hs
new file mode 100644
--- /dev/null
+++ b/backpack/RnModIface.hs
@@ -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=]:B. We need a *specific* ModIface, e.g.
+-- p[A=q():A]:B (or maybe even p[A=]:B) which we load
+-- up (either to merge it, or to just use during typechecking).
+--
+-- Suppose we have:
+--
+-- p[A=]:M ==> p[A=q():A]:M
+--
+-- Substitute all occurrences of with q():A (renameHoleModule).
+-- Then, for any Name of form {A.T}, replace the Name with
+-- the Name according to the exports of the implementing module.
+-- This works even for p[A=]:M, since we just read in the
+-- exports of B.hi, which is assumed to be ready now.
+--
+-- This function takes an optional 'NameShape', which can be used
+-- to further refine the identities in this interface: suppose
+-- we read a declaration for {H.T} but we actually know that this
+-- should be Foo.T; then we'll also rename this (this is used
+-- when loading an interface to merge it into a requirement.)
+rnModIface :: HscEnv -> [(ModuleName, Module)] -> Maybe NameShape
+ -> ModIface -> IO (Either ErrorMessages ModIface)
+rnModIface hsc_env insts nsubst iface = do
+ initRnIface hsc_env iface insts nsubst $ do
+ mod <- rnModule (mi_module iface)
+ sig_of <- case mi_sig_of iface of
+ Nothing -> return Nothing
+ Just x -> fmap Just (rnModule x)
+ exports <- mapM rnAvailInfo (mi_exports iface)
+ decls <- mapM rnIfaceDecl' (mi_decls iface)
+ insts <- mapM rnIfaceClsInst (mi_insts iface)
+ fams <- mapM rnIfaceFamInst (mi_fam_insts iface)
+ deps <- rnDependencies (mi_deps iface)
+ -- TODO:
+ -- mi_rules
+ -- mi_vect_info (LOW PRIORITY)
+ return iface { mi_module = mod
+ , mi_sig_of = sig_of
+ , mi_insts = insts
+ , mi_fam_insts = fams
+ , mi_exports = exports
+ , mi_decls = decls
+ , mi_deps = deps }
+
+-- | Rename just the exports of a 'ModIface'. Useful when we're doing
+-- shaping prior to signature merging.
+rnModExports :: HscEnv -> [(ModuleName, Module)] -> ModIface -> IO (Either ErrorMessages [AvailInfo])
+rnModExports hsc_env insts iface
+ = initRnIface hsc_env iface insts Nothing
+ $ mapM rnAvailInfo (mi_exports iface)
+
+rnDependencies :: Rename Dependencies
+rnDependencies deps = do
+ orphs <- rnDepModules dep_orphs deps
+ finsts <- rnDepModules dep_finsts deps
+ return deps { dep_orphs = orphs, dep_finsts = finsts }
+
+rnDepModules :: (Dependencies -> [Module]) -> Dependencies -> ShIfM [Module]
+rnDepModules sel deps = do
+ hsc_env <- getTopEnv
+ hmap <- getHoleSubst
+ -- NB: It's not necessary to test if we're doing signature renaming,
+ -- because ModIface will never contain module reference for itself
+ -- in these dependencies.
+ fmap (nubSort . concat) . T.forM (sel deps) $ \mod -> do
+ dflags <- getDynFlags
+ let mod' = renameHoleModule dflags hmap mod
+ iface <- liftIO . initIfaceCheck (text "rnDepModule") hsc_env
+ $ loadSysInterface (text "rnDepModule") mod'
+ return (mod' : sel (mi_deps iface))
+
+{-
+************************************************************************
+* *
+ ModIface substitution
+* *
+************************************************************************
+-}
+
+-- | Run a computation in the 'ShIfM' monad.
+initRnIface :: HscEnv -> ModIface -> [(ModuleName, Module)] -> Maybe NameShape
+ -> ShIfM a -> IO (Either ErrorMessages a)
+initRnIface hsc_env iface insts nsubst do_this = do
+ errs_var <- newIORef emptyBag
+ let dflags = hsc_dflags hsc_env
+ hsubst = listToUFM insts
+ rn_mod = renameHoleModule dflags hsubst
+ env = ShIfEnv {
+ sh_if_module = rn_mod (mi_module iface),
+ sh_if_semantic_module = rn_mod (mi_semantic_module iface),
+ sh_if_hole_subst = listToUFM insts,
+ sh_if_shape = nsubst,
+ sh_if_errs = errs_var
+ }
+ -- Modeled off of 'initTc'
+ res <- initTcRnIf 'c' hsc_env env () $ tryM do_this
+ msgs <- readIORef errs_var
+ case res of
+ Left _ -> return (Left msgs)
+ Right r | not (isEmptyBag msgs) -> return (Left msgs)
+ | otherwise -> return (Right r)
+
+-- | Environment for 'ShIfM' monads.
+data ShIfEnv = ShIfEnv {
+ -- What we are renaming the ModIface to. It assumed that
+ -- the original mi_module of the ModIface is
+ -- @generalizeModule (mi_module iface)@.
+ sh_if_module :: Module,
+ -- The semantic module that we are renaming to
+ sh_if_semantic_module :: Module,
+ -- Cached hole substitution, e.g.
+ -- @sh_if_hole_subst == listToUFM . unitIdInsts . moduleUnitId . sh_if_module@
+ sh_if_hole_subst :: ShHoleSubst,
+ -- An optional name substitution to be applied when renaming
+ -- the names in the interface. If this is 'Nothing', then
+ -- we just load the target interface and look at the export
+ -- list to determine the renaming.
+ sh_if_shape :: Maybe NameShape,
+ -- Mutable reference to keep track of errors (similar to 'tcl_errs')
+ sh_if_errs :: IORef ErrorMessages
+ }
+
+getHoleSubst :: ShIfM ShHoleSubst
+getHoleSubst = fmap sh_if_hole_subst getGblEnv
+
+type ShIfM = TcRnIf ShIfEnv ()
+type Rename a = a -> ShIfM a
+
+
+rnModule :: Rename Module
+rnModule mod = do
+ hmap <- getHoleSubst
+ dflags <- getDynFlags
+ return (renameHoleModule dflags hmap mod)
+
+rnAvailInfo :: Rename AvailInfo
+rnAvailInfo (Avail n) = Avail <$> rnIfaceGlobal n
+rnAvailInfo (AvailTC n ns fs) = do
+ -- Why don't we rnIfaceGlobal the availName itself? It may not
+ -- actually be exported by the module it putatively is from, in
+ -- which case we won't be able to tell what the name actually
+ -- is. But for the availNames they MUST be exported, so they
+ -- will rename fine.
+ ns' <- mapM rnIfaceGlobal ns
+ fs' <- mapM rnFieldLabel fs
+ case ns' ++ map flSelector fs' of
+ [] -> panic "rnAvailInfoEmpty AvailInfo"
+ (rep:rest) -> ASSERT2( all ((== nameModule rep) . nameModule) rest, ppr rep $$ hcat (map ppr rest) ) do
+ n' <- setNameModule (Just (nameModule rep)) n
+ return (AvailTC n' ns' fs')
+
+rnFieldLabel :: Rename FieldLabel
+rnFieldLabel (FieldLabel l b sel) = do
+ sel' <- rnIfaceGlobal sel
+ return (FieldLabel l b sel')
+
+
+
+
+-- | The key function. This gets called on every Name embedded
+-- inside a ModIface. Our job is to take a Name from some
+-- generalized unit ID p[A=, B=], and change
+-- it to the correct name for a (partially) instantiated unit
+-- ID, e.g. p[A=q[]:A, B=].
+--
+-- There are two important things to do:
+--
+-- If a hole is substituted with a real module implementation,
+-- we need to look at that actual implementation to determine what
+-- the true identity of this name should be. We'll do this by
+-- loading that module's interface and looking at the mi_exports.
+--
+-- However, there is one special exception: when we are loading
+-- the interface of a requirement. In this case, we may not have
+-- the "implementing" interface, because we are reading this
+-- interface precisely to "merge it in".
+--
+-- External case:
+-- p[A=]:A (and thisUnitId is something else)
+-- We are loading this in order to determine B.hi! So
+-- don't load B.hi to find the exports.
+--
+-- Local case:
+-- p[A=]:A (and thisUnitId is p[A=])
+-- This should not happen, because the rename is not necessary
+-- in this case, but if it does we shouldn't load A.hi!
+--
+-- Compare me with 'tcIfaceGlobal'!
+
+-- In effect, this function needs compute the name substitution on the
+-- fly. What it has is the name that we would like to substitute.
+-- If the name is not a hole name {M.x} (e.g. isHoleModule) then
+-- no renaming can take place (although the inner hole structure must
+-- be updated to account for the hole module renaming.)
+rnIfaceGlobal :: Name -> ShIfM Name
+rnIfaceGlobal n = do
+ hsc_env <- getTopEnv
+ let dflags = hsc_dflags hsc_env
+ iface_semantic_mod <- fmap sh_if_semantic_module getGblEnv
+ mb_nsubst <- fmap sh_if_shape getGblEnv
+ hmap <- getHoleSubst
+ let m = nameModule n
+ m' = renameHoleModule dflags hmap m
+ case () of
+ -- Did we encounter {A.T} while renaming p[A=]:A? If so,
+ -- do NOT assume B.hi is available.
+ -- In this case, rename {A.T} to {B.T} but don't look up exports.
+ _ | m' == iface_semantic_mod
+ , isHoleModule m'
+ -- NB: this could be Nothing for computeExports, we have
+ -- nothing to say.
+ -> do n' <- setNameModule (Just m') n
+ case mb_nsubst of
+ Nothing -> return n'
+ Just nsubst ->
+ case maybeSubstNameShape nsubst n' of
+ -- TODO: would love to have context
+ -- TODO: This will give an unpleasant message if n'
+ -- is a constructor; then we'll suggest adding T
+ -- but it won't work.
+ Nothing -> failWithRn $ vcat [
+ text "The identifier" <+> ppr (occName n') <+>
+ text "does not exist in the local signature.",
+ parens (text "Try adding it to the export list of the hsig file.")
+ ]
+ Just n'' -> return n''
+ -- Fastpath: we are renaming p[H=]:A.T, in which case the
+ -- export list is irrelevant.
+ | not (isHoleModule m)
+ -> setNameModule (Just m') n
+ -- The substitution was from to p[]:A.
+ -- But this does not mean {A.T} goes to p[]:A.T:
+ -- p[]:A may reexport T from somewhere else. Do the name
+ -- substitution. Furthermore, we need
+ -- to make sure we pick the accurate name NOW,
+ -- or we might accidentally reject a merge.
+ | otherwise
+ -> do -- Make sure we look up the local interface if substitution
+ -- went from to .
+ let m'' = if isHoleModule m'
+ -- Pull out the local guy!!
+ then mkModule (thisPackage dflags) (moduleName m')
+ else m'
+ iface <- liftIO . initIfaceCheck (text "rnIfaceGlobal") hsc_env
+ $ loadSysInterface (text "rnIfaceGlobal") m''
+ let nsubst = mkNameShape (moduleName m) (mi_exports iface)
+ case maybeSubstNameShape nsubst n of
+ Nothing -> failWithRn $ vcat [
+ text "The identifier" <+> ppr (occName n) <+>
+ -- NB: report m' because it's more user-friendly
+ text "does not exist in the signature for" <+> ppr m',
+ parens (text "Try adding it to the export list in that hsig file.")
+ ]
+ Just n' -> return n'
+
+-- | Rename an implicit name, e.g., a DFun or coercion axiom.
+-- Here is where we ensure that DFuns have the correct module as described in
+-- Note [rnIfaceNeverExported].
+rnIfaceNeverExported :: Name -> ShIfM Name
+rnIfaceNeverExported name = do
+ hmap <- getHoleSubst
+ dflags <- getDynFlags
+ iface_semantic_mod <- fmap sh_if_semantic_module getGblEnv
+ let m = renameHoleModule dflags hmap $ nameModule name
+ -- Doublecheck that this DFun/coercion axiom was, indeed, locally defined.
+ MASSERT2( iface_semantic_mod == m, ppr iface_semantic_mod <+> ppr m )
+ setNameModule (Just m) name
+
+-- Note [rnIfaceNeverExported]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- For the high-level overview, see
+-- Note [Handling never-exported TyThings under Backpack]
+--
+-- When we see a reference to an entity that was defined in a signature,
+-- 'rnIfaceGlobal' relies on the identifier in question being part of the
+-- exports of the implementing 'ModIface', so that we can use the exports to
+-- decide how to rename the identifier. Unfortunately, references to 'DFun's
+-- and 'CoAxiom's will run into trouble under this strategy, because they are
+-- never exported.
+--
+-- Let us consider first what should happen in the absence of promotion. In
+-- this setting, a reference to a 'DFun' or a 'CoAxiom' can only occur inside
+-- the signature *that is defining it* (as there are no Core terms in
+-- typechecked-only interface files, there's no way for a reference to occur
+-- besides from the defining 'ClsInst' or closed type family). Thus,
+-- it doesn't really matter what names we give the DFun/CoAxiom, as long
+-- as it's consistent between the declaration site and the use site.
+--
+-- We have to make sure that these bogus names don't get propagated,
+-- but it is fine: see Note [Signature merging DFuns] for the fixups
+-- to the names we do before writing out the merged interface.
+-- (It's even easier for instantiation, since the DFuns all get
+-- dropped entirely; the instances are reexported implicitly.)
+--
+-- Unfortunately, this strategy is not enough in the presence of promotion
+-- (see bug #13149), where modules which import the signature may make
+-- reference to their coercions. It's not altogether clear how to
+-- fix this case, but it is definitely a bug!
+
+-- PILES AND PILES OF BOILERPLATE
+
+-- | Rename an 'IfaceClsInst', with special handling for an associated
+-- dictionary function.
+rnIfaceClsInst :: Rename IfaceClsInst
+rnIfaceClsInst cls_inst = do
+ n <- rnIfaceGlobal (ifInstCls cls_inst)
+ tys <- mapM rnMaybeIfaceTyCon (ifInstTys cls_inst)
+
+ dfun <- rnIfaceNeverExported (ifDFun cls_inst)
+ return cls_inst { ifInstCls = n
+ , ifInstTys = tys
+ , ifDFun = dfun
+ }
+
+rnMaybeIfaceTyCon :: Rename (Maybe IfaceTyCon)
+rnMaybeIfaceTyCon Nothing = return Nothing
+rnMaybeIfaceTyCon (Just tc) = Just <$> rnIfaceTyCon tc
+
+rnIfaceFamInst :: Rename IfaceFamInst
+rnIfaceFamInst d = do
+ fam <- rnIfaceGlobal (ifFamInstFam d)
+ tys <- mapM rnMaybeIfaceTyCon (ifFamInstTys d)
+ axiom <- rnIfaceGlobal (ifFamInstAxiom d)
+ return d { ifFamInstFam = fam, ifFamInstTys = tys, ifFamInstAxiom = axiom }
+
+rnIfaceDecl' :: Rename (Fingerprint, IfaceDecl)
+rnIfaceDecl' (fp, decl) = (,) fp <$> rnIfaceDecl decl
+
+rnIfaceDecl :: Rename IfaceDecl
+rnIfaceDecl d@IfaceId{} = do
+ name <- case ifIdDetails d of
+ IfDFunId -> rnIfaceNeverExported (ifName d)
+ _ | isDefaultMethodOcc (occName (ifName d))
+ -> rnIfaceNeverExported (ifName d)
+ -- Typeable bindings. See Note [Grand plan for Typeable].
+ _ | isTypeableBindOcc (occName (ifName d))
+ -> rnIfaceNeverExported (ifName d)
+ | otherwise -> rnIfaceGlobal (ifName d)
+ ty <- rnIfaceType (ifType d)
+ details <- rnIfaceIdDetails (ifIdDetails d)
+ info <- rnIfaceIdInfo (ifIdInfo d)
+ return d { ifName = name
+ , ifType = ty
+ , ifIdDetails = details
+ , ifIdInfo = info
+ }
+rnIfaceDecl d@IfaceData{} = do
+ name <- rnIfaceGlobal (ifName d)
+ binders <- mapM rnIfaceTyConBinder (ifBinders d)
+ ctxt <- mapM rnIfaceType (ifCtxt d)
+ cons <- rnIfaceConDecls (ifCons d)
+ parent <- rnIfaceTyConParent (ifParent d)
+ return d { ifName = name
+ , ifBinders = binders
+ , ifCtxt = ctxt
+ , ifCons = cons
+ , ifParent = parent
+ }
+rnIfaceDecl d@IfaceSynonym{} = do
+ name <- rnIfaceGlobal (ifName d)
+ binders <- mapM rnIfaceTyConBinder (ifBinders d)
+ syn_kind <- rnIfaceType (ifResKind d)
+ syn_rhs <- rnIfaceType (ifSynRhs d)
+ return d { ifName = name
+ , ifBinders = binders
+ , ifResKind = syn_kind
+ , ifSynRhs = syn_rhs
+ }
+rnIfaceDecl d@IfaceFamily{} = do
+ name <- rnIfaceGlobal (ifName d)
+ binders <- mapM rnIfaceTyConBinder (ifBinders d)
+ fam_kind <- rnIfaceType (ifResKind d)
+ fam_flav <- rnIfaceFamTyConFlav (ifFamFlav d)
+ return d { ifName = name
+ , ifBinders = binders
+ , ifResKind = fam_kind
+ , ifFamFlav = fam_flav
+ }
+rnIfaceDecl d@IfaceClass{} = do
+ name <- rnIfaceGlobal (ifName d)
+ binders <- mapM rnIfaceTyConBinder (ifBinders d)
+ body <- rnIfaceClassBody (ifBody d)
+ return d { ifName = name
+ , ifBinders = binders
+ , ifBody = body
+ }
+rnIfaceDecl d@IfaceAxiom{} = do
+ name <- rnIfaceNeverExported (ifName d)
+ tycon <- rnIfaceTyCon (ifTyCon d)
+ ax_branches <- mapM rnIfaceAxBranch (ifAxBranches d)
+ return d { ifName = name
+ , ifTyCon = tycon
+ , ifAxBranches = ax_branches
+ }
+rnIfaceDecl d@IfacePatSyn{} = do
+ name <- rnIfaceGlobal (ifName d)
+ let rnPat (n, b) = (,) <$> rnIfaceGlobal n <*> pure b
+ pat_matcher <- rnPat (ifPatMatcher d)
+ pat_builder <- T.traverse rnPat (ifPatBuilder d)
+ pat_univ_bndrs <- mapM rnIfaceForAllBndr (ifPatUnivBndrs d)
+ pat_ex_bndrs <- mapM rnIfaceForAllBndr (ifPatExBndrs d)
+ pat_prov_ctxt <- mapM rnIfaceType (ifPatProvCtxt d)
+ pat_req_ctxt <- mapM rnIfaceType (ifPatReqCtxt d)
+ pat_args <- mapM rnIfaceType (ifPatArgs d)
+ pat_ty <- rnIfaceType (ifPatTy d)
+ return d { ifName = name
+ , ifPatMatcher = pat_matcher
+ , ifPatBuilder = pat_builder
+ , ifPatUnivBndrs = pat_univ_bndrs
+ , ifPatExBndrs = pat_ex_bndrs
+ , ifPatProvCtxt = pat_prov_ctxt
+ , ifPatReqCtxt = pat_req_ctxt
+ , ifPatArgs = pat_args
+ , ifPatTy = pat_ty
+ }
+
+rnIfaceClassBody :: Rename IfaceClassBody
+rnIfaceClassBody IfAbstractClass = return IfAbstractClass
+rnIfaceClassBody d@IfConcreteClass{} = do
+ ctxt <- mapM rnIfaceType (ifClassCtxt d)
+ ats <- mapM rnIfaceAT (ifATs d)
+ sigs <- mapM rnIfaceClassOp (ifSigs d)
+ return d { ifClassCtxt = ctxt, ifATs = ats, ifSigs = sigs }
+
+rnIfaceFamTyConFlav :: Rename IfaceFamTyConFlav
+rnIfaceFamTyConFlav (IfaceClosedSynFamilyTyCon (Just (n, axs)))
+ = IfaceClosedSynFamilyTyCon . Just <$> ((,) <$> rnIfaceNeverExported n
+ <*> mapM rnIfaceAxBranch axs)
+rnIfaceFamTyConFlav flav = pure flav
+
+rnIfaceAT :: Rename IfaceAT
+rnIfaceAT (IfaceAT decl mb_ty)
+ = IfaceAT <$> rnIfaceDecl decl <*> T.traverse rnIfaceType mb_ty
+
+rnIfaceTyConParent :: Rename IfaceTyConParent
+rnIfaceTyConParent (IfDataInstance n tc args)
+ = IfDataInstance <$> rnIfaceGlobal n
+ <*> rnIfaceTyCon tc
+ <*> rnIfaceTcArgs args
+rnIfaceTyConParent IfNoParent = pure IfNoParent
+
+rnIfaceConDecls :: Rename IfaceConDecls
+rnIfaceConDecls (IfDataTyCon ds)
+ = IfDataTyCon <$> mapM rnIfaceConDecl ds
+rnIfaceConDecls (IfNewTyCon d) = IfNewTyCon <$> rnIfaceConDecl d
+rnIfaceConDecls IfAbstractTyCon = pure IfAbstractTyCon
+
+rnIfaceConDecl :: Rename IfaceConDecl
+rnIfaceConDecl d = do
+ con_name <- rnIfaceGlobal (ifConName d)
+ con_ex_tvs <- mapM rnIfaceForAllBndr (ifConExTvs d)
+ let rnIfConEqSpec (n,t) = (,) n <$> rnIfaceType t
+ con_eq_spec <- mapM rnIfConEqSpec (ifConEqSpec d)
+ con_ctxt <- mapM rnIfaceType (ifConCtxt d)
+ con_arg_tys <- mapM rnIfaceType (ifConArgTys d)
+ con_fields <- mapM rnFieldLabel (ifConFields d)
+ let rnIfaceBang (IfUnpackCo co) = IfUnpackCo <$> rnIfaceCo co
+ rnIfaceBang bang = pure bang
+ con_stricts <- mapM rnIfaceBang (ifConStricts d)
+ return d { ifConName = con_name
+ , ifConExTvs = con_ex_tvs
+ , ifConEqSpec = con_eq_spec
+ , ifConCtxt = con_ctxt
+ , ifConArgTys = con_arg_tys
+ , ifConFields = con_fields
+ , ifConStricts = con_stricts
+ }
+
+rnIfaceClassOp :: Rename IfaceClassOp
+rnIfaceClassOp (IfaceClassOp n ty dm) =
+ IfaceClassOp <$> rnIfaceGlobal n
+ <*> rnIfaceType ty
+ <*> rnMaybeDefMethSpec dm
+
+rnMaybeDefMethSpec :: Rename (Maybe (DefMethSpec IfaceType))
+rnMaybeDefMethSpec (Just (GenericDM ty)) = Just . GenericDM <$> rnIfaceType ty
+rnMaybeDefMethSpec mb = return mb
+
+rnIfaceAxBranch :: Rename IfaceAxBranch
+rnIfaceAxBranch d = do
+ ty_vars <- mapM rnIfaceTvBndr (ifaxbTyVars d)
+ lhs <- rnIfaceTcArgs (ifaxbLHS d)
+ rhs <- rnIfaceType (ifaxbRHS d)
+ return d { ifaxbTyVars = ty_vars
+ , ifaxbLHS = lhs
+ , ifaxbRHS = rhs }
+
+rnIfaceIdInfo :: Rename IfaceIdInfo
+rnIfaceIdInfo NoInfo = pure NoInfo
+rnIfaceIdInfo (HasInfo is) = HasInfo <$> mapM rnIfaceInfoItem is
+
+rnIfaceInfoItem :: Rename IfaceInfoItem
+rnIfaceInfoItem (HsUnfold lb if_unf)
+ = HsUnfold lb <$> rnIfaceUnfolding if_unf
+rnIfaceInfoItem i
+ = pure i
+
+rnIfaceUnfolding :: Rename IfaceUnfolding
+rnIfaceUnfolding (IfCoreUnfold stable if_expr)
+ = IfCoreUnfold stable <$> rnIfaceExpr if_expr
+rnIfaceUnfolding (IfCompulsory if_expr)
+ = IfCompulsory <$> rnIfaceExpr if_expr
+rnIfaceUnfolding (IfInlineRule arity unsat_ok boring_ok if_expr)
+ = IfInlineRule arity unsat_ok boring_ok <$> rnIfaceExpr if_expr
+rnIfaceUnfolding (IfDFunUnfold bs ops)
+ = IfDFunUnfold <$> rnIfaceBndrs bs <*> mapM rnIfaceExpr ops
+
+rnIfaceExpr :: Rename IfaceExpr
+rnIfaceExpr (IfaceLcl name) = pure (IfaceLcl name)
+rnIfaceExpr (IfaceExt gbl) = IfaceExt <$> rnIfaceGlobal gbl
+rnIfaceExpr (IfaceType ty) = IfaceType <$> rnIfaceType ty
+rnIfaceExpr (IfaceCo co) = IfaceCo <$> rnIfaceCo co
+rnIfaceExpr (IfaceTuple sort args) = IfaceTuple sort <$> rnIfaceExprs args
+rnIfaceExpr (IfaceLam lam_bndr expr)
+ = IfaceLam <$> rnIfaceLamBndr lam_bndr <*> rnIfaceExpr expr
+rnIfaceExpr (IfaceApp fun arg)
+ = IfaceApp <$> rnIfaceExpr fun <*> rnIfaceExpr arg
+rnIfaceExpr (IfaceCase scrut case_bndr alts)
+ = IfaceCase <$> rnIfaceExpr scrut
+ <*> pure case_bndr
+ <*> mapM rnIfaceAlt alts
+rnIfaceExpr (IfaceECase scrut ty)
+ = IfaceECase <$> rnIfaceExpr scrut <*> rnIfaceType ty
+rnIfaceExpr (IfaceLet (IfaceNonRec bndr rhs) body)
+ = IfaceLet <$> (IfaceNonRec <$> rnIfaceLetBndr bndr <*> rnIfaceExpr rhs)
+ <*> rnIfaceExpr body
+rnIfaceExpr (IfaceLet (IfaceRec pairs) body)
+ = IfaceLet <$> (IfaceRec <$> mapM (\(bndr, rhs) ->
+ (,) <$> rnIfaceLetBndr bndr
+ <*> rnIfaceExpr rhs) pairs)
+ <*> rnIfaceExpr body
+rnIfaceExpr (IfaceCast expr co)
+ = IfaceCast <$> rnIfaceExpr expr <*> rnIfaceCo co
+rnIfaceExpr (IfaceLit lit) = pure (IfaceLit lit)
+rnIfaceExpr (IfaceFCall cc ty) = IfaceFCall cc <$> rnIfaceType ty
+rnIfaceExpr (IfaceTick tickish expr) = IfaceTick tickish <$> rnIfaceExpr expr
+
+rnIfaceBndrs :: Rename [IfaceBndr]
+rnIfaceBndrs = mapM rnIfaceBndr
+
+rnIfaceBndr :: Rename IfaceBndr
+rnIfaceBndr (IfaceIdBndr (fs, ty)) = IfaceIdBndr <$> ((,) fs <$> rnIfaceType ty)
+rnIfaceBndr (IfaceTvBndr tv_bndr) = IfaceIdBndr <$> rnIfaceTvBndr tv_bndr
+
+rnIfaceTvBndr :: Rename IfaceTvBndr
+rnIfaceTvBndr (fs, kind) = (,) fs <$> rnIfaceType kind
+
+rnIfaceTyConBinder :: Rename IfaceTyConBinder
+rnIfaceTyConBinder (TvBndr tv vis) = TvBndr <$> rnIfaceTvBndr tv <*> pure vis
+
+rnIfaceAlt :: Rename IfaceAlt
+rnIfaceAlt (conalt, names, rhs)
+ = (,,) <$> rnIfaceConAlt conalt <*> pure names <*> rnIfaceExpr rhs
+
+rnIfaceConAlt :: Rename IfaceConAlt
+rnIfaceConAlt (IfaceDataAlt data_occ) = IfaceDataAlt <$> rnIfaceGlobal data_occ
+rnIfaceConAlt alt = pure alt
+
+rnIfaceLetBndr :: Rename IfaceLetBndr
+rnIfaceLetBndr (IfLetBndr fs ty info jpi)
+ = IfLetBndr fs <$> rnIfaceType ty <*> rnIfaceIdInfo info <*> pure jpi
+
+rnIfaceLamBndr :: Rename IfaceLamBndr
+rnIfaceLamBndr (bndr, oneshot) = (,) <$> rnIfaceBndr bndr <*> pure oneshot
+
+rnIfaceCo :: Rename IfaceCoercion
+rnIfaceCo (IfaceReflCo role ty) = IfaceReflCo role <$> rnIfaceType ty
+rnIfaceCo (IfaceFunCo role co1 co2)
+ = IfaceFunCo role <$> rnIfaceCo co1 <*> rnIfaceCo co2
+rnIfaceCo (IfaceTyConAppCo role tc cos)
+ = IfaceTyConAppCo role <$> rnIfaceTyCon tc <*> mapM rnIfaceCo cos
+rnIfaceCo (IfaceAppCo co1 co2)
+ = IfaceAppCo <$> rnIfaceCo co1 <*> rnIfaceCo co2
+rnIfaceCo (IfaceForAllCo bndr co1 co2)
+ = IfaceForAllCo <$> rnIfaceTvBndr bndr <*> rnIfaceCo co1 <*> rnIfaceCo co2
+rnIfaceCo (IfaceCoVarCo lcl) = IfaceCoVarCo <$> pure lcl
+rnIfaceCo (IfaceAxiomInstCo n i cs)
+ = IfaceAxiomInstCo <$> rnIfaceGlobal n <*> pure i <*> mapM rnIfaceCo cs
+rnIfaceCo (IfaceUnivCo s r t1 t2)
+ = IfaceUnivCo s r <$> rnIfaceType t1 <*> rnIfaceType t2
+rnIfaceCo (IfaceSymCo c)
+ = IfaceSymCo <$> rnIfaceCo c
+rnIfaceCo (IfaceTransCo c1 c2)
+ = IfaceTransCo <$> rnIfaceCo c1 <*> rnIfaceCo c2
+rnIfaceCo (IfaceInstCo c1 c2)
+ = IfaceInstCo <$> rnIfaceCo c1 <*> rnIfaceCo c2
+rnIfaceCo (IfaceNthCo d c) = IfaceNthCo d <$> rnIfaceCo c
+rnIfaceCo (IfaceLRCo lr c) = IfaceLRCo lr <$> rnIfaceCo c
+rnIfaceCo (IfaceSubCo c) = IfaceSubCo <$> rnIfaceCo c
+rnIfaceCo (IfaceAxiomRuleCo ax cos)
+ = IfaceAxiomRuleCo ax <$> mapM rnIfaceCo cos
+rnIfaceCo (IfaceKindCo c) = IfaceKindCo <$> rnIfaceCo c
+rnIfaceCo (IfaceCoherenceCo c1 c2) = IfaceCoherenceCo <$> rnIfaceCo c1 <*> rnIfaceCo c2
+
+rnIfaceTyCon :: Rename IfaceTyCon
+rnIfaceTyCon (IfaceTyCon n info)
+ = IfaceTyCon <$> rnIfaceGlobal n <*> pure info
+
+rnIfaceExprs :: Rename [IfaceExpr]
+rnIfaceExprs = mapM rnIfaceExpr
+
+rnIfaceIdDetails :: Rename IfaceIdDetails
+rnIfaceIdDetails (IfRecSelId (Left tc) b) = IfRecSelId <$> fmap Left (rnIfaceTyCon tc) <*> pure b
+rnIfaceIdDetails (IfRecSelId (Right decl) b) = IfRecSelId <$> fmap Right (rnIfaceDecl decl) <*> pure b
+rnIfaceIdDetails details = pure details
+
+rnIfaceType :: Rename IfaceType
+rnIfaceType (IfaceFreeTyVar n) = pure (IfaceFreeTyVar n)
+rnIfaceType (IfaceTyVar n) = pure (IfaceTyVar n)
+rnIfaceType (IfaceAppTy t1 t2)
+ = IfaceAppTy <$> rnIfaceType t1 <*> rnIfaceType t2
+rnIfaceType (IfaceLitTy l) = return (IfaceLitTy l)
+rnIfaceType (IfaceFunTy t1 t2)
+ = IfaceFunTy <$> rnIfaceType t1 <*> rnIfaceType t2
+rnIfaceType (IfaceDFunTy t1 t2)
+ = IfaceDFunTy <$> rnIfaceType t1 <*> rnIfaceType t2
+rnIfaceType (IfaceTupleTy s i tks)
+ = IfaceTupleTy s i <$> rnIfaceTcArgs tks
+rnIfaceType (IfaceTyConApp tc tks)
+ = IfaceTyConApp <$> rnIfaceTyCon tc <*> rnIfaceTcArgs tks
+rnIfaceType (IfaceForAllTy tv t)
+ = IfaceForAllTy <$> rnIfaceForAllBndr tv <*> rnIfaceType t
+rnIfaceType (IfaceCoercionTy co)
+ = IfaceCoercionTy <$> rnIfaceCo co
+rnIfaceType (IfaceCastTy ty co)
+ = IfaceCastTy <$> rnIfaceType ty <*> rnIfaceCo co
+
+rnIfaceForAllBndr :: Rename IfaceForAllBndr
+rnIfaceForAllBndr (TvBndr tv vis) = TvBndr <$> rnIfaceTvBndr tv <*> pure vis
+
+rnIfaceTcArgs :: Rename IfaceTcArgs
+rnIfaceTcArgs (ITC_Invis t ts) = ITC_Invis <$> rnIfaceType t <*> rnIfaceTcArgs ts
+rnIfaceTcArgs (ITC_Vis t ts) = ITC_Vis <$> rnIfaceType t <*> rnIfaceTcArgs ts
+rnIfaceTcArgs ITC_Nil = pure ITC_Nil
diff --git a/basicTypes/Avail.hs b/basicTypes/Avail.hs
new file mode 100644
--- /dev/null
+++ b/basicTypes/Avail.hs
@@ -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)
diff --git a/basicTypes/BasicTypes.hs b/basicTypes/BasicTypes.hs
new file mode 100644
--- /dev/null
+++ b/basicTypes/BasicTypes.hs
@@ -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 ""
+ ppr NotTopLevel = text ""
+
+{-
+************************************************************************
+* *
+ Boxity flag
+* *
+************************************************************************
+-}
+
+data Boxity
+ = Boxed
+ | Unboxed
+ deriving( Eq, Data )
+
+isBoxed :: Boxity -> Bool
+isBoxed Boxed = True
+isBoxed Unboxed = False
+
+instance Outputable Boxity where
+ ppr Boxed = text "Boxed"
+ ppr Unboxed = text "Unboxed"
+
+{-
+************************************************************************
+* *
+ Recursive/Non-Recursive flag
+* *
+************************************************************************
+-}
+
+-- | Recursivity Flag
+data RecFlag = Recursive
+ | NonRecursive
+ deriving( Eq, Data )
+
+isRec :: RecFlag -> Bool
+isRec Recursive = True
+isRec NonRecursive = False
+
+isNonRec :: RecFlag -> Bool
+isNonRec Recursive = False
+isNonRec NonRecursive = True
+
+boolToRecFlag :: Bool -> RecFlag
+boolToRecFlag True = Recursive
+boolToRecFlag False = NonRecursive
+
+instance Outputable RecFlag where
+ ppr Recursive = text "Recursive"
+ ppr NonRecursive = text "NonRecursive"
+
+{-
+************************************************************************
+* *
+ Code origin
+* *
+************************************************************************
+-}
+
+data Origin = FromSource
+ | Generated
+ deriving( Eq, Data )
+
+isGenerated :: Origin -> Bool
+isGenerated Generated = True
+isGenerated FromSource = False
+
+instance Outputable Origin where
+ ppr FromSource = text "FromSource"
+ ppr Generated = text "Generated"
+
+{-
+************************************************************************
+* *
+ Deriving strategies
+* *
+************************************************************************
+-}
+
+-- | Which technique the user explicitly requested when deriving an instance.
+data DerivStrategy
+ -- See Note [Deriving strategies] in TcDeriv
+ = StockStrategy -- ^ GHC's \"standard\" strategy, which is to implement a
+ -- custom instance for the data type. This only works
+ -- for certain types that GHC knows about (e.g., 'Eq',
+ -- 'Show', 'Functor' when @-XDeriveFunctor@ is enabled,
+ -- etc.)
+ | AnyclassStrategy -- ^ @-XDeriveAnyClass@
+ | NewtypeStrategy -- ^ @-XGeneralizedNewtypeDeriving@
+ deriving (Eq, Data)
+
+instance Outputable DerivStrategy where
+ ppr StockStrategy = text "stock"
+ ppr AnyclassStrategy = text "anyclass"
+ ppr NewtypeStrategy = text "newtype"
+
+{-
+************************************************************************
+* *
+ Instance overlap flag
+* *
+************************************************************************
+-}
+
+-- | The semantics allowed for overlapping instances for a particular
+-- instance. See Note [Safe Haskell isSafeOverlap] (in `InstEnv.hs`) for a
+-- explanation of the `isSafeOverlap` field.
+--
+-- - 'ApiAnnotation.AnnKeywordId' :
+-- 'ApiAnnotation.AnnOpen' @'\{-\# OVERLAPPABLE'@ or
+-- @'\{-\# OVERLAPPING'@ or
+-- @'\{-\# OVERLAPS'@ or
+-- @'\{-\# INCOHERENT'@,
+-- 'ApiAnnotation.AnnClose' @`\#-\}`@,
+
+-- For details on above see note [Api annotations] in ApiAnnotation
+data OverlapFlag = OverlapFlag
+ { overlapMode :: OverlapMode
+ , isSafeOverlap :: Bool
+ } deriving (Eq, Data)
+
+setOverlapModeMaybe :: OverlapFlag -> Maybe OverlapMode -> OverlapFlag
+setOverlapModeMaybe f Nothing = f
+setOverlapModeMaybe f (Just m) = f { overlapMode = m }
+
+hasIncoherentFlag :: OverlapMode -> Bool
+hasIncoherentFlag mode =
+ case mode of
+ Incoherent _ -> True
+ _ -> False
+
+hasOverlappableFlag :: OverlapMode -> Bool
+hasOverlappableFlag mode =
+ case mode of
+ Overlappable _ -> True
+ Overlaps _ -> True
+ Incoherent _ -> True
+ _ -> False
+
+hasOverlappingFlag :: OverlapMode -> Bool
+hasOverlappingFlag mode =
+ case mode of
+ Overlapping _ -> True
+ Overlaps _ -> True
+ Incoherent _ -> True
+ _ -> False
+
+data OverlapMode -- See Note [Rules for instance lookup] in InstEnv
+ = NoOverlap SourceText
+ -- See Note [Pragma source text]
+ -- ^ This instance must not overlap another `NoOverlap` instance.
+ -- However, it may be overlapped by `Overlapping` instances,
+ -- and it may overlap `Overlappable` instances.
+
+
+ | Overlappable SourceText
+ -- See Note [Pragma source text]
+ -- ^ Silently ignore this instance if you find a
+ -- more specific one that matches the constraint
+ -- you are trying to resolve
+ --
+ -- Example: constraint (Foo [Int])
+ -- instance Foo [Int]
+ -- instance {-# OVERLAPPABLE #-} Foo [a]
+ --
+ -- Since the second instance has the Overlappable flag,
+ -- the first instance will be chosen (otherwise
+ -- its ambiguous which to choose)
+
+
+ | Overlapping SourceText
+ -- See Note [Pragma source text]
+ -- ^ Silently ignore any more general instances that may be
+ -- used to solve the constraint.
+ --
+ -- Example: constraint (Foo [Int])
+ -- instance {-# OVERLAPPING #-} Foo [Int]
+ -- instance Foo [a]
+ --
+ -- Since the first instance has the Overlapping flag,
+ -- the second---more general---instance will be ignored (otherwise
+ -- it is ambiguous which to choose)
+
+
+ | Overlaps SourceText
+ -- See Note [Pragma source text]
+ -- ^ Equivalent to having both `Overlapping` and `Overlappable` flags.
+
+ | Incoherent SourceText
+ -- See Note [Pragma source text]
+ -- ^ Behave like Overlappable and Overlapping, and in addition pick
+ -- an an arbitrary one if there are multiple matching candidates, and
+ -- don't worry about later instantiation
+ --
+ -- Example: constraint (Foo [b])
+ -- instance {-# INCOHERENT -} Foo [Int]
+ -- instance Foo [a]
+ -- Without the Incoherent flag, we'd complain that
+ -- instantiating 'b' would change which instance
+ -- was chosen. See also note [Incoherent instances] in InstEnv
+
+ deriving (Eq, Data)
+
+
+instance Outputable OverlapFlag where
+ ppr flag = ppr (overlapMode flag) <+> pprSafeOverlap (isSafeOverlap flag)
+
+instance Outputable OverlapMode where
+ ppr (NoOverlap _) = empty
+ ppr (Overlappable _) = text "[overlappable]"
+ ppr (Overlapping _) = text "[overlapping]"
+ ppr (Overlaps _) = text "[overlap ok]"
+ ppr (Incoherent _) = text "[incoherent]"
+
+pprSafeOverlap :: Bool -> SDoc
+pprSafeOverlap True = text "[safe]"
+pprSafeOverlap False = empty
+
+{-
+************************************************************************
+* *
+ Type precedence
+* *
+************************************************************************
+-}
+
+data TyPrec -- See Note [Precedence in types] in TyCoRep.hs
+ = TopPrec -- No parens
+ | FunPrec -- Function args; no parens for tycon apps
+ | TyOpPrec -- Infix operator
+ | TyConPrec -- Tycon args; no parens for atomic
+ deriving( Eq, Ord )
+
+maybeParen :: TyPrec -> TyPrec -> SDoc -> SDoc
+maybeParen ctxt_prec inner_prec pretty
+ | ctxt_prec < inner_prec = pretty
+ | otherwise = parens pretty
+
+{-
+************************************************************************
+* *
+ Tuples
+* *
+************************************************************************
+-}
+
+data TupleSort
+ = BoxedTuple
+ | UnboxedTuple
+ | ConstraintTuple
+ deriving( Eq, Data )
+
+tupleSortBoxity :: TupleSort -> Boxity
+tupleSortBoxity BoxedTuple = Boxed
+tupleSortBoxity UnboxedTuple = Unboxed
+tupleSortBoxity ConstraintTuple = Boxed
+
+boxityTupleSort :: Boxity -> TupleSort
+boxityTupleSort Boxed = BoxedTuple
+boxityTupleSort Unboxed = UnboxedTuple
+
+tupleParens :: TupleSort -> SDoc -> SDoc
+tupleParens BoxedTuple p = parens p
+tupleParens UnboxedTuple p = text "(#" <+> p <+> ptext (sLit "#)")
+tupleParens ConstraintTuple p -- In debug-style write (% Eq a, Ord b %)
+ = sdocWithPprDebug $ \dbg -> if dbg
+ then text "(%" <+> p <+> ptext (sLit "%)")
+ else parens p
+
+{-
+************************************************************************
+* *
+ Sums
+* *
+************************************************************************
+-}
+
+sumParens :: SDoc -> SDoc
+sumParens p = ptext (sLit "(#") <+> p <+> ptext (sLit "#)")
+
+-- | Pretty print an alternative in an unboxed sum e.g. "| a | |".
+pprAlternative :: (a -> SDoc) -- ^ The pretty printing function to use
+ -> a -- ^ The things to be pretty printed
+ -> ConTag -- ^ Alternative (one-based)
+ -> Arity -- ^ Arity
+ -> SDoc -- ^ 'SDoc' where the alternative havs been pretty
+ -- printed and finally packed into a paragraph.
+pprAlternative pp x alt arity =
+ fsep (replicate (alt - 1) vbar ++ [pp x] ++ replicate (arity - alt) vbar)
+
+{-
+************************************************************************
+* *
+\subsection[Generic]{Generic flag}
+* *
+************************************************************************
+
+This is the "Embedding-Projection pair" datatype, it contains
+two pieces of code (normally either RenamedExpr's or Id's)
+If we have a such a pair (EP from to), the idea is that 'from' and 'to'
+represents functions of type
+
+ from :: T -> Tring
+ to :: Tring -> T
+
+And we should have
+
+ to (from x) = x
+
+T and Tring are arbitrary, but typically T is the 'main' type while
+Tring is the 'representation' type. (This just helps us remember
+whether to use 'from' or 'to'.
+-}
+
+-- | Embedding Projection pair
+data EP a = EP { fromEP :: a, -- :: T -> Tring
+ toEP :: a } -- :: Tring -> T
+
+{-
+Embedding-projection pairs are used in several places:
+
+First of all, each type constructor has an EP associated with it, the
+code in EP converts (datatype T) from T to Tring and back again.
+
+Secondly, when we are filling in Generic methods (in the typechecker,
+tcMethodBinds), we are constructing bimaps by induction on the structure
+of the type of the method signature.
+
+
+************************************************************************
+* *
+\subsection{Occurrence information}
+* *
+************************************************************************
+
+This data type is used exclusively by the simplifier, but it appears in a
+SubstResult, which is currently defined in VarEnv, which is pretty near
+the base of the module hierarchy. So it seemed simpler to put the
+defn of OccInfo here, safely at the bottom
+-}
+
+-- | identifier Occurrence Information
+data OccInfo
+ = ManyOccs { occ_tail :: !TailCallInfo }
+ -- ^ There are many occurrences, or unknown occurrences
+
+ | IAmDead -- ^ Marks unused variables. Sometimes useful for
+ -- lambda and case-bound variables.
+
+ | OneOcc { occ_in_lam :: !InsideLam
+ , occ_one_br :: !OneBranch
+ , occ_int_cxt :: !InterestingCxt
+ , occ_tail :: !TailCallInfo }
+ -- ^ Occurs exactly once (per branch), not inside a rule
+
+ -- | This identifier breaks a loop of mutually recursive functions. The field
+ -- marks whether it is only a loop breaker due to a reference in a rule
+ | IAmALoopBreaker { occ_rules_only :: !RulesOnly
+ , occ_tail :: !TailCallInfo }
+ -- Note [LoopBreaker OccInfo]
+
+ deriving (Eq)
+
+type RulesOnly = Bool
+
+{-
+Note [LoopBreaker OccInfo]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+ IAmALoopBreaker True <=> A "weak" or rules-only loop breaker
+ Do not preInlineUnconditionally
+
+ IAmALoopBreaker False <=> A "strong" loop breaker
+ Do not inline at all
+
+See OccurAnal Note [Weak loop breakers]
+-}
+
+noOccInfo :: OccInfo
+noOccInfo = ManyOccs { occ_tail = NoTailCallInfo }
+
+isManyOccs :: OccInfo -> Bool
+isManyOccs ManyOccs{} = True
+isManyOccs _ = False
+
+seqOccInfo :: OccInfo -> ()
+seqOccInfo occ = occ `seq` ()
+
+-----------------
+-- | Interesting Context
+type InterestingCxt = Bool -- True <=> Function: is applied
+ -- Data value: scrutinised by a case with
+ -- at least one non-DEFAULT branch
+
+-----------------
+-- | Inside Lambda
+type InsideLam = Bool -- True <=> Occurs inside a non-linear lambda
+ -- Substituting a redex for this occurrence is
+ -- dangerous because it might duplicate work.
+insideLam, notInsideLam :: InsideLam
+insideLam = True
+notInsideLam = False
+
+-----------------
+type OneBranch = Bool -- True <=> Occurs in only one case branch
+ -- so no code-duplication issue to worry about
+oneBranch, notOneBranch :: OneBranch
+oneBranch = True
+notOneBranch = False
+
+-----------------
+data TailCallInfo = AlwaysTailCalled JoinArity -- See Note [TailCallInfo]
+ | NoTailCallInfo
+ deriving (Eq)
+
+tailCallInfo :: OccInfo -> TailCallInfo
+tailCallInfo IAmDead = NoTailCallInfo
+tailCallInfo other = occ_tail other
+
+zapOccTailCallInfo :: OccInfo -> OccInfo
+zapOccTailCallInfo IAmDead = IAmDead
+zapOccTailCallInfo occ = occ { occ_tail = NoTailCallInfo }
+
+isAlwaysTailCalled :: OccInfo -> Bool
+isAlwaysTailCalled occ
+ = case tailCallInfo occ of AlwaysTailCalled{} -> True
+ NoTailCallInfo -> False
+
+instance Outputable TailCallInfo where
+ ppr (AlwaysTailCalled ar) = sep [ text "Tail", int ar ]
+ ppr _ = empty
+
+-----------------
+strongLoopBreaker, weakLoopBreaker :: OccInfo
+strongLoopBreaker = IAmALoopBreaker False NoTailCallInfo
+weakLoopBreaker = IAmALoopBreaker True NoTailCallInfo
+
+isWeakLoopBreaker :: OccInfo -> Bool
+isWeakLoopBreaker (IAmALoopBreaker{}) = True
+isWeakLoopBreaker _ = False
+
+isStrongLoopBreaker :: OccInfo -> Bool
+isStrongLoopBreaker (IAmALoopBreaker { occ_rules_only = False }) = True
+ -- Loop-breaker that breaks a non-rule cycle
+isStrongLoopBreaker _ = False
+
+isDeadOcc :: OccInfo -> Bool
+isDeadOcc IAmDead = True
+isDeadOcc _ = False
+
+isOneOcc :: OccInfo -> Bool
+isOneOcc (OneOcc {}) = True
+isOneOcc _ = False
+
+zapFragileOcc :: OccInfo -> OccInfo
+-- Keep only the most robust data: deadness, loop-breaker-hood
+zapFragileOcc (OneOcc {}) = noOccInfo
+zapFragileOcc occ = zapOccTailCallInfo occ
+
+instance Outputable OccInfo where
+ -- only used for debugging; never parsed. KSW 1999-07
+ ppr (ManyOccs tails) = pprShortTailCallInfo tails
+ ppr IAmDead = text "Dead"
+ ppr (IAmALoopBreaker rule_only tails)
+ = text "LoopBreaker" <> pp_ro <> pprShortTailCallInfo tails
+ where
+ pp_ro | rule_only = char '!'
+ | otherwise = empty
+ ppr (OneOcc inside_lam one_branch int_cxt tail_info)
+ = text "Once" <> pp_lam <> pp_br <> pp_args <> pp_tail
+ where
+ pp_lam | inside_lam = char 'L'
+ | otherwise = empty
+ pp_br | one_branch = empty
+ | otherwise = char '*'
+ pp_args | int_cxt = char '!'
+ | otherwise = empty
+ pp_tail = pprShortTailCallInfo tail_info
+
+pprShortTailCallInfo :: TailCallInfo -> SDoc
+pprShortTailCallInfo (AlwaysTailCalled ar) = char 'T' <> brackets (int ar)
+pprShortTailCallInfo NoTailCallInfo = empty
+
+{-
+Note [TailCallInfo]
+~~~~~~~~~~~~~~~~~~~
+The occurrence analyser determines what can be made into a join point, but it
+doesn't change the binder into a JoinId because then it would be inconsistent
+with the occurrences. Thus it's left to the simplifier (or to simpleOptExpr) to
+change the IdDetails.
+
+The AlwaysTailCalled marker actually means slightly more than simply that the
+function is always tail-called. See Note [Invariants on join points].
+
+This info is quite fragile and should not be relied upon unless the occurrence
+analyser has *just* run. Use 'Id.isJoinId_maybe' for the permanent state of
+the join-point-hood of a binder; a join id itself will not be marked
+AlwaysTailCalled.
+
+Note that there is a 'TailCallInfo' on a 'ManyOccs' value. One might expect that
+being tail-called would mean that the variable could only appear once per branch
+(thus getting a `OneOcc { occ_one_br = True }` occurrence info), but a join
+point can also be invoked from other join points, not just from case branches:
+
+ let j1 x = ...
+ j2 y = ... j1 z {- tail call -} ...
+ in case w of
+ A -> j1 v
+ B -> j2 u
+ C -> j2 q
+
+Here both 'j1' and 'j2' will get marked AlwaysTailCalled, but j1 will get
+ManyOccs and j2 will get `OneOcc { occ_one_br = True }`.
+
+************************************************************************
+* *
+ Default method specification
+* *
+************************************************************************
+
+The DefMethSpec enumeration just indicates what sort of default method
+is used for a class. It is generated from source code, and present in
+interface files; it is converted to Class.DefMethInfo before begin put in a
+Class object.
+-}
+
+-- | Default Method Specification
+data DefMethSpec ty
+ = VanillaDM -- Default method given with polymorphic code
+ | GenericDM ty -- Default method given with code of this type
+
+instance Outputable (DefMethSpec ty) where
+ ppr VanillaDM = text "{- Has default method -}"
+ ppr (GenericDM {}) = text "{- Has generic default method -}"
+
+{-
+************************************************************************
+* *
+\subsection{Success flag}
+* *
+************************************************************************
+-}
+
+data SuccessFlag = Succeeded | Failed
+
+instance Outputable SuccessFlag where
+ ppr Succeeded = text "Succeeded"
+ ppr Failed = text "Failed"
+
+successIf :: Bool -> SuccessFlag
+successIf True = Succeeded
+successIf False = Failed
+
+succeeded, failed :: SuccessFlag -> Bool
+succeeded Succeeded = True
+succeeded Failed = False
+
+failed Succeeded = False
+failed Failed = True
+
+{-
+************************************************************************
+* *
+\subsection{Source Text}
+* *
+************************************************************************
+Keeping Source Text for source to source conversions
+
+Note [Pragma source text]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+The lexer does a case-insensitive match for pragmas, as well as
+accepting both UK and US spelling variants.
+
+So
+
+ {-# SPECIALISE #-}
+ {-# SPECIALIZE #-}
+ {-# Specialize #-}
+
+will all generate ITspec_prag token for the start of the pragma.
+
+In order to be able to do source to source conversions, the original
+source text for the token needs to be preserved, hence the
+`SourceText` field.
+
+So the lexer will then generate
+
+ ITspec_prag "{ -# SPECIALISE"
+ ITspec_prag "{ -# SPECIALIZE"
+ ITspec_prag "{ -# Specialize"
+
+for the cases above.
+ [without the space between '{' and '-', otherwise this comment won't parse]
+
+
+Note [Literal source text]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+The lexer/parser converts literals from their original source text
+versions to an appropriate internal representation. This is a problem
+for tools doing source to source conversions, so the original source
+text is stored in literals where this can occur.
+
+Motivating examples for HsLit
+
+ HsChar '\n' == '\x20`
+ HsCharPrim '\x41`# == `A`
+ HsString "\x20\x41" == " A"
+ HsStringPrim "\x20"# == " "#
+ HsInt 001 == 1
+ HsIntPrim 002# == 2#
+ HsWordPrim 003## == 3##
+ HsInt64Prim 004## == 4##
+ HsWord64Prim 005## == 5##
+ HsInteger 006 == 6
+
+For OverLitVal
+
+ HsIntegral 003 == 0x003
+ HsIsString "\x41nd" == "And"
+-}
+
+ -- Note [Literal source text],[Pragma source text]
+data SourceText = SourceText String
+ | NoSourceText -- ^ For when code is generated, e.g. TH,
+ -- deriving. The pretty printer will then make
+ -- its own representation of the item.
+ deriving (Data, Show, Eq )
+
+instance Outputable SourceText where
+ ppr (SourceText s) = text "SourceText" <+> text s
+ ppr NoSourceText = text "NoSourceText"
+
+-- | Special combinator for showing string literals.
+pprWithSourceText :: SourceText -> SDoc -> SDoc
+pprWithSourceText NoSourceText d = d
+pprWithSourceText (SourceText src) _ = text src
+
+{-
+************************************************************************
+* *
+\subsection{Activation}
+* *
+************************************************************************
+
+When a rule or inlining is active
+-}
+
+-- | Phase Number
+type PhaseNum = Int -- Compilation phase
+ -- Phases decrease towards zero
+ -- Zero is the last phase
+
+data CompilerPhase
+ = Phase PhaseNum
+ | InitialPhase -- The first phase -- number = infinity!
+
+instance Outputable CompilerPhase where
+ ppr (Phase n) = int n
+ ppr InitialPhase = text "InitialPhase"
+
+-- See note [Pragma source text]
+data Activation = NeverActive
+ | AlwaysActive
+ | ActiveBefore SourceText PhaseNum
+ -- Active only *strictly before* this phase
+ | ActiveAfter SourceText PhaseNum
+ -- Active in this phase and later
+ deriving( Eq, Data )
+ -- Eq used in comparing rules in HsDecls
+
+-- | Rule Match Information
+data RuleMatchInfo = ConLike -- See Note [CONLIKE pragma]
+ | FunLike
+ deriving( Eq, Data, Show )
+ -- Show needed for Lexer.x
+
+data InlinePragma -- Note [InlinePragma]
+ = InlinePragma
+ { inl_src :: SourceText -- Note [Pragma source text]
+ , inl_inline :: InlineSpec -- See Note [inl_inline and inl_act]
+
+ , inl_sat :: Maybe Arity -- Just n <=> Inline only when applied to n
+ -- explicit (non-type, non-dictionary) args
+ -- That is, inl_sat describes the number of *source-code*
+ -- arguments the thing must be applied to. We add on the
+ -- number of implicit, dictionary arguments when making
+ -- the Unfolding, and don't look at inl_sat further
+
+ , inl_act :: Activation -- Says during which phases inlining is allowed
+ -- See Note [inl_inline and inl_act]
+
+ , inl_rule :: RuleMatchInfo -- Should the function be treated like a constructor?
+ } deriving( Eq, Data )
+
+-- | Inline Specification
+data InlineSpec -- What the user's INLINE pragma looked like
+ = Inline
+ | Inlinable
+ | NoInline
+ | EmptyInlineSpec -- Used in a place-holder InlinePragma in SpecPrag or IdInfo,
+ -- where there isn't any real inline pragma at all
+ deriving( Eq, Data, Show )
+ -- Show needed for Lexer.x
+
+{- Note [InlinePragma]
+~~~~~~~~~~~~~~~~~~~~~~
+This data type mirrors what you can write in an INLINE or NOINLINE pragma in
+the source program.
+
+If you write nothing at all, you get defaultInlinePragma:
+ inl_inline = EmptyInlineSpec
+ inl_act = AlwaysActive
+ inl_rule = FunLike
+
+It's not possible to get that combination by *writing* something, so
+if an Id has defaultInlinePragma it means the user didn't specify anything.
+
+If inl_inline = Inline or Inlineable, then the Id should have an InlineRule unfolding.
+
+If you want to know where InlinePragmas take effect: Look in DsBinds.makeCorePair
+
+Note [inl_inline and inl_act]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+* inl_inline says what the user wrote: did she say INLINE, NOINLINE,
+ INLINABLE, or nothing at all
+
+* inl_act says in what phases the unfolding is active or inactive
+ E.g If you write INLINE[1] then inl_act will be set to ActiveAfter 1
+ If you write NOINLINE[1] then inl_act will be set to ActiveBefore 1
+ If you write NOINLINE[~1] then inl_act will be set to ActiveAfter 1
+ So note that inl_act does not say what pragma you wrote: it just
+ expresses its consequences
+
+* inl_act just says when the unfolding is active; it doesn't say what
+ to inline. If you say INLINE f, then f's inl_act will be AlwaysActive,
+ but in addition f will get a "stable unfolding" with UnfoldingGuidance
+ that tells the inliner to be pretty eager about it.
+
+Note [CONLIKE pragma]
+~~~~~~~~~~~~~~~~~~~~~
+The ConLike constructor of a RuleMatchInfo is aimed at the following.
+Consider first
+ {-# RULE "r/cons" forall a as. r (a:as) = f (a+1) #-}
+ g b bs = let x = b:bs in ..x...x...(r x)...
+Now, the rule applies to the (r x) term, because GHC "looks through"
+the definition of 'x' to see that it is (b:bs).
+
+Now consider
+ {-# RULE "r/f" forall v. r (f v) = f (v+1) #-}
+ g v = let x = f v in ..x...x...(r x)...
+Normally the (r x) would *not* match the rule, because GHC would be
+scared about duplicating the redex (f v), so it does not "look
+through" the bindings.
+
+However the CONLIKE modifier says to treat 'f' like a constructor in
+this situation, and "look through" the unfolding for x. So (r x)
+fires, yielding (f (v+1)).
+
+This is all controlled with a user-visible pragma:
+ {-# NOINLINE CONLIKE [1] f #-}
+
+The main effects of CONLIKE are:
+
+ - The occurrence analyser (OccAnal) and simplifier (Simplify) treat
+ CONLIKE thing like constructors, by ANF-ing them
+
+ - New function coreUtils.exprIsExpandable is like exprIsCheap, but
+ additionally spots applications of CONLIKE functions
+
+ - A CoreUnfolding has a field that caches exprIsExpandable
+
+ - The rule matcher consults this field. See
+ Note [Expanding variables] in Rules.hs.
+-}
+
+isConLike :: RuleMatchInfo -> Bool
+isConLike ConLike = True
+isConLike _ = False
+
+isFunLike :: RuleMatchInfo -> Bool
+isFunLike FunLike = True
+isFunLike _ = False
+
+isEmptyInlineSpec :: InlineSpec -> Bool
+isEmptyInlineSpec EmptyInlineSpec = True
+isEmptyInlineSpec _ = False
+
+defaultInlinePragma, alwaysInlinePragma, neverInlinePragma, dfunInlinePragma
+ :: InlinePragma
+defaultInlinePragma = InlinePragma { inl_src = SourceText "{-# INLINE"
+ , inl_act = AlwaysActive
+ , inl_rule = FunLike
+ , inl_inline = EmptyInlineSpec
+ , inl_sat = Nothing }
+
+alwaysInlinePragma = defaultInlinePragma { inl_inline = Inline }
+neverInlinePragma = defaultInlinePragma { inl_act = NeverActive }
+
+inlinePragmaSpec :: InlinePragma -> InlineSpec
+inlinePragmaSpec = inl_inline
+
+-- A DFun has an always-active inline activation so that
+-- exprIsConApp_maybe can "see" its unfolding
+-- (However, its actual Unfolding is a DFunUnfolding, which is
+-- never inlined other than via exprIsConApp_maybe.)
+dfunInlinePragma = defaultInlinePragma { inl_act = AlwaysActive
+ , inl_rule = ConLike }
+
+isDefaultInlinePragma :: InlinePragma -> Bool
+isDefaultInlinePragma (InlinePragma { inl_act = activation
+ , inl_rule = match_info
+ , inl_inline = inline })
+ = isEmptyInlineSpec inline && isAlwaysActive activation && isFunLike match_info
+
+isInlinePragma :: InlinePragma -> Bool
+isInlinePragma prag = case inl_inline prag of
+ Inline -> True
+ _ -> False
+
+isInlinablePragma :: InlinePragma -> Bool
+isInlinablePragma prag = case inl_inline prag of
+ Inlinable -> True
+ _ -> False
+
+isAnyInlinePragma :: InlinePragma -> Bool
+-- INLINE or INLINABLE
+isAnyInlinePragma prag = case inl_inline prag of
+ Inline -> True
+ Inlinable -> True
+ _ -> False
+
+inlinePragmaSat :: InlinePragma -> Maybe Arity
+inlinePragmaSat = inl_sat
+
+inlinePragmaActivation :: InlinePragma -> Activation
+inlinePragmaActivation (InlinePragma { inl_act = activation }) = activation
+
+inlinePragmaRuleMatchInfo :: InlinePragma -> RuleMatchInfo
+inlinePragmaRuleMatchInfo (InlinePragma { inl_rule = info }) = info
+
+setInlinePragmaActivation :: InlinePragma -> Activation -> InlinePragma
+setInlinePragmaActivation prag activation = prag { inl_act = activation }
+
+setInlinePragmaRuleMatchInfo :: InlinePragma -> RuleMatchInfo -> InlinePragma
+setInlinePragmaRuleMatchInfo prag info = prag { inl_rule = info }
+
+instance Outputable Activation where
+ ppr AlwaysActive = empty
+ ppr NeverActive = brackets (text "~")
+ ppr (ActiveBefore _ n) = brackets (char '~' <> int n)
+ ppr (ActiveAfter _ n) = brackets (int n)
+
+instance Outputable RuleMatchInfo where
+ ppr ConLike = text "CONLIKE"
+ ppr FunLike = text "FUNLIKE"
+
+instance Outputable InlineSpec where
+ ppr Inline = text "INLINE"
+ ppr NoInline = text "NOINLINE"
+ ppr Inlinable = text "INLINABLE"
+ ppr EmptyInlineSpec = empty
+
+instance Outputable InlinePragma where
+ ppr = pprInline
+
+pprInline :: InlinePragma -> SDoc
+pprInline = pprInline' True
+
+pprInlineDebug :: InlinePragma -> SDoc
+pprInlineDebug = pprInline' False
+
+pprInline' :: Bool -> InlinePragma -> SDoc
+pprInline' emptyInline (InlinePragma { inl_inline = inline, inl_act = activation
+ , inl_rule = info, inl_sat = mb_arity })
+ = pp_inl inline <> pp_act inline activation <+> pp_sat <+> pp_info
+ where
+ pp_inl x = if emptyInline then empty else ppr x
+
+ pp_act Inline AlwaysActive = empty
+ pp_act NoInline NeverActive = empty
+ pp_act _ act = ppr act
+
+ pp_sat | Just ar <- mb_arity = parens (text "sat-args=" <> int ar)
+ | otherwise = empty
+ pp_info | isFunLike info = empty
+ | otherwise = ppr info
+
+isActive :: CompilerPhase -> Activation -> Bool
+isActive InitialPhase AlwaysActive = True
+isActive InitialPhase (ActiveBefore {}) = True
+isActive InitialPhase _ = False
+isActive (Phase p) act = isActiveIn p act
+
+isActiveIn :: PhaseNum -> Activation -> Bool
+isActiveIn _ NeverActive = False
+isActiveIn _ AlwaysActive = True
+isActiveIn p (ActiveAfter _ n) = p <= n
+isActiveIn p (ActiveBefore _ n) = p > n
+
+competesWith :: Activation -> Activation -> Bool
+-- See Note [Activation competition]
+competesWith NeverActive _ = False
+competesWith _ NeverActive = False
+competesWith AlwaysActive _ = True
+
+competesWith (ActiveBefore {}) AlwaysActive = True
+competesWith (ActiveBefore {}) (ActiveBefore {}) = True
+competesWith (ActiveBefore _ a) (ActiveAfter _ b) = a < b
+
+competesWith (ActiveAfter {}) AlwaysActive = False
+competesWith (ActiveAfter {}) (ActiveBefore {}) = False
+competesWith (ActiveAfter _ a) (ActiveAfter _ b) = a >= b
+
+{- Note [Competing activations]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Sometimes a RULE and an inlining may compete, or two RULES.
+See Note [Rules and inlining/other rules] in Desugar.
+
+We say that act1 "competes with" act2 iff
+ act1 is active in the phase when act2 *becomes* active
+NB: remember that phases count *down*: 2, 1, 0!
+
+It's too conservative to ensure that the two are never simultaneously
+active. For example, a rule might be always active, and an inlining
+might switch on in phase 2. We could switch off the rule, but it does
+no harm.
+-}
+
+isNeverActive, isAlwaysActive, isEarlyActive :: Activation -> Bool
+isNeverActive NeverActive = True
+isNeverActive _ = False
+
+isAlwaysActive AlwaysActive = True
+isAlwaysActive _ = False
+
+isEarlyActive AlwaysActive = True
+isEarlyActive (ActiveBefore {}) = True
+isEarlyActive _ = False
+
+-- | Fractional Literal
+--
+-- Used (instead of Rational) to represent exactly the floating point literal that we
+-- encountered in the user's source program. This allows us to pretty-print exactly what
+-- the user wrote, which is important e.g. for floating point numbers that can't represented
+-- as Doubles (we used to via Double for pretty-printing). See also #2245.
+data FractionalLit
+ = FL { fl_text :: String -- How the value was written in the source
+ , fl_value :: Rational -- Numeric value of the literal
+ }
+ deriving (Data, Show)
+ -- The Show instance is required for the derived Lexer.x:Token instance when DEBUG is on
+
+negateFractionalLit :: FractionalLit -> FractionalLit
+negateFractionalLit (FL { fl_text = '-':text, fl_value = value }) = FL { fl_text = text, fl_value = negate value }
+negateFractionalLit (FL { fl_text = text, fl_value = value }) = FL { fl_text = '-':text, fl_value = negate value }
+
+integralFractionalLit :: Integer -> FractionalLit
+integralFractionalLit i = FL { fl_text = show i, fl_value = fromInteger i }
+
+-- Comparison operations are needed when grouping literals
+-- for compiling pattern-matching (module MatchLit)
+
+instance Eq FractionalLit where
+ (==) = (==) `on` fl_value
+
+instance Ord FractionalLit where
+ compare = compare `on` fl_value
+
+instance Outputable FractionalLit where
+ ppr = text . fl_text
+
+{-
+************************************************************************
+* *
+ IntWithInf
+* *
+************************************************************************
+
+Represents an integer or positive infinity
+
+-}
+
+-- | An integer or infinity
+data IntWithInf = Int {-# UNPACK #-} !Int
+ | Infinity
+ deriving Eq
+
+-- | A representation of infinity
+infinity :: IntWithInf
+infinity = Infinity
+
+instance Ord IntWithInf where
+ compare Infinity Infinity = EQ
+ compare (Int _) Infinity = LT
+ compare Infinity (Int _) = GT
+ compare (Int a) (Int b) = a `compare` b
+
+instance Outputable IntWithInf where
+ ppr Infinity = char '∞'
+ ppr (Int n) = int n
+
+instance Num IntWithInf where
+ (+) = plusWithInf
+ (*) = mulWithInf
+
+ abs Infinity = Infinity
+ abs (Int n) = Int (abs n)
+
+ signum Infinity = Int 1
+ signum (Int n) = Int (signum n)
+
+ fromInteger = Int . fromInteger
+
+ (-) = panic "subtracting IntWithInfs"
+
+intGtLimit :: Int -> IntWithInf -> Bool
+intGtLimit _ Infinity = False
+intGtLimit n (Int m) = n > m
+
+-- | Add two 'IntWithInf's
+plusWithInf :: IntWithInf -> IntWithInf -> IntWithInf
+plusWithInf Infinity _ = Infinity
+plusWithInf _ Infinity = Infinity
+plusWithInf (Int a) (Int b) = Int (a + b)
+
+-- | Multiply two 'IntWithInf's
+mulWithInf :: IntWithInf -> IntWithInf -> IntWithInf
+mulWithInf Infinity _ = Infinity
+mulWithInf _ Infinity = Infinity
+mulWithInf (Int a) (Int b) = Int (a * b)
+
+-- | Turn a positive number into an 'IntWithInf', where 0 represents infinity
+treatZeroAsInf :: Int -> IntWithInf
+treatZeroAsInf 0 = Infinity
+treatZeroAsInf n = Int n
+
+-- | Inject any integer into an 'IntWithInf'
+mkIntWithInf :: Int -> IntWithInf
+mkIntWithInf = Int
+
+data SpliceExplicitFlag
+ = ExplicitSplice | -- ^ <=> $(f x y)
+ ImplicitSplice -- ^ <=> f x y, i.e. a naked top level expression
+ deriving Data
diff --git a/basicTypes/ConLike.hs b/basicTypes/ConLike.hs
new file mode 100644
--- /dev/null
+++ b/basicTypes/ConLike.hs
@@ -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
diff --git a/basicTypes/ConLike.hs-boot b/basicTypes/ConLike.hs-boot
new file mode 100644
--- /dev/null
+++ b/basicTypes/ConLike.hs-boot
@@ -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
diff --git a/basicTypes/DataCon.hs b/basicTypes/DataCon.hs
new file mode 100644
--- /dev/null
+++ b/basicTypes/DataCon.hs
@@ -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
diff --git a/basicTypes/DataCon.hs-boot b/basicTypes/DataCon.hs-boot
new file mode 100644
--- /dev/null
+++ b/basicTypes/DataCon.hs-boot
@@ -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
diff --git a/basicTypes/Demand.hs b/basicTypes/Demand.hs
new file mode 100644
--- /dev/null
+++ b/basicTypes/Demand.hs
@@ -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=] :: (Bool, Bool)) ->
+ case x_an1
+ of wild_X7 [Dmd=]
+ { (p_an2 [Dmd=], ds_dnz [Dmd=]) ->
+ case p_an2 of _ {
+ False -> GHC.Types.True;
+ True -> foo wild_X7 }
+
+It's true that ds_dnz is *itself* absent, but the use of wild_X7 means
+that it is very much alive and demanded. See Trac #10148 for how the
+consequences play out.
+
+This is needed even for non-product types, in case the case-binder
+is used but the components of the case alternative are not.
+
+Note [Don't optimise UProd(Used) to Used]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+These two UseDmds:
+ UProd [Used, Used] and Used
+are semantically equivalent, but we do not turn the former into
+the latter, for a regrettable-subtle reason. Suppose we did.
+then
+ f (x,y) = (y,x)
+would get
+ StrDmd = Str = SProd [Lazy, Lazy]
+ UseDmd = Used = UProd [Used, Used]
+But with the joint demand of doesn't convey any clue
+that there is a product involved, and so the worthSplittingFun
+will not fire. (We'd need to use the type as well to make it fire.)
+Moreover, consider
+ g h p@(_,_) = h p
+This too would get , but this time there really isn't any
+point in w/w since the components of the pair are not used at all.
+
+So the solution is: don't aggressively collapse UProd [Used,Used] to
+Used; intead leave it as-is. In effect we are using the UseDmd to do a
+little bit of boxity analysis. Not very nice.
+
+Note [Used should win]
+~~~~~~~~~~~~~~~~~~~~~~
+Both in lubUse and bothUse we want (Used `both` UProd us) to be Used.
+Why? Because Used carries the implication the whole thing is used,
+box and all, so we don't want to w/w it. If we use it both boxed and
+unboxed, then we are definitely using the box, and so we are quite
+likely to pay a reboxing cost. So we make Used win here.
+
+Example is in the Buffer argument of GHC.IO.Handle.Internals.writeCharBuffer
+
+Baseline: (A) Not making Used win (UProd wins)
+Compare with: (B) making Used win for lub and both
+
+ Min -0.3% -5.6% -10.7% -11.0% -33.3%
+ Max +0.3% +45.6% +11.5% +11.5% +6.9%
+ Geometric Mean -0.0% +0.5% +0.3% +0.2% -0.8%
+
+Baseline: (B) Making Used win for both lub and both
+Compare with: (C) making Used win for both, but UProd win for lub
+
+ Min -0.1% -0.3% -7.9% -8.0% -6.5%
+ Max +0.1% +1.0% +21.0% +21.0% +0.5%
+ Geometric Mean +0.0% +0.0% -0.0% -0.1% -0.1%
+-}
+
+-- If a demand is used multiple times (i.e. reused), than any use-once
+-- mentioned there, that is not protected by a UCall, can happen many times.
+markReusedDmd :: ArgUse -> ArgUse
+markReusedDmd Abs = Abs
+markReusedDmd (Use _ a) = Use Many (markReused a)
+
+markReused :: UseDmd -> UseDmd
+markReused (UCall _ u) = UCall Many u -- No need to recurse here
+markReused (UProd ux) = UProd (map markReusedDmd ux)
+markReused u = u
+
+isUsedMU :: ArgUse -> Bool
+-- True <=> markReusedDmd d = d
+isUsedMU Abs = True
+isUsedMU (Use One _) = False
+isUsedMU (Use Many u) = isUsedU u
+
+isUsedU :: UseDmd -> Bool
+-- True <=> markReused d = d
+isUsedU Used = True
+isUsedU UHead = True
+isUsedU (UProd us) = all isUsedMU us
+isUsedU (UCall One _) = False
+isUsedU (UCall Many _) = True -- No need to recurse
+
+-- Squashing usage demand demands
+seqUseDmd :: UseDmd -> ()
+seqUseDmd (UProd ds) = seqArgUseList ds
+seqUseDmd (UCall c d) = c `seq` seqUseDmd d
+seqUseDmd _ = ()
+
+seqArgUseList :: [ArgUse] -> ()
+seqArgUseList [] = ()
+seqArgUseList (d:ds) = seqArgUse d `seq` seqArgUseList ds
+
+seqArgUse :: ArgUse -> ()
+seqArgUse (Use c u) = c `seq` seqUseDmd u
+seqArgUse _ = ()
+
+-- Splitting polymorphic Maybe-Used demands
+splitUseProdDmd :: Int -> UseDmd -> Maybe [ArgUse]
+splitUseProdDmd n Used = Just (replicate n useTop)
+splitUseProdDmd n UHead = Just (replicate n Abs)
+splitUseProdDmd n (UProd ds) = WARN( not (ds `lengthIs` n),
+ text "splitUseProdDmd" $$ ppr n
+ $$ ppr ds )
+ Just ds
+splitUseProdDmd _ (UCall _ _) = Nothing
+ -- This can happen when the programmer uses unsafeCoerce,
+ -- and we don't then want to crash the compiler (Trac #9208)
+
+useCount :: Use u -> Count
+useCount Abs = One
+useCount (Use One _) = One
+useCount _ = Many
+
+
+{-
+************************************************************************
+* *
+ Clean demand for Strictness and Usage
+* *
+************************************************************************
+
+This domain differst from JointDemand in the sence that pure absence
+is taken away, i.e., we deal *only* with non-absent demands.
+
+Note [Strict demands]
+~~~~~~~~~~~~~~~~~~~~~
+isStrictDmd returns true only of demands that are
+ both strict
+ and used
+In particular, it is False for , which can and does
+arise in, say (Trac #7319)
+ f x = raise#
+Then 'x' is not used, so f gets strictness -> .
+Now the w/w generates
+ fx = let x = absentError "unused"
+ in raise
+At this point we really don't want to convert to
+ fx = case absentError "unused" of x -> raise
+Since the program is going to diverge, this swaps one error for another,
+but it's really a bad idea to *ever* evaluate an absent argument.
+In Trac #7319 we get
+ T7319.exe: Oops! Entered absent arg w_s1Hd{v} [lid] [base:GHC.Base.String{tc 36u}]
+
+Note [Dealing with call demands]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Call demands are constructed and deconstructed coherently for
+strictness and absence. For instance, the strictness signature for the
+following function
+
+f :: (Int -> (Int, Int)) -> (Int, Bool)
+f g = (snd (g 3), True)
+
+should be: m
+-}
+
+type CleanDemand = JointDmd StrDmd UseDmd
+ -- A demand that is at least head-strict
+
+bothCleanDmd :: CleanDemand -> CleanDemand -> CleanDemand
+bothCleanDmd (JD { sd = s1, ud = a1}) (JD { sd = s2, ud = a2})
+ = JD { sd = s1 `bothStr` s2, ud = a1 `bothUse` a2 }
+
+mkHeadStrict :: CleanDemand -> CleanDemand
+mkHeadStrict cd = cd { sd = HeadStr }
+
+mkOnceUsedDmd, mkManyUsedDmd :: CleanDemand -> Demand
+mkOnceUsedDmd (JD {sd = s,ud = a}) = JD { sd = Str VanStr s, ud = Use One a }
+mkManyUsedDmd (JD {sd = s,ud = a}) = JD { sd = Str VanStr s, ud = Use Many a }
+
+evalDmd :: Demand
+-- Evaluated strictly, and used arbitrarily deeply
+evalDmd = JD { sd = Str VanStr HeadStr, ud = useTop }
+
+mkProdDmd :: [Demand] -> CleanDemand
+mkProdDmd dx
+ = JD { sd = mkSProd $ map getStrDmd dx
+ , ud = mkUProd $ map getUseDmd dx }
+
+mkCallDmd :: CleanDemand -> CleanDemand
+mkCallDmd (JD {sd = d, ud = u})
+ = JD { sd = mkSCall d, ud = mkUCall One u }
+
+-- See Note [Demand on the worker] in WorkWrap
+mkWorkerDemand :: Int -> Demand
+mkWorkerDemand n = JD { sd = Lazy, ud = Use One (go n) }
+ where go 0 = Used
+ go n = mkUCall One $ go (n-1)
+
+cleanEvalDmd :: CleanDemand
+cleanEvalDmd = JD { sd = HeadStr, ud = Used }
+
+cleanEvalProdDmd :: Arity -> CleanDemand
+cleanEvalProdDmd n = JD { sd = HeadStr, ud = UProd (replicate n useTop) }
+
+
+{-
+************************************************************************
+* *
+ Demand: combining stricness and usage
+* *
+************************************************************************
+-}
+
+type Demand = JointDmd ArgStr ArgUse
+
+lubDmd :: Demand -> Demand -> Demand
+lubDmd (JD {sd = s1, ud = a1}) (JD {sd = s2, ud = a2})
+ = JD { sd = s1 `lubArgStr` s2
+ , ud = a1 `lubArgUse` a2 }
+
+bothDmd :: Demand -> Demand -> Demand
+bothDmd (JD {sd = s1, ud = a1}) (JD {sd = s2, ud = a2})
+ = JD { sd = s1 `bothArgStr` s2
+ , ud = a1 `bothArgUse` a2 }
+
+lazyApply1Dmd, lazyApply2Dmd, strictApply1Dmd, catchArgDmd :: Demand
+
+strictApply1Dmd = JD { sd = Str VanStr (SCall HeadStr)
+ , ud = Use Many (UCall One Used) }
+
+-- First argument of catchRetry# and catchSTM#:
+-- uses its arg once, applies it once
+-- and catches exceptions (the ExnStr) part
+catchArgDmd = JD { sd = Str ExnStr (SCall HeadStr)
+ , ud = Use One (UCall One Used) }
+
+lazyApply1Dmd = JD { sd = Lazy
+ , ud = Use One (UCall One Used) }
+
+-- Second argument of catch#:
+-- uses its arg at most once, applies it once
+-- but is lazy (might not be called at all)
+lazyApply2Dmd = JD { sd = Lazy
+ , ud = Use One (UCall One (UCall One Used)) }
+
+absDmd :: Demand
+absDmd = JD { sd = Lazy, ud = Abs }
+
+topDmd :: Demand
+topDmd = JD { sd = Lazy, ud = useTop }
+
+botDmd :: Demand
+botDmd = JD { sd = strBot, ud = useBot }
+
+seqDmd :: Demand
+seqDmd = JD { sd = Str VanStr HeadStr, ud = Use One UHead }
+
+oneifyDmd :: Demand -> Demand
+oneifyDmd (JD { sd = s, ud = Use _ a }) = JD { sd = s, ud = Use One a }
+oneifyDmd jd = jd
+
+isTopDmd :: Demand -> Bool
+-- Used to suppress pretty-printing of an uninformative demand
+isTopDmd (JD {sd = Lazy, ud = Use Many Used}) = True
+isTopDmd _ = False
+
+isAbsDmd :: Demand -> Bool
+isAbsDmd (JD {ud = Abs}) = True -- The strictness part can be HyperStr
+isAbsDmd _ = False -- for a bottom demand
+
+isSeqDmd :: Demand -> Bool
+isSeqDmd (JD {sd = Str VanStr HeadStr, ud = Use _ UHead}) = True
+isSeqDmd _ = False
+
+isUsedOnce :: Demand -> Bool
+isUsedOnce (JD { ud = a }) = case useCount a of
+ One -> True
+ Many -> False
+
+-- More utility functions for strictness
+seqDemand :: Demand -> ()
+seqDemand (JD {sd = s, ud = u}) = seqArgStr s `seq` seqArgUse u
+
+seqDemandList :: [Demand] -> ()
+seqDemandList [] = ()
+seqDemandList (d:ds) = seqDemand d `seq` seqDemandList ds
+
+isStrictDmd :: Demand -> Bool
+-- See Note [Strict demands]
+isStrictDmd (JD {ud = Abs}) = False
+isStrictDmd (JD {sd = Lazy}) = False
+isStrictDmd _ = True
+
+isWeakDmd :: Demand -> Bool
+isWeakDmd (JD {sd = s, ud = a}) = isLazy s && isUsedMU a
+
+cleanUseDmd_maybe :: Demand -> Maybe UseDmd
+cleanUseDmd_maybe (JD { ud = Use _ u }) = Just u
+cleanUseDmd_maybe _ = Nothing
+
+splitFVs :: Bool -- Thunk
+ -> DmdEnv -> (DmdEnv, DmdEnv)
+splitFVs is_thunk rhs_fvs
+ | is_thunk = nonDetFoldUFM_Directly add (emptyVarEnv, emptyVarEnv) rhs_fvs
+ -- It's OK to use nonDetFoldUFM_Directly because we
+ -- immediately forget the ordering by putting the elements
+ -- in the envs again
+ | otherwise = partitionVarEnv isWeakDmd rhs_fvs
+ where
+ add uniq dmd@(JD { sd = s, ud = u }) (lazy_fv, sig_fv)
+ | Lazy <- s = (addToUFM_Directly lazy_fv uniq dmd, sig_fv)
+ | otherwise = ( addToUFM_Directly lazy_fv uniq (JD { sd = Lazy, ud = u })
+ , addToUFM_Directly sig_fv uniq (JD { sd = s, ud = Abs }) )
+
+data TypeShape = TsFun TypeShape
+ | TsProd [TypeShape]
+ | TsUnk
+
+instance Outputable TypeShape where
+ ppr TsUnk = text "TsUnk"
+ ppr (TsFun ts) = text "TsFun" <> parens (ppr ts)
+ ppr (TsProd tss) = parens (hsep $ punctuate comma $ map ppr tss)
+
+trimToType :: Demand -> TypeShape -> Demand
+-- See Note [Trimming a demand to a type]
+trimToType (JD { sd = ms, ud = mu }) ts
+ = JD (go_ms ms ts) (go_mu mu ts)
+ where
+ go_ms :: ArgStr -> TypeShape -> ArgStr
+ go_ms Lazy _ = Lazy
+ go_ms (Str x s) ts = Str x (go_s s ts)
+
+ go_s :: StrDmd -> TypeShape -> StrDmd
+ go_s HyperStr _ = HyperStr
+ go_s (SCall s) (TsFun ts) = SCall (go_s s ts)
+ go_s (SProd mss) (TsProd tss)
+ | equalLength mss tss = SProd (zipWith go_ms mss tss)
+ go_s _ _ = HeadStr
+
+ go_mu :: ArgUse -> TypeShape -> ArgUse
+ go_mu Abs _ = Abs
+ go_mu (Use c u) ts = Use c (go_u u ts)
+
+ go_u :: UseDmd -> TypeShape -> UseDmd
+ go_u UHead _ = UHead
+ go_u (UCall c u) (TsFun ts) = UCall c (go_u u ts)
+ go_u (UProd mus) (TsProd tss)
+ | equalLength mus tss = UProd (zipWith go_mu mus tss)
+ go_u _ _ = Used
+
+{-
+Note [Trimming a demand to a type]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this:
+
+ f :: a -> Bool
+ f x = case ... of
+ A g1 -> case (x |> g1) of (p,q) -> ...
+ B -> error "urk"
+
+where A,B are the constructors of a GADT. We'll get a U(U,U) demand
+on x from the A branch, but that's a stupid demand for x itself, which
+has type 'a'. Indeed we get ASSERTs going off (notably in
+splitUseProdDmd, Trac #8569).
+
+Bottom line: we really don't want to have a binder whose demand is more
+deeply-nested than its type. There are various ways to tackle this.
+When processing (x |> g1), we could "trim" the incoming demand U(U,U)
+to match x's type. But I'm currently doing so just at the moment when
+we pin a demand on a binder, in DmdAnal.findBndrDmd.
+
+
+Note [Threshold demands]
+~~~~~~~~~~~~~~~~~~~~~~~~
+Threshold usage demand is generated to figure out if
+cardinality-instrumented demands of a binding's free variables should
+be unleashed. See also [Aggregated demand for cardinality].
+
+Note [Replicating polymorphic demands]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Some demands can be considered as polymorphic. Generally, it is
+applicable to such beasts as tops, bottoms as well as Head-Used and
+Head-stricts demands. For instance,
+
+S ~ S(L, ..., L)
+
+Also, when top or bottom is occurred as a result demand, it in fact
+can be expanded to saturate a callee's arity.
+-}
+
+splitProdDmd_maybe :: Demand -> Maybe [Demand]
+-- Split a product into its components, iff there is any
+-- useful information to be extracted thereby
+-- The demand is not necessarily strict!
+splitProdDmd_maybe (JD { sd = s, ud = u })
+ = case (s,u) of
+ (Str _ (SProd sx), Use _ u) | Just ux <- splitUseProdDmd (length sx) u
+ -> Just (mkJointDmds sx ux)
+ (Str _ s, Use _ (UProd ux)) | Just sx <- splitStrProdDmd (length ux) s
+ -> Just (mkJointDmds sx ux)
+ (Lazy, Use _ (UProd ux)) -> Just (mkJointDmds (replicate (length ux) Lazy) ux)
+ _ -> Nothing
+
+{-
+************************************************************************
+* *
+ Demand results
+* *
+************************************************************************
+
+
+DmdResult: Dunno CPRResult
+ /
+ ThrowsExn
+ /
+ Diverges
+
+
+CPRResult: NoCPR
+ / \
+ RetProd RetSum ConTag
+
+
+Product constructors return (Dunno (RetProd rs))
+In a fixpoint iteration, start from Diverges
+We have lubs, but not glbs; but that is ok.
+-}
+
+------------------------------------------------------------------------
+-- Constructed Product Result
+------------------------------------------------------------------------
+
+data Termination r
+ = Diverges -- Definitely diverges
+ | ThrowsExn -- Definitely throws an exception or diverges
+ | Dunno r -- Might diverge or converge
+ deriving( Eq, Show )
+
+type DmdResult = Termination CPRResult
+
+data CPRResult = NoCPR -- Top of the lattice
+ | RetProd -- Returns a constructor from a product type
+ | RetSum ConTag -- Returns a constructor from a data type
+ deriving( Eq, Show )
+
+lubCPR :: CPRResult -> CPRResult -> CPRResult
+lubCPR (RetSum t1) (RetSum t2)
+ | t1 == t2 = RetSum t1
+lubCPR RetProd RetProd = RetProd
+lubCPR _ _ = NoCPR
+
+lubDmdResult :: DmdResult -> DmdResult -> DmdResult
+lubDmdResult Diverges r = r
+lubDmdResult ThrowsExn Diverges = ThrowsExn
+lubDmdResult ThrowsExn r = r
+lubDmdResult (Dunno c1) Diverges = Dunno c1
+lubDmdResult (Dunno c1) ThrowsExn = Dunno c1
+lubDmdResult (Dunno c1) (Dunno c2) = Dunno (c1 `lubCPR` c2)
+-- This needs to commute with defaultDmd, i.e.
+-- defaultDmd (r1 `lubDmdResult` r2) = defaultDmd r1 `lubDmd` defaultDmd r2
+-- (See Note [Default demand on free variables] for why)
+
+bothDmdResult :: DmdResult -> Termination () -> DmdResult
+-- See Note [Asymmetry of 'both' for DmdType and DmdResult]
+bothDmdResult _ Diverges = Diverges
+bothDmdResult r ThrowsExn = case r of { Diverges -> r; _ -> ThrowsExn }
+bothDmdResult r (Dunno {}) = r
+-- This needs to commute with defaultDmd, i.e.
+-- defaultDmd (r1 `bothDmdResult` r2) = defaultDmd r1 `bothDmd` defaultDmd r2
+-- (See Note [Default demand on free variables] for why)
+
+instance Outputable r => Outputable (Termination r) where
+ ppr Diverges = char 'b'
+ ppr ThrowsExn = char 'x'
+ ppr (Dunno c) = ppr c
+
+instance Outputable CPRResult where
+ ppr NoCPR = empty
+ ppr (RetSum n) = char 'm' <> int n
+ ppr RetProd = char 'm'
+
+seqDmdResult :: DmdResult -> ()
+seqDmdResult Diverges = ()
+seqDmdResult ThrowsExn = ()
+seqDmdResult (Dunno c) = seqCPRResult c
+
+seqCPRResult :: CPRResult -> ()
+seqCPRResult NoCPR = ()
+seqCPRResult (RetSum n) = n `seq` ()
+seqCPRResult RetProd = ()
+
+
+------------------------------------------------------------------------
+-- Combined demand result --
+------------------------------------------------------------------------
+
+-- [cprRes] lets us switch off CPR analysis
+-- by making sure that everything uses TopRes
+topRes, exnRes, botRes :: DmdResult
+topRes = Dunno NoCPR
+exnRes = ThrowsExn
+botRes = Diverges
+
+cprSumRes :: ConTag -> DmdResult
+cprSumRes tag = Dunno $ RetSum tag
+
+cprProdRes :: [DmdType] -> DmdResult
+cprProdRes _arg_tys = Dunno $ RetProd
+
+vanillaCprProdRes :: Arity -> DmdResult
+vanillaCprProdRes _arity = Dunno $ RetProd
+
+isTopRes :: DmdResult -> Bool
+isTopRes (Dunno NoCPR) = True
+isTopRes _ = False
+
+isBotRes :: DmdResult -> Bool
+-- True if the result diverges or throws an exception
+isBotRes Diverges = True
+isBotRes ThrowsExn = True
+isBotRes (Dunno {}) = False
+
+trimCPRInfo :: Bool -> Bool -> DmdResult -> DmdResult
+trimCPRInfo trim_all trim_sums res
+ = trimR res
+ where
+ trimR (Dunno c) = Dunno (trimC c)
+ trimR res = res
+
+ trimC (RetSum n) | trim_all || trim_sums = NoCPR
+ | otherwise = RetSum n
+ trimC RetProd | trim_all = NoCPR
+ | otherwise = RetProd
+ trimC NoCPR = NoCPR
+
+returnsCPR_maybe :: DmdResult -> Maybe ConTag
+returnsCPR_maybe (Dunno c) = retCPR_maybe c
+returnsCPR_maybe _ = Nothing
+
+retCPR_maybe :: CPRResult -> Maybe ConTag
+retCPR_maybe (RetSum t) = Just t
+retCPR_maybe RetProd = Just fIRST_TAG
+retCPR_maybe NoCPR = Nothing
+
+-- See Notes [Default demand on free variables]
+-- and [defaultDmd vs. resTypeArgDmd]
+defaultDmd :: Termination r -> Demand
+defaultDmd (Dunno {}) = absDmd
+defaultDmd _ = botDmd -- Diverges or ThrowsExn
+
+resTypeArgDmd :: Termination r -> Demand
+-- TopRes and BotRes are polymorphic, so that
+-- BotRes === (Bot -> BotRes) === ...
+-- TopRes === (Top -> TopRes) === ...
+-- This function makes that concrete
+-- Also see Note [defaultDmd vs. resTypeArgDmd]
+resTypeArgDmd (Dunno _) = topDmd
+resTypeArgDmd _ = botDmd -- Diverges or ThrowsExn
+
+{-
+Note [defaultDmd and resTypeArgDmd]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+These functions are similar: They express the demand on something not
+explicitly mentioned in the environment resp. the argument list. Yet they are
+different:
+ * Variables not mentioned in the free variables environment are definitely
+ unused, so we can use absDmd there.
+ * Further arguments *can* be used, of course. Hence topDmd is used.
+
+Note [Worthy functions for Worker-Wrapper split]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For non-bottoming functions a worker-wrapper transformation takes into
+account several possibilities to decide if the function is worthy for
+splitting:
+
+1. The result is of product type and the function is strict in some
+(or even all) of its arguments. The check that the argument is used is
+more of sanity nature, since strictness implies usage. Example:
+
+f :: (Int, Int) -> Int
+f p = (case p of (a,b) -> a) + 1
+
+should be splitted to
+
+f :: (Int, Int) -> Int
+f p = case p of (a,b) -> $wf a
+
+$wf :: Int -> Int
+$wf a = a + 1
+
+2. Sometimes it also makes sense to perform a WW split if the
+strictness analysis cannot say for sure if the function is strict in
+components of its argument. Then we reason according to the inferred
+usage information: if the function uses its product argument's
+components, the WW split can be beneficial. Example:
+
+g :: Bool -> (Int, Int) -> Int
+g c p = case p of (a,b) ->
+ if c then a else b
+
+The function g is strict in is argument p and lazy in its
+components. However, both components are used in the RHS. The idea is
+since some of the components (both in this case) are used in the
+right-hand side, the product must presumable be taken apart.
+
+Therefore, the WW transform splits the function g to
+
+g :: Bool -> (Int, Int) -> Int
+g c p = case p of (a,b) -> $wg c a b
+
+$wg :: Bool -> Int -> Int -> Int
+$wg c a b = if c then a else b
+
+3. If an argument is absent, it would be silly to pass it to a
+function, hence the worker with reduced arity is generated.
+
+
+Note [Worker-wrapper for bottoming functions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We used not to split if the result is bottom.
+[Justification: there's no efficiency to be gained.]
+
+But it's sometimes bad not to make a wrapper. Consider
+ fw = \x# -> let x = I# x# in case e of
+ p1 -> error_fn x
+ p2 -> error_fn x
+ p3 -> the real stuff
+The re-boxing code won't go away unless error_fn gets a wrapper too.
+[We don't do reboxing now, but in general it's better to pass an
+unboxed thing to f, and have it reboxed in the error cases....]
+
+However we *don't* want to do this when the argument is not actually
+taken apart in the function at all. Otherwise we risk decomposing a
+massive tuple which is barely used. Example:
+
+ f :: ((Int,Int) -> String) -> (Int,Int) -> a
+ f g pr = error (g pr)
+
+ main = print (f fst (1, error "no"))
+
+Here, f does not take 'pr' apart, and it's stupid to do so.
+Imagine that it had millions of fields. This actually happened
+in GHC itself where the tuple was DynFlags
+
+
+************************************************************************
+* *
+ Demand environments and types
+* *
+************************************************************************
+-}
+
+type DmdEnv = VarEnv Demand -- See Note [Default demand on free variables]
+
+data DmdType = DmdType
+ DmdEnv -- Demand on explicitly-mentioned
+ -- free variables
+ [Demand] -- Demand on arguments
+ DmdResult -- See [Nature of result demand]
+
+{-
+Note [Nature of result demand]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+A DmdResult contains information about termination (currently distinguishing
+definite divergence and no information; it is possible to include definite
+convergence here), and CPR information about the result.
+
+The semantics of this depends on whether we are looking at a DmdType, i.e. the
+demand put on by an expression _under a specific incoming demand_ on its
+environment, or at a StrictSig describing a demand transformer.
+
+For a
+ * DmdType, the termination information is true given the demand it was
+ generated with, while for
+ * a StrictSig it holds after applying enough arguments.
+
+The CPR information, though, is valid after the number of arguments mentioned
+in the type is given. Therefore, when forgetting the demand on arguments, as in
+dmdAnalRhs, this needs to be considere (via removeDmdTyArgs).
+
+Consider
+ b2 x y = x `seq` y `seq` error (show x)
+this has a strictness signature of
+ b
+meaning that "b2 `seq` ()" and "b2 1 `seq` ()" might well terminate, but
+for "b2 1 2 `seq` ()" we get definite divergence.
+
+For comparison,
+ b1 x = x `seq` error (show x)
+has a strictness signature of
+ b
+and "b1 1 `seq` ()" is known to terminate.
+
+Now consider a function h with signature "", and the expression
+ e1 = h b1
+now h puts a demand of onto its argument, and the demand transformer
+turns it into
+ b
+Now the DmdResult "b" does apply to us, even though "b1 `seq` ()" does not
+diverge, and we do not anything being passed to b.
+
+Note [Asymmetry of 'both' for DmdType and DmdResult]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+'both' for DmdTypes is *asymmetrical*, because there is only one
+result! For example, given (e1 e2), we get a DmdType dt1 for e1, use
+its arg demand to analyse e2 giving dt2, and then do (dt1 `bothType` dt2).
+Similarly with
+ case e of { p -> rhs }
+we get dt_scrut from the scrutinee and dt_rhs from the RHS, and then
+compute (dt_rhs `bothType` dt_scrut).
+
+We
+ 1. combine the information on the free variables,
+ 2. take the demand on arguments from the first argument
+ 3. combine the termination results, but
+ 4. take CPR info from the first argument.
+
+3 and 4 are implementd in bothDmdResult.
+-}
+
+-- Equality needed for fixpoints in DmdAnal
+instance Eq DmdType where
+ (==) (DmdType fv1 ds1 res1)
+ (DmdType fv2 ds2 res2) = nonDetUFMToList fv1 == nonDetUFMToList fv2
+ -- It's OK to use nonDetUFMToList here because we're testing for
+ -- equality and even though the lists will be in some arbitrary
+ -- Unique order, it is the same order for both
+ && ds1 == ds2 && res1 == res2
+
+lubDmdType :: DmdType -> DmdType -> DmdType
+lubDmdType d1 d2
+ = DmdType lub_fv lub_ds lub_res
+ where
+ n = max (dmdTypeDepth d1) (dmdTypeDepth d2)
+ (DmdType fv1 ds1 r1) = ensureArgs n d1
+ (DmdType fv2 ds2 r2) = ensureArgs n d2
+
+ lub_fv = plusVarEnv_CD lubDmd fv1 (defaultDmd r1) fv2 (defaultDmd r2)
+ lub_ds = zipWithEqual "lubDmdType" lubDmd ds1 ds2
+ lub_res = lubDmdResult r1 r2
+
+{-
+Note [The need for BothDmdArg]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Previously, the right argument to bothDmdType, as well as the return value of
+dmdAnalStar via postProcessDmdType, was a DmdType. But bothDmdType only needs
+to know about the free variables and termination information, but nothing about
+the demand put on arguments, nor cpr information. So we make that explicit by
+only passing the relevant information.
+-}
+
+type BothDmdArg = (DmdEnv, Termination ())
+
+mkBothDmdArg :: DmdEnv -> BothDmdArg
+mkBothDmdArg env = (env, Dunno ())
+
+toBothDmdArg :: DmdType -> BothDmdArg
+toBothDmdArg (DmdType fv _ r) = (fv, go r)
+ where
+ go (Dunno {}) = Dunno ()
+ go ThrowsExn = ThrowsExn
+ go Diverges = Diverges
+
+bothDmdType :: DmdType -> BothDmdArg -> DmdType
+bothDmdType (DmdType fv1 ds1 r1) (fv2, t2)
+ -- See Note [Asymmetry of 'both' for DmdType and DmdResult]
+ -- 'both' takes the argument/result info from its *first* arg,
+ -- using its second arg just for its free-var info.
+ = DmdType (plusVarEnv_CD bothDmd fv1 (defaultDmd r1) fv2 (defaultDmd t2))
+ ds1
+ (r1 `bothDmdResult` t2)
+
+instance Outputable DmdType where
+ ppr (DmdType fv ds res)
+ = hsep [hcat (map ppr ds) <> ppr res,
+ if null fv_elts then empty
+ else braces (fsep (map pp_elt fv_elts))]
+ where
+ pp_elt (uniq, dmd) = ppr uniq <> text "->" <> ppr dmd
+ fv_elts = nonDetUFMToList fv
+ -- It's OK to use nonDetUFMToList here because we only do it for
+ -- pretty printing
+
+emptyDmdEnv :: VarEnv Demand
+emptyDmdEnv = emptyVarEnv
+
+-- nopDmdType is the demand of doing nothing
+-- (lazy, absent, no CPR information, no termination information).
+-- Note that it is ''not'' the top of the lattice (which would be "may use everything"),
+-- so it is (no longer) called topDmd
+nopDmdType, botDmdType, exnDmdType :: DmdType
+nopDmdType = DmdType emptyDmdEnv [] topRes
+botDmdType = DmdType emptyDmdEnv [] botRes
+exnDmdType = DmdType emptyDmdEnv [] exnRes
+
+cprProdDmdType :: Arity -> DmdType
+cprProdDmdType arity
+ = DmdType emptyDmdEnv [] (vanillaCprProdRes arity)
+
+isTopDmdType :: DmdType -> Bool
+isTopDmdType (DmdType env [] res)
+ | isTopRes res && isEmptyVarEnv env = True
+isTopDmdType _ = False
+
+mkDmdType :: DmdEnv -> [Demand] -> DmdResult -> DmdType
+mkDmdType fv ds res = DmdType fv ds res
+
+dmdTypeDepth :: DmdType -> Arity
+dmdTypeDepth (DmdType _ ds _) = length ds
+
+-- Remove any demand on arguments. This is used in dmdAnalRhs on the body
+removeDmdTyArgs :: DmdType -> DmdType
+removeDmdTyArgs = ensureArgs 0
+
+-- This makes sure we can use the demand type with n arguments,
+-- It extends the argument list with the correct resTypeArgDmd
+-- It also adjusts the DmdResult: Divergence survives additional arguments,
+-- CPR information does not (and definite converge also would not).
+ensureArgs :: Arity -> DmdType -> DmdType
+ensureArgs n d | n == depth = d
+ | otherwise = DmdType fv ds' r'
+ where depth = dmdTypeDepth d
+ DmdType fv ds r = d
+
+ ds' = take n (ds ++ repeat (resTypeArgDmd r))
+ r' = case r of -- See [Nature of result demand]
+ Dunno _ -> topRes
+ _ -> r
+
+
+seqDmdType :: DmdType -> ()
+seqDmdType (DmdType env ds res) =
+ seqDmdEnv env `seq` seqDemandList ds `seq` seqDmdResult res `seq` ()
+
+seqDmdEnv :: DmdEnv -> ()
+seqDmdEnv env = seqEltsUFM seqDemandList env
+
+splitDmdTy :: DmdType -> (Demand, DmdType)
+-- Split off one function argument
+-- We already have a suitable demand on all
+-- free vars, so no need to add more!
+splitDmdTy (DmdType fv (dmd:dmds) res_ty) = (dmd, DmdType fv dmds res_ty)
+splitDmdTy ty@(DmdType _ [] res_ty) = (resTypeArgDmd res_ty, ty)
+
+-- When e is evaluated after executing an IO action, and d is e's demand, then
+-- what of this demand should we consider, given that the IO action can cleanly
+-- exit?
+-- * We have to kill all strictness demands (i.e. lub with a lazy demand)
+-- * We can keep usage information (i.e. lub with an absent demand)
+-- * We have to kill definite divergence
+-- * We can keep CPR information.
+-- See Note [IO hack in the demand analyser] in DmdAnal
+deferAfterIO :: DmdType -> DmdType
+deferAfterIO d@(DmdType _ _ res) =
+ case d `lubDmdType` nopDmdType of
+ DmdType fv ds _ -> DmdType fv ds (defer_res res)
+ where
+ defer_res r@(Dunno {}) = r
+ defer_res _ = topRes -- Diverges and ThrowsExn
+
+strictenDmd :: Demand -> CleanDemand
+strictenDmd (JD { sd = s, ud = u})
+ = JD { sd = poke_s s, ud = poke_u u }
+ where
+ poke_s Lazy = HeadStr
+ poke_s (Str _ s) = s
+ poke_u Abs = UHead
+ poke_u (Use _ u) = u
+
+-- Deferring and peeling
+
+type DmdShell -- Describes the "outer shell"
+ -- of a Demand
+ = JointDmd (Str ()) (Use ())
+
+toCleanDmd :: Demand -> Type -> (DmdShell, CleanDemand)
+-- Splits a Demand into its "shell" and the inner "clean demand"
+toCleanDmd (JD { sd = s, ud = u }) expr_ty
+ = (JD { sd = ss, ud = us }, JD { sd = s', ud = u' })
+ -- See Note [Analyzing with lazy demand and lambdas]
+ where
+ (ss, s') = case s of
+ Str x s' -> (Str x (), s')
+ Lazy | is_unlifted -> (Str VanStr (), HeadStr)
+ | otherwise -> (Lazy, HeadStr)
+
+ (us, u') = case u of
+ Use c u' -> (Use c (), u')
+ Abs | is_unlifted -> (Use One (), Used)
+ | otherwise -> (Abs, Used)
+
+ is_unlifted = isUnliftedType expr_ty
+ -- See Note [Analysing with absent demand]
+
+
+-- This is used in dmdAnalStar when post-processing
+-- a function's argument demand. So we only care about what
+-- does to free variables, and whether it terminates.
+-- see Note [The need for BothDmdArg]
+postProcessDmdType :: DmdShell -> DmdType -> BothDmdArg
+postProcessDmdType du@(JD { sd = ss }) (DmdType fv _ res_ty)
+ = (postProcessDmdEnv du fv, term_info)
+ where
+ term_info = case postProcessDmdResult ss res_ty of
+ Dunno _ -> Dunno ()
+ ThrowsExn -> ThrowsExn
+ Diverges -> Diverges
+
+postProcessDmdResult :: Str () -> DmdResult -> DmdResult
+postProcessDmdResult Lazy _ = topRes
+postProcessDmdResult (Str ExnStr _) ThrowsExn = topRes -- Key point!
+postProcessDmdResult _ res = res
+
+postProcessDmdEnv :: DmdShell -> DmdEnv -> DmdEnv
+postProcessDmdEnv ds@(JD { sd = ss, ud = us }) env
+ | Abs <- us = emptyDmdEnv
+ -- In this case (postProcessDmd ds) == id; avoid a redundant rebuild
+ -- of the environment. Be careful, bad things will happen if this doesn't
+ -- match postProcessDmd (see #13977).
+ | Str VanStr _ <- ss
+ , Use One _ <- us = env
+ | otherwise = mapVarEnv (postProcessDmd ds) env
+ -- For the Absent case just discard all usage information
+ -- We only processed the thing at all to analyse the body
+ -- See Note [Always analyse in virgin pass]
+
+reuseEnv :: DmdEnv -> DmdEnv
+reuseEnv = mapVarEnv (postProcessDmd
+ (JD { sd = Str VanStr (), ud = Use Many () }))
+
+postProcessUnsat :: DmdShell -> DmdType -> DmdType
+postProcessUnsat ds@(JD { sd = ss }) (DmdType fv args res_ty)
+ = DmdType (postProcessDmdEnv ds fv)
+ (map (postProcessDmd ds) args)
+ (postProcessDmdResult ss res_ty)
+
+postProcessDmd :: DmdShell -> Demand -> Demand
+postProcessDmd (JD { sd = ss, ud = us }) (JD { sd = s, ud = a})
+ = JD { sd = s', ud = a' }
+ where
+ s' = case ss of
+ Lazy -> Lazy
+ Str ExnStr _ -> markExnStr s
+ Str VanStr _ -> s
+ a' = case us of
+ Abs -> Abs
+ Use Many _ -> markReusedDmd a
+ Use One _ -> a
+
+markExnStr :: ArgStr -> ArgStr
+markExnStr (Str VanStr s) = Str ExnStr s
+markExnStr s = s
+
+-- Peels one call level from the demand, and also returns
+-- whether it was unsaturated (separately for strictness and usage)
+peelCallDmd :: CleanDemand -> (CleanDemand, DmdShell)
+-- Exploiting the fact that
+-- on the strictness side C(B) = B
+-- and on the usage side C(U) = U
+peelCallDmd (JD {sd = s, ud = u})
+ = (JD { sd = s', ud = u' }, JD { sd = ss, ud = us })
+ where
+ (s', ss) = case s of
+ SCall s' -> (s', Str VanStr ())
+ HyperStr -> (HyperStr, Str VanStr ())
+ _ -> (HeadStr, Lazy)
+ (u', us) = case u of
+ UCall c u' -> (u', Use c ())
+ _ -> (Used, Use Many ())
+ -- The _ cases for usage includes UHead which seems a bit wrong
+ -- because the body isn't used at all!
+ -- c.f. the Abs case in toCleanDmd
+
+-- Peels that multiple nestings of calls clean demand and also returns
+-- whether it was unsaturated (separately for strictness and usage
+-- see Note [Demands from unsaturated function calls]
+peelManyCalls :: Int -> CleanDemand -> DmdShell
+peelManyCalls n (JD { sd = str, ud = abs })
+ = JD { sd = go_str n str, ud = go_abs n abs }
+ where
+ go_str :: Int -> StrDmd -> Str () -- True <=> unsaturated, defer
+ go_str 0 _ = Str VanStr ()
+ go_str _ HyperStr = Str VanStr () -- == go_str (n-1) HyperStr, as HyperStr = Call(HyperStr)
+ go_str n (SCall d') = go_str (n-1) d'
+ go_str _ _ = Lazy
+
+ go_abs :: Int -> UseDmd -> Use () -- Many <=> unsaturated, or at least
+ go_abs 0 _ = Use One () -- one UCall Many in the demand
+ go_abs n (UCall One d') = go_abs (n-1) d'
+ go_abs _ _ = Use Many ()
+
+{-
+Note [Demands from unsaturated function calls]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Consider a demand transformer d1 -> d2 -> r for f.
+If a sufficiently detailed demand is fed into this transformer,
+e.g arising from "f x1 x2" in a strict, use-once context,
+then d1 and d2 is precisely the demand unleashed onto x1 and x2 (similar for
+the free variable environment) and furthermore the result information r is the
+one we want to use.
+
+An anonymous lambda is also an unsaturated function all (needs one argument,
+none given), so this applies to that case as well.
+
+But the demand fed into f might be less than . There are a few cases:
+ * Not enough demand on the strictness side:
+ - In that case, we need to zap all strictness in the demand on arguments and
+ free variables.
+ - Furthermore, we remove CPR information. It could be left, but given the incoming
+ demand is not enough to evaluate so far we just do not bother.
+ - And finally termination information: If r says that f diverges for sure,
+ then this holds when the demand guarantees that two arguments are going to
+ be passed. If the demand is lower, we may just as well converge.
+ If we were tracking definite convegence, than that would still hold under
+ a weaker demand than expected by the demand transformer.
+ * Not enough demand from the usage side: The missing usage can be expanded
+ using UCall Many, therefore this is subsumed by the third case:
+ * At least one of the uses has a cardinality of Many.
+ - Even if f puts a One demand on any of its argument or free variables, if
+ we call f multiple times, we may evaluate this argument or free variable
+ multiple times. So forget about any occurrence of "One" in the demand.
+
+In dmdTransformSig, we call peelManyCalls to find out if we are in any of these
+cases, and then call postProcessUnsat to reduce the demand appropriately.
+
+Similarly, dmdTransformDictSelSig and dmdAnal, when analyzing a Lambda, use
+peelCallDmd, which peels only one level, but also returns the demand put on the
+body of the function.
+-}
+
+peelFV :: DmdType -> Var -> (DmdType, Demand)
+peelFV (DmdType fv ds res) id = -- pprTrace "rfv" (ppr id <+> ppr dmd $$ ppr fv)
+ (DmdType fv' ds res, dmd)
+ where
+ fv' = fv `delVarEnv` id
+ -- See Note [Default demand on free variables]
+ dmd = lookupVarEnv fv id `orElse` defaultDmd res
+
+addDemand :: Demand -> DmdType -> DmdType
+addDemand dmd (DmdType fv ds res) = DmdType fv (dmd:ds) res
+
+findIdDemand :: DmdType -> Var -> Demand
+findIdDemand (DmdType fv _ res) id
+ = lookupVarEnv fv id `orElse` defaultDmd res
+
+{-
+Note [Default demand on free variables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If the variable is not mentioned in the environment of a demand type,
+its demand is taken to be a result demand of the type.
+ For the stricness component,
+ if the result demand is a Diverges, then we use HyperStr
+ else we use Lazy
+ For the usage component, we use Absent.
+So we use either absDmd or botDmd.
+
+Also note the equations for lubDmdResult (resp. bothDmdResult) noted there.
+
+Note [Always analyse in virgin pass]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Tricky point: make sure that we analyse in the 'virgin' pass. Consider
+ rec { f acc x True = f (...rec { g y = ...g... }...)
+ f acc x False = acc }
+In the virgin pass for 'f' we'll give 'f' a very strict (bottom) type.
+That might mean that we analyse the sub-expression containing the
+E = "...rec g..." stuff in a bottom demand. Suppose we *didn't analyse*
+E, but just returned botType.
+
+Then in the *next* (non-virgin) iteration for 'f', we might analyse E
+in a weaker demand, and that will trigger doing a fixpoint iteration
+for g. But *because it's not the virgin pass* we won't start g's
+iteration at bottom. Disaster. (This happened in $sfibToList' of
+nofib/spectral/fibheaps.)
+
+So in the virgin pass we make sure that we do analyse the expression
+at least once, to initialise its signatures.
+
+Note [Analyzing with lazy demand and lambdas]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The insight for analyzing lambdas follows from the fact that for
+strictness S = C(L). This polymorphic expansion is critical for
+cardinality analysis of the following example:
+
+{-# NOINLINE build #-}
+build g = (g (:) [], g (:) [])
+
+h c z = build (\x ->
+ let z1 = z ++ z
+ in if c
+ then \y -> x (y ++ z1)
+ else \y -> x (z1 ++ y))
+
+One can see that `build` assigns to `g` demand .
+Therefore, when analyzing the lambda `(\x -> ...)`, we
+expect each lambda \y -> ... to be annotated as "one-shot"
+one. Therefore (\x -> \y -> x (y ++ z)) should be analyzed with a
+demand .
+
+This is achieved by, first, converting the lazy demand L into the
+strict S by the second clause of the analysis.
+
+Note [Analysing with absent demand]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we analyse an expression with demand . The "A" means
+"absent", so this expression will never be needed. What should happen?
+There are several wrinkles:
+
+* We *do* want to analyse the expression regardless.
+ Reason: Note [Always analyse in virgin pass]
+
+ But we can post-process the results to ignore all the usage
+ demands coming back. This is done by postProcessDmdType.
+
+* But in the case of an *unlifted type* we must be extra careful,
+ because unlifted values are evaluated even if they are not used.
+ Example (see Trac #9254):
+ f :: (() -> (# Int#, () #)) -> ()
+ -- Strictness signature is
+ --
+ -- I.e. calls k, but discards first component of result
+ f k = case k () of (# _, r #) -> r
+
+ g :: Int -> ()
+ g y = f (\n -> (# case y of I# y2 -> y2, n #))
+
+ Here f's strictness signature says (correctly) that it calls its
+ argument function and ignores the first component of its result.
+ This is correct in the sense that it'd be fine to (say) modify the
+ function so that always returned 0# in the first component.
+
+ But in function g, we *will* evaluate the 'case y of ...', because
+ it has type Int#. So 'y' will be evaluated. So we must record this
+ usage of 'y', else 'g' will say 'y' is absent, and will w/w so that
+ 'y' is bound to an aBSENT_ERROR thunk.
+
+ An alternative would be to replace the 'case y of ...' with (say) 0#,
+ but I have not tried that. It's not a common situation, but it is
+ not theoretical: unsafePerformIO's implementation is very very like
+ 'f' above.
+
+
+************************************************************************
+* *
+ Demand signatures
+* *
+************************************************************************
+
+In a let-bound Id we record its strictness info.
+In principle, this strictness info is a demand transformer, mapping
+a demand on the Id into a DmdType, which gives
+ a) the free vars of the Id's value
+ b) the Id's arguments
+ c) an indication of the result of applying
+ the Id to its arguments
+
+However, in fact we store in the Id an extremely emascuated demand
+transfomer, namely
+
+ a single DmdType
+(Nevertheless we dignify StrictSig as a distinct type.)
+
+This DmdType gives the demands unleashed by the Id when it is applied
+to as many arguments as are given in by the arg demands in the DmdType.
+Also see Note [Nature of result demand] for the meaning of a DmdResult in a
+strictness signature.
+
+If an Id is applied to less arguments than its arity, it means that
+the demand on the function at a call site is weaker than the vanilla
+call demand, used for signature inference. Therefore we place a top
+demand on all arguments. Otherwise, the demand is specified by Id's
+signature.
+
+For example, the demand transformer described by the demand signature
+ StrictSig (DmdType {x -> } m)
+says that when the function is applied to two arguments, it
+unleashes demand on the free var x, on the first arg,
+and on the second, then returning a constructor.
+
+If this same function is applied to one arg, all we can say is that it
+uses x with , and its arg with demand .
+-}
+
+newtype StrictSig = StrictSig DmdType
+ deriving( Eq )
+
+instance Outputable StrictSig where
+ ppr (StrictSig ty) = ppr ty
+
+-- Used for printing top-level strictness pragmas in interface files
+pprIfaceStrictSig :: StrictSig -> SDoc
+pprIfaceStrictSig (StrictSig (DmdType _ dmds res))
+ = hcat (map ppr dmds) <> ppr res
+
+mkStrictSig :: DmdType -> StrictSig
+mkStrictSig dmd_ty = StrictSig dmd_ty
+
+mkClosedStrictSig :: [Demand] -> DmdResult -> StrictSig
+mkClosedStrictSig ds res = mkStrictSig (DmdType emptyDmdEnv ds res)
+
+splitStrictSig :: StrictSig -> ([Demand], DmdResult)
+splitStrictSig (StrictSig (DmdType _ dmds res)) = (dmds, res)
+
+increaseStrictSigArity :: Int -> StrictSig -> StrictSig
+-- Add extra arguments to a strictness signature
+increaseStrictSigArity arity_increase (StrictSig (DmdType env dmds res))
+ = StrictSig (DmdType env (replicate arity_increase topDmd ++ dmds) res)
+
+isTopSig :: StrictSig -> Bool
+isTopSig (StrictSig ty) = isTopDmdType ty
+
+hasDemandEnvSig :: StrictSig -> Bool
+hasDemandEnvSig (StrictSig (DmdType env _ _)) = not (isEmptyVarEnv env)
+
+strictSigDmdEnv :: StrictSig -> DmdEnv
+strictSigDmdEnv (StrictSig (DmdType env _ _)) = env
+
+isBottomingSig :: StrictSig -> Bool
+-- True if the signature diverges or throws an exception
+isBottomingSig (StrictSig (DmdType _ _ res)) = isBotRes res
+
+nopSig, botSig, exnSig :: StrictSig
+nopSig = StrictSig nopDmdType
+botSig = StrictSig botDmdType
+exnSig = StrictSig exnDmdType
+
+cprProdSig :: Arity -> StrictSig
+cprProdSig arity = StrictSig (cprProdDmdType arity)
+
+seqStrictSig :: StrictSig -> ()
+seqStrictSig (StrictSig ty) = seqDmdType ty
+
+dmdTransformSig :: StrictSig -> CleanDemand -> DmdType
+-- (dmdTransformSig fun_sig dmd) considers a call to a function whose
+-- signature is fun_sig, with demand dmd. We return the demand
+-- that the function places on its context (eg its args)
+dmdTransformSig (StrictSig dmd_ty@(DmdType _ arg_ds _)) cd
+ = postProcessUnsat (peelManyCalls (length arg_ds) cd) dmd_ty
+ -- see Note [Demands from unsaturated function calls]
+
+dmdTransformDataConSig :: Arity -> StrictSig -> CleanDemand -> DmdType
+-- Same as dmdTransformSig but for a data constructor (worker),
+-- which has a special kind of demand transformer.
+-- If the constructor is saturated, we feed the demand on
+-- the result into the constructor arguments.
+dmdTransformDataConSig arity (StrictSig (DmdType _ _ con_res))
+ (JD { sd = str, ud = abs })
+ | Just str_dmds <- go_str arity str
+ , Just abs_dmds <- go_abs arity abs
+ = DmdType emptyDmdEnv (mkJointDmds str_dmds abs_dmds) con_res
+ -- Must remember whether it's a product, hence con_res, not TopRes
+
+ | otherwise -- Not saturated
+ = nopDmdType
+ where
+ go_str 0 dmd = splitStrProdDmd arity dmd
+ go_str n (SCall s') = go_str (n-1) s'
+ go_str n HyperStr = go_str (n-1) HyperStr
+ go_str _ _ = Nothing
+
+ go_abs 0 dmd = splitUseProdDmd arity dmd
+ go_abs n (UCall One u') = go_abs (n-1) u'
+ go_abs _ _ = Nothing
+
+dmdTransformDictSelSig :: StrictSig -> CleanDemand -> DmdType
+-- Like dmdTransformDataConSig, we have a special demand transformer
+-- for dictionary selectors. If the selector is saturated (ie has one
+-- argument: the dictionary), we feed the demand on the result into
+-- the indicated dictionary component.
+dmdTransformDictSelSig (StrictSig (DmdType _ [dict_dmd] _)) cd
+ | (cd',defer_use) <- peelCallDmd cd
+ , Just jds <- splitProdDmd_maybe dict_dmd
+ = postProcessUnsat defer_use $
+ DmdType emptyDmdEnv [mkOnceUsedDmd $ mkProdDmd $ map (enhance cd') jds] topRes
+ | otherwise
+ = nopDmdType -- See Note [Demand transformer for a dictionary selector]
+ where
+ enhance cd old | isAbsDmd old = old
+ | otherwise = mkOnceUsedDmd cd -- This is the one!
+
+dmdTransformDictSelSig _ _ = panic "dmdTransformDictSelSig: no args"
+
+{-
+Note [Demand transformer for a dictionary selector]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If we evaluate (op dict-expr) under demand 'd', then we can push the demand 'd'
+into the appropriate field of the dictionary. What *is* the appropriate field?
+We just look at the strictness signature of the class op, which will be
+something like: U(AAASAAAAA). Then replace the 'S' by the demand 'd'.
+
+For single-method classes, which are represented by newtypes the signature
+of 'op' won't look like U(...), so the splitProdDmd_maybe will fail.
+That's fine: if we are doing strictness analysis we are also doing inlining,
+so we'll have inlined 'op' into a cast. So we can bale out in a conservative
+way, returning nopDmdType.
+
+It is (just.. Trac #8329) possible to be running strictness analysis *without*
+having inlined class ops from single-method classes. Suppose you are using
+ghc --make; and the first module has a local -O0 flag. So you may load a class
+without interface pragmas, ie (currently) without an unfolding for the class
+ops. Now if a subsequent module in the --make sweep has a local -O flag
+you might do strictness analysis, but there is no inlining for the class op.
+This is weird, so I'm not worried about whether this optimises brilliantly; but
+it should not fall over.
+-}
+
+argsOneShots :: StrictSig -> Arity -> [[OneShotInfo]]
+-- See Note [Computing one-shot info]
+argsOneShots (StrictSig (DmdType _ arg_ds _)) n_val_args
+ | unsaturated_call = []
+ | otherwise = go arg_ds
+ where
+ unsaturated_call = arg_ds `lengthExceeds` n_val_args
+
+ go [] = []
+ go (arg_d : arg_ds) = argOneShots arg_d `cons` go arg_ds
+
+ -- Avoid list tail like [ [], [], [] ]
+ cons [] [] = []
+ cons a as = a:as
+
+-- saturatedByOneShots n C1(C1(...)) = True,
+-- <=>
+-- there are at least n nested C1(..) calls
+-- See Note [Demand on the worker] in WorkWrap
+saturatedByOneShots :: Int -> Demand -> Bool
+saturatedByOneShots n (JD { ud = usg })
+ = case usg of
+ Use _ arg_usg -> go n arg_usg
+ _ -> False
+ where
+ go 0 _ = True
+ go n (UCall One u) = go (n-1) u
+ go _ _ = False
+
+argOneShots :: Demand -- depending on saturation
+ -> [OneShotInfo]
+argOneShots (JD { ud = usg })
+ = case usg of
+ Use _ arg_usg -> go arg_usg
+ _ -> []
+ where
+ go (UCall One u) = OneShotLam : go u
+ go (UCall Many u) = NoOneShotInfo : go u
+ go _ = []
+
+{- Note [Computing one-shot info]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider a call
+ f (\pqr. e1) (\xyz. e2) e3
+where f has usage signature
+ C1(C(C1(U))) C1(U) U
+Then argsOneShots returns a [[OneShotInfo]] of
+ [[OneShot,NoOneShotInfo,OneShot], [OneShot]]
+The occurrence analyser propagates this one-shot infor to the
+binders \pqr and \xyz; see Note [Use one-shot information] in OccurAnal.
+-}
+
+-- appIsBottom returns true if an application to n args
+-- would diverge or throw an exception
+-- See Note [Unsaturated applications]
+appIsBottom :: StrictSig -> Int -> Bool
+appIsBottom (StrictSig (DmdType _ ds res)) n
+ | isBotRes res = not $ lengthExceeds ds n
+appIsBottom _ _ = False
+
+{-
+Note [Unsaturated applications]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If a function having bottom as its demand result is applied to a less
+number of arguments than its syntactic arity, we cannot say for sure
+that it is going to diverge. This is the reason why we use the
+function appIsBottom, which, given a strictness signature and a number
+of arguments, says conservatively if the function is going to diverge
+or not.
+
+Zap absence or one-shot information, under control of flags
+
+Note [Killing usage information]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The flags -fkill-one-shot and -fkill-absence let you switch off the generation
+of absence or one-shot information altogether. This is only used for performance
+tests, to see how important they are.
+-}
+
+zapUsageEnvSig :: StrictSig -> StrictSig
+-- Remove the usage environment from the demand
+zapUsageEnvSig (StrictSig (DmdType _ ds r)) = mkClosedStrictSig ds r
+
+zapUsageDemand :: Demand -> Demand
+-- Remove the usage info, but not the strictness info, from the demand
+zapUsageDemand = kill_usage $ KillFlags
+ { kf_abs = True
+ , kf_used_once = True
+ , kf_called_once = True
+ }
+
+-- | Remove all 1* information (but not C1 information) from the demand
+zapUsedOnceDemand :: Demand -> Demand
+zapUsedOnceDemand = kill_usage $ KillFlags
+ { kf_abs = False
+ , kf_used_once = True
+ , kf_called_once = False
+ }
+
+-- | Remove all 1* information (but not C1 information) from the strictness
+-- signature
+zapUsedOnceSig :: StrictSig -> StrictSig
+zapUsedOnceSig (StrictSig (DmdType env ds r))
+ = StrictSig (DmdType env (map zapUsedOnceDemand ds) r)
+
+killUsageDemand :: DynFlags -> Demand -> Demand
+-- See Note [Killing usage information]
+killUsageDemand dflags dmd
+ | Just kfs <- killFlags dflags = kill_usage kfs dmd
+ | otherwise = dmd
+
+killUsageSig :: DynFlags -> StrictSig -> StrictSig
+-- See Note [Killing usage information]
+killUsageSig dflags sig@(StrictSig (DmdType env ds r))
+ | Just kfs <- killFlags dflags = StrictSig (DmdType env (map (kill_usage kfs) ds) r)
+ | otherwise = sig
+
+data KillFlags = KillFlags
+ { kf_abs :: Bool
+ , kf_used_once :: Bool
+ , kf_called_once :: Bool
+ }
+
+killFlags :: DynFlags -> Maybe KillFlags
+-- See Note [Killing usage information]
+killFlags dflags
+ | not kf_abs && not kf_used_once = Nothing
+ | otherwise = Just (KillFlags {..})
+ where
+ kf_abs = gopt Opt_KillAbsence dflags
+ kf_used_once = gopt Opt_KillOneShot dflags
+ kf_called_once = kf_used_once
+
+kill_usage :: KillFlags -> Demand -> Demand
+kill_usage kfs (JD {sd = s, ud = u}) = JD {sd = s, ud = zap_musg kfs u}
+
+zap_musg :: KillFlags -> ArgUse -> ArgUse
+zap_musg kfs Abs
+ | kf_abs kfs = useTop
+ | otherwise = Abs
+zap_musg kfs (Use c u)
+ | kf_used_once kfs = Use Many (zap_usg kfs u)
+ | otherwise = Use c (zap_usg kfs u)
+
+zap_usg :: KillFlags -> UseDmd -> UseDmd
+zap_usg kfs (UCall c u)
+ | kf_called_once kfs = UCall Many (zap_usg kfs u)
+ | otherwise = UCall c (zap_usg kfs u)
+zap_usg kfs (UProd us) = UProd (map (zap_musg kfs) us)
+zap_usg _ u = u
+
+-- If the argument is a used non-newtype dictionary, give it strict
+-- demand. Also split the product type & demand and recur in order to
+-- similarly strictify the argument's contained used non-newtype
+-- superclass dictionaries. We use the demand as our recursive measure
+-- to guarantee termination.
+strictifyDictDmd :: Type -> Demand -> Demand
+strictifyDictDmd ty dmd = case getUseDmd dmd of
+ Use n _ |
+ Just (tycon, _arg_tys, _data_con, inst_con_arg_tys)
+ <- splitDataProductType_maybe ty,
+ not (isNewTyCon tycon), isClassTyCon tycon -- is a non-newtype dictionary
+ -> seqDmd `bothDmd` -- main idea: ensure it's strict
+ case splitProdDmd_maybe dmd of
+ -- superclass cycles should not be a problem, since the demand we are
+ -- consuming would also have to be infinite in order for us to diverge
+ Nothing -> dmd -- no components have interesting demand, so stop
+ -- looking for superclass dicts
+ Just dmds
+ | all (not . isAbsDmd) dmds -> evalDmd
+ -- abstract to strict w/ arbitrary component use, since this
+ -- smells like reboxing; results in CBV boxed
+ --
+ -- TODO revisit this if we ever do boxity analysis
+ | otherwise -> case mkProdDmd $ zipWith strictifyDictDmd inst_con_arg_tys dmds of
+ JD {sd = s,ud = a} -> JD (Str VanStr s) (Use n a)
+ -- TODO could optimize with an aborting variant of zipWith since
+ -- the superclass dicts are always a prefix
+ _ -> dmd -- unused or not a dictionary
+
+{-
+Note [HyperStr and Use demands]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+The information "HyperStr" needs to be in the strictness signature, and not in
+the demand signature, because we still want to know about the demand on things. Consider
+
+ f (x,y) True = error (show x)
+ f (x,y) False = x+1
+
+The signature of f should be m. If we were not
+distinguishing the uses on x and y in the True case, we could either not figure
+out how deeply we can unpack x, or that we do not have to pass y.
+
+
+************************************************************************
+* *
+ Serialisation
+* *
+************************************************************************
+-}
+
+instance Binary StrDmd where
+ put_ bh HyperStr = do putByte bh 0
+ put_ bh HeadStr = do putByte bh 1
+ put_ bh (SCall s) = do putByte bh 2
+ put_ bh s
+ put_ bh (SProd sx) = do putByte bh 3
+ put_ bh sx
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> do return HyperStr
+ 1 -> do return HeadStr
+ 2 -> do s <- get bh
+ return (SCall s)
+ _ -> do sx <- get bh
+ return (SProd sx)
+
+instance Binary ExnStr where
+ put_ bh VanStr = putByte bh 0
+ put_ bh ExnStr = putByte bh 1
+
+ get bh = do h <- getByte bh
+ return (case h of
+ 0 -> VanStr
+ _ -> ExnStr)
+
+instance Binary ArgStr where
+ put_ bh Lazy = do
+ putByte bh 0
+ put_ bh (Str x s) = do
+ putByte bh 1
+ put_ bh x
+ put_ bh s
+
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> return Lazy
+ _ -> do x <- get bh
+ s <- get bh
+ return $ Str x s
+
+instance Binary Count where
+ put_ bh One = do putByte bh 0
+ put_ bh Many = do putByte bh 1
+
+ get bh = do h <- getByte bh
+ case h of
+ 0 -> return One
+ _ -> return Many
+
+instance Binary ArgUse where
+ put_ bh Abs = do
+ putByte bh 0
+ put_ bh (Use c u) = do
+ putByte bh 1
+ put_ bh c
+ put_ bh u
+
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> return Abs
+ _ -> do c <- get bh
+ u <- get bh
+ return $ Use c u
+
+instance Binary UseDmd where
+ put_ bh Used = do
+ putByte bh 0
+ put_ bh UHead = do
+ putByte bh 1
+ put_ bh (UCall c u) = do
+ putByte bh 2
+ put_ bh c
+ put_ bh u
+ put_ bh (UProd ux) = do
+ putByte bh 3
+ put_ bh ux
+
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> return $ Used
+ 1 -> return $ UHead
+ 2 -> do c <- get bh
+ u <- get bh
+ return (UCall c u)
+ _ -> do ux <- get bh
+ return (UProd ux)
+
+instance (Binary s, Binary u) => Binary (JointDmd s u) where
+ put_ bh (JD { sd = x, ud = y }) = do put_ bh x; put_ bh y
+ get bh = do
+ x <- get bh
+ y <- get bh
+ return $ JD { sd = x, ud = y }
+
+instance Binary StrictSig where
+ put_ bh (StrictSig aa) = do
+ put_ bh aa
+ get bh = do
+ aa <- get bh
+ return (StrictSig aa)
+
+instance Binary DmdType where
+ -- Ignore DmdEnv when spitting out the DmdType
+ put_ bh (DmdType _ ds dr)
+ = do put_ bh ds
+ put_ bh dr
+ get bh
+ = do ds <- get bh
+ dr <- get bh
+ return (DmdType emptyDmdEnv ds dr)
+
+instance Binary DmdResult where
+ put_ bh (Dunno c) = do { putByte bh 0; put_ bh c }
+ put_ bh ThrowsExn = putByte bh 1
+ put_ bh Diverges = putByte bh 2
+
+ get bh = do { h <- getByte bh
+ ; case h of
+ 0 -> do { c <- get bh; return (Dunno c) }
+ 1 -> return ThrowsExn
+ _ -> return Diverges }
+
+instance Binary CPRResult where
+ put_ bh (RetSum n) = do { putByte bh 0; put_ bh n }
+ put_ bh RetProd = putByte bh 1
+ put_ bh NoCPR = putByte bh 2
+
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> do { n <- get bh; return (RetSum n) }
+ 1 -> return RetProd
+ _ -> return NoCPR
diff --git a/basicTypes/FieldLabel.hs b/basicTypes/FieldLabel.hs
new file mode 100644
--- /dev/null
+++ b/basicTypes/FieldLabel.hs
@@ -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
diff --git a/basicTypes/Id.hs b/basicTypes/Id.hs
new file mode 100644
--- /dev/null
+++ b/basicTypes/Id.hs
@@ -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
diff --git a/basicTypes/IdInfo.hs b/basicTypes/IdInfo.hs
new file mode 100644
--- /dev/null
+++ b/basicTypes/IdInfo.hs
@@ -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
diff --git a/basicTypes/IdInfo.hs-boot b/basicTypes/IdInfo.hs-boot
new file mode 100644
--- /dev/null
+++ b/basicTypes/IdInfo.hs-boot
@@ -0,0 +1,10 @@
+module IdInfo where
+import Outputable
+data IdInfo
+data IdDetails
+
+vanillaIdInfo :: IdInfo
+coVarDetails :: IdDetails
+isCoVarDetails :: IdDetails -> Bool
+pprIdDetails :: IdDetails -> SDoc
+
diff --git a/basicTypes/Lexeme.hs b/basicTypes/Lexeme.hs
new file mode 100644
--- /dev/null
+++ b/basicTypes/Lexeme.hs
@@ -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
diff --git a/basicTypes/Literal.hs b/basicTypes/Literal.hs
new file mode 100644
--- /dev/null
+++ b/basicTypes/Literal.hs
@@ -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@ => @\@ will
+ -- be appended to label name when emitting assembly.
+
+ | LitInteger Integer Type -- ^ Integer literals
+ -- See Note [Integer literals]
+ deriving Data
+
+{-
+Note [Integer literals]
+~~~~~~~~~~~~~~~~~~~~~~~
+An Integer literal is represented using, well, an Integer, to make it
+easier to write RULEs for them. They also contain the Integer type, so
+that e.g. literalType can return the right Type for them.
+
+They only get converted into real Core,
+ mkInteger [c1, c2, .., cn]
+during the CorePrep phase, although TidyPgm looks ahead at what the
+core will be, so that it can see whether it involves CAFs.
+
+When we initally build an Integer literal, notably when
+deserialising it from an interface file (see the Binary instance
+below), we don't have convenient access to the mkInteger Id. So we
+just use an error thunk, and fill in the real Id when we do tcIfaceLit
+in TcIface.
+
+
+Binary instance
+-}
+
+instance Binary Literal where
+ put_ bh (MachChar aa) = do putByte bh 0; put_ bh aa
+ put_ bh (MachStr ab) = do putByte bh 1; put_ bh ab
+ put_ bh (MachNullAddr) = do putByte bh 2
+ put_ bh (MachInt ad) = do putByte bh 3; put_ bh ad
+ put_ bh (MachInt64 ae) = do putByte bh 4; put_ bh ae
+ put_ bh (MachWord af) = do putByte bh 5; put_ bh af
+ put_ bh (MachWord64 ag) = do putByte bh 6; put_ bh ag
+ put_ bh (MachFloat ah) = do putByte bh 7; put_ bh ah
+ put_ bh (MachDouble ai) = do putByte bh 8; put_ bh ai
+ put_ bh (MachLabel aj mb fod)
+ = do putByte bh 9
+ put_ bh aj
+ put_ bh mb
+ put_ bh fod
+ put_ bh (LitInteger i _) = do putByte bh 10; put_ bh i
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> do
+ aa <- get bh
+ return (MachChar aa)
+ 1 -> do
+ ab <- get bh
+ return (MachStr ab)
+ 2 -> do
+ return (MachNullAddr)
+ 3 -> do
+ ad <- get bh
+ return (MachInt ad)
+ 4 -> do
+ ae <- get bh
+ return (MachInt64 ae)
+ 5 -> do
+ af <- get bh
+ return (MachWord af)
+ 6 -> do
+ ag <- get bh
+ return (MachWord64 ag)
+ 7 -> do
+ ah <- get bh
+ return (MachFloat ah)
+ 8 -> do
+ ai <- get bh
+ return (MachDouble ai)
+ 9 -> do
+ aj <- get bh
+ mb <- get bh
+ fod <- get bh
+ return (MachLabel aj mb fod)
+ _ -> do
+ i <- get bh
+ -- See Note [Integer literals]
+ return $ mkLitInteger i (panic "Evaluated the place holder for mkInteger")
+
+instance Outputable Literal where
+ ppr lit = pprLiteral (\d -> d) lit
+
+instance Eq Literal where
+ a == b = case (a `compare` b) of { EQ -> True; _ -> False }
+ a /= b = case (a `compare` b) of { EQ -> False; _ -> True }
+
+instance Ord Literal where
+ a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False }
+ a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False }
+ a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True }
+ a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True }
+ compare a b = cmpLit a b
+
+{-
+ Construction
+ ~~~~~~~~~~~~
+-}
+
+-- | Creates a 'Literal' of type @Int#@
+mkMachInt :: DynFlags -> Integer -> Literal
+mkMachInt dflags x = ASSERT2( inIntRange dflags x, integer x )
+ MachInt x
+
+-- | Creates a 'Literal' of type @Int#@.
+-- If the argument is out of the (target-dependent) range, it is wrapped.
+mkMachIntWrap :: DynFlags -> Integer -> Literal
+mkMachIntWrap dflags i
+ = MachInt $ case platformWordSize (targetPlatform dflags) of
+ 4 -> toInteger (fromIntegral i :: Int32)
+ 8 -> toInteger (fromIntegral i :: Int64)
+ w -> panic ("toIntRange: Unknown platformWordSize: " ++ show w)
+
+-- | Creates a 'Literal' of type @Word#@
+mkMachWord :: DynFlags -> Integer -> Literal
+mkMachWord dflags x = ASSERT2( inWordRange dflags x, integer x )
+ MachWord x
+
+-- | Creates a 'Literal' of type @Word#@.
+-- If the argument is out of the (target-dependent) range, it is wrapped.
+mkMachWordWrap :: DynFlags -> Integer -> Literal
+mkMachWordWrap dflags i
+ = MachWord $ case platformWordSize (targetPlatform dflags) of
+ 4 -> toInteger (fromInteger i :: Word32)
+ 8 -> toInteger (fromInteger i :: Word64)
+ w -> panic ("toWordRange: Unknown platformWordSize: " ++ show w)
+
+-- | Creates a 'Literal' of type @Int64#@
+mkMachInt64 :: Integer -> Literal
+mkMachInt64 x = ASSERT2( inInt64Range x, integer x )
+ MachInt64 x
+
+-- | Creates a 'Literal' of type @Int64#@.
+-- If the argument is out of the range, it is wrapped.
+mkMachInt64Wrap :: Integer -> Literal
+mkMachInt64Wrap i = MachInt64 (toInteger (fromIntegral i :: Int64))
+
+-- | Creates a 'Literal' of type @Word64#@
+mkMachWord64 :: Integer -> Literal
+mkMachWord64 x = ASSERT2( inWord64Range x, integer x )
+ MachWord64 x
+
+-- | Creates a 'Literal' of type @Word64#@.
+-- If the argument is out of the range, it is wrapped.
+mkMachWord64Wrap :: Integer -> Literal
+mkMachWord64Wrap i = MachWord64 (toInteger (fromIntegral i :: Word64))
+
+-- | Creates a 'Literal' of type @Float#@
+mkMachFloat :: Rational -> Literal
+mkMachFloat = MachFloat
+
+-- | Creates a 'Literal' of type @Double#@
+mkMachDouble :: Rational -> Literal
+mkMachDouble = MachDouble
+
+-- | Creates a 'Literal' of type @Char#@
+mkMachChar :: Char -> Literal
+mkMachChar = MachChar
+
+-- | Creates a 'Literal' of type @Addr#@, which is appropriate for passing to
+-- e.g. some of the \"error\" functions in GHC.Err such as @GHC.Err.runtimeError@
+mkMachString :: String -> Literal
+-- stored UTF-8 encoded
+mkMachString s = MachStr (fastStringToByteString $ mkFastString s)
+
+mkLitInteger :: Integer -> Type -> Literal
+mkLitInteger = LitInteger
+
+inIntRange, inWordRange :: DynFlags -> Integer -> Bool
+inIntRange dflags x = x >= tARGET_MIN_INT dflags && x <= tARGET_MAX_INT dflags
+inWordRange dflags x = x >= 0 && x <= tARGET_MAX_WORD dflags
+
+inInt64Range, inWord64Range :: Integer -> Bool
+inInt64Range x = x >= toInteger (minBound :: Int64) &&
+ x <= toInteger (maxBound :: Int64)
+inWord64Range x = x >= toInteger (minBound :: Word64) &&
+ x <= toInteger (maxBound :: Word64)
+
+inCharRange :: Char -> Bool
+inCharRange c = c >= '\0' && c <= chr tARGET_MAX_CHAR
+
+-- | Tests whether the literal represents a zero of whatever type it is
+isZeroLit :: Literal -> Bool
+isZeroLit (MachInt 0) = True
+isZeroLit (MachInt64 0) = True
+isZeroLit (MachWord 0) = True
+isZeroLit (MachWord64 0) = True
+isZeroLit (MachFloat 0) = True
+isZeroLit (MachDouble 0) = True
+isZeroLit _ = False
+
+-- | Returns the 'Integer' contained in the 'Literal', for when that makes
+-- sense, i.e. for 'Char', 'Int', 'Word' and 'LitInteger'.
+litValue :: Literal -> Integer
+litValue l = case isLitValue_maybe l of
+ Just x -> x
+ Nothing -> pprPanic "litValue" (ppr l)
+
+-- | Returns the 'Integer' contained in the 'Literal', for when that makes
+-- sense, i.e. for 'Char', 'Int', 'Word' and 'LitInteger'.
+isLitValue_maybe :: Literal -> Maybe Integer
+isLitValue_maybe (MachChar c) = Just $ toInteger $ ord c
+isLitValue_maybe (MachInt i) = Just i
+isLitValue_maybe (MachInt64 i) = Just i
+isLitValue_maybe (MachWord i) = Just i
+isLitValue_maybe (MachWord64 i) = Just i
+isLitValue_maybe (LitInteger i _) = Just i
+isLitValue_maybe _ = Nothing
+
+-- | Apply a function to the 'Integer' contained in the 'Literal', for when that
+-- makes sense, e.g. for 'Char', 'Int', 'Word' and 'LitInteger'. For
+-- fixed-size integral literals, the result will be wrapped in
+-- accordance with the semantics of the target type.
+mapLitValue :: DynFlags -> (Integer -> Integer) -> Literal -> Literal
+mapLitValue _ f (MachChar c) = mkMachChar (fchar c)
+ where fchar = chr . fromInteger . f . toInteger . ord
+mapLitValue dflags f (MachInt i) = mkMachIntWrap dflags (f i)
+mapLitValue _ f (MachInt64 i) = mkMachInt64Wrap (f i)
+mapLitValue dflags f (MachWord i) = mkMachWordWrap dflags (f i)
+mapLitValue _ f (MachWord64 i) = mkMachWord64Wrap (f i)
+mapLitValue _ f (LitInteger i t) = mkLitInteger (f i) t
+mapLitValue _ _ l = pprPanic "mapLitValue" (ppr l)
+
+-- | Indicate if the `Literal` contains an 'Integer' value, e.g. 'Char',
+-- 'Int', 'Word' and 'LitInteger'.
+isLitValue :: Literal -> Bool
+isLitValue = isJust . isLitValue_maybe
+
+{-
+ Coercions
+ ~~~~~~~~~
+-}
+
+narrow8IntLit, narrow16IntLit, narrow32IntLit,
+ narrow8WordLit, narrow16WordLit, narrow32WordLit,
+ char2IntLit, int2CharLit,
+ float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit,
+ float2DoubleLit, double2FloatLit
+ :: Literal -> Literal
+
+word2IntLit, int2WordLit :: DynFlags -> Literal -> Literal
+word2IntLit dflags (MachWord w)
+ | w > tARGET_MAX_INT dflags = MachInt (w - tARGET_MAX_WORD dflags - 1)
+ | otherwise = MachInt w
+word2IntLit _ l = pprPanic "word2IntLit" (ppr l)
+
+int2WordLit dflags (MachInt i)
+ | i < 0 = MachWord (1 + tARGET_MAX_WORD dflags + i) -- (-1) ---> tARGET_MAX_WORD
+ | otherwise = MachWord i
+int2WordLit _ l = pprPanic "int2WordLit" (ppr l)
+
+narrow8IntLit (MachInt i) = MachInt (toInteger (fromInteger i :: Int8))
+narrow8IntLit l = pprPanic "narrow8IntLit" (ppr l)
+narrow16IntLit (MachInt i) = MachInt (toInteger (fromInteger i :: Int16))
+narrow16IntLit l = pprPanic "narrow16IntLit" (ppr l)
+narrow32IntLit (MachInt i) = MachInt (toInteger (fromInteger i :: Int32))
+narrow32IntLit l = pprPanic "narrow32IntLit" (ppr l)
+narrow8WordLit (MachWord w) = MachWord (toInteger (fromInteger w :: Word8))
+narrow8WordLit l = pprPanic "narrow8WordLit" (ppr l)
+narrow16WordLit (MachWord w) = MachWord (toInteger (fromInteger w :: Word16))
+narrow16WordLit l = pprPanic "narrow16WordLit" (ppr l)
+narrow32WordLit (MachWord w) = MachWord (toInteger (fromInteger w :: Word32))
+narrow32WordLit l = pprPanic "narrow32WordLit" (ppr l)
+
+char2IntLit (MachChar c) = MachInt (toInteger (ord c))
+char2IntLit l = pprPanic "char2IntLit" (ppr l)
+int2CharLit (MachInt i) = MachChar (chr (fromInteger i))
+int2CharLit l = pprPanic "int2CharLit" (ppr l)
+
+float2IntLit (MachFloat f) = MachInt (truncate f)
+float2IntLit l = pprPanic "float2IntLit" (ppr l)
+int2FloatLit (MachInt i) = MachFloat (fromInteger i)
+int2FloatLit l = pprPanic "int2FloatLit" (ppr l)
+
+double2IntLit (MachDouble f) = MachInt (truncate f)
+double2IntLit l = pprPanic "double2IntLit" (ppr l)
+int2DoubleLit (MachInt i) = MachDouble (fromInteger i)
+int2DoubleLit l = pprPanic "int2DoubleLit" (ppr l)
+
+float2DoubleLit (MachFloat f) = MachDouble f
+float2DoubleLit l = pprPanic "float2DoubleLit" (ppr l)
+double2FloatLit (MachDouble d) = MachFloat d
+double2FloatLit l = pprPanic "double2FloatLit" (ppr l)
+
+nullAddrLit :: Literal
+nullAddrLit = MachNullAddr
+
+{-
+ Predicates
+ ~~~~~~~~~~
+-}
+
+-- | True if there is absolutely no penalty to duplicating the literal.
+-- False principally of strings.
+--
+-- "Why?", you say? I'm glad you asked. Well, for one duplicating strings would
+-- blow up code sizes. Not only this, it's also unsafe.
+--
+-- Consider a program that wants to traverse a string. One way it might do this
+-- is to first compute the Addr# pointing to the end of the string, and then,
+-- starting from the beginning, bump a pointer using eqAddr# to determine the
+-- end. For instance,
+--
+-- @
+-- -- Given pointers to the start and end of a string, count how many zeros
+-- -- the string contains.
+-- countZeros :: Addr# -> Addr# -> -> Int
+-- countZeros start end = go start 0
+-- where
+-- go off n
+-- | off `addrEq#` end = n
+-- | otherwise = go (off `plusAddr#` 1) n'
+-- where n' | isTrue# (indexInt8OffAddr# off 0# ==# 0#) = n + 1
+-- | otherwise = n
+-- @
+--
+-- Consider what happens if we considered strings to be trivial (and therefore
+-- duplicable) and emitted a call like @countZeros "hello"# ("hello"#
+-- `plusAddr`# 5)@. The beginning and end pointers do not belong to the same
+-- string, meaning that an iteration like the above would blow up terribly.
+-- This is what happened in #12757.
+--
+-- Ultimately the solution here is to make primitive strings a bit more
+-- structured, ensuring that the compiler can't inline in ways that will break
+-- user code. One approach to this is described in #8472.
+litIsTrivial :: Literal -> Bool
+-- c.f. CoreUtils.exprIsTrivial
+litIsTrivial (MachStr _) = False
+litIsTrivial (LitInteger {}) = False
+litIsTrivial _ = True
+
+-- | True if code space does not go bad if we duplicate this literal
+-- Currently we treat it just like 'litIsTrivial'
+litIsDupable :: DynFlags -> Literal -> Bool
+-- c.f. CoreUtils.exprIsDupable
+litIsDupable _ (MachStr _) = False
+litIsDupable dflags (LitInteger i _) = inIntRange dflags i
+litIsDupable _ _ = True
+
+litFitsInChar :: Literal -> Bool
+litFitsInChar (MachInt i) = i >= toInteger (ord minBound)
+ && i <= toInteger (ord maxBound)
+litFitsInChar _ = False
+
+litIsLifted :: Literal -> Bool
+litIsLifted (LitInteger {}) = True
+litIsLifted _ = False
+
+{-
+ Types
+ ~~~~~
+-}
+
+-- | Find the Haskell 'Type' the literal occupies
+literalType :: Literal -> Type
+literalType MachNullAddr = addrPrimTy
+literalType (MachChar _) = charPrimTy
+literalType (MachStr _) = addrPrimTy
+literalType (MachInt _) = intPrimTy
+literalType (MachWord _) = wordPrimTy
+literalType (MachInt64 _) = int64PrimTy
+literalType (MachWord64 _) = word64PrimTy
+literalType (MachFloat _) = floatPrimTy
+literalType (MachDouble _) = doublePrimTy
+literalType (MachLabel _ _ _) = addrPrimTy
+literalType (LitInteger _ t) = t
+
+absentLiteralOf :: TyCon -> Maybe Literal
+-- Return a literal of the appropriate primtive
+-- TyCon, to use as a placeholder when it doesn't matter
+absentLiteralOf tc = lookupUFM absent_lits (tyConName tc)
+
+absent_lits :: UniqFM Literal
+absent_lits = listToUFM [ (addrPrimTyConKey, MachNullAddr)
+ , (charPrimTyConKey, MachChar 'x')
+ , (intPrimTyConKey, MachInt 0)
+ , (int64PrimTyConKey, MachInt64 0)
+ , (floatPrimTyConKey, MachFloat 0)
+ , (doublePrimTyConKey, MachDouble 0)
+ , (wordPrimTyConKey, MachWord 0)
+ , (word64PrimTyConKey, MachWord64 0) ]
+
+{-
+ Comparison
+ ~~~~~~~~~~
+-}
+
+cmpLit :: Literal -> Literal -> Ordering
+cmpLit (MachChar a) (MachChar b) = a `compare` b
+cmpLit (MachStr a) (MachStr b) = a `compare` b
+cmpLit (MachNullAddr) (MachNullAddr) = EQ
+cmpLit (MachInt a) (MachInt b) = a `compare` b
+cmpLit (MachWord a) (MachWord b) = a `compare` b
+cmpLit (MachInt64 a) (MachInt64 b) = a `compare` b
+cmpLit (MachWord64 a) (MachWord64 b) = a `compare` b
+cmpLit (MachFloat a) (MachFloat b) = a `compare` b
+cmpLit (MachDouble a) (MachDouble b) = a `compare` b
+cmpLit (MachLabel a _ _) (MachLabel b _ _) = a `compare` b
+cmpLit (LitInteger a _) (LitInteger b _) = a `compare` b
+cmpLit lit1 lit2 | litTag lit1 < litTag lit2 = LT
+ | otherwise = GT
+
+litTag :: Literal -> Int
+litTag (MachChar _) = 1
+litTag (MachStr _) = 2
+litTag (MachNullAddr) = 3
+litTag (MachInt _) = 4
+litTag (MachWord _) = 5
+litTag (MachInt64 _) = 6
+litTag (MachWord64 _) = 7
+litTag (MachFloat _) = 8
+litTag (MachDouble _) = 9
+litTag (MachLabel _ _ _) = 10
+litTag (LitInteger {}) = 11
+
+{-
+ Printing
+ ~~~~~~~~
+* See Note [Printing of literals in Core]
+-}
+
+pprLiteral :: (SDoc -> SDoc) -> Literal -> SDoc
+pprLiteral _ (MachChar c) = pprPrimChar c
+pprLiteral _ (MachStr s) = pprHsBytes s
+pprLiteral _ (MachNullAddr) = text "__NULL"
+pprLiteral _ (MachInt i) = pprPrimInt i
+pprLiteral _ (MachInt64 i) = pprPrimInt64 i
+pprLiteral _ (MachWord w) = pprPrimWord w
+pprLiteral _ (MachWord64 w) = pprPrimWord64 w
+pprLiteral _ (MachFloat f) = float (fromRat f) <> primFloatSuffix
+pprLiteral _ (MachDouble d) = double (fromRat d) <> primDoubleSuffix
+pprLiteral add_par (LitInteger i _) = pprIntegerVal add_par i
+pprLiteral add_par (MachLabel l mb fod) = add_par (text "__label" <+> b <+> ppr fod)
+ where b = case mb of
+ Nothing -> pprHsString l
+ Just x -> doubleQuotes (text (unpackFS l ++ '@':show x))
+
+pprIntegerVal :: (SDoc -> SDoc) -> Integer -> SDoc
+-- See Note [Printing of literals in Core].
+pprIntegerVal add_par i | i < 0 = add_par (integer i)
+ | otherwise = integer i
+
+{-
+Note [Printing of literals in Core]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The function `add_par` is used to wrap parenthesis around negative integers
+(`LitInteger`) and labels (`MachLabel`), if they occur in a context requiring
+an atomic thing (for example function application).
+
+Although not all Core literals would be valid Haskell, we are trying to stay
+as close as possible to Haskell syntax in the printing of Core, to make it
+easier for a Haskell user to read Core.
+
+To that end:
+ * We do print parenthesis around negative `LitInteger`, because we print
+ `LitInteger` using plain number literals (no prefix or suffix), and plain
+ number literals in Haskell require parenthesis in contexts like function
+ application (i.e. `1 - -1` is not valid Haskell).
+
+ * We don't print parenthesis around other (negative) literals, because they
+ aren't needed in GHC/Haskell either (i.e. `1# -# -1#` is accepted by GHC's
+ parser).
+
+Literal Output Output if context requires
+ an atom (if different)
+------- ------- ----------------------
+MachChar 'a'#
+MachStr "aaa"#
+MachNullAddr "__NULL"
+MachInt -1#
+MachInt64 -1L#
+MachWord 1##
+MachWord64 1L##
+MachFloat -1.0#
+MachDouble -1.0##
+LitInteger -1 (-1)
+MachLabel "__label" ... ("__label" ...)
+-}
diff --git a/basicTypes/MkId.hs b/basicTypes/MkId.hs
new file mode 100644
--- /dev/null
+++ b/basicTypes/MkId.hs
@@ -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.
diff --git a/basicTypes/MkId.hs-boot b/basicTypes/MkId.hs-boot
new file mode 100644
--- /dev/null
+++ b/basicTypes/MkId.hs-boot
@@ -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
diff --git a/basicTypes/Module.hs b/basicTypes/Module.hs
new file mode 100644
--- /dev/null
+++ b/basicTypes/Module.hs
@@ -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. @@) which can be instantiated to a
+-- specific module at some later point in time are represented
+-- with 'moduleUnitId' set to 'holeUnitId' (this allows us to
+-- avoid having to make 'moduleUnitId' a partial operation.)
+--
+data Module = Module {
+ moduleUnitId :: !UnitId, -- pkg-1.0
+ moduleName :: !ModuleName -- A.B.C
+ }
+ deriving (Eq, Ord)
+
+-- | Calculate the free holes of a 'Module'. If this set is non-empty,
+-- this module was defined in an indefinite library that had required
+-- signatures.
+--
+-- If a module has free holes, that means that substitutions can operate on it;
+-- if it has no free holes, substituting over a module has no effect.
+moduleFreeHoles :: Module -> UniqDSet ModuleName
+moduleFreeHoles m
+ | isHoleModule m = unitUniqDSet (moduleName m)
+ | otherwise = unitIdFreeHoles (moduleUnitId m)
+
+-- | A 'Module' is definite if it has no free holes.
+moduleIsDefinite :: Module -> Bool
+moduleIsDefinite = isEmptyUniqDSet . moduleFreeHoles
+
+-- | Create a module variable at some 'ModuleName'.
+-- See Note [Representation of module/name variables]
+mkHoleModule :: ModuleName -> Module
+mkHoleModule = mkModule holeUnitId
+
+instance Uniquable Module where
+ getUnique (Module p n) = getUnique (unitIdFS p `appendFS` moduleNameFS n)
+
+instance Outputable Module where
+ ppr = pprModule
+
+instance Binary Module where
+ put_ bh (Module p n) = put_ bh p >> put_ bh n
+ get bh = do p <- get bh; n <- get bh; return (Module p n)
+
+instance Data Module where
+ -- don't traverse?
+ toConstr _ = abstractConstr "Module"
+ gunfold _ _ = error "gunfold"
+ dataTypeOf _ = mkNoRepType "Module"
+
+instance NFData Module where
+ rnf x = x `seq` ()
+
+-- | This gives a stable ordering, as opposed to the Ord instance which
+-- gives an ordering based on the 'Unique's of the components, which may
+-- not be stable from run to run of the compiler.
+stableModuleCmp :: Module -> Module -> Ordering
+stableModuleCmp (Module p1 n1) (Module p2 n2)
+ = (p1 `stableUnitIdCmp` p2) `thenCmp`
+ (n1 `stableModuleNameCmp` n2)
+
+mkModule :: UnitId -> ModuleName -> Module
+mkModule = Module
+
+pprModule :: Module -> SDoc
+pprModule mod@(Module p n) = getPprStyle doc
+ where
+ doc sty
+ | codeStyle sty =
+ (if p == mainUnitId
+ then empty -- never qualify the main package in code
+ else ztext (zEncodeFS (unitIdFS p)) <> char '_')
+ <> pprModuleName n
+ | qualModule sty mod =
+ if isHoleModule mod
+ then angleBrackets (pprModuleName n)
+ else ppr (moduleUnitId mod) <> char ':' <> pprModuleName n
+ | otherwise =
+ pprModuleName n
+
+class ContainsModule t where
+ extractModule :: t -> Module
+
+class HasModule m where
+ getModule :: m Module
+
+instance DbUnitIdModuleRep InstalledUnitId ComponentId UnitId ModuleName Module where
+ fromDbModule (DbModule uid mod_name) = mkModule uid mod_name
+ fromDbModule (DbModuleVar mod_name) = mkHoleModule mod_name
+ fromDbUnitId (DbUnitId cid insts) = newUnitId cid insts
+ fromDbUnitId (DbInstalledUnitId iuid) = DefiniteUnitId (DefUnitId iuid)
+ -- GHC never writes to the database, so it's not needed
+ toDbModule = error "toDbModule: not implemented"
+ toDbUnitId = error "toDbUnitId: not implemented"
+
+{-
+************************************************************************
+* *
+\subsection{ComponentId}
+* *
+************************************************************************
+-}
+
+-- | A 'ComponentId' consists of the package name, package version, component
+-- ID, the transitive dependencies of the component, and other information to
+-- uniquely identify the source code and build configuration of a component.
+--
+-- This used to be known as an 'InstalledPackageId', but a package can contain
+-- multiple components and a 'ComponentId' uniquely identifies a component
+-- within a package. When a package only has one component, the 'ComponentId'
+-- coincides with the 'InstalledPackageId'
+newtype ComponentId = ComponentId FastString deriving (Eq, Ord)
+
+instance BinaryStringRep ComponentId where
+ fromStringRep = ComponentId . mkFastStringByteString
+ toStringRep (ComponentId s) = fastStringToByteString s
+
+instance Uniquable ComponentId where
+ getUnique (ComponentId n) = getUnique n
+
+instance Outputable ComponentId where
+ ppr cid@(ComponentId fs) =
+ getPprStyle $ \sty ->
+ sdocWithDynFlags $ \dflags ->
+ case componentIdString dflags cid of
+ Just str | not (debugStyle sty) -> text str
+ _ -> ftext fs
+
+{-
+************************************************************************
+* *
+\subsection{UnitId}
+* *
+************************************************************************
+-}
+
+-- | A unit identifier identifies a (possibly partially) instantiated
+-- library. It is primarily used as part of 'Module', which in turn
+-- is used in 'Name', which is used to give names to entities when
+-- typechecking.
+--
+-- There are two possible forms for a 'UnitId'. It can be a
+-- 'DefiniteUnitId', in which case we just have a string that uniquely
+-- identifies some fully compiled, installed library we have on disk.
+-- However, when we are typechecking a library with missing holes,
+-- we may need to instantiate a library on the fly (in which case
+-- we don't have any on-disk representation.) In that case, you
+-- have an 'IndefiniteUnitId', which explicitly records the
+-- instantiation, so that we can substitute over it.
+data UnitId
+ = IndefiniteUnitId {-# UNPACK #-} !IndefUnitId
+ | DefiniteUnitId {-# UNPACK #-} !DefUnitId
+ deriving (Typeable)
+
+unitIdFS :: UnitId -> FastString
+unitIdFS (IndefiniteUnitId x) = indefUnitIdFS x
+unitIdFS (DefiniteUnitId (DefUnitId x)) = installedUnitIdFS x
+
+unitIdKey :: UnitId -> Unique
+unitIdKey (IndefiniteUnitId x) = indefUnitIdKey x
+unitIdKey (DefiniteUnitId (DefUnitId x)) = installedUnitIdKey x
+
+-- | A unit identifier which identifies an indefinite
+-- library (with holes) that has been *on-the-fly* instantiated
+-- with a substitution 'indefUnitIdInsts'. In fact, an indefinite
+-- unit identifier could have no holes, but we haven't gotten
+-- around to compiling the actual library yet.
+--
+-- An indefinite unit identifier pretty-prints to something like
+-- @p[H=,A=aimpl:A>]@ (@p@ is the 'ComponentId', and the
+-- brackets enclose the module substitution).
+data IndefUnitId
+ = IndefUnitId {
+ -- | A private, uniquely identifying representation of
+ -- a UnitId. This string is completely private to GHC
+ -- and is just used to get a unique; in particular, we don't use it for
+ -- symbols (indefinite libraries are not compiled).
+ indefUnitIdFS :: FastString,
+ -- | Cached unique of 'unitIdFS'.
+ indefUnitIdKey :: Unique,
+ -- | The component identity of the indefinite library that
+ -- is being instantiated.
+ indefUnitIdComponentId :: !ComponentId,
+ -- | The sorted (by 'ModuleName') instantiations of this library.
+ indefUnitIdInsts :: ![(ModuleName, Module)],
+ -- | A cache of the free module variables of 'unitIdInsts'.
+ -- This lets us efficiently tell if a 'UnitId' has been
+ -- fully instantiated (free module variables are empty)
+ -- and whether or not a substitution can have any effect.
+ indefUnitIdFreeHoles :: UniqDSet ModuleName
+ } deriving (Typeable)
+
+instance Eq IndefUnitId where
+ u1 == u2 = indefUnitIdKey u1 == indefUnitIdKey u2
+
+instance Ord IndefUnitId where
+ u1 `compare` u2 = indefUnitIdFS u1 `compare` indefUnitIdFS u2
+
+instance Binary IndefUnitId where
+ put_ bh indef = do
+ put_ bh (indefUnitIdComponentId indef)
+ put_ bh (indefUnitIdInsts indef)
+ get bh = do
+ cid <- get bh
+ insts <- get bh
+ let fs = hashUnitId cid insts
+ return IndefUnitId {
+ indefUnitIdComponentId = cid,
+ indefUnitIdInsts = insts,
+ indefUnitIdFreeHoles = unionManyUniqDSets (map (moduleFreeHoles.snd) insts),
+ indefUnitIdFS = fs,
+ indefUnitIdKey = getUnique fs
+ }
+
+-- | Create a new 'IndefUnitId' given an explicit module substitution.
+newIndefUnitId :: ComponentId -> [(ModuleName, Module)] -> IndefUnitId
+newIndefUnitId cid insts =
+ IndefUnitId {
+ indefUnitIdComponentId = cid,
+ indefUnitIdInsts = sorted_insts,
+ indefUnitIdFreeHoles = unionManyUniqDSets (map (moduleFreeHoles.snd) insts),
+ indefUnitIdFS = fs,
+ indefUnitIdKey = getUnique fs
+ }
+ where
+ fs = hashUnitId cid sorted_insts
+ sorted_insts = sortBy (stableModuleNameCmp `on` fst) insts
+
+-- | Injects an 'IndefUnitId' (indefinite library which
+-- was on-the-fly instantiated) to a 'UnitId' (either
+-- an indefinite or definite library).
+indefUnitIdToUnitId :: DynFlags -> IndefUnitId -> UnitId
+indefUnitIdToUnitId dflags iuid =
+ -- NB: suppose that we want to compare the indefinite
+ -- unit id p[H=impl:H] against p+abcd (where p+abcd
+ -- happens to be the existing, installed version of
+ -- p[H=impl:H]. If we *only* wrap in p[H=impl:H]
+ -- IndefiniteUnitId, they won't compare equal; only
+ -- after improvement will the equality hold.
+ improveUnitId (getPackageConfigMap dflags) $
+ IndefiniteUnitId iuid
+
+data IndefModule = IndefModule {
+ indefModuleUnitId :: IndefUnitId,
+ indefModuleName :: ModuleName
+ } deriving (Typeable, Eq, Ord)
+
+instance Outputable IndefModule where
+ ppr (IndefModule uid m) =
+ ppr uid <> char ':' <> ppr m
+
+-- | Injects an 'IndefModule' to 'Module' (see also
+-- 'indefUnitIdToUnitId'.
+indefModuleToModule :: DynFlags -> IndefModule -> Module
+indefModuleToModule dflags (IndefModule iuid mod_name) =
+ mkModule (indefUnitIdToUnitId dflags iuid) mod_name
+
+-- | An installed unit identifier identifies a library which has
+-- been installed to the package database. These strings are
+-- provided to us via the @-this-unit-id@ flag. The library
+-- in question may be definite or indefinite; if it is indefinite,
+-- none of the holes have been filled (we never install partially
+-- instantiated libraries.) Put another way, an installed unit id
+-- is either fully instantiated, or not instantiated at all.
+--
+-- Installed unit identifiers look something like @p+af23SAj2dZ219@,
+-- or maybe just @p@ if they don't use Backpack.
+newtype InstalledUnitId =
+ InstalledUnitId {
+ -- | The full hashed unit identifier, including the component id
+ -- and the hash.
+ installedUnitIdFS :: FastString
+ }
+ deriving (Typeable)
+
+instance Binary InstalledUnitId where
+ put_ bh (InstalledUnitId fs) = put_ bh fs
+ get bh = do fs <- get bh; return (InstalledUnitId fs)
+
+instance BinaryStringRep InstalledUnitId where
+ fromStringRep bs = InstalledUnitId (mkFastStringByteString bs)
+ -- GHC doesn't write to database
+ toStringRep = error "BinaryStringRep InstalledUnitId: not implemented"
+
+instance Eq InstalledUnitId where
+ uid1 == uid2 = installedUnitIdKey uid1 == installedUnitIdKey uid2
+
+instance Ord InstalledUnitId where
+ u1 `compare` u2 = installedUnitIdFS u1 `compare` installedUnitIdFS u2
+
+instance Uniquable InstalledUnitId where
+ getUnique = installedUnitIdKey
+
+instance Outputable InstalledUnitId where
+ ppr uid@(InstalledUnitId fs) =
+ getPprStyle $ \sty ->
+ sdocWithDynFlags $ \dflags ->
+ case displayInstalledUnitId dflags uid of
+ Just str | not (debugStyle sty) -> text str
+ _ -> ftext fs
+
+installedUnitIdKey :: InstalledUnitId -> Unique
+installedUnitIdKey = getUnique . installedUnitIdFS
+
+-- | Lossy conversion to the on-disk 'InstalledUnitId' for a component.
+toInstalledUnitId :: UnitId -> InstalledUnitId
+toInstalledUnitId (DefiniteUnitId (DefUnitId iuid)) = iuid
+toInstalledUnitId (IndefiniteUnitId indef) =
+ componentIdToInstalledUnitId (indefUnitIdComponentId indef)
+
+installedUnitIdString :: InstalledUnitId -> String
+installedUnitIdString = unpackFS . installedUnitIdFS
+
+instance Outputable IndefUnitId where
+ ppr uid =
+ -- getPprStyle $ \sty ->
+ ppr cid <>
+ (if not (null insts) -- pprIf
+ then
+ brackets (hcat
+ (punctuate comma $
+ [ ppr modname <> text "=" <> ppr m
+ | (modname, m) <- insts]))
+ else empty)
+ where
+ cid = indefUnitIdComponentId uid
+ insts = indefUnitIdInsts uid
+
+-- | A 'InstalledModule' is a 'Module' which contains a 'InstalledUnitId'.
+data InstalledModule = InstalledModule {
+ installedModuleUnitId :: !InstalledUnitId,
+ installedModuleName :: !ModuleName
+ }
+ deriving (Eq, Ord)
+
+instance Outputable InstalledModule where
+ ppr (InstalledModule p n) =
+ ppr p <> char ':' <> pprModuleName n
+
+fsToInstalledUnitId :: FastString -> InstalledUnitId
+fsToInstalledUnitId fs = InstalledUnitId fs
+
+componentIdToInstalledUnitId :: ComponentId -> InstalledUnitId
+componentIdToInstalledUnitId (ComponentId fs) = fsToInstalledUnitId fs
+
+stringToInstalledUnitId :: String -> InstalledUnitId
+stringToInstalledUnitId = fsToInstalledUnitId . mkFastString
+
+-- | Test if a 'Module' corresponds to a given 'InstalledModule',
+-- modulo instantiation.
+installedModuleEq :: InstalledModule -> Module -> Bool
+installedModuleEq imod mod =
+ fst (splitModuleInsts mod) == imod
+
+-- | Test if a 'UnitId' corresponds to a given 'InstalledUnitId',
+-- modulo instantiation.
+installedUnitIdEq :: InstalledUnitId -> UnitId -> Bool
+installedUnitIdEq iuid uid =
+ fst (splitUnitIdInsts uid) == iuid
+
+-- | A 'DefUnitId' is an 'InstalledUnitId' with the invariant that
+-- it only refers to a definite library; i.e., one we have generated
+-- code for.
+newtype DefUnitId = DefUnitId { unDefUnitId :: InstalledUnitId }
+ deriving (Eq, Ord, Typeable)
+
+instance Outputable DefUnitId where
+ ppr (DefUnitId uid) = ppr uid
+
+instance Binary DefUnitId where
+ put_ bh (DefUnitId uid) = put_ bh uid
+ get bh = do uid <- get bh; return (DefUnitId uid)
+
+-- | A map keyed off of 'InstalledModule'
+newtype InstalledModuleEnv elt = InstalledModuleEnv (Map InstalledModule elt)
+
+emptyInstalledModuleEnv :: InstalledModuleEnv a
+emptyInstalledModuleEnv = InstalledModuleEnv Map.empty
+
+lookupInstalledModuleEnv :: InstalledModuleEnv a -> InstalledModule -> Maybe a
+lookupInstalledModuleEnv (InstalledModuleEnv e) m = Map.lookup m e
+
+extendInstalledModuleEnv :: InstalledModuleEnv a -> InstalledModule -> a -> InstalledModuleEnv a
+extendInstalledModuleEnv (InstalledModuleEnv e) m x = InstalledModuleEnv (Map.insert m x e)
+
+filterInstalledModuleEnv :: (InstalledModule -> a -> Bool) -> InstalledModuleEnv a -> InstalledModuleEnv a
+filterInstalledModuleEnv f (InstalledModuleEnv e) =
+ InstalledModuleEnv (Map.filterWithKey f e)
+
+delInstalledModuleEnv :: InstalledModuleEnv a -> InstalledModule -> InstalledModuleEnv a
+delInstalledModuleEnv (InstalledModuleEnv e) m = InstalledModuleEnv (Map.delete m e)
+
+-- Note [UnitId to InstalledUnitId improvement]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- Just because a UnitId is definite (has no holes) doesn't
+-- mean it's necessarily a InstalledUnitId; it could just be
+-- that over the course of renaming UnitIds on the fly
+-- while typechecking an indefinite library, we
+-- ended up with a fully instantiated unit id with no hash,
+-- since we haven't built it yet. This is fine.
+--
+-- However, if there is a hashed unit id for this instantiation
+-- in the package database, we *better use it*, because
+-- that hashed unit id may be lurking in another interface,
+-- and chaos will ensue if we attempt to compare the two
+-- (the unitIdFS for a UnitId never corresponds to a Cabal-provided
+-- hash of a compiled instantiated library).
+--
+-- There is one last niggle: improvement based on the package database means
+-- that we might end up developing on a package that is not transitively
+-- depended upon by the packages the user specified directly via command line
+-- flags. This could lead to strange and difficult to understand bugs if those
+-- instantiations are out of date. The solution is to only improve a
+-- unit id if the new unit id is part of the 'preloadClosure'; i.e., the
+-- closure of all the packages which were explicitly specified.
+
+-- | Retrieve the set of free holes of a 'UnitId'.
+unitIdFreeHoles :: UnitId -> UniqDSet ModuleName
+unitIdFreeHoles (IndefiniteUnitId x) = indefUnitIdFreeHoles x
+-- Hashed unit ids are always fully instantiated
+unitIdFreeHoles (DefiniteUnitId _) = emptyUniqDSet
+
+instance Show UnitId where
+ show = unitIdString
+
+-- | A 'UnitId' is definite if it has no free holes.
+unitIdIsDefinite :: UnitId -> Bool
+unitIdIsDefinite = isEmptyUniqDSet . unitIdFreeHoles
+
+-- | Generate a uniquely identifying 'FastString' for a unit
+-- identifier. This is a one-way function. You can rely on one special
+-- property: if a unit identifier is in most general form, its 'FastString'
+-- coincides with its 'ComponentId'. This hash is completely internal
+-- to GHC and is not used for symbol names or file paths.
+hashUnitId :: ComponentId -> [(ModuleName, Module)] -> FastString
+hashUnitId cid sorted_holes =
+ mkFastStringByteString
+ . fingerprintUnitId (toStringRep cid)
+ $ rawHashUnitId sorted_holes
+
+-- | Generate a hash for a sorted module substitution.
+rawHashUnitId :: [(ModuleName, Module)] -> Fingerprint
+rawHashUnitId sorted_holes =
+ fingerprintByteString
+ . BS.concat $ do
+ (m, b) <- sorted_holes
+ [ toStringRep m, BS.Char8.singleton ' ',
+ fastStringToByteString (unitIdFS (moduleUnitId b)), BS.Char8.singleton ':',
+ toStringRep (moduleName b), BS.Char8.singleton '\n']
+
+fingerprintByteString :: BS.ByteString -> Fingerprint
+fingerprintByteString bs = unsafePerformIO
+ . BS.unsafeUseAsCStringLen bs
+ $ \(p,l) -> fingerprintData (castPtr p) l
+
+fingerprintUnitId :: BS.ByteString -> Fingerprint -> BS.ByteString
+fingerprintUnitId prefix (Fingerprint a b)
+ = BS.concat
+ $ [ prefix
+ , BS.Char8.singleton '-'
+ , BS.Char8.pack (toBase62Padded a)
+ , BS.Char8.pack (toBase62Padded b) ]
+
+-- | Create a new, un-hashed unit identifier.
+newUnitId :: ComponentId -> [(ModuleName, Module)] -> UnitId
+newUnitId cid [] = newSimpleUnitId cid -- TODO: this indicates some latent bug...
+newUnitId cid insts = IndefiniteUnitId $ newIndefUnitId cid insts
+
+pprUnitId :: UnitId -> SDoc
+pprUnitId (DefiniteUnitId uid) = ppr uid
+pprUnitId (IndefiniteUnitId uid) = ppr uid
+
+instance Eq UnitId where
+ uid1 == uid2 = unitIdKey uid1 == unitIdKey uid2
+
+instance Uniquable UnitId where
+ getUnique = unitIdKey
+
+instance Ord UnitId where
+ nm1 `compare` nm2 = stableUnitIdCmp nm1 nm2
+
+instance Data UnitId where
+ -- don't traverse?
+ toConstr _ = abstractConstr "UnitId"
+ gunfold _ _ = error "gunfold"
+ dataTypeOf _ = mkNoRepType "UnitId"
+
+instance NFData UnitId where
+ rnf x = x `seq` ()
+
+stableUnitIdCmp :: UnitId -> UnitId -> Ordering
+-- ^ Compares package ids lexically, rather than by their 'Unique's
+stableUnitIdCmp p1 p2 = unitIdFS p1 `compare` unitIdFS p2
+
+instance Outputable UnitId where
+ ppr pk = pprUnitId pk
+
+-- Performance: would prefer to have a NameCache like thing
+instance Binary UnitId where
+ put_ bh (DefiniteUnitId def_uid) = do
+ putByte bh 0
+ put_ bh def_uid
+ put_ bh (IndefiniteUnitId indef_uid) = do
+ putByte bh 1
+ put_ bh indef_uid
+ get bh = do b <- getByte bh
+ case b of
+ 0 -> fmap DefiniteUnitId (get bh)
+ _ -> fmap IndefiniteUnitId (get bh)
+
+instance Binary ComponentId where
+ put_ bh (ComponentId fs) = put_ bh fs
+ get bh = do { fs <- get bh; return (ComponentId fs) }
+
+-- | Create a new simple unit identifier (no holes) from a 'ComponentId'.
+newSimpleUnitId :: ComponentId -> UnitId
+newSimpleUnitId (ComponentId fs) = fsToUnitId fs
+
+-- | Create a new simple unit identifier from a 'FastString'. Internally,
+-- this is primarily used to specify wired-in unit identifiers.
+fsToUnitId :: FastString -> UnitId
+fsToUnitId = DefiniteUnitId . DefUnitId . InstalledUnitId
+
+stringToUnitId :: String -> UnitId
+stringToUnitId = fsToUnitId . mkFastString
+
+unitIdString :: UnitId -> String
+unitIdString = unpackFS . unitIdFS
+
+{-
+************************************************************************
+* *
+ Hole substitutions
+* *
+************************************************************************
+-}
+
+-- | Substitution on module variables, mapping module names to module
+-- identifiers.
+type ShHoleSubst = ModuleNameEnv Module
+
+-- | Substitutes holes in a 'Module'. NOT suitable for being called
+-- directly on a 'nameModule', see Note [Representation of module/name variable].
+-- @p[A=]:B@ maps to @p[A=q():A]:B@ with @A=q():A@;
+-- similarly, @@ maps to @q():A@.
+renameHoleModule :: DynFlags -> ShHoleSubst -> Module -> Module
+renameHoleModule dflags = renameHoleModule' (getPackageConfigMap dflags)
+
+-- | Substitutes holes in a 'UnitId', suitable for renaming when
+-- an include occurs; see Note [Representation of module/name variable].
+--
+-- @p[A=]@ maps to @p[A=]@ with @A=@.
+renameHoleUnitId :: DynFlags -> ShHoleSubst -> UnitId -> UnitId
+renameHoleUnitId dflags = renameHoleUnitId' (getPackageConfigMap dflags)
+
+-- | Like 'renameHoleModule', but requires only 'PackageConfigMap'
+-- so it can be used by "Packages".
+renameHoleModule' :: PackageConfigMap -> ShHoleSubst -> Module -> Module
+renameHoleModule' pkg_map env m
+ | not (isHoleModule m) =
+ let uid = renameHoleUnitId' pkg_map env (moduleUnitId m)
+ in mkModule uid (moduleName m)
+ | Just m' <- lookupUFM env (moduleName m) = m'
+ -- NB m = , that's what's in scope.
+ | otherwise = m
+
+-- | Like 'renameHoleUnitId, but requires only 'PackageConfigMap'
+-- so it can be used by "Packages".
+renameHoleUnitId' :: PackageConfigMap -> ShHoleSubst -> UnitId -> UnitId
+renameHoleUnitId' pkg_map env uid =
+ case uid of
+ (IndefiniteUnitId
+ IndefUnitId{ indefUnitIdComponentId = cid
+ , indefUnitIdInsts = insts
+ , indefUnitIdFreeHoles = fh })
+ -> if isNullUFM (intersectUFM_C const (udfmToUfm fh) env)
+ then uid
+ -- Functorially apply the substitution to the instantiation,
+ -- then check the 'PackageConfigMap' to see if there is
+ -- a compiled version of this 'UnitId' we can improve to.
+ -- See Note [UnitId to InstalledUnitId] improvement
+ else improveUnitId pkg_map $
+ newUnitId cid
+ (map (\(k,v) -> (k, renameHoleModule' pkg_map env v)) insts)
+ _ -> uid
+
+-- | Given a possibly on-the-fly instantiated module, split it into
+-- a 'Module' that we definitely can find on-disk, as well as an
+-- instantiation if we need to instantiate it on the fly. If the
+-- instantiation is @Nothing@ no on-the-fly renaming is needed.
+splitModuleInsts :: Module -> (InstalledModule, Maybe IndefModule)
+splitModuleInsts m =
+ let (uid, mb_iuid) = splitUnitIdInsts (moduleUnitId m)
+ in (InstalledModule uid (moduleName m),
+ fmap (\iuid -> IndefModule iuid (moduleName m)) mb_iuid)
+
+-- | See 'splitModuleInsts'.
+splitUnitIdInsts :: UnitId -> (InstalledUnitId, Maybe IndefUnitId)
+splitUnitIdInsts (IndefiniteUnitId iuid) =
+ (componentIdToInstalledUnitId (indefUnitIdComponentId iuid), Just iuid)
+splitUnitIdInsts (DefiniteUnitId (DefUnitId uid)) = (uid, Nothing)
+
+generalizeIndefUnitId :: IndefUnitId -> IndefUnitId
+generalizeIndefUnitId IndefUnitId{ indefUnitIdComponentId = cid
+ , indefUnitIdInsts = insts } =
+ newIndefUnitId cid (map (\(m,_) -> (m, mkHoleModule m)) insts)
+
+generalizeIndefModule :: IndefModule -> IndefModule
+generalizeIndefModule (IndefModule uid n) = IndefModule (generalizeIndefUnitId uid) n
+
+parseModuleName :: ReadP ModuleName
+parseModuleName = fmap mkModuleName
+ $ Parse.munch1 (\c -> isAlphaNum c || c `elem` "_.")
+
+parseUnitId :: ReadP UnitId
+parseUnitId = parseFullUnitId <++ parseDefiniteUnitId <++ parseSimpleUnitId
+ where
+ parseFullUnitId = do
+ cid <- parseComponentId
+ insts <- parseModSubst
+ return (newUnitId cid insts)
+ parseDefiniteUnitId = do
+ s <- Parse.munch1 (\c -> isAlphaNum c || c `elem` "-_.+")
+ return (stringToUnitId s)
+ parseSimpleUnitId = do
+ cid <- parseComponentId
+ return (newSimpleUnitId cid)
+
+parseComponentId :: ReadP ComponentId
+parseComponentId = (ComponentId . mkFastString) `fmap` Parse.munch1 abi_char
+ where abi_char c = isAlphaNum c || c `elem` "-_."
+
+parseModuleId :: ReadP Module
+parseModuleId = parseModuleVar <++ parseModule
+ where
+ parseModuleVar = do
+ _ <- Parse.char '<'
+ modname <- parseModuleName
+ _ <- Parse.char '>'
+ return (mkHoleModule modname)
+ parseModule = do
+ uid <- parseUnitId
+ _ <- Parse.char ':'
+ modname <- parseModuleName
+ return (mkModule uid modname)
+
+parseModSubst :: ReadP [(ModuleName, Module)]
+parseModSubst = Parse.between (Parse.char '[') (Parse.char ']')
+ . flip Parse.sepBy (Parse.char ',')
+ $ do k <- parseModuleName
+ _ <- Parse.char '='
+ v <- parseModuleId
+ return (k, v)
+
+
+-- -----------------------------------------------------------------------------
+-- $wired_in_packages
+-- Certain packages are known to the compiler, in that we know about certain
+-- entities that reside in these packages, and the compiler needs to
+-- declare static Modules and Names that refer to these packages. Hence
+-- the wired-in packages can't include version numbers, since we don't want
+-- to bake the version numbers of these packages into GHC.
+--
+-- So here's the plan. Wired-in packages are still versioned as
+-- normal in the packages database, and you can still have multiple
+-- versions of them installed. However, for each invocation of GHC,
+-- only a single instance of each wired-in package will be recognised
+-- (the desired one is selected via @-package@\/@-hide-package@), and GHC
+-- will use the unversioned 'UnitId' below when referring to it,
+-- including in .hi files and object file symbols. Unselected
+-- versions of wired-in packages will be ignored, as will any other
+-- package that depends directly or indirectly on it (much as if you
+-- had used @-ignore-package@).
+
+-- Make sure you change 'Packages.findWiredInPackages' if you add an entry here
+
+integerUnitId, primUnitId,
+ baseUnitId, rtsUnitId,
+ thUnitId, dphSeqUnitId, dphParUnitId,
+ mainUnitId, thisGhcUnitId, interactiveUnitId :: UnitId
+primUnitId = fsToUnitId (fsLit "ghc-prim")
+integerUnitId = fsToUnitId (fsLit n)
+ where
+ n = case cIntegerLibraryType of
+ IntegerGMP -> "integer-gmp"
+ IntegerSimple -> "integer-simple"
+baseUnitId = fsToUnitId (fsLit "base")
+rtsUnitId = fsToUnitId (fsLit "rts")
+thUnitId = fsToUnitId (fsLit "template-haskell")
+dphSeqUnitId = fsToUnitId (fsLit "dph-seq")
+dphParUnitId = fsToUnitId (fsLit "dph-par")
+thisGhcUnitId = fsToUnitId (fsLit "ghc")
+interactiveUnitId = fsToUnitId (fsLit "interactive")
+
+-- | This is the package Id for the current program. It is the default
+-- package Id if you don't specify a package name. We don't add this prefix
+-- to symbol names, since there can be only one main package per program.
+mainUnitId = fsToUnitId (fsLit "main")
+
+-- | This is a fake package id used to provide identities to any un-implemented
+-- signatures. The set of hole identities is global over an entire compilation.
+-- Don't use this directly: use 'mkHoleModule' or 'isHoleModule' instead.
+-- See Note [Representation of module/name variables]
+holeUnitId :: UnitId
+holeUnitId = fsToUnitId (fsLit "hole")
+
+isInteractiveModule :: Module -> Bool
+isInteractiveModule mod = moduleUnitId mod == interactiveUnitId
+
+-- Note [Representation of module/name variables]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- In our ICFP'16, we use to represent module holes, and {A.T} to represent
+-- name holes. This could have been represented by adding some new cases
+-- to the core data types, but this would have made the existing 'nameModule'
+-- and 'moduleUnitId' partial, which would have required a lot of modifications
+-- to existing code.
+--
+-- Instead, we adopted the following encoding scheme:
+--
+-- ===> hole:A
+-- {A.T} ===> hole:A.T
+--
+-- This encoding is quite convenient, but it is also a bit dangerous too,
+-- because if you have a 'hole:A' you need to know if it's actually a
+-- 'Module' or just a module stored in a 'Name'; these two cases must be
+-- treated differently when doing substitutions. 'renameHoleModule'
+-- and 'renameHoleUnitId' assume they are NOT operating on a
+-- 'Name'; 'NameShape' handles name substitutions exclusively.
+
+isHoleModule :: Module -> Bool
+isHoleModule mod = moduleUnitId mod == holeUnitId
+
+wiredInUnitIds :: [UnitId]
+wiredInUnitIds = [ primUnitId,
+ integerUnitId,
+ baseUnitId,
+ rtsUnitId,
+ thUnitId,
+ thisGhcUnitId,
+ dphSeqUnitId,
+ dphParUnitId ]
+
+{-
+************************************************************************
+* *
+\subsection{@ModuleEnv@s}
+* *
+************************************************************************
+-}
+
+-- | A map keyed off of 'Module's
+newtype ModuleEnv elt = ModuleEnv (Map NDModule elt)
+
+{-
+Note [ModuleEnv performance and determinism]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+To prevent accidental reintroduction of nondeterminism the Ord instance
+for Module was changed to not depend on Unique ordering and to use the
+lexicographic order. This is potentially expensive, but when measured
+there was no difference in performance.
+
+To be on the safe side and not pessimize ModuleEnv uses nondeterministic
+ordering on Module and normalizes by doing the lexicographic sort when
+turning the env to a list.
+See Note [Unique Determinism] for more information about the source of
+nondeterminismand and Note [Deterministic UniqFM] for explanation of why
+it matters for maps.
+-}
+
+newtype NDModule = NDModule { unNDModule :: Module }
+ deriving Eq
+ -- A wrapper for Module with faster nondeterministic Ord.
+ -- Don't export, See [ModuleEnv performance and determinism]
+
+instance Ord NDModule where
+ compare (NDModule (Module p1 n1)) (NDModule (Module p2 n2)) =
+ (getUnique p1 `nonDetCmpUnique` getUnique p2) `thenCmp`
+ (getUnique n1 `nonDetCmpUnique` getUnique n2)
+
+filterModuleEnv :: (Module -> a -> Bool) -> ModuleEnv a -> ModuleEnv a
+filterModuleEnv f (ModuleEnv e) =
+ ModuleEnv (Map.filterWithKey (f . unNDModule) e)
+
+elemModuleEnv :: Module -> ModuleEnv a -> Bool
+elemModuleEnv m (ModuleEnv e) = Map.member (NDModule m) e
+
+extendModuleEnv :: ModuleEnv a -> Module -> a -> ModuleEnv a
+extendModuleEnv (ModuleEnv e) m x = ModuleEnv (Map.insert (NDModule m) x e)
+
+extendModuleEnvWith :: (a -> a -> a) -> ModuleEnv a -> Module -> a
+ -> ModuleEnv a
+extendModuleEnvWith f (ModuleEnv e) m x =
+ ModuleEnv (Map.insertWith f (NDModule m) x e)
+
+extendModuleEnvList :: ModuleEnv a -> [(Module, a)] -> ModuleEnv a
+extendModuleEnvList (ModuleEnv e) xs =
+ ModuleEnv (Map.insertList [(NDModule k, v) | (k,v) <- xs] e)
+
+extendModuleEnvList_C :: (a -> a -> a) -> ModuleEnv a -> [(Module, a)]
+ -> ModuleEnv a
+extendModuleEnvList_C f (ModuleEnv e) xs =
+ ModuleEnv (Map.insertListWith f [(NDModule k, v) | (k,v) <- xs] e)
+
+plusModuleEnv_C :: (a -> a -> a) -> ModuleEnv a -> ModuleEnv a -> ModuleEnv a
+plusModuleEnv_C f (ModuleEnv e1) (ModuleEnv e2) =
+ ModuleEnv (Map.unionWith f e1 e2)
+
+delModuleEnvList :: ModuleEnv a -> [Module] -> ModuleEnv a
+delModuleEnvList (ModuleEnv e) ms =
+ ModuleEnv (Map.deleteList (map NDModule ms) e)
+
+delModuleEnv :: ModuleEnv a -> Module -> ModuleEnv a
+delModuleEnv (ModuleEnv e) m = ModuleEnv (Map.delete (NDModule m) e)
+
+plusModuleEnv :: ModuleEnv a -> ModuleEnv a -> ModuleEnv a
+plusModuleEnv (ModuleEnv e1) (ModuleEnv e2) = ModuleEnv (Map.union e1 e2)
+
+lookupModuleEnv :: ModuleEnv a -> Module -> Maybe a
+lookupModuleEnv (ModuleEnv e) m = Map.lookup (NDModule m) e
+
+lookupWithDefaultModuleEnv :: ModuleEnv a -> a -> Module -> a
+lookupWithDefaultModuleEnv (ModuleEnv e) x m =
+ Map.findWithDefault x (NDModule m) e
+
+mapModuleEnv :: (a -> b) -> ModuleEnv a -> ModuleEnv b
+mapModuleEnv f (ModuleEnv e) = ModuleEnv (Map.mapWithKey (\_ v -> f v) e)
+
+mkModuleEnv :: [(Module, a)] -> ModuleEnv a
+mkModuleEnv xs = ModuleEnv (Map.fromList [(NDModule k, v) | (k,v) <- xs])
+
+emptyModuleEnv :: ModuleEnv a
+emptyModuleEnv = ModuleEnv Map.empty
+
+moduleEnvKeys :: ModuleEnv a -> [Module]
+moduleEnvKeys (ModuleEnv e) = sort $ map unNDModule $ Map.keys e
+ -- See Note [ModuleEnv performance and determinism]
+
+moduleEnvElts :: ModuleEnv a -> [a]
+moduleEnvElts e = map snd $ moduleEnvToList e
+ -- See Note [ModuleEnv performance and determinism]
+
+moduleEnvToList :: ModuleEnv a -> [(Module, a)]
+moduleEnvToList (ModuleEnv e) =
+ sortBy (comparing fst) [(m, v) | (NDModule m, v) <- Map.toList e]
+ -- See Note [ModuleEnv performance and determinism]
+
+unitModuleEnv :: Module -> a -> ModuleEnv a
+unitModuleEnv m x = ModuleEnv (Map.singleton (NDModule m) x)
+
+isEmptyModuleEnv :: ModuleEnv a -> Bool
+isEmptyModuleEnv (ModuleEnv e) = Map.null e
+
+-- | A set of 'Module's
+type ModuleSet = Set NDModule
+
+mkModuleSet :: [Module] -> ModuleSet
+extendModuleSet :: ModuleSet -> Module -> ModuleSet
+emptyModuleSet :: ModuleSet
+moduleSetElts :: ModuleSet -> [Module]
+elemModuleSet :: Module -> ModuleSet -> Bool
+
+emptyModuleSet = Set.empty
+mkModuleSet = Set.fromList . coerce
+extendModuleSet s m = Set.insert (NDModule m) s
+moduleSetElts = sort . coerce . Set.toList
+elemModuleSet = Set.member . coerce
+
+{-
+A ModuleName has a Unique, so we can build mappings of these using
+UniqFM.
+-}
+
+-- | A map keyed off of 'ModuleName's (actually, their 'Unique's)
+type ModuleNameEnv elt = UniqFM elt
+
+
+-- | A map keyed off of 'ModuleName's (actually, their 'Unique's)
+-- Has deterministic folds and can be deterministically converted to a list
+type DModuleNameEnv elt = UniqDFM elt
diff --git a/basicTypes/Module.hs-boot b/basicTypes/Module.hs-boot
new file mode 100644
--- /dev/null
+++ b/basicTypes/Module.hs-boot
@@ -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
diff --git a/basicTypes/Name.hs b/basicTypes/Name.hs
new file mode 100644
--- /dev/null
+++ b/basicTypes/Name.hs
@@ -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 " or
+-- "Defined in " information for a Name.
+pprDefinedAt :: Name -> SDoc
+pprDefinedAt name = text "Defined" <+> pprNameDefnLoc name
+
+pprNameDefnLoc :: Name -> SDoc
+-- Prints "at " or
+-- or "in " depending on what info is available
+pprNameDefnLoc name
+ = case nameSrcLoc name of
+ -- nameSrcLoc rather than nameSrcSpan
+ -- It seems less cluttered to show a location
+ -- rather than a span for the definition point
+ RealSrcLoc s -> text "at" <+> ppr s
+ UnhelpfulLoc s
+ | isInternalName name || isSystemName name
+ -> text "at" <+> ftext s
+ | otherwise
+ -> text "in" <+> quotes (ppr (nameModule name))
+
+
+-- | Get a string representation of a 'Name' that's unique and stable
+-- across recompilations. Used for deterministic generation of binds for
+-- derived instances.
+-- eg. "$aeson_70dylHtv1FFGeai1IoxcQr$Data.Aeson.Types.Internal$String"
+nameStableString :: Name -> String
+nameStableString Name{..} =
+ nameSortStableString n_sort ++ "$" ++ occNameString n_occ
+
+nameSortStableString :: NameSort -> String
+nameSortStableString System = "$_sys"
+nameSortStableString Internal = "$_in"
+nameSortStableString (External mod) = moduleStableString mod
+nameSortStableString (WiredIn mod _ _) = moduleStableString mod
+
+{-
+************************************************************************
+* *
+\subsection{Overloaded functions related to Names}
+* *
+************************************************************************
+-}
+
+-- | A class allowing convenient access to the 'Name' of various datatypes
+class NamedThing a where
+ getOccName :: a -> OccName
+ getName :: a -> Name
+
+ getOccName n = nameOccName (getName n) -- Default method
+
+instance NamedThing e => NamedThing (GenLocated l e) where
+ getName = getName . unLoc
+
+getSrcLoc :: NamedThing a => a -> SrcLoc
+getSrcSpan :: NamedThing a => a -> SrcSpan
+getOccString :: NamedThing a => a -> String
+getOccFS :: NamedThing a => a -> FastString
+
+getSrcLoc = nameSrcLoc . getName
+getSrcSpan = nameSrcSpan . getName
+getOccString = occNameString . getOccName
+getOccFS = occNameFS . getOccName
+
+pprInfixName :: (Outputable a, NamedThing a) => a -> SDoc
+-- See Outputable.pprPrefixVar, pprInfixVar;
+-- add parens or back-quotes as appropriate
+pprInfixName n = pprInfixVar (isSymOcc (getOccName n)) (ppr n)
+
+pprPrefixName :: NamedThing a => a -> SDoc
+pprPrefixName thing
+ | name `hasKey` starKindTyConKey || name `hasKey` unicodeStarKindTyConKey
+ = ppr name -- See Note [Special treatment for kind *]
+ | otherwise
+ = pprPrefixVar (isSymOcc (nameOccName name)) (ppr name)
+ where
+ name = getName thing
+
+{-
+Note [Special treatment for kind *]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Do not put parens around the kind '*'. Even though it looks like
+an operator, it is really a special case.
+
+This pprPrefixName stuff is really only used when printing HsSyn,
+which has to be polymorphic in the name type, and hence has to go via
+the overloaded function pprPrefixOcc. It's easier where we know the
+type being pretty printed; eg the pretty-printing code in TyCoRep.
+
+See Trac #7645, which led to this.
+-}
diff --git a/basicTypes/Name.hs-boot b/basicTypes/Name.hs-boot
new file mode 100644
--- /dev/null
+++ b/basicTypes/Name.hs-boot
@@ -0,0 +1,3 @@
+module Name where
+
+data Name
diff --git a/basicTypes/NameCache.hs b/basicTypes/NameCache.hs
new file mode 100644
--- /dev/null
+++ b/basicTypes/NameCache.hs
@@ -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
diff --git a/basicTypes/NameEnv.hs b/basicTypes/NameEnv.hs
new file mode 100644
--- /dev/null
+++ b/basicTypes/NameEnv.hs
@@ -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
diff --git a/basicTypes/NameSet.hs b/basicTypes/NameSet.hs
new file mode 100644
--- /dev/null
+++ b/basicTypes/NameSet.hs
@@ -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
diff --git a/basicTypes/OccName.hs b/basicTypes/OccName.hs
new file mode 100644
--- /dev/null
+++ b/basicTypes/OccName.hs
@@ -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)
diff --git a/basicTypes/OccName.hs-boot b/basicTypes/OccName.hs-boot
new file mode 100644
--- /dev/null
+++ b/basicTypes/OccName.hs-boot
@@ -0,0 +1,3 @@
+module OccName where
+
+data OccName
diff --git a/basicTypes/PatSyn.hs b/basicTypes/PatSyn.hs
new file mode 100644
--- /dev/null
+++ b/basicTypes/PatSyn.hs
@@ -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)
diff --git a/basicTypes/PatSyn.hs-boot b/basicTypes/PatSyn.hs-boot
new file mode 100644
--- /dev/null
+++ b/basicTypes/PatSyn.hs-boot
@@ -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
diff --git a/basicTypes/RdrName.hs b/basicTypes/RdrName.hs
new file mode 100644
--- /dev/null
+++ b/basicTypes/RdrName.hs
@@ -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";
+ -- }
+ -- I think we can do without this conversion
+ compare (Exact n1) (Exact n2) = n1 `compare` n2
+ compare (Exact _) _ = LT
+
+ compare (Unqual _) (Exact _) = GT
+ compare (Unqual o1) (Unqual o2) = o1 `compare` o2
+ compare (Unqual _) _ = LT
+
+ compare (Qual _ _) (Exact _) = GT
+ compare (Qual _ _) (Unqual _) = GT
+ compare (Qual m1 o1) (Qual m2 o2) = (o1 `compare` o2) `thenCmp` (m1 `compare` m2)
+ compare (Qual _ _) (Orig _ _) = LT
+
+ compare (Orig m1 o1) (Orig m2 o2) = (o1 `compare` o2) `thenCmp` (m1 `compare` m2)
+ compare (Orig _ _) _ = GT
+
+{-
+************************************************************************
+* *
+ LocalRdrEnv
+* *
+************************************************************************
+-}
+
+-- | Local Reader Environment
+--
+-- This environment is used to store local bindings
+-- (@let@, @where@, lambda, @case@).
+-- It is keyed by OccName, because we never use it for qualified names
+-- We keep the current mapping, *and* the set of all Names in scope
+-- Reason: see Note [Splicing Exact names] in RnEnv
+data LocalRdrEnv = LRE { lre_env :: OccEnv Name
+ , lre_in_scope :: NameSet }
+
+instance Outputable LocalRdrEnv where
+ ppr (LRE {lre_env = env, lre_in_scope = ns})
+ = hang (text "LocalRdrEnv {")
+ 2 (vcat [ text "env =" <+> pprOccEnv ppr_elt env
+ , text "in_scope ="
+ <+> pprUFM (getUniqSet ns) (braces . pprWithCommas ppr)
+ ] <+> char '}')
+ where
+ ppr_elt name = parens (ppr (getUnique (nameOccName name))) <+> ppr name
+ -- So we can see if the keys line up correctly
+
+emptyLocalRdrEnv :: LocalRdrEnv
+emptyLocalRdrEnv = LRE { lre_env = emptyOccEnv
+ , lre_in_scope = emptyNameSet }
+
+extendLocalRdrEnv :: LocalRdrEnv -> Name -> LocalRdrEnv
+-- The Name should be a non-top-level thing
+extendLocalRdrEnv lre@(LRE { lre_env = env, lre_in_scope = ns }) name
+ = WARN( isExternalName name, ppr name )
+ lre { lre_env = extendOccEnv env (nameOccName name) name
+ , lre_in_scope = extendNameSet ns name }
+
+extendLocalRdrEnvList :: LocalRdrEnv -> [Name] -> LocalRdrEnv
+extendLocalRdrEnvList lre@(LRE { lre_env = env, lre_in_scope = ns }) names
+ = WARN( any isExternalName names, ppr names )
+ lre { lre_env = extendOccEnvList env [(nameOccName n, n) | n <- names]
+ , lre_in_scope = extendNameSetList ns names }
+
+lookupLocalRdrEnv :: LocalRdrEnv -> RdrName -> Maybe Name
+lookupLocalRdrEnv (LRE { lre_env = env, lre_in_scope = ns }) rdr
+ | Unqual occ <- rdr
+ = lookupOccEnv env occ
+
+ -- See Note [Local bindings with Exact Names]
+ | Exact name <- rdr
+ , name `elemNameSet` ns
+ = Just name
+
+ | otherwise
+ = Nothing
+
+lookupLocalRdrOcc :: LocalRdrEnv -> OccName -> Maybe Name
+lookupLocalRdrOcc (LRE { lre_env = env }) occ = lookupOccEnv env occ
+
+elemLocalRdrEnv :: RdrName -> LocalRdrEnv -> Bool
+elemLocalRdrEnv rdr_name (LRE { lre_env = env, lre_in_scope = ns })
+ = case rdr_name of
+ Unqual occ -> occ `elemOccEnv` env
+ Exact name -> name `elemNameSet` ns -- See Note [Local bindings with Exact Names]
+ Qual {} -> False
+ Orig {} -> False
+
+localRdrEnvElts :: LocalRdrEnv -> [Name]
+localRdrEnvElts (LRE { lre_env = env }) = occEnvElts env
+
+inLocalRdrEnvScope :: Name -> LocalRdrEnv -> Bool
+-- This is the point of the NameSet
+inLocalRdrEnvScope name (LRE { lre_in_scope = ns }) = name `elemNameSet` ns
+
+delLocalRdrEnvList :: LocalRdrEnv -> [OccName] -> LocalRdrEnv
+delLocalRdrEnvList lre@(LRE { lre_env = env }) occs
+ = lre { lre_env = delListFromOccEnv env occs }
+
+{-
+Note [Local bindings with Exact Names]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+With Template Haskell we can make local bindings that have Exact Names.
+Computing shadowing etc may use elemLocalRdrEnv (at least it certainly
+does so in RnTpes.bindHsQTyVars), so for an Exact Name we must consult
+the in-scope-name-set.
+
+
+************************************************************************
+* *
+ GlobalRdrEnv
+* *
+************************************************************************
+-}
+
+-- | Global Reader Environment
+type GlobalRdrEnv = OccEnv [GlobalRdrElt]
+-- ^ Keyed by 'OccName'; when looking up a qualified name
+-- we look up the 'OccName' part, and then check the 'Provenance'
+-- to see if the appropriate qualification is valid. This
+-- saves routinely doubling the size of the env by adding both
+-- qualified and unqualified names to the domain.
+--
+-- The list in the codomain is required because there may be name clashes
+-- These only get reported on lookup, not on construction
+--
+-- INVARIANT 1: All the members of the list have distinct
+-- 'gre_name' fields; that is, no duplicate Names
+--
+-- INVARIANT 2: Imported provenance => Name is an ExternalName
+-- However LocalDefs can have an InternalName. This
+-- happens only when type-checking a [d| ... |] Template
+-- Haskell quotation; see this note in RnNames
+-- Note [Top-level Names in Template Haskell decl quotes]
+--
+-- INVARIANT 3: If the GlobalRdrEnv maps [occ -> gre], then
+-- greOccName gre = occ
+--
+-- NB: greOccName gre is usually the same as
+-- nameOccName (gre_name gre), but not always in the
+-- case of record seectors; see greOccName
+
+-- | Global Reader Element
+--
+-- An element of the 'GlobalRdrEnv'
+data GlobalRdrElt
+ = GRE { gre_name :: Name
+ , gre_par :: Parent
+ , gre_lcl :: Bool -- ^ True <=> the thing was defined locally
+ , gre_imp :: [ImportSpec] -- ^ In scope through these imports
+ } deriving (Data, Eq)
+ -- INVARIANT: either gre_lcl = True or gre_imp is non-empty
+ -- See Note [GlobalRdrElt provenance]
+
+-- | The children of a Name are the things that are abbreviated by the ".."
+-- notation in export lists. See Note [Parents]
+data Parent = NoParent
+ | ParentIs { par_is :: Name }
+ | FldParent { par_is :: Name, par_lbl :: Maybe FieldLabelString }
+ -- ^ See Note [Parents for record fields]
+ deriving (Eq, Data, Typeable)
+
+instance Outputable Parent where
+ ppr NoParent = empty
+ ppr (ParentIs n) = text "parent:" <> ppr n
+ ppr (FldParent n f) = text "fldparent:"
+ <> ppr n <> colon <> ppr f
+
+plusParent :: Parent -> Parent -> Parent
+-- See Note [Combining parents]
+plusParent p1@(ParentIs _) p2 = hasParent p1 p2
+plusParent p1@(FldParent _ _) p2 = hasParent p1 p2
+plusParent p1 p2@(ParentIs _) = hasParent p2 p1
+plusParent p1 p2@(FldParent _ _) = hasParent p2 p1
+plusParent _ _ = NoParent
+
+hasParent :: Parent -> Parent -> Parent
+#ifdef DEBUG
+hasParent p NoParent = p
+hasParent p p'
+ | p /= p' = pprPanic "hasParent" (ppr p <+> ppr p') -- Parents should agree
+#endif
+hasParent p _ = p
+
+
+{- Note [GlobalRdrElt provenance]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The gre_lcl and gre_imp fields of a GlobalRdrElt describe its "provenance",
+i.e. how the Name came to be in scope. It can be in scope two ways:
+ - gre_lcl = True: it is bound in this module
+ - gre_imp: a list of all the imports that brought it into scope
+
+It's an INVARIANT that you have one or the other; that is, either
+gre_lcl is True, or gre_imp is non-empty.
+
+It is just possible to have *both* if there is a module loop: a Name
+is defined locally in A, and also brought into scope by importing a
+module that SOURCE-imported A. Exapmle (Trac #7672):
+
+ A.hs-boot module A where
+ data T
+
+ B.hs module B(Decl.T) where
+ import {-# SOURCE #-} qualified A as Decl
+
+ A.hs module A where
+ import qualified B
+ data T = Z | S B.T
+
+In A.hs, 'T' is locally bound, *and* imported as B.T.
+
+Note [Parents]
+~~~~~~~~~~~~~~~~~
+ Parent Children
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ data T Data constructors
+ Record-field ids
+
+ data family T Data constructors and record-field ids
+ of all visible data instances of T
+
+ class C Class operations
+ Associated type constructors
+
+~~~~~~~~~~~~~~~~~~~~~~~~~
+ Constructor Meaning
+ ~~~~~~~~~~~~~~~~~~~~~~~~
+ NoParent Can not be bundled with a type constructor.
+ ParentIs n Can be bundled with the type constructor corresponding to
+ n.
+ FldParent See Note [Parents for record fields]
+
+
+
+
+Note [Parents for record fields]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For record fields, in addition to the Name of the type constructor
+(stored in par_is), we use FldParent to store the field label. This
+extra information is used for identifying overloaded record fields
+during renaming.
+
+In a definition arising from a normal module (without
+-XDuplicateRecordFields), par_lbl will be Nothing, meaning that the
+field's label is the same as the OccName of the selector's Name. The
+GlobalRdrEnv will contain an entry like this:
+
+ "x" |-> GRE x (FldParent T Nothing) LocalDef
+
+When -XDuplicateRecordFields is enabled for the module that contains
+T, the selector's Name will be mangled (see comments in FieldLabel).
+Thus we store the actual field label in par_lbl, and the GlobalRdrEnv
+entry looks like this:
+
+ "x" |-> GRE $sel:x:MkT (FldParent T (Just "x")) LocalDef
+
+Note that the OccName used when adding a GRE to the environment
+(greOccName) now depends on the parent field: for FldParent it is the
+field label, if present, rather than the selector name.
+
+~~
+
+Record pattern synonym selectors are treated differently. Their parent
+information is `NoParent` in the module in which they are defined. This is because
+a pattern synonym `P` has no parent constructor either.
+
+However, if `f` is bundled with a type constructor `T` then whenever `f` is
+imported the parent will use the `Parent` constructor so the parent of `f` is
+now `T`.
+
+
+Note [Combining parents]
+~~~~~~~~~~~~~~~~~~~~~~~~
+With an associated type we might have
+ module M where
+ class C a where
+ data T a
+ op :: T a -> a
+ instance C Int where
+ data T Int = TInt
+ instance C Bool where
+ data T Bool = TBool
+
+Then: C is the parent of T
+ T is the parent of TInt and TBool
+So: in an export list
+ C(..) is short for C( op, T )
+ T(..) is short for T( TInt, TBool )
+
+Module M exports everything, so its exports will be
+ AvailTC C [C,T,op]
+ AvailTC T [T,TInt,TBool]
+On import we convert to GlobalRdrElt and then combine
+those. For T that will mean we have
+ one GRE with Parent C
+ one GRE with NoParent
+That's why plusParent picks the "best" case.
+-}
+
+-- | make a 'GlobalRdrEnv' where all the elements point to the same
+-- Provenance (useful for "hiding" imports, or imports with no details).
+gresFromAvails :: Maybe ImportSpec -> [AvailInfo] -> [GlobalRdrElt]
+-- prov = Nothing => locally bound
+-- Just spec => imported as described by spec
+gresFromAvails prov avails
+ = concatMap (gresFromAvail (const prov)) avails
+
+localGREsFromAvail :: AvailInfo -> [GlobalRdrElt]
+-- Turn an Avail into a list of LocalDef GlobalRdrElts
+localGREsFromAvail = gresFromAvail (const Nothing)
+
+gresFromAvail :: (Name -> Maybe ImportSpec) -> AvailInfo -> [GlobalRdrElt]
+gresFromAvail prov_fn avail
+ = map mk_gre (availNonFldNames avail) ++ map mk_fld_gre (availFlds avail)
+ where
+ mk_gre n
+ = case prov_fn n of -- Nothing => bound locally
+ -- Just is => imported from 'is'
+ Nothing -> GRE { gre_name = n, gre_par = mkParent n avail
+ , gre_lcl = True, gre_imp = [] }
+ Just is -> GRE { gre_name = n, gre_par = mkParent n avail
+ , gre_lcl = False, gre_imp = [is] }
+
+ mk_fld_gre (FieldLabel { flLabel = lbl, flIsOverloaded = is_overloaded
+ , flSelector = n })
+ = case prov_fn n of -- Nothing => bound locally
+ -- Just is => imported from 'is'
+ Nothing -> GRE { gre_name = n, gre_par = FldParent (availName avail) mb_lbl
+ , gre_lcl = True, gre_imp = [] }
+ Just is -> GRE { gre_name = n, gre_par = FldParent (availName avail) mb_lbl
+ , gre_lcl = False, gre_imp = [is] }
+ where
+ mb_lbl | is_overloaded = Just lbl
+ | otherwise = Nothing
+
+
+greQualModName :: GlobalRdrElt -> ModuleName
+-- Get a suitable module qualifier for the GRE
+-- (used in mkPrintUnqualified)
+-- Prerecondition: the gre_name is always External
+greQualModName gre@(GRE { gre_name = name, gre_lcl = lcl, gre_imp = iss })
+ | lcl, Just mod <- nameModule_maybe name = moduleName mod
+ | (is:_) <- iss = is_as (is_decl is)
+ | otherwise = pprPanic "greQualModName" (ppr gre)
+
+greUsedRdrName :: GlobalRdrElt -> RdrName
+-- For imported things, return a RdrName to add to the used-RdrName
+-- set, which is used to generate unused-import-decl warnings.
+-- Return a Qual RdrName if poss, so that identifies the most
+-- specific ImportSpec. See Trac #10890 for some good examples.
+greUsedRdrName gre@GRE{ gre_name = name, gre_lcl = lcl, gre_imp = iss }
+ | lcl, Just mod <- nameModule_maybe name = Qual (moduleName mod) occ
+ | not (null iss), is <- bestImport iss = Qual (is_as (is_decl is)) occ
+ | otherwise = pprTrace "greUsedRdrName" (ppr gre) (Unqual occ)
+ where
+ occ = greOccName gre
+
+greRdrNames :: GlobalRdrElt -> [RdrName]
+greRdrNames gre@GRE{ gre_lcl = lcl, gre_imp = iss }
+ = (if lcl then [unqual] else []) ++ concatMap do_spec (map is_decl iss)
+ where
+ occ = greOccName gre
+ unqual = Unqual occ
+ do_spec decl_spec
+ | is_qual decl_spec = [qual]
+ | otherwise = [unqual,qual]
+ where qual = Qual (is_as decl_spec) occ
+
+-- the SrcSpan that pprNameProvenance prints out depends on whether
+-- the Name is defined locally or not: for a local definition the
+-- definition site is used, otherwise the location of the import
+-- declaration. We want to sort the export locations in
+-- exportClashErr by this SrcSpan, we need to extract it:
+greSrcSpan :: GlobalRdrElt -> SrcSpan
+greSrcSpan gre@(GRE { gre_name = name, gre_lcl = lcl, gre_imp = iss } )
+ | lcl = nameSrcSpan name
+ | (is:_) <- iss = is_dloc (is_decl is)
+ | otherwise = pprPanic "greSrcSpan" (ppr gre)
+
+mkParent :: Name -> AvailInfo -> Parent
+mkParent _ (Avail _) = NoParent
+mkParent n (AvailTC m _ _) | n == m = NoParent
+ | otherwise = ParentIs m
+
+greParentName :: GlobalRdrElt -> Maybe Name
+greParentName gre = case gre_par gre of
+ NoParent -> Nothing
+ ParentIs n -> Just n
+ FldParent n _ -> Just n
+
+-- | Takes a list of distinct GREs and folds them
+-- into AvailInfos. This is more efficient than mapping each individual
+-- GRE to an AvailInfo and the folding using `plusAvail` but needs the
+-- uniqueness assumption.
+gresToAvailInfo :: [GlobalRdrElt] -> [AvailInfo]
+gresToAvailInfo gres
+ = ASSERT( nub gres == gres ) nameEnvElts avail_env
+ where
+ avail_env :: NameEnv AvailInfo -- keyed by the parent
+ avail_env = foldl' add emptyNameEnv gres
+
+ add :: NameEnv AvailInfo -> GlobalRdrElt -> NameEnv AvailInfo
+ add env gre = extendNameEnv_Acc comb availFromGRE env
+ (fromMaybe (gre_name gre)
+ (greParentName gre)) gre
+
+ where
+ -- We want to insert the child `k` into a list of children but
+ -- need to maintain the invariant that the parent is first.
+ --
+ -- We also use the invariant that `k` is not already in `ns`.
+ insertChildIntoChildren :: Name -> [Name] -> Name -> [Name]
+ insertChildIntoChildren _ [] k = [k]
+ insertChildIntoChildren p (n:ns) k
+ | p == k = k:n:ns
+ | otherwise = n:k:ns
+
+ comb :: GlobalRdrElt -> AvailInfo -> AvailInfo
+ comb _ (Avail n) = Avail n -- Duplicated name
+ comb gre (AvailTC m ns fls) =
+ let n = gre_name gre
+ in case gre_par gre of
+ NoParent -> AvailTC m (n:ns) fls -- Not sure this ever happens
+ ParentIs {} -> AvailTC m (insertChildIntoChildren m ns n) fls
+ FldParent _ mb_lbl -> AvailTC m ns (mkFieldLabel n mb_lbl : fls)
+
+availFromGRE :: GlobalRdrElt -> AvailInfo
+availFromGRE (GRE { gre_name = me, gre_par = parent })
+ = case parent of
+ ParentIs p -> AvailTC p [me] []
+ NoParent | isTyConName me -> AvailTC me [me] []
+ | otherwise -> avail me
+ FldParent p mb_lbl -> AvailTC p [] [mkFieldLabel me mb_lbl]
+
+mkFieldLabel :: Name -> Maybe FastString -> FieldLabel
+mkFieldLabel me mb_lbl =
+ case mb_lbl of
+ Nothing -> FieldLabel { flLabel = occNameFS (nameOccName me)
+ , flIsOverloaded = False
+ , flSelector = me }
+ Just lbl -> FieldLabel { flLabel = lbl
+ , flIsOverloaded = True
+ , flSelector = me }
+
+emptyGlobalRdrEnv :: GlobalRdrEnv
+emptyGlobalRdrEnv = emptyOccEnv
+
+globalRdrEnvElts :: GlobalRdrEnv -> [GlobalRdrElt]
+globalRdrEnvElts env = foldOccEnv (++) [] env
+
+instance Outputable GlobalRdrElt where
+ ppr gre = hang (ppr (gre_name gre) <+> ppr (gre_par gre))
+ 2 (pprNameProvenance gre)
+
+pprGlobalRdrEnv :: Bool -> GlobalRdrEnv -> SDoc
+pprGlobalRdrEnv locals_only env
+ = vcat [ text "GlobalRdrEnv" <+> ppWhen locals_only (ptext (sLit "(locals only)"))
+ <+> lbrace
+ , nest 2 (vcat [ pp (remove_locals gre_list) | gre_list <- occEnvElts env ]
+ <+> rbrace) ]
+ where
+ remove_locals gres | locals_only = filter isLocalGRE gres
+ | otherwise = gres
+ pp [] = empty
+ pp gres = hang (ppr occ
+ <+> parens (text "unique" <+> ppr (getUnique occ))
+ <> colon)
+ 2 (vcat (map ppr gres))
+ where
+ occ = nameOccName (gre_name (head gres))
+
+lookupGlobalRdrEnv :: GlobalRdrEnv -> OccName -> [GlobalRdrElt]
+lookupGlobalRdrEnv env occ_name = case lookupOccEnv env occ_name of
+ Nothing -> []
+ Just gres -> gres
+
+greOccName :: GlobalRdrElt -> OccName
+greOccName (GRE{gre_par = FldParent{par_lbl = Just lbl}}) = mkVarOccFS lbl
+greOccName gre = nameOccName (gre_name gre)
+
+lookupGRE_RdrName :: RdrName -> GlobalRdrEnv -> [GlobalRdrElt]
+lookupGRE_RdrName rdr_name env
+ = case lookupOccEnv env (rdrNameOcc rdr_name) of
+ Nothing -> []
+ Just gres -> pickGREs rdr_name gres
+
+lookupGRE_Name :: GlobalRdrEnv -> Name -> Maybe GlobalRdrElt
+-- ^ Look for precisely this 'Name' in the environment. This tests
+-- whether it is in scope, ignoring anything else that might be in
+-- scope with the same 'OccName'.
+lookupGRE_Name env name
+ = lookupGRE_Name_OccName env name (nameOccName name)
+
+lookupGRE_FieldLabel :: GlobalRdrEnv -> FieldLabel -> Maybe GlobalRdrElt
+-- ^ Look for a particular record field selector in the environment, where the
+-- selector name and field label may be different: the GlobalRdrEnv is keyed on
+-- the label. See Note [Parents for record fields] for why this happens.
+lookupGRE_FieldLabel env fl
+ = lookupGRE_Name_OccName env (flSelector fl) (mkVarOccFS (flLabel fl))
+
+lookupGRE_Name_OccName :: GlobalRdrEnv -> Name -> OccName -> Maybe GlobalRdrElt
+-- ^ Look for precisely this 'Name' in the environment, but with an 'OccName'
+-- that might differ from that of the 'Name'. See 'lookupGRE_FieldLabel' and
+-- Note [Parents for record fields].
+lookupGRE_Name_OccName env name occ
+ = case [ gre | gre <- lookupGlobalRdrEnv env occ
+ , gre_name gre == name ] of
+ [] -> Nothing
+ [gre] -> Just gre
+ gres -> pprPanic "lookupGRE_Name_OccName"
+ (ppr name $$ ppr occ $$ ppr gres)
+ -- See INVARIANT 1 on GlobalRdrEnv
+
+
+getGRE_NameQualifier_maybes :: GlobalRdrEnv -> Name -> [Maybe [ModuleName]]
+-- Returns all the qualifiers by which 'x' is in scope
+-- Nothing means "the unqualified version is in scope"
+-- [] means the thing is not in scope at all
+getGRE_NameQualifier_maybes env name
+ = case lookupGRE_Name env name of
+ Just gre -> [qualifier_maybe gre]
+ Nothing -> []
+ where
+ qualifier_maybe (GRE { gre_lcl = lcl, gre_imp = iss })
+ | lcl = Nothing
+ | otherwise = Just $ map (is_as . is_decl) iss
+
+isLocalGRE :: GlobalRdrElt -> Bool
+isLocalGRE (GRE {gre_lcl = lcl }) = lcl
+
+isRecFldGRE :: GlobalRdrElt -> Bool
+isRecFldGRE (GRE {gre_par = FldParent{}}) = True
+isRecFldGRE _ = False
+
+-- Returns the field label of this GRE, if it has one
+greLabel :: GlobalRdrElt -> Maybe FieldLabelString
+greLabel (GRE{gre_par = FldParent{par_lbl = Just lbl}}) = Just lbl
+greLabel (GRE{gre_name = n, gre_par = FldParent{}}) = Just (occNameFS (nameOccName n))
+greLabel _ = Nothing
+
+unQualOK :: GlobalRdrElt -> Bool
+-- ^ Test if an unqualified version of this thing would be in scope
+unQualOK (GRE {gre_lcl = lcl, gre_imp = iss })
+ | lcl = True
+ | otherwise = any unQualSpecOK iss
+
+{- Note [GRE filtering]
+~~~~~~~~~~~~~~~~~~~~~~~
+(pickGREs rdr gres) takes a list of GREs which have the same OccName
+as 'rdr', say "x". It does two things:
+
+(a) filters the GREs to a subset that are in scope
+ * Qualified, as 'M.x' if want_qual is Qual M _
+ * Unqualified, as 'x' if want_unqual is Unqual _
+
+(b) for that subset, filter the provenance field (gre_lcl and gre_imp)
+ to ones that brought it into scope qualified or unqualified resp.
+
+Example:
+ module A ( f ) where
+ import qualified Foo( f )
+ import Baz( f )
+ f = undefined
+
+Let's suppose that Foo.f and Baz.f are the same entity really, but the local
+'f' is different, so there will be two GREs matching "f":
+ gre1: gre_lcl = True, gre_imp = []
+ gre2: gre_lcl = False, gre_imp = [ imported from Foo, imported from Bar ]
+
+The use of "f" in the export list is ambiguous because it's in scope
+from the local def and the import Baz(f); but *not* the import qualified Foo.
+pickGREs returns two GRE
+ gre1: gre_lcl = True, gre_imp = []
+ gre2: gre_lcl = False, gre_imp = [ imported from Bar ]
+
+Now the the "ambiguous occurrence" message can correctly report how the
+ambiguity arises.
+-}
+
+pickGREs :: RdrName -> [GlobalRdrElt] -> [GlobalRdrElt]
+-- ^ Takes a list of GREs which have the right OccName 'x'
+-- Pick those GREs that are are in scope
+-- * Qualified, as 'M.x' if want_qual is Qual M _
+-- * Unqualified, as 'x' if want_unqual is Unqual _
+--
+-- Return each such GRE, with its ImportSpecs filtered, to reflect
+-- how it is in scope qualified or unqualified respectively.
+-- See Note [GRE filtering]
+pickGREs (Unqual {}) gres = mapMaybe pickUnqualGRE gres
+pickGREs (Qual mod _) gres = mapMaybe (pickQualGRE mod) gres
+pickGREs _ _ = [] -- I don't think this actually happens
+
+pickUnqualGRE :: GlobalRdrElt -> Maybe GlobalRdrElt
+pickUnqualGRE gre@(GRE { gre_lcl = lcl, gre_imp = iss })
+ | not lcl, null iss' = Nothing
+ | otherwise = Just (gre { gre_imp = iss' })
+ where
+ iss' = filter unQualSpecOK iss
+
+pickQualGRE :: ModuleName -> GlobalRdrElt -> Maybe GlobalRdrElt
+pickQualGRE mod gre@(GRE { gre_name = n, gre_lcl = lcl, gre_imp = iss })
+ | not lcl', null iss' = Nothing
+ | otherwise = Just (gre { gre_lcl = lcl', gre_imp = iss' })
+ where
+ iss' = filter (qualSpecOK mod) iss
+ lcl' = lcl && name_is_from mod n
+
+ name_is_from :: ModuleName -> Name -> Bool
+ name_is_from mod name = case nameModule_maybe name of
+ Just n_mod -> moduleName n_mod == mod
+ Nothing -> False
+
+pickGREsModExp :: ModuleName -> [GlobalRdrElt] -> [(GlobalRdrElt,GlobalRdrElt)]
+-- ^ Pick GREs that are in scope *both* qualified *and* unqualified
+-- Return each GRE that is, as a pair
+-- (qual_gre, unqual_gre)
+-- These two GREs are the original GRE with imports filtered to express how
+-- it is in scope qualified an unqualified respectively
+--
+-- Used only for the 'module M' item in export list;
+-- see RnNames.exports_from_avail
+pickGREsModExp mod gres = mapMaybe (pickBothGRE mod) gres
+
+pickBothGRE :: ModuleName -> GlobalRdrElt -> Maybe (GlobalRdrElt, GlobalRdrElt)
+pickBothGRE mod gre@(GRE { gre_name = n })
+ | isBuiltInSyntax n = Nothing
+ | Just gre1 <- pickQualGRE mod gre
+ , Just gre2 <- pickUnqualGRE gre = Just (gre1, gre2)
+ | otherwise = Nothing
+ where
+ -- isBuiltInSyntax filter out names for built-in syntax They
+ -- just clutter up the environment (esp tuples), and the
+ -- parser will generate Exact RdrNames for them, so the
+ -- cluttered envt is no use. Really, it's only useful for
+ -- GHC.Base and GHC.Tuple.
+
+-- Building GlobalRdrEnvs
+
+plusGlobalRdrEnv :: GlobalRdrEnv -> GlobalRdrEnv -> GlobalRdrEnv
+plusGlobalRdrEnv env1 env2 = plusOccEnv_C (foldr insertGRE) env1 env2
+
+mkGlobalRdrEnv :: [GlobalRdrElt] -> GlobalRdrEnv
+mkGlobalRdrEnv gres
+ = foldr add emptyGlobalRdrEnv gres
+ where
+ add gre env = extendOccEnv_Acc insertGRE singleton env
+ (greOccName gre)
+ gre
+
+insertGRE :: GlobalRdrElt -> [GlobalRdrElt] -> [GlobalRdrElt]
+insertGRE new_g [] = [new_g]
+insertGRE new_g (old_g : old_gs)
+ | gre_name new_g == gre_name old_g
+ = new_g `plusGRE` old_g : old_gs
+ | otherwise
+ = old_g : insertGRE new_g old_gs
+
+plusGRE :: GlobalRdrElt -> GlobalRdrElt -> GlobalRdrElt
+-- Used when the gre_name fields match
+plusGRE g1 g2
+ = GRE { gre_name = gre_name g1
+ , gre_lcl = gre_lcl g1 || gre_lcl g2
+ , gre_imp = gre_imp g1 ++ gre_imp g2
+ , gre_par = gre_par g1 `plusParent` gre_par g2 }
+
+transformGREs :: (GlobalRdrElt -> GlobalRdrElt)
+ -> [OccName]
+ -> GlobalRdrEnv -> GlobalRdrEnv
+-- ^ Apply a transformation function to the GREs for these OccNames
+transformGREs trans_gre occs rdr_env
+ = foldr trans rdr_env occs
+ where
+ trans occ env
+ = case lookupOccEnv env occ of
+ Just gres -> extendOccEnv env occ (map trans_gre gres)
+ Nothing -> env
+
+extendGlobalRdrEnv :: GlobalRdrEnv -> GlobalRdrElt -> GlobalRdrEnv
+extendGlobalRdrEnv env gre
+ = extendOccEnv_Acc insertGRE singleton env
+ (greOccName gre) gre
+
+shadowNames :: GlobalRdrEnv -> [Name] -> GlobalRdrEnv
+shadowNames = foldl shadowName
+
+{- Note [GlobalRdrEnv shadowing]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Before adding new names to the GlobalRdrEnv we nuke some existing entries;
+this is "shadowing". The actual work is done by RdrEnv.shadowNames.
+There are two reasons for shadowing:
+
+* The GHCi REPL
+
+ - Ids bought into scope on the command line (eg let x = True) have
+ External Names, like Ghci4.x. We want a new binding for 'x' (say)
+ to override the existing binding for 'x'.
+ See Note [Interactively-bound Ids in GHCi] in HscTypes
+
+ - Data types also have Extenal Names, like Ghci4.T; but we still want
+ 'T' to mean the newly-declared 'T', not an old one.
+
+* Nested Template Haskell declaration brackets
+ See Note [Top-level Names in Template Haskell decl quotes] in RnNames
+
+ Consider a TH decl quote:
+ module M where
+ f x = h [d| f = 3 |]
+ We must shadow the outer declaration of 'f', else we'll get a
+ complaint when extending the GlobalRdrEnv, saying that there are two
+ bindings for 'f'. There are several tricky points:
+
+ - This shadowing applies even if the binding for 'f' is in a
+ where-clause, and hence is in the *local* RdrEnv not the *global*
+ RdrEnv. This is done in lcl_env_TH in extendGlobalRdrEnvRn.
+
+ - The External Name M.f from the enclosing module must certainly
+ still be available. So we don't nuke it entirely; we just make
+ it seem like qualified import.
+
+ - We only shadow *External* names (which come from the main module),
+ or from earlier GHCi commands. Do not shadow *Internal* names
+ because in the bracket
+ [d| class C a where f :: a
+ f = 4 |]
+ rnSrcDecls will first call extendGlobalRdrEnvRn with C[f] from the
+ class decl, and *separately* extend the envt with the value binding.
+ At that stage, the class op 'f' will have an Internal name.
+-}
+
+shadowName :: GlobalRdrEnv -> Name -> GlobalRdrEnv
+-- Remove certain old GREs that share the same OccName as this new Name.
+-- See Note [GlobalRdrEnv shadowing] for details
+shadowName env name
+ = alterOccEnv (fmap alter_fn) env (nameOccName name)
+ where
+ alter_fn :: [GlobalRdrElt] -> [GlobalRdrElt]
+ alter_fn gres = mapMaybe (shadow_with name) gres
+
+ shadow_with :: Name -> GlobalRdrElt -> Maybe GlobalRdrElt
+ shadow_with new_name
+ old_gre@(GRE { gre_name = old_name, gre_lcl = lcl, gre_imp = iss })
+ = case nameModule_maybe old_name of
+ Nothing -> Just old_gre -- Old name is Internal; do not shadow
+ Just old_mod
+ | Just new_mod <- nameModule_maybe new_name
+ , new_mod == old_mod -- Old name same as new name; shadow completely
+ -> Nothing
+
+ | null iss' -- Nothing remains
+ -> Nothing
+
+ | otherwise
+ -> Just (old_gre { gre_lcl = False, gre_imp = iss' })
+
+ where
+ iss' = lcl_imp ++ mapMaybe (shadow_is new_name) iss
+ lcl_imp | lcl = [mk_fake_imp_spec old_name old_mod]
+ | otherwise = []
+
+ mk_fake_imp_spec old_name old_mod -- Urgh!
+ = ImpSpec id_spec ImpAll
+ where
+ old_mod_name = moduleName old_mod
+ id_spec = ImpDeclSpec { is_mod = old_mod_name
+ , is_as = old_mod_name
+ , is_qual = True
+ , is_dloc = nameSrcSpan old_name }
+
+ shadow_is :: Name -> ImportSpec -> Maybe ImportSpec
+ shadow_is new_name is@(ImpSpec { is_decl = id_spec })
+ | Just new_mod <- nameModule_maybe new_name
+ , is_as id_spec == moduleName new_mod
+ = Nothing -- Shadow both qualified and unqualified
+ | otherwise -- Shadow unqualified only
+ = Just (is { is_decl = id_spec { is_qual = True } })
+
+
+{-
+************************************************************************
+* *
+ ImportSpec
+* *
+************************************************************************
+-}
+
+-- | Import Specification
+--
+-- The 'ImportSpec' of something says how it came to be imported
+-- It's quite elaborate so that we can give accurate unused-name warnings.
+data ImportSpec = ImpSpec { is_decl :: ImpDeclSpec,
+ is_item :: ImpItemSpec }
+ deriving( Eq, Ord, Data )
+
+-- | Import Declaration Specification
+--
+-- Describes a particular import declaration and is
+-- shared among all the 'Provenance's for that decl
+data ImpDeclSpec
+ = ImpDeclSpec {
+ is_mod :: ModuleName, -- ^ Module imported, e.g. @import Muggle@
+ -- Note the @Muggle@ may well not be
+ -- the defining module for this thing!
+
+ -- TODO: either should be Module, or there
+ -- should be a Maybe UnitId here too.
+ is_as :: ModuleName, -- ^ Import alias, e.g. from @as M@ (or @Muggle@ if there is no @as@ clause)
+ is_qual :: Bool, -- ^ Was this import qualified?
+ is_dloc :: SrcSpan -- ^ The location of the entire import declaration
+ } deriving Data
+
+-- | Import Item Specification
+--
+-- Describes import info a particular Name
+data ImpItemSpec
+ = ImpAll -- ^ The import had no import list,
+ -- or had a hiding list
+
+ | ImpSome {
+ is_explicit :: Bool,
+ is_iloc :: SrcSpan -- Location of the import item
+ } -- ^ The import had an import list.
+ -- The 'is_explicit' field is @True@ iff the thing was named
+ -- /explicitly/ in the import specs rather
+ -- than being imported as part of a "..." group. Consider:
+ --
+ -- > import C( T(..) )
+ --
+ -- Here the constructors of @T@ are not named explicitly;
+ -- only @T@ is named explicitly.
+ deriving Data
+
+instance Eq ImpDeclSpec where
+ p1 == p2 = case p1 `compare` p2 of EQ -> True; _ -> False
+
+instance Ord ImpDeclSpec where
+ compare is1 is2 = (is_mod is1 `compare` is_mod is2) `thenCmp`
+ (is_dloc is1 `compare` is_dloc is2)
+
+instance Eq ImpItemSpec where
+ p1 == p2 = case p1 `compare` p2 of EQ -> True; _ -> False
+
+instance Ord ImpItemSpec where
+ compare is1 is2 =
+ case (is1, is2) of
+ (ImpAll, ImpAll) -> EQ
+ (ImpAll, _) -> GT
+ (_, ImpAll) -> LT
+ (ImpSome _ l1, ImpSome _ l2) -> l1 `compare` l2
+
+
+bestImport :: [ImportSpec] -> ImportSpec
+-- Given a non-empty bunch of ImportSpecs, return the one that
+-- imported the item most specifically (e.g. by name), using
+-- textually-first as a tie breaker. This is used when reporting
+-- redundant imports
+bestImport iss
+ = case sortBy best iss of
+ (is:_) -> is
+ [] -> pprPanic "bestImport" (ppr iss)
+ where
+ best :: ImportSpec -> ImportSpec -> Ordering
+ -- Less means better
+ best (ImpSpec { is_item = item1, is_decl = d1 })
+ (ImpSpec { is_item = item2, is_decl = d2 })
+ = best_item item1 item2 `thenCmp` (is_dloc d1 `compare` is_dloc d2)
+
+ best_item :: ImpItemSpec -> ImpItemSpec -> Ordering
+ best_item ImpAll ImpAll = EQ
+ best_item ImpAll (ImpSome {}) = GT
+ best_item (ImpSome {}) ImpAll = LT
+ best_item (ImpSome { is_explicit = e1 })
+ (ImpSome { is_explicit = e2 }) = e2 `compare` e1
+ -- False < True, so if e1 is explicit and e2 is not, we get LT
+
+unQualSpecOK :: ImportSpec -> Bool
+-- ^ Is in scope unqualified?
+unQualSpecOK is = not (is_qual (is_decl is))
+
+qualSpecOK :: ModuleName -> ImportSpec -> Bool
+-- ^ Is in scope qualified with the given module?
+qualSpecOK mod is = mod == is_as (is_decl is)
+
+importSpecLoc :: ImportSpec -> SrcSpan
+importSpecLoc (ImpSpec decl ImpAll) = is_dloc decl
+importSpecLoc (ImpSpec _ item) = is_iloc item
+
+importSpecModule :: ImportSpec -> ModuleName
+importSpecModule is = is_mod (is_decl is)
+
+isExplicitItem :: ImpItemSpec -> Bool
+isExplicitItem ImpAll = False
+isExplicitItem (ImpSome {is_explicit = exp}) = exp
+
+pprNameProvenance :: GlobalRdrElt -> SDoc
+-- ^ Print out one place where the name was define/imported
+-- (With -dppr-debug, print them all)
+pprNameProvenance (GRE { gre_name = name, gre_lcl = lcl, gre_imp = iss })
+ = sdocWithPprDebug $ \dbg -> if dbg
+ then vcat pp_provs
+ else head pp_provs
+ where
+ pp_provs = pp_lcl ++ map pp_is iss
+ pp_lcl = if lcl then [text "defined at" <+> ppr (nameSrcLoc name)]
+ else []
+ pp_is is = sep [ppr is, ppr_defn_site is name]
+
+-- If we know the exact definition point (which we may do with GHCi)
+-- then show that too. But not if it's just "imported from X".
+ppr_defn_site :: ImportSpec -> Name -> SDoc
+ppr_defn_site imp_spec name
+ | same_module && not (isGoodSrcSpan loc)
+ = empty -- Nothing interesting to say
+ | otherwise
+ = parens $ hang (text "and originally defined" <+> pp_mod)
+ 2 (pprLoc loc)
+ where
+ loc = nameSrcSpan name
+ defining_mod = ASSERT2( isExternalName name, ppr name ) nameModule name
+ same_module = importSpecModule imp_spec == moduleName defining_mod
+ pp_mod | same_module = empty
+ | otherwise = text "in" <+> quotes (ppr defining_mod)
+
+
+instance Outputable ImportSpec where
+ ppr imp_spec
+ = text "imported" <+> qual
+ <+> text "from" <+> quotes (ppr (importSpecModule imp_spec))
+ <+> pprLoc (importSpecLoc imp_spec)
+ where
+ qual | is_qual (is_decl imp_spec) = text "qualified"
+ | otherwise = empty
+
+pprLoc :: SrcSpan -> SDoc
+pprLoc (RealSrcSpan s) = text "at" <+> ppr s
+pprLoc (UnhelpfulSpan {}) = empty
diff --git a/basicTypes/SrcLoc.hs b/basicTypes/SrcLoc.hs
new file mode 100644
--- /dev/null
+++ b/basicTypes/SrcLoc.hs
@@ -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 "")
+generatedSrcLoc = UnhelpfulLoc (fsLit "")
+interactiveSrcLoc = UnhelpfulLoc (fsLit "")
+
+-- | Creates a "bad" 'SrcLoc' that has no detailed information about its location
+mkGeneralSrcLoc :: FastString -> SrcLoc
+mkGeneralSrcLoc = UnhelpfulLoc
+
+-- | Gives the filename of the 'RealSrcLoc'
+srcLocFile :: RealSrcLoc -> FastString
+srcLocFile (SrcLoc fname _ _) = fname
+
+-- | Raises an error when used on a "bad" 'SrcLoc'
+srcLocLine :: RealSrcLoc -> Int
+srcLocLine (SrcLoc _ l _) = l
+
+-- | Raises an error when used on a "bad" 'SrcLoc'
+srcLocCol :: RealSrcLoc -> Int
+srcLocCol (SrcLoc _ _ c) = c
+
+-- | Move the 'SrcLoc' down by one line if the character is a newline,
+-- to the next 8-char tabstop if it is a tab, and across by one
+-- character in any other case
+advanceSrcLoc :: RealSrcLoc -> Char -> RealSrcLoc
+advanceSrcLoc (SrcLoc f l _) '\n' = SrcLoc f (l + 1) 1
+advanceSrcLoc (SrcLoc f l c) '\t' = SrcLoc f l (((((c - 1) `shiftR` 3) + 1)
+ `shiftL` 3) + 1)
+advanceSrcLoc (SrcLoc f l c) _ = SrcLoc f l (c + 1)
+
+{-
+************************************************************************
+* *
+\subsection[SrcLoc-instances]{Instance declarations for various names}
+* *
+************************************************************************
+-}
+
+sortLocated :: [Located a] -> [Located a]
+sortLocated things = sortBy (comparing getLoc) things
+
+instance Outputable RealSrcLoc where
+ ppr (SrcLoc src_path src_line src_col)
+ = hcat [ pprFastFilePath src_path <> colon
+ , int src_line <> colon
+ , int src_col ]
+
+-- I don't know why there is this style-based difference
+-- if userStyle sty || debugStyle sty then
+-- hcat [ pprFastFilePath src_path, char ':',
+-- int src_line,
+-- char ':', int src_col
+-- ]
+-- else
+-- hcat [text "{-# LINE ", int src_line, space,
+-- char '\"', pprFastFilePath src_path, text " #-}"]
+
+instance Outputable SrcLoc where
+ ppr (RealSrcLoc l) = ppr l
+ ppr (UnhelpfulLoc s) = ftext s
+
+instance Data RealSrcSpan where
+ -- don't traverse?
+ toConstr _ = abstractConstr "RealSrcSpan"
+ gunfold _ _ = error "gunfold"
+ dataTypeOf _ = mkNoRepType "RealSrcSpan"
+
+instance Data SrcSpan where
+ -- don't traverse?
+ toConstr _ = abstractConstr "SrcSpan"
+ gunfold _ _ = error "gunfold"
+ dataTypeOf _ = mkNoRepType "SrcSpan"
+
+{-
+************************************************************************
+* *
+\subsection[SrcSpan]{Source Spans}
+* *
+************************************************************************
+-}
+
+{- |
+A 'RealSrcSpan' delimits a portion of a text file. It could be represented
+by a pair of (line,column) coordinates, but in fact we optimise
+slightly by using more compact representations for single-line and
+zero-length spans, both of which are quite common.
+
+The end position is defined to be the column /after/ the end of the
+span. That is, a span of (1,1)-(1,2) is one character long, and a
+span of (1,1)-(1,1) is zero characters long.
+-}
+
+-- | Real Source Span
+data RealSrcSpan
+ = RealSrcSpan'
+ { srcSpanFile :: !FastString,
+ srcSpanSLine :: {-# UNPACK #-} !Int,
+ srcSpanSCol :: {-# UNPACK #-} !Int,
+ srcSpanELine :: {-# UNPACK #-} !Int,
+ srcSpanECol :: {-# UNPACK #-} !Int
+ }
+ deriving Eq
+
+-- | Source Span
+--
+-- A 'SrcSpan' identifies either a specific portion of a text file
+-- or a human-readable description of a location.
+data SrcSpan =
+ RealSrcSpan !RealSrcSpan
+ | UnhelpfulSpan !FastString -- Just a general indication
+ -- also used to indicate an empty span
+
+ deriving (Eq, Ord, Show) -- Show is used by Lexer.x, because we
+ -- derive Show for Token
+
+instance ToJson SrcSpan where
+ json (UnhelpfulSpan {} ) = JSNull --JSObject [( "type", "unhelpful")]
+ json (RealSrcSpan rss) = json rss
+
+instance ToJson RealSrcSpan where
+ json (RealSrcSpan'{..}) = JSObject [ ("file", JSString (unpackFS srcSpanFile))
+ , ("startLine", JSInt srcSpanSLine)
+ , ("startCol", JSInt srcSpanSCol)
+ , ("endLine", JSInt srcSpanELine)
+ , ("endCol", JSInt srcSpanECol)
+ ]
+
+instance NFData SrcSpan where
+ rnf x = x `seq` ()
+
+-- | Built-in "bad" 'SrcSpan's for common sources of location uncertainty
+noSrcSpan, wiredInSrcSpan, interactiveSrcSpan :: SrcSpan
+noSrcSpan = UnhelpfulSpan (fsLit "")
+wiredInSrcSpan = UnhelpfulSpan (fsLit "")
+interactiveSrcSpan = UnhelpfulSpan (fsLit "")
+
+-- | Create a "bad" 'SrcSpan' that has not location information
+mkGeneralSrcSpan :: FastString -> SrcSpan
+mkGeneralSrcSpan = UnhelpfulSpan
+
+-- | Create a 'SrcSpan' corresponding to a single point
+srcLocSpan :: SrcLoc -> SrcSpan
+srcLocSpan (UnhelpfulLoc str) = UnhelpfulSpan str
+srcLocSpan (RealSrcLoc l) = RealSrcSpan (realSrcLocSpan l)
+
+realSrcLocSpan :: RealSrcLoc -> RealSrcSpan
+realSrcLocSpan (SrcLoc file line col) = RealSrcSpan' file line col line col
+
+-- | Create a 'SrcSpan' between two points in a file
+mkRealSrcSpan :: RealSrcLoc -> RealSrcLoc -> RealSrcSpan
+mkRealSrcSpan loc1 loc2 = RealSrcSpan' file line1 col1 line2 col2
+ where
+ line1 = srcLocLine loc1
+ line2 = srcLocLine loc2
+ col1 = srcLocCol loc1
+ col2 = srcLocCol loc2
+ file = srcLocFile loc1
+
+-- | 'True' if the span is known to straddle only one line.
+isOneLineRealSpan :: RealSrcSpan -> Bool
+isOneLineRealSpan (RealSrcSpan' _ line1 _ line2 _)
+ = line1 == line2
+
+-- | 'True' if the span is a single point
+isPointRealSpan :: RealSrcSpan -> Bool
+isPointRealSpan (RealSrcSpan' _ line1 col1 line2 col2)
+ = line1 == line2 && col1 == col2
+
+-- | Create a 'SrcSpan' between two points in a file
+mkSrcSpan :: SrcLoc -> SrcLoc -> SrcSpan
+mkSrcSpan (UnhelpfulLoc str) _ = UnhelpfulSpan str
+mkSrcSpan _ (UnhelpfulLoc str) = UnhelpfulSpan str
+mkSrcSpan (RealSrcLoc loc1) (RealSrcLoc loc2)
+ = RealSrcSpan (mkRealSrcSpan loc1 loc2)
+
+-- | Combines two 'SrcSpan' into one that spans at least all the characters
+-- within both spans. Assumes the "file" part is the same in both inputs
+combineSrcSpans :: SrcSpan -> SrcSpan -> SrcSpan
+combineSrcSpans (UnhelpfulSpan _) r = r -- this seems more useful
+combineSrcSpans l (UnhelpfulSpan _) = l
+combineSrcSpans (RealSrcSpan span1) (RealSrcSpan span2)
+ = RealSrcSpan (combineRealSrcSpans span1 span2)
+
+-- | Combines two 'SrcSpan' into one that spans at least all the characters
+-- within both spans. Assumes the "file" part is the same in both inputs
+combineRealSrcSpans :: RealSrcSpan -> RealSrcSpan -> RealSrcSpan
+combineRealSrcSpans span1 span2
+ = RealSrcSpan' file line_start col_start line_end col_end
+ where
+ (line_start, col_start) = min (srcSpanStartLine span1, srcSpanStartCol span1)
+ (srcSpanStartLine span2, srcSpanStartCol span2)
+ (line_end, col_end) = max (srcSpanEndLine span1, srcSpanEndCol span1)
+ (srcSpanEndLine span2, srcSpanEndCol span2)
+ file = srcSpanFile span1
+
+-- | Convert a SrcSpan into one that represents only its first character
+srcSpanFirstCharacter :: SrcSpan -> SrcSpan
+srcSpanFirstCharacter l@(UnhelpfulSpan {}) = l
+srcSpanFirstCharacter (RealSrcSpan span) = RealSrcSpan $ mkRealSrcSpan loc1 loc2
+ where
+ loc1@(SrcLoc f l c) = realSrcSpanStart span
+ loc2 = SrcLoc f l (c+1)
+{-
+************************************************************************
+* *
+\subsection[SrcSpan-predicates]{Predicates}
+* *
+************************************************************************
+-}
+
+-- | Test if a 'SrcSpan' is "good", i.e. has precise location information
+isGoodSrcSpan :: SrcSpan -> Bool
+isGoodSrcSpan (RealSrcSpan _) = True
+isGoodSrcSpan (UnhelpfulSpan _) = False
+
+isOneLineSpan :: SrcSpan -> Bool
+-- ^ True if the span is known to straddle only one line.
+-- For "bad" 'SrcSpan', it returns False
+isOneLineSpan (RealSrcSpan s) = srcSpanStartLine s == srcSpanEndLine s
+isOneLineSpan (UnhelpfulSpan _) = False
+
+-- | Tests whether the first span "contains" the other span, meaning
+-- that it covers at least as much source code. True where spans are equal.
+containsSpan :: RealSrcSpan -> RealSrcSpan -> Bool
+containsSpan s1 s2
+ = (srcSpanStartLine s1, srcSpanStartCol s1)
+ <= (srcSpanStartLine s2, srcSpanStartCol s2)
+ && (srcSpanEndLine s1, srcSpanEndCol s1)
+ >= (srcSpanEndLine s2, srcSpanEndCol s2)
+ && (srcSpanFile s1 == srcSpanFile s2)
+ -- We check file equality last because it is (presumably?) least
+ -- likely to fail.
+{-
+%************************************************************************
+%* *
+\subsection[SrcSpan-unsafe-access-fns]{Unsafe access functions}
+* *
+************************************************************************
+-}
+
+srcSpanStartLine :: RealSrcSpan -> Int
+srcSpanEndLine :: RealSrcSpan -> Int
+srcSpanStartCol :: RealSrcSpan -> Int
+srcSpanEndCol :: RealSrcSpan -> Int
+
+srcSpanStartLine RealSrcSpan'{ srcSpanSLine=l } = l
+srcSpanEndLine RealSrcSpan'{ srcSpanELine=l } = l
+srcSpanStartCol RealSrcSpan'{ srcSpanSCol=l } = l
+srcSpanEndCol RealSrcSpan'{ srcSpanECol=c } = c
+
+{-
+************************************************************************
+* *
+\subsection[SrcSpan-access-fns]{Access functions}
+* *
+************************************************************************
+-}
+
+-- | Returns the location at the start of the 'SrcSpan' or a "bad" 'SrcSpan' if that is unavailable
+srcSpanStart :: SrcSpan -> SrcLoc
+srcSpanStart (UnhelpfulSpan str) = UnhelpfulLoc str
+srcSpanStart (RealSrcSpan s) = RealSrcLoc (realSrcSpanStart s)
+
+-- | Returns the location at the end of the 'SrcSpan' or a "bad" 'SrcSpan' if that is unavailable
+srcSpanEnd :: SrcSpan -> SrcLoc
+srcSpanEnd (UnhelpfulSpan str) = UnhelpfulLoc str
+srcSpanEnd (RealSrcSpan s) = RealSrcLoc (realSrcSpanEnd s)
+
+realSrcSpanStart :: RealSrcSpan -> RealSrcLoc
+realSrcSpanStart s = mkRealSrcLoc (srcSpanFile s)
+ (srcSpanStartLine s)
+ (srcSpanStartCol s)
+
+realSrcSpanEnd :: RealSrcSpan -> RealSrcLoc
+realSrcSpanEnd s = mkRealSrcLoc (srcSpanFile s)
+ (srcSpanEndLine s)
+ (srcSpanEndCol s)
+
+-- | Obtains the filename for a 'SrcSpan' if it is "good"
+srcSpanFileName_maybe :: SrcSpan -> Maybe FastString
+srcSpanFileName_maybe (RealSrcSpan s) = Just (srcSpanFile s)
+srcSpanFileName_maybe (UnhelpfulSpan _) = Nothing
+
+{-
+************************************************************************
+* *
+\subsection[SrcSpan-instances]{Instances}
+* *
+************************************************************************
+-}
+
+-- We want to order RealSrcSpans first by the start point, then by the
+-- end point.
+instance Ord RealSrcSpan where
+ a `compare` b =
+ (realSrcSpanStart a `compare` realSrcSpanStart b) `thenCmp`
+ (realSrcSpanEnd a `compare` realSrcSpanEnd b)
+
+instance Show RealSrcLoc where
+ show (SrcLoc filename row col)
+ = "SrcLoc " ++ show filename ++ " " ++ show row ++ " " ++ show col
+
+-- Show is used by Lexer.x, because we derive Show for Token
+instance Show RealSrcSpan where
+ show span@(RealSrcSpan' file sl sc el ec)
+ | isPointRealSpan span
+ = "SrcSpanPoint " ++ show file ++ " " ++ intercalate " " (map show [sl,sc])
+
+ | isOneLineRealSpan span
+ = "SrcSpanOneLine " ++ show file ++ " "
+ ++ intercalate " " (map show [sl,sc,ec])
+
+ | otherwise
+ = "SrcSpanMultiLine " ++ show file ++ " "
+ ++ intercalate " " (map show [sl,sc,el,ec])
+
+
+instance Outputable RealSrcSpan where
+ ppr span = pprUserRealSpan True span
+
+-- I don't know why there is this style-based difference
+-- = getPprStyle $ \ sty ->
+-- if userStyle sty || debugStyle sty then
+-- text (showUserRealSpan True span)
+-- else
+-- hcat [text "{-# LINE ", int (srcSpanStartLine span), space,
+-- char '\"', pprFastFilePath $ srcSpanFile span, text " #-}"]
+
+instance Outputable SrcSpan where
+ ppr span = pprUserSpan True span
+
+-- I don't know why there is this style-based difference
+-- = getPprStyle $ \ sty ->
+-- if userStyle sty || debugStyle sty then
+-- pprUserSpan True span
+-- else
+-- case span of
+-- UnhelpfulSpan _ -> panic "Outputable UnhelpfulSpan"
+-- RealSrcSpan s -> ppr s
+
+pprUserSpan :: Bool -> SrcSpan -> SDoc
+pprUserSpan _ (UnhelpfulSpan s) = ftext s
+pprUserSpan show_path (RealSrcSpan s) = pprUserRealSpan show_path s
+
+pprUserRealSpan :: Bool -> RealSrcSpan -> SDoc
+pprUserRealSpan show_path span@(RealSrcSpan' src_path line col _ _)
+ | isPointRealSpan span
+ = hcat [ ppWhen show_path (pprFastFilePath src_path <> colon)
+ , int line <> colon
+ , int col ]
+
+pprUserRealSpan show_path span@(RealSrcSpan' src_path line scol _ ecol)
+ | isOneLineRealSpan span
+ = hcat [ ppWhen show_path (pprFastFilePath src_path <> colon)
+ , int line <> colon
+ , int scol
+ , ppUnless (ecol - scol <= 1) (char '-' <> int (ecol - 1)) ]
+ -- For single-character or point spans, we just
+ -- output the starting column number
+
+pprUserRealSpan show_path (RealSrcSpan' src_path sline scol eline ecol)
+ = hcat [ ppWhen show_path (pprFastFilePath src_path <> colon)
+ , parens (int sline <> comma <> int scol)
+ , char '-'
+ , parens (int eline <> comma <> int ecol') ]
+ where
+ ecol' = if ecol == 0 then ecol else ecol - 1
+
+{-
+************************************************************************
+* *
+\subsection[Located]{Attaching SrcSpans to things}
+* *
+************************************************************************
+-}
+
+-- | We attach SrcSpans to lots of things, so let's have a datatype for it.
+data GenLocated l e = L l e
+ deriving (Eq, Ord, Data, Functor, Foldable, Traversable)
+
+type Located e = GenLocated SrcSpan e
+type RealLocated e = GenLocated RealSrcSpan e
+
+unLoc :: GenLocated l e -> e
+unLoc (L _ e) = e
+
+getLoc :: GenLocated l e -> l
+getLoc (L l _) = l
+
+noLoc :: e -> Located e
+noLoc e = L noSrcSpan e
+
+mkGeneralLocated :: String -> e -> Located e
+mkGeneralLocated s e = L (mkGeneralSrcSpan (fsLit s)) e
+
+combineLocs :: Located a -> Located b -> SrcSpan
+combineLocs a b = combineSrcSpans (getLoc a) (getLoc b)
+
+-- | Combine locations from two 'Located' things and add them to a third thing
+addCLoc :: Located a -> Located b -> c -> Located c
+addCLoc a b c = L (combineSrcSpans (getLoc a) (getLoc b)) c
+
+-- not clear whether to add a general Eq instance, but this is useful sometimes:
+
+-- | Tests whether the two located things are equal
+eqLocated :: Eq a => Located a -> Located a -> Bool
+eqLocated a b = unLoc a == unLoc b
+
+-- not clear whether to add a general Ord instance, but this is useful sometimes:
+
+-- | Tests the ordering of the two located things
+cmpLocated :: Ord a => Located a -> Located a -> Ordering
+cmpLocated a b = unLoc a `compare` unLoc b
+
+instance (Outputable l, Outputable e) => Outputable (GenLocated l e) where
+ ppr (L l e) = -- TODO: We can't do this since Located was refactored into
+ -- GenLocated:
+ -- Print spans without the file name etc
+ -- ifPprDebug (braces (pprUserSpan False l))
+ ifPprDebug (braces (ppr l))
+ $$ ppr e
+
+{-
+************************************************************************
+* *
+\subsection{Ordering SrcSpans for InteractiveUI}
+* *
+************************************************************************
+-}
+
+-- | Alternative strategies for ordering 'SrcSpan's
+leftmost_smallest, leftmost_largest, rightmost :: SrcSpan -> SrcSpan -> Ordering
+rightmost = flip compare
+leftmost_smallest = compare
+leftmost_largest a b = (srcSpanStart a `compare` srcSpanStart b)
+ `thenCmp`
+ (srcSpanEnd b `compare` srcSpanEnd a)
+
+-- | Determines whether a span encloses a given line and column index
+spans :: SrcSpan -> (Int, Int) -> Bool
+spans (UnhelpfulSpan _) _ = panic "spans UnhelpfulSpan"
+spans (RealSrcSpan span) (l,c) = realSrcSpanStart span <= loc && loc <= realSrcSpanEnd span
+ where loc = mkRealSrcLoc (srcSpanFile span) l c
+
+-- | Determines whether a span is enclosed by another one
+isSubspanOf :: SrcSpan -- ^ The span that may be enclosed by the other
+ -> SrcSpan -- ^ The span it may be enclosed by
+ -> Bool
+isSubspanOf src parent
+ | srcSpanFileName_maybe parent /= srcSpanFileName_maybe src = False
+ | otherwise = srcSpanStart parent <= srcSpanStart src &&
+ srcSpanEnd parent >= srcSpanEnd src
diff --git a/basicTypes/UniqSupply.hs b/basicTypes/UniqSupply.hs
new file mode 100644
--- /dev/null
+++ b/basicTypes/UniqSupply.hs
@@ -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)
diff --git a/basicTypes/Unique.hs b/basicTypes/Unique.hs
new file mode 100644
--- /dev/null
+++ b/basicTypes/Unique.hs
@@ -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)
diff --git a/basicTypes/Var.hs b/basicTypes/Var.hs
new file mode 100644
--- /dev/null
+++ b/basicTypes/Var.hs
@@ -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
diff --git a/basicTypes/VarEnv.hs b/basicTypes/VarEnv.hs
new file mode 100644
--- /dev/null
+++ b/basicTypes/VarEnv.hs
@@ -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
diff --git a/basicTypes/VarSet.hs b/basicTypes/VarSet.hs
new file mode 100644
--- /dev/null
+++ b/basicTypes/VarSet.hs
@@ -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
diff --git a/cbits/genSym.c b/cbits/genSym.c
new file mode 100644
--- /dev/null
+++ b/cbits/genSym.c
@@ -0,0 +1,40 @@
+#include
+#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;
+}
diff --git a/cmm/Bitmap.hs b/cmm/Bitmap.hs
new file mode 100644
--- /dev/null
+++ b/cmm/Bitmap.hs
@@ -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
+
diff --git a/cmm/BlockId.hs b/cmm/BlockId.hs
new file mode 100644
--- /dev/null
+++ b/cmm/BlockId.hs
@@ -0,0 +1,51 @@
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+{- BlockId module should probably go away completely, being superseded by Label -}
+module BlockId
+ ( BlockId, mkBlockId -- ToDo: BlockId should be abstract, but it isn't yet
+ , newBlockId
+ , blockLbl, infoTblLbl
+ ) where
+
+import CLabel
+import IdInfo
+import Name
+import Outputable
+import Unique
+import UniqSupply
+
+import Compiler.Hoopl as Hoopl hiding (Unique)
+import Compiler.Hoopl.Internals (uniqueToLbl, lblToUnique)
+
+----------------------------------------------------------------
+--- Block Ids, their environments, and their sets
+
+{- Note [Unique BlockId]
+~~~~~~~~~~~~~~~~~~~~~~~~
+Although a 'BlockId' is a local label, for reasons of implementation,
+'BlockId's must be unique within an entire compilation unit. The reason
+is that each local label is mapped to an assembly-language label, and in
+most assembly languages allow, a label is visible throughout the entire
+compilation unit in which it appears.
+-}
+
+type BlockId = Hoopl.Label
+
+instance Uniquable BlockId where
+ getUnique label = getUnique (lblToUnique label)
+
+instance Outputable BlockId where
+ ppr label = ppr (getUnique label)
+
+mkBlockId :: Unique -> BlockId
+mkBlockId unique = uniqueToLbl $ intToUnique $ getKey unique
+
+newBlockId :: MonadUnique m => m BlockId
+newBlockId = mkBlockId <$> getUniqueM
+
+blockLbl :: BlockId -> CLabel
+blockLbl label = mkEntryLabel (mkFCallName (getUnique label) "block") NoCafRefs
+
+infoTblLbl :: BlockId -> CLabel
+infoTblLbl label = mkInfoTableLabel (mkFCallName (getUnique label) "block") NoCafRefs
diff --git a/cmm/CLabel.hs b/cmm/CLabel.hs
new file mode 100644
--- /dev/null
+++ b/cmm/CLabel.hs
@@ -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:
+
+ _
+
+where is _ for external names and for
+internal names. is one of the following:
+
+ info Info table
+ srt Static reference table
+ srtd Static reference table descriptor
+ entry Entry code (function, closure)
+ slow Slow entry code (if any)
+ ret Direct return address
+ vtbl Vector table
+ _alt Case alternative (tag n)
+ dflt Default case alternative
+ btm Large bitmap vector
+ closure Static closure
+ con_entry Dynamic Constructor entry code
+ con_info Dynamic Constructor info table
+ static_entry Static Constructor entry code
+ static_info Static Constructor info table
+ sel_info Selector info table
+ sel_entry Selector entry code
+ cc Cost centre
+ ccs Cost centre stack
+
+Many of these distinctions are only for documentation reasons. For
+example, _ret is only distinguished from _entry to make it easy to
+tell whether a code fragment is a return point or a closure/function
+entry.
+
+Note [Closure and info labels]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For a function 'foo, we have:
+ foo_info : Points to the info table describing foo's closure
+ (and entry code for foo with tables next to code)
+ foo_closure : Static (no-free-var) closure only:
+ points to the statically-allocated closure
+
+For a data constructor (such as Just or Nothing), we have:
+ Just_con_info: Info table for the data constructor itself
+ the first word of a heap-allocated Just
+ Just_info: Info table for the *worker function*, an
+ ordinary Haskell function of arity 1 that
+ allocates a (Just x) box:
+ Just = \x -> Just x
+ Just_closure: The closure for this worker
+
+ Nothing_closure: a statically allocated closure for Nothing
+ Nothing_static_info: info table for Nothing_closure
+
+All these must be exported symbol, EXCEPT Just_info. We don't need to
+export this because in other modules we either have
+ * A reference to 'Just'; use Just_closure
+ * A saturated call 'Just x'; allocate using Just_con_info
+Not exporting these Just_info labels reduces the number of symbols
+somewhat.
+
+Note [Bytes label]
+~~~~~~~~~~~~~~~~~~
+For a top-level string literal 'foo', we have just one symbol 'foo_bytes', which
+points to a static data block containing the content of the literal.
+-}
+
+instance Outputable CLabel where
+ ppr c = sdocWithPlatform $ \platform -> pprCLabel platform c
+
+pprCLabel :: Platform -> CLabel -> SDoc
+
+pprCLabel platform (AsmTempLabel u)
+ | cGhcWithNativeCodeGen == "YES"
+ = getPprStyle $ \ sty ->
+ if asmStyle sty then
+ ptext (asmTempLabelPrefix platform) <> pprUniqueAlways u
+ else
+ char '_' <> pprUniqueAlways u
+
+pprCLabel platform (AsmTempDerivedLabel l suf)
+ | cGhcWithNativeCodeGen == "YES"
+ = ptext (asmTempLabelPrefix platform)
+ <> case l of AsmTempLabel u -> pprUniqueAlways u
+ _other -> pprCLabel platform l
+ <> ftext suf
+
+pprCLabel platform (DynamicLinkerLabel info lbl)
+ | cGhcWithNativeCodeGen == "YES"
+ = pprDynamicLinkerAsmLabel platform info lbl
+
+pprCLabel _ PicBaseLabel
+ | cGhcWithNativeCodeGen == "YES"
+ = text "1b"
+
+pprCLabel platform (DeadStripPreventer lbl)
+ | cGhcWithNativeCodeGen == "YES"
+ = pprCLabel platform lbl <> text "_dsp"
+
+pprCLabel _ (StringLitLabel u)
+ | cGhcWithNativeCodeGen == "YES"
+ = pprUniqueAlways u <> ptext (sLit "_str")
+
+pprCLabel platform lbl
+ = getPprStyle $ \ sty ->
+ if cGhcWithNativeCodeGen == "YES" && asmStyle sty
+ then maybe_underscore (pprAsmCLbl platform lbl)
+ else pprCLbl lbl
+
+maybe_underscore :: SDoc -> SDoc
+maybe_underscore doc
+ | underscorePrefix = pp_cSEP <> doc
+ | otherwise = doc
+
+pprAsmCLbl :: Platform -> CLabel -> SDoc
+pprAsmCLbl platform (ForeignLabel fs (Just sz) _ _)
+ | platformOS platform == OSMinGW32
+ -- In asm mode, we need to put the suffix on a stdcall ForeignLabel.
+ -- (The C compiler does this itself).
+ = ftext fs <> char '@' <> int sz
+pprAsmCLbl _ lbl
+ = pprCLbl lbl
+
+pprCLbl :: CLabel -> SDoc
+pprCLbl (StringLitLabel u)
+ = pprUniqueAlways u <> text "_str"
+
+pprCLbl (CaseLabel u CaseReturnPt)
+ = hcat [pprUniqueAlways u, text "_ret"]
+pprCLbl (CaseLabel u CaseReturnInfo)
+ = hcat [pprUniqueAlways u, text "_info"]
+pprCLbl (CaseLabel u (CaseAlt tag))
+ = hcat [pprUniqueAlways u, pp_cSEP, int tag, text "_alt"]
+pprCLbl (CaseLabel u CaseDefault)
+ = hcat [pprUniqueAlways u, text "_dflt"]
+
+pprCLbl (SRTLabel u)
+ = pprUniqueAlways u <> pp_cSEP <> text "srt"
+
+pprCLbl (LargeSRTLabel u) = pprUniqueAlways u <> pp_cSEP <> text "srtd"
+pprCLbl (LargeBitmapLabel u) = text "b" <> pprUniqueAlways u <> pp_cSEP <> text "btm"
+-- Some bitsmaps for tuple constructors have a numeric tag (e.g. '7')
+-- until that gets resolved we'll just force them to start
+-- with a letter so the label will be legal assmbly code.
+
+
+pprCLbl (CmmLabel _ str CmmCode) = ftext str
+pprCLbl (CmmLabel _ str CmmData) = ftext str
+pprCLbl (CmmLabel _ str CmmPrimCall) = ftext str
+
+pprCLbl (RtsLabel (RtsApFast str)) = ftext str <> text "_fast"
+
+pprCLbl (RtsLabel (RtsSelectorInfoTable upd_reqd offset))
+ = sdocWithDynFlags $ \dflags ->
+ ASSERT(offset >= 0 && offset <= mAX_SPEC_SELECTEE_SIZE dflags)
+ hcat [text "stg_sel_", text (show offset),
+ ptext (if upd_reqd
+ then (sLit "_upd_info")
+ else (sLit "_noupd_info"))
+ ]
+
+pprCLbl (RtsLabel (RtsSelectorEntry upd_reqd offset))
+ = sdocWithDynFlags $ \dflags ->
+ ASSERT(offset >= 0 && offset <= mAX_SPEC_SELECTEE_SIZE dflags)
+ hcat [text "stg_sel_", text (show offset),
+ ptext (if upd_reqd
+ then (sLit "_upd_entry")
+ else (sLit "_noupd_entry"))
+ ]
+
+pprCLbl (RtsLabel (RtsApInfoTable upd_reqd arity))
+ = sdocWithDynFlags $ \dflags ->
+ ASSERT(arity > 0 && arity <= mAX_SPEC_AP_SIZE dflags)
+ hcat [text "stg_ap_", text (show arity),
+ ptext (if upd_reqd
+ then (sLit "_upd_info")
+ else (sLit "_noupd_info"))
+ ]
+
+pprCLbl (RtsLabel (RtsApEntry upd_reqd arity))
+ = sdocWithDynFlags $ \dflags ->
+ ASSERT(arity > 0 && arity <= mAX_SPEC_AP_SIZE dflags)
+ hcat [text "stg_ap_", text (show arity),
+ ptext (if upd_reqd
+ then (sLit "_upd_entry")
+ else (sLit "_noupd_entry"))
+ ]
+
+pprCLbl (CmmLabel _ fs CmmInfo)
+ = ftext fs <> text "_info"
+
+pprCLbl (CmmLabel _ fs CmmEntry)
+ = ftext fs <> text "_entry"
+
+pprCLbl (CmmLabel _ fs CmmRetInfo)
+ = ftext fs <> text "_info"
+
+pprCLbl (CmmLabel _ fs CmmRet)
+ = ftext fs <> text "_ret"
+
+pprCLbl (CmmLabel _ fs CmmClosure)
+ = ftext fs <> text "_closure"
+
+pprCLbl (RtsLabel (RtsPrimOp primop))
+ = text "stg_" <> ppr primop
+
+pprCLbl (RtsLabel (RtsSlowFastTickyCtr pat))
+ = text "SLOW_CALL_fast_" <> text pat <> ptext (sLit "_ctr")
+
+pprCLbl (ForeignLabel str _ _ _)
+ = ftext str
+
+pprCLbl (IdLabel name _cafs flavor) = ppr name <> ppIdFlavor flavor
+
+pprCLbl (CC_Label cc) = ppr cc
+pprCLbl (CCS_Label ccs) = ppr ccs
+
+pprCLbl (PlainModuleInitLabel mod)
+ = text "__stginit_" <> ppr mod
+
+pprCLbl (HpcTicksLabel mod)
+ = text "_hpc_tickboxes_" <> ppr mod <> ptext (sLit "_hpc")
+
+pprCLbl (AsmTempLabel {}) = panic "pprCLbl AsmTempLabel"
+pprCLbl (AsmTempDerivedLabel {})= panic "pprCLbl AsmTempDerivedLabel"
+pprCLbl (DynamicLinkerLabel {}) = panic "pprCLbl DynamicLinkerLabel"
+pprCLbl (PicBaseLabel {}) = panic "pprCLbl PicBaseLabel"
+pprCLbl (DeadStripPreventer {}) = panic "pprCLbl DeadStripPreventer"
+
+ppIdFlavor :: IdLabelInfo -> SDoc
+ppIdFlavor x = pp_cSEP <>
+ (case x of
+ Closure -> text "closure"
+ SRT -> text "srt"
+ InfoTable -> text "info"
+ LocalInfoTable -> text "info"
+ Entry -> text "entry"
+ LocalEntry -> text "entry"
+ Slow -> text "slow"
+ RednCounts -> text "ct"
+ ConEntry -> text "con_entry"
+ ConInfoTable -> text "con_info"
+ ClosureTable -> text "closure_tbl"
+ Bytes -> text "bytes"
+ )
+
+
+pp_cSEP :: SDoc
+pp_cSEP = char '_'
+
+
+instance Outputable ForeignLabelSource where
+ ppr fs
+ = case fs of
+ ForeignLabelInPackage pkgId -> parens $ text "package: " <> ppr pkgId
+ ForeignLabelInThisPackage -> parens $ text "this package"
+ ForeignLabelInExternalPackage -> parens $ text "external package"
+
+-- -----------------------------------------------------------------------------
+-- Machine-dependent knowledge about labels.
+
+underscorePrefix :: Bool -- leading underscore on assembler labels?
+underscorePrefix = (cLeadingUnderscore == "YES")
+
+asmTempLabelPrefix :: Platform -> LitString -- for formatting labels
+asmTempLabelPrefix platform = case platformOS platform of
+ OSDarwin -> sLit "L"
+ OSAIX -> sLit "__L" -- follow IBM XL C's convention
+ _ -> sLit ".L"
+
+pprDynamicLinkerAsmLabel :: Platform -> DynamicLinkerLabelInfo -> CLabel -> SDoc
+pprDynamicLinkerAsmLabel platform dllInfo lbl
+ = if platformOS platform == OSDarwin
+ then if platformArch platform == ArchX86_64
+ then case dllInfo of
+ CodeStub -> char 'L' <> ppr lbl <> text "$stub"
+ SymbolPtr -> char 'L' <> ppr lbl <> text "$non_lazy_ptr"
+ GotSymbolPtr -> ppr lbl <> text "@GOTPCREL"
+ GotSymbolOffset -> ppr lbl
+ else case dllInfo of
+ CodeStub -> char 'L' <> ppr lbl <> text "$stub"
+ SymbolPtr -> char 'L' <> ppr lbl <> text "$non_lazy_ptr"
+ _ -> panic "pprDynamicLinkerAsmLabel"
+
+ else if platformOS platform == OSAIX
+ then case dllInfo of
+ SymbolPtr -> text "LC.." <> ppr lbl -- GCC's naming convention
+ _ -> panic "pprDynamicLinkerAsmLabel"
+
+ else if osElfTarget (platformOS platform)
+ then if platformArch platform == ArchPPC
+ then case dllInfo of
+ CodeStub -> -- See Note [.LCTOC1 in PPC PIC code]
+ ppr lbl <> text "+32768@plt"
+ SymbolPtr -> text ".LC_" <> ppr lbl
+ _ -> panic "pprDynamicLinkerAsmLabel"
+ else if platformArch platform == ArchX86_64
+ then case dllInfo of
+ CodeStub -> ppr lbl <> text "@plt"
+ GotSymbolPtr -> ppr lbl <> text "@gotpcrel"
+ GotSymbolOffset -> ppr lbl
+ SymbolPtr -> text ".LC_" <> ppr lbl
+ else if platformArch platform == ArchPPC_64 ELF_V1
+ || platformArch platform == ArchPPC_64 ELF_V2
+ then case dllInfo of
+ GotSymbolPtr -> text ".LC_" <> ppr lbl
+ <> text "@toc"
+ GotSymbolOffset -> ppr lbl
+ SymbolPtr -> text ".LC_" <> ppr lbl
+ _ -> panic "pprDynamicLinkerAsmLabel"
+ else case dllInfo of
+ CodeStub -> ppr lbl <> text "@plt"
+ SymbolPtr -> text ".LC_" <> ppr lbl
+ GotSymbolPtr -> ppr lbl <> text "@got"
+ GotSymbolOffset -> ppr lbl <> text "@gotoff"
+ else if platformOS platform == OSMinGW32
+ then case dllInfo of
+ SymbolPtr -> text "__imp_" <> ppr lbl
+ _ -> panic "pprDynamicLinkerAsmLabel"
+ else panic "pprDynamicLinkerAsmLabel"
+
diff --git a/cmm/Cmm.hs b/cmm/Cmm.hs
new file mode 100644
--- /dev/null
+++ b/cmm/Cmm.hs
@@ -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))
+
diff --git a/cmm/CmmBuildInfoTables.hs b/cmm/CmmBuildInfoTables.hs
new file mode 100644
--- /dev/null
+++ b/cmm/CmmBuildInfoTables.hs
@@ -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
diff --git a/cmm/CmmCallConv.hs b/cmm/CmmCallConv.hs
new file mode 100644
--- /dev/null
+++ b/cmm/CmmCallConv.hs
@@ -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)
diff --git a/cmm/CmmCommonBlockElim.hs b/cmm/CmmCommonBlockElim.hs
new file mode 100644
--- /dev/null
+++ b/cmm/CmmCommonBlockElim.hs
@@ -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)
diff --git a/cmm/CmmContFlowOpt.hs b/cmm/CmmContFlowOpt.hs
new file mode 100644
--- /dev/null
+++ b/cmm/CmmContFlowOpt.hs
@@ -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
diff --git a/cmm/CmmExpr.hs b/cmm/CmmExpr.hs
new file mode 100644
--- /dev/null
+++ b/cmm/CmmExpr.hs
@@ -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
diff --git a/cmm/CmmImplementSwitchPlans.hs b/cmm/CmmImplementSwitchPlans.hs
new file mode 100644
--- /dev/null
+++ b/cmm/CmmImplementSwitchPlans.hs
@@ -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)
diff --git a/cmm/CmmInfo.hs b/cmm/CmmInfo.hs
new file mode 100644
--- /dev/null
+++ b/cmm/CmmInfo.hs
@@ -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
+--
+--
+--
+--
+-- Without tablesNextToCode, the layout of an info table is
+--
+--
+--
+--
+-- See includes/rts/storage/InfoTables.h
+--
+-- For return-points these are as follows
+--
+-- Tables next to code:
+--
+--
+--
+-- ret-addr -->
+--
+-- Not tables-next-to-code:
+--
+-- ret-addr -->
+--
+--
+--
+-- * The SRT slot is only there if there is SRT info to record
+
+mkInfoTable :: DynFlags -> CmmDecl -> UniqSM [RawCmmDecl]
+mkInfoTable _ (CmmData sec dat)
+ = return [CmmData sec dat]
+
+mkInfoTable dflags proc@(CmmProc infos entry_lbl live blocks)
+ --
+ -- in the non-tables-next-to-code case, procs can have at most a
+ -- single info table associated with the entry label of the proc.
+ --
+ | not (tablesNextToCode dflags)
+ = case topInfoTable proc of -- must be at most one
+ -- no info table
+ Nothing ->
+ return [CmmProc mapEmpty entry_lbl live blocks]
+
+ Just info@CmmInfoTable { cit_lbl = info_lbl } -> do
+ (top_decls, (std_info, extra_bits)) <-
+ mkInfoTableContents dflags info Nothing
+ let
+ rel_std_info = map (makeRelativeRefTo dflags info_lbl) std_info
+ rel_extra_bits = map (makeRelativeRefTo dflags info_lbl) extra_bits
+ --
+ -- Separately emit info table (with the function entry
+ -- point as first entry) and the entry code
+ --
+ return (top_decls ++
+ [CmmProc mapEmpty entry_lbl live blocks,
+ mkDataLits (Section Data info_lbl) info_lbl
+ (CmmLabel entry_lbl : rel_std_info ++ rel_extra_bits)])
+
+ --
+ -- With tables-next-to-code, we can have many info tables,
+ -- associated with some of the BlockIds of the proc. For each info
+ -- table we need to turn it into CmmStatics, and collect any new
+ -- CmmDecls that arise from doing so.
+ --
+ | otherwise
+ = do
+ (top_declss, raw_infos) <-
+ unzip `fmap` mapM do_one_info (mapToList (info_tbls infos))
+ return (concat top_declss ++
+ [CmmProc (mapFromList raw_infos) entry_lbl live blocks])
+
+ where
+ do_one_info (lbl,itbl) = do
+ (top_decls, (std_info, extra_bits)) <-
+ mkInfoTableContents dflags itbl Nothing
+ let
+ info_lbl = cit_lbl itbl
+ rel_std_info = map (makeRelativeRefTo dflags info_lbl) std_info
+ rel_extra_bits = map (makeRelativeRefTo dflags info_lbl) extra_bits
+ --
+ return (top_decls, (lbl, Statics info_lbl $ map CmmStaticLit $
+ reverse rel_extra_bits ++ rel_std_info))
+
+-----------------------------------------------------
+type InfoTableContents = ( [CmmLit] -- The standard part
+ , [CmmLit] ) -- The "extra bits"
+-- These Lits have *not* had mkRelativeTo applied to them
+
+mkInfoTableContents :: DynFlags
+ -> CmmInfoTable
+ -> Maybe Int -- Override default RTS type tag?
+ -> UniqSM ([RawCmmDecl], -- Auxiliary top decls
+ InfoTableContents) -- Info tbl + extra bits
+
+mkInfoTableContents dflags
+ info@(CmmInfoTable { cit_lbl = info_lbl
+ , cit_rep = smrep
+ , cit_prof = prof
+ , cit_srt = srt })
+ mb_rts_tag
+ | RTSRep rts_tag rep <- smrep
+ = mkInfoTableContents dflags info{cit_rep = rep} (Just rts_tag)
+ -- Completely override the rts_tag that mkInfoTableContents would
+ -- otherwise compute, with the rts_tag stored in the RTSRep
+ -- (which in turn came from a handwritten .cmm file)
+
+ | StackRep frame <- smrep
+ = do { (prof_lits, prof_data) <- mkProfLits dflags prof
+ ; let (srt_label, srt_bitmap) = mkSRTLit dflags srt
+ ; (liveness_lit, liveness_data) <- mkLivenessBits dflags frame
+ ; let
+ std_info = mkStdInfoTable dflags prof_lits rts_tag srt_bitmap liveness_lit
+ rts_tag | Just tag <- mb_rts_tag = tag
+ | null liveness_data = rET_SMALL -- Fits in extra_bits
+ | otherwise = rET_BIG -- Does not; extra_bits is
+ -- a label
+ ; return (prof_data ++ liveness_data, (std_info, srt_label)) }
+
+ | HeapRep _ ptrs nonptrs closure_type <- smrep
+ = do { let layout = packIntsCLit dflags ptrs nonptrs
+ ; (prof_lits, prof_data) <- mkProfLits dflags prof
+ ; let (srt_label, srt_bitmap) = mkSRTLit dflags srt
+ ; (mb_srt_field, mb_layout, extra_bits, ct_data)
+ <- mk_pieces closure_type srt_label
+ ; let std_info = mkStdInfoTable dflags prof_lits
+ (mb_rts_tag `orElse` rtsClosureType smrep)
+ (mb_srt_field `orElse` srt_bitmap)
+ (mb_layout `orElse` layout)
+ ; return (prof_data ++ ct_data, (std_info, extra_bits)) }
+ where
+ mk_pieces :: ClosureTypeInfo -> [CmmLit]
+ -> UniqSM ( Maybe StgHalfWord -- Override the SRT field with this
+ , Maybe CmmLit -- Override the layout field with this
+ , [CmmLit] -- "Extra bits" for info table
+ , [RawCmmDecl]) -- Auxiliary data decls
+ mk_pieces (Constr con_tag con_descr) _no_srt -- A data constructor
+ = do { (descr_lit, decl) <- newStringLit con_descr
+ ; return ( Just (toStgHalfWord dflags (fromIntegral con_tag))
+ , Nothing, [descr_lit], [decl]) }
+
+ mk_pieces Thunk srt_label
+ = return (Nothing, Nothing, srt_label, [])
+
+ mk_pieces (ThunkSelector offset) _no_srt
+ = return (Just (toStgHalfWord dflags 0), Just (mkWordCLit dflags (fromIntegral offset)), [], [])
+ -- Layout known (one free var); we use the layout field for offset
+
+ mk_pieces (Fun arity (ArgSpec fun_type)) srt_label
+ = do { let extra_bits = packIntsCLit dflags fun_type arity : srt_label
+ ; return (Nothing, Nothing, extra_bits, []) }
+
+ mk_pieces (Fun arity (ArgGen arg_bits)) srt_label
+ = do { (liveness_lit, liveness_data) <- mkLivenessBits dflags arg_bits
+ ; let fun_type | null liveness_data = aRG_GEN
+ | otherwise = aRG_GEN_BIG
+ extra_bits = [ packIntsCLit dflags fun_type arity
+ , srt_lit, liveness_lit, slow_entry ]
+ ; return (Nothing, Nothing, extra_bits, liveness_data) }
+ where
+ slow_entry = CmmLabel (toSlowEntryLbl info_lbl)
+ srt_lit = case srt_label of
+ [] -> mkIntCLit dflags 0
+ (lit:_rest) -> ASSERT( null _rest ) lit
+
+ mk_pieces other _ = pprPanic "mk_pieces" (ppr other)
+
+mkInfoTableContents _ _ _ = panic "mkInfoTableContents" -- NonInfoTable dealt with earlier
+
+packIntsCLit :: DynFlags -> Int -> Int -> CmmLit
+packIntsCLit dflags a b = packHalfWordsCLit dflags
+ (toStgHalfWord dflags (fromIntegral a))
+ (toStgHalfWord dflags (fromIntegral b))
+
+
+mkSRTLit :: DynFlags
+ -> C_SRT
+ -> ([CmmLit], -- srt_label, if any
+ StgHalfWord) -- srt_bitmap
+mkSRTLit dflags NoC_SRT = ([], toStgHalfWord dflags 0)
+mkSRTLit dflags (C_SRT lbl off bitmap) = ([cmmLabelOffW dflags lbl off], bitmap)
+
+
+-------------------------------------------------------------------------
+--
+-- Lay out the info table and handle relative offsets
+--
+-------------------------------------------------------------------------
+
+-- This function takes
+-- * the standard info table portion (StgInfoTable)
+-- * the "extra bits" (StgFunInfoExtraRev etc.)
+-- * the entry label
+-- * the code
+-- and lays them out in memory, producing a list of RawCmmDecl
+
+-------------------------------------------------------------------------
+--
+-- Position independent code
+--
+-------------------------------------------------------------------------
+-- In order to support position independent code, we mustn't put absolute
+-- references into read-only space. Info tables in the tablesNextToCode
+-- case must be in .text, which is read-only, so we doctor the CmmLits
+-- to use relative offsets instead.
+
+-- Note that this is done even when the -fPIC flag is not specified,
+-- as we want to keep binary compatibility between PIC and non-PIC.
+
+makeRelativeRefTo :: DynFlags -> CLabel -> CmmLit -> CmmLit
+
+makeRelativeRefTo dflags info_lbl (CmmLabel lbl)
+ | tablesNextToCode dflags
+ = CmmLabelDiffOff lbl info_lbl 0
+makeRelativeRefTo dflags info_lbl (CmmLabelOff lbl off)
+ | tablesNextToCode dflags
+ = CmmLabelDiffOff lbl info_lbl off
+makeRelativeRefTo _ _ lit = lit
+
+
+-------------------------------------------------------------------------
+--
+-- Build a liveness mask for the stack layout
+--
+-------------------------------------------------------------------------
+
+-- There are four kinds of things on the stack:
+--
+-- - pointer variables (bound in the environment)
+-- - non-pointer variables (bound in the environment)
+-- - free slots (recorded in the stack free list)
+-- - non-pointer data slots (recorded in the stack free list)
+--
+-- The first two are represented with a 'Just' of a 'LocalReg'.
+-- The last two with one or more 'Nothing' constructors.
+-- Each 'Nothing' represents one used word.
+--
+-- The head of the stack layout is the top of the stack and
+-- the least-significant bit.
+
+mkLivenessBits :: DynFlags -> Liveness -> UniqSM (CmmLit, [RawCmmDecl])
+ -- ^ Returns:
+ -- 1. The bitmap (literal value or label)
+ -- 2. Large bitmap CmmData if needed
+
+mkLivenessBits dflags liveness
+ | n_bits > mAX_SMALL_BITMAP_SIZE dflags -- does not fit in one word
+ = do { uniq <- getUniqueM
+ ; let bitmap_lbl = mkBitmapLabel uniq
+ ; return (CmmLabel bitmap_lbl,
+ [mkRODataLits bitmap_lbl lits]) }
+
+ | otherwise -- Fits in one word
+ = return (mkStgWordCLit dflags bitmap_word, [])
+ where
+ n_bits = length liveness
+
+ bitmap :: Bitmap
+ bitmap = mkBitmap dflags liveness
+
+ small_bitmap = case bitmap of
+ [] -> toStgWord dflags 0
+ [b] -> b
+ _ -> panic "mkLiveness"
+ bitmap_word = toStgWord dflags (fromIntegral n_bits)
+ .|. (small_bitmap `shiftL` bITMAP_BITS_SHIFT dflags)
+
+ lits = mkWordCLit dflags (fromIntegral n_bits)
+ : map (mkStgWordCLit dflags) bitmap
+ -- The first word is the size. The structure must match
+ -- StgLargeBitmap in includes/rts/storage/InfoTable.h
+
+-------------------------------------------------------------------------
+--
+-- Generating a standard info table
+--
+-------------------------------------------------------------------------
+
+-- The standard bits of an info table. This part of the info table
+-- corresponds to the StgInfoTable type defined in
+-- includes/rts/storage/InfoTables.h.
+--
+-- Its shape varies with ticky/profiling/tables next to code etc
+-- so we can't use constant offsets from Constants
+
+mkStdInfoTable
+ :: DynFlags
+ -> (CmmLit,CmmLit) -- Closure type descr and closure descr (profiling)
+ -> Int -- Closure RTS tag
+ -> StgHalfWord -- SRT length
+ -> CmmLit -- layout field
+ -> [CmmLit]
+
+mkStdInfoTable dflags (type_descr, closure_descr) cl_type srt_len layout_lit
+ = -- Parallel revertible-black hole field
+ prof_info
+ -- Ticky info (none at present)
+ -- Debug info (none at present)
+ ++ [layout_lit, type_lit]
+
+ where
+ prof_info
+ | gopt Opt_SccProfilingOn dflags = [type_descr, closure_descr]
+ | otherwise = []
+
+ type_lit = packHalfWordsCLit dflags (toStgHalfWord dflags (fromIntegral cl_type)) srt_len
+
+-------------------------------------------------------------------------
+--
+-- Making string literals
+--
+-------------------------------------------------------------------------
+
+mkProfLits :: DynFlags -> ProfilingInfo -> UniqSM ((CmmLit,CmmLit), [RawCmmDecl])
+mkProfLits dflags NoProfilingInfo = return ((zeroCLit dflags, zeroCLit dflags), [])
+mkProfLits _ (ProfilingInfo td cd)
+ = do { (td_lit, td_decl) <- newStringLit td
+ ; (cd_lit, cd_decl) <- newStringLit cd
+ ; return ((td_lit,cd_lit), [td_decl,cd_decl]) }
+
+newStringLit :: [Word8] -> UniqSM (CmmLit, GenCmmDecl CmmStatics info stmt)
+newStringLit bytes
+ = do { uniq <- getUniqueM
+ ; return (mkByteStringCLit (mkStringLitLabel uniq) bytes) }
+
+
+-- Misc utils
+
+-- | Value of the srt field of an info table when using an StgLargeSRT
+srtEscape :: DynFlags -> StgHalfWord
+srtEscape dflags = toStgHalfWord dflags (-1)
+
+-------------------------------------------------------------------------
+--
+-- Accessing fields of an info table
+--
+-------------------------------------------------------------------------
+
+closureInfoPtr :: DynFlags -> CmmExpr -> CmmExpr
+-- Takes a closure pointer and returns the info table pointer
+closureInfoPtr dflags e = CmmLoad e (bWord dflags)
+
+entryCode :: DynFlags -> CmmExpr -> CmmExpr
+-- Takes an info pointer (the first word of a closure)
+-- and returns its entry code
+entryCode dflags e
+ | tablesNextToCode dflags = e
+ | otherwise = CmmLoad e (bWord dflags)
+
+getConstrTag :: DynFlags -> CmmExpr -> CmmExpr
+-- Takes a closure pointer, and return the *zero-indexed*
+-- constructor tag obtained from the info table
+-- This lives in the SRT field of the info table
+-- (constructors don't need SRTs).
+getConstrTag dflags closure_ptr
+ = CmmMachOp (MO_UU_Conv (halfWordWidth dflags) (wordWidth dflags)) [infoTableConstrTag dflags info_table]
+ where
+ info_table = infoTable dflags (closureInfoPtr dflags closure_ptr)
+
+cmmGetClosureType :: DynFlags -> CmmExpr -> CmmExpr
+-- Takes a closure pointer, and return the closure type
+-- obtained from the info table
+cmmGetClosureType dflags closure_ptr
+ = CmmMachOp (MO_UU_Conv (halfWordWidth dflags) (wordWidth dflags)) [infoTableClosureType dflags info_table]
+ where
+ info_table = infoTable dflags (closureInfoPtr dflags closure_ptr)
+
+infoTable :: DynFlags -> CmmExpr -> CmmExpr
+-- Takes an info pointer (the first word of a closure)
+-- and returns a pointer to the first word of the standard-form
+-- info table, excluding the entry-code word (if present)
+infoTable dflags info_ptr
+ | tablesNextToCode dflags = cmmOffsetB dflags info_ptr (- stdInfoTableSizeB dflags)
+ | otherwise = cmmOffsetW dflags info_ptr 1 -- Past the entry code pointer
+
+infoTableConstrTag :: DynFlags -> CmmExpr -> CmmExpr
+-- Takes an info table pointer (from infoTable) and returns the constr tag
+-- field of the info table (same as the srt_bitmap field)
+infoTableConstrTag = infoTableSrtBitmap
+
+infoTableSrtBitmap :: DynFlags -> CmmExpr -> CmmExpr
+-- Takes an info table pointer (from infoTable) and returns the srt_bitmap
+-- field of the info table
+infoTableSrtBitmap dflags info_tbl
+ = CmmLoad (cmmOffsetB dflags info_tbl (stdSrtBitmapOffset dflags)) (bHalfWord dflags)
+
+infoTableClosureType :: DynFlags -> CmmExpr -> CmmExpr
+-- Takes an info table pointer (from infoTable) and returns the closure type
+-- field of the info table.
+infoTableClosureType dflags info_tbl
+ = CmmLoad (cmmOffsetB dflags info_tbl (stdClosureTypeOffset dflags)) (bHalfWord dflags)
+
+infoTablePtrs :: DynFlags -> CmmExpr -> CmmExpr
+infoTablePtrs dflags info_tbl
+ = CmmLoad (cmmOffsetB dflags info_tbl (stdPtrsOffset dflags)) (bHalfWord dflags)
+
+infoTableNonPtrs :: DynFlags -> CmmExpr -> CmmExpr
+infoTableNonPtrs dflags info_tbl
+ = CmmLoad (cmmOffsetB dflags info_tbl (stdNonPtrsOffset dflags)) (bHalfWord dflags)
+
+funInfoTable :: DynFlags -> CmmExpr -> CmmExpr
+-- Takes the info pointer of a function,
+-- and returns a pointer to the first word of the StgFunInfoExtra struct
+-- in the info table.
+funInfoTable dflags info_ptr
+ | tablesNextToCode dflags
+ = cmmOffsetB dflags info_ptr (- stdInfoTableSizeB dflags - sIZEOF_StgFunInfoExtraRev dflags)
+ | otherwise
+ = cmmOffsetW dflags info_ptr (1 + stdInfoTableSizeW dflags)
+ -- Past the entry code pointer
+
+-- Takes the info pointer of a function, returns the function's arity
+funInfoArity :: DynFlags -> CmmExpr -> CmmExpr
+funInfoArity dflags iptr
+ = cmmToWord dflags (cmmLoadIndex dflags rep fun_info (offset `div` rep_bytes))
+ where
+ fun_info = funInfoTable dflags iptr
+ rep = cmmBits (widthFromBytes rep_bytes)
+
+ (rep_bytes, offset)
+ | tablesNextToCode dflags = ( pc_REP_StgFunInfoExtraRev_arity pc
+ , oFFSET_StgFunInfoExtraRev_arity dflags )
+ | otherwise = ( pc_REP_StgFunInfoExtraFwd_arity pc
+ , oFFSET_StgFunInfoExtraFwd_arity dflags )
+
+ pc = sPlatformConstants (settings dflags)
+
+-----------------------------------------------------------------------------
+--
+-- Info table sizes & offsets
+--
+-----------------------------------------------------------------------------
+
+stdInfoTableSizeW :: DynFlags -> WordOff
+-- The size of a standard info table varies with profiling/ticky etc,
+-- so we can't get it from Constants
+-- It must vary in sync with mkStdInfoTable
+stdInfoTableSizeW dflags
+ = fixedInfoTableSizeW
+ + if gopt Opt_SccProfilingOn dflags
+ then profInfoTableSizeW
+ else 0
+
+fixedInfoTableSizeW :: WordOff
+fixedInfoTableSizeW = 2 -- layout, type
+
+profInfoTableSizeW :: WordOff
+profInfoTableSizeW = 2
+
+maxStdInfoTableSizeW :: WordOff
+maxStdInfoTableSizeW =
+ 1 {- entry, when !tablesNextToCode -}
+ + fixedInfoTableSizeW
+ + profInfoTableSizeW
+
+maxRetInfoTableSizeW :: WordOff
+maxRetInfoTableSizeW =
+ maxStdInfoTableSizeW
+ + 1 {- srt label -}
+
+stdInfoTableSizeB :: DynFlags -> ByteOff
+stdInfoTableSizeB dflags = stdInfoTableSizeW dflags * wORD_SIZE dflags
+
+stdSrtBitmapOffset :: DynFlags -> ByteOff
+-- Byte offset of the SRT bitmap half-word which is
+-- in the *higher-addressed* part of the type_lit
+stdSrtBitmapOffset dflags = stdInfoTableSizeB dflags - hALF_WORD_SIZE dflags
+
+stdClosureTypeOffset :: DynFlags -> ByteOff
+-- Byte offset of the closure type half-word
+stdClosureTypeOffset dflags = stdInfoTableSizeB dflags - wORD_SIZE dflags
+
+stdPtrsOffset, stdNonPtrsOffset :: DynFlags -> ByteOff
+stdPtrsOffset dflags = stdInfoTableSizeB dflags - 2 * wORD_SIZE dflags
+stdNonPtrsOffset dflags = stdInfoTableSizeB dflags - 2 * wORD_SIZE dflags + hALF_WORD_SIZE dflags
+
+conInfoTableSizeB :: DynFlags -> Int
+conInfoTableSizeB dflags = stdInfoTableSizeB dflags + wORD_SIZE dflags
diff --git a/cmm/CmmLayoutStack.hs b/cmm/CmmLayoutStack.hs
new file mode 100644
--- /dev/null
+++ b/cmm/CmmLayoutStack.hs
@@ -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]
diff --git a/cmm/CmmLex.x b/cmm/CmmLex.x
new file mode 100644
--- /dev/null
+++ b/cmm/CmmLex.x
@@ -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
+-- # "" \n
+ $digit+ { setLine line_prag1 }
+ \" [^\"]* \" { setFile line_prag2 }
+ .* { pop }
+
+<0> {
+ \n ;
+
+ [\:\;\{\}\[\]\(\)\=\`\~\/\*\%\-\+\&\^\|\>\<\,\!] { special_char }
+
+ ".." { kw CmmT_DotDot }
+ "::" { kw CmmT_DoubleColon }
+ ">>" { kw CmmT_Shr }
+ "<<" { kw CmmT_Shl }
+ ">=" { kw CmmT_Ge }
+ "<=" { kw CmmT_Le }
+ "==" { kw CmmT_Eq }
+ "!=" { kw CmmT_Ne }
+ "&&" { kw CmmT_BoolAnd }
+ "||" { kw CmmT_BoolOr }
+
+ P@decimal { global_regN (\n -> VanillaReg n VGcPtr) }
+ R@decimal { global_regN (\n -> VanillaReg n VNonGcPtr) }
+ F@decimal { global_regN FloatReg }
+ D@decimal { global_regN DoubleReg }
+ L@decimal { global_regN LongReg }
+ Sp { global_reg Sp }
+ SpLim { global_reg SpLim }
+ Hp { global_reg Hp }
+ HpLim { global_reg HpLim }
+ CCCS { global_reg CCCS }
+ CurrentTSO { global_reg CurrentTSO }
+ CurrentNursery { global_reg CurrentNursery }
+ HpAlloc { global_reg HpAlloc }
+ BaseReg { global_reg BaseReg }
+ MachSp { global_reg MachSp }
+ UnwindReturnReg { global_reg UnwindReturnReg }
+
+ $namebegin $namechar* { name }
+
+ 0 @octal { tok_octal }
+ @decimal { tok_decimal }
+ 0[xX] @hexadecimal { tok_hexadecimal }
+ @floating_point { strtoken tok_float }
+
+ \" @strchar* \" { strtoken tok_string }
+}
+
+{
+data CmmToken
+ = CmmT_SpecChar Char
+ | CmmT_DotDot
+ | CmmT_DoubleColon
+ | CmmT_Shr
+ | CmmT_Shl
+ | CmmT_Ge
+ | CmmT_Le
+ | CmmT_Eq
+ | CmmT_Ne
+ | CmmT_BoolAnd
+ | CmmT_BoolOr
+ | CmmT_CLOSURE
+ | CmmT_INFO_TABLE
+ | CmmT_INFO_TABLE_RET
+ | CmmT_INFO_TABLE_FUN
+ | CmmT_INFO_TABLE_CONSTR
+ | CmmT_INFO_TABLE_SELECTOR
+ | CmmT_else
+ | CmmT_export
+ | CmmT_section
+ | CmmT_goto
+ | CmmT_if
+ | CmmT_call
+ | CmmT_jump
+ | CmmT_foreign
+ | CmmT_never
+ | CmmT_prim
+ | CmmT_reserve
+ | CmmT_return
+ | CmmT_returns
+ | CmmT_import
+ | CmmT_switch
+ | CmmT_case
+ | CmmT_default
+ | CmmT_push
+ | CmmT_unwind
+ | CmmT_bits8
+ | CmmT_bits16
+ | CmmT_bits32
+ | CmmT_bits64
+ | CmmT_bits128
+ | CmmT_bits256
+ | CmmT_bits512
+ | CmmT_float32
+ | CmmT_float64
+ | CmmT_gcptr
+ | CmmT_GlobalReg GlobalReg
+ | CmmT_Name FastString
+ | CmmT_String String
+ | CmmT_Int Integer
+ | CmmT_Float Rational
+ | CmmT_EOF
+ deriving (Show)
+
+-- -----------------------------------------------------------------------------
+-- Lexer actions
+
+type Action = RealSrcSpan -> StringBuffer -> Int -> PD (RealLocated CmmToken)
+
+begin :: Int -> Action
+begin code _span _str _len = do liftP (pushLexState code); lexToken
+
+pop :: Action
+pop _span _buf _len = liftP popLexState >> lexToken
+
+special_char :: Action
+special_char span buf _len = return (L span (CmmT_SpecChar (currentChar buf)))
+
+kw :: CmmToken -> Action
+kw tok span _buf _len = return (L span tok)
+
+global_regN :: (Int -> GlobalReg) -> Action
+global_regN con span buf len
+ = return (L span (CmmT_GlobalReg (con (fromIntegral n))))
+ where buf' = stepOn buf
+ n = parseUnsignedInteger buf' (len-1) 10 octDecDigit
+
+global_reg :: GlobalReg -> Action
+global_reg r span _buf _len = return (L span (CmmT_GlobalReg r))
+
+strtoken :: (String -> CmmToken) -> Action
+strtoken f span buf len =
+ return (L span $! (f $! lexemeToString buf len))
+
+name :: Action
+name span buf len =
+ case lookupUFM reservedWordsFM fs of
+ Just tok -> return (L span tok)
+ Nothing -> return (L span (CmmT_Name fs))
+ where
+ fs = lexemeToFastString buf len
+
+reservedWordsFM = listToUFM $
+ map (\(x, y) -> (mkFastString x, y)) [
+ ( "CLOSURE", CmmT_CLOSURE ),
+ ( "INFO_TABLE", CmmT_INFO_TABLE ),
+ ( "INFO_TABLE_RET", CmmT_INFO_TABLE_RET ),
+ ( "INFO_TABLE_FUN", CmmT_INFO_TABLE_FUN ),
+ ( "INFO_TABLE_CONSTR", CmmT_INFO_TABLE_CONSTR ),
+ ( "INFO_TABLE_SELECTOR",CmmT_INFO_TABLE_SELECTOR ),
+ ( "else", CmmT_else ),
+ ( "export", CmmT_export ),
+ ( "section", CmmT_section ),
+ ( "goto", CmmT_goto ),
+ ( "if", CmmT_if ),
+ ( "call", CmmT_call ),
+ ( "jump", CmmT_jump ),
+ ( "foreign", CmmT_foreign ),
+ ( "never", CmmT_never ),
+ ( "prim", CmmT_prim ),
+ ( "reserve", CmmT_reserve ),
+ ( "return", CmmT_return ),
+ ( "returns", CmmT_returns ),
+ ( "import", CmmT_import ),
+ ( "switch", CmmT_switch ),
+ ( "case", CmmT_case ),
+ ( "default", CmmT_default ),
+ ( "push", CmmT_push ),
+ ( "unwind", CmmT_unwind ),
+ ( "bits8", CmmT_bits8 ),
+ ( "bits16", CmmT_bits16 ),
+ ( "bits32", CmmT_bits32 ),
+ ( "bits64", CmmT_bits64 ),
+ ( "bits128", CmmT_bits128 ),
+ ( "bits256", CmmT_bits256 ),
+ ( "bits512", CmmT_bits512 ),
+ ( "float32", CmmT_float32 ),
+ ( "float64", CmmT_float64 ),
+-- New forms
+ ( "b8", CmmT_bits8 ),
+ ( "b16", CmmT_bits16 ),
+ ( "b32", CmmT_bits32 ),
+ ( "b64", CmmT_bits64 ),
+ ( "b128", CmmT_bits128 ),
+ ( "b256", CmmT_bits256 ),
+ ( "b512", CmmT_bits512 ),
+ ( "f32", CmmT_float32 ),
+ ( "f64", CmmT_float64 ),
+ ( "gcptr", CmmT_gcptr )
+ ]
+
+tok_decimal span buf len
+ = return (L span (CmmT_Int $! parseUnsignedInteger buf len 10 octDecDigit))
+
+tok_octal span buf len
+ = return (L span (CmmT_Int $! parseUnsignedInteger (offsetBytes 1 buf) (len-1) 8 octDecDigit))
+
+tok_hexadecimal span buf len
+ = return (L span (CmmT_Int $! parseUnsignedInteger (offsetBytes 2 buf) (len-2) 16 hexDigit))
+
+tok_float str = CmmT_Float $! readRational str
+
+tok_string str = CmmT_String (read str)
+ -- urk, not quite right, but it'll do for now
+
+-- -----------------------------------------------------------------------------
+-- Line pragmas
+
+setLine :: Int -> Action
+setLine code span buf len = do
+ let line = parseUnsignedInteger buf len 10 octDecDigit
+ liftP $ do
+ setSrcLoc (mkRealSrcLoc (srcSpanFile span) (fromIntegral line - 1) 1)
+ -- subtract one: the line number refers to the *following* line
+ -- trace ("setLine " ++ show line) $ do
+ popLexState >> pushLexState code
+ lexToken
+
+setFile :: Int -> Action
+setFile code span buf len = do
+ let file = lexemeToFastString (stepOn buf) (len-2)
+ liftP $ do
+ setSrcLoc (mkRealSrcLoc file (srcSpanEndLine span) (srcSpanEndCol span))
+ popLexState >> pushLexState code
+ lexToken
+
+-- -----------------------------------------------------------------------------
+-- This is the top-level function: called from the parser each time a
+-- new token is to be read from the input.
+
+cmmlex :: (Located CmmToken -> PD a) -> PD a
+cmmlex cont = do
+ (L span tok) <- lexToken
+ --trace ("token: " ++ show tok) $ do
+ cont (L (RealSrcSpan span) tok)
+
+lexToken :: PD (RealLocated CmmToken)
+lexToken = do
+ inp@(loc1,buf) <- getInput
+ sc <- liftP getLexState
+ case alexScan inp sc of
+ AlexEOF -> do let span = mkRealSrcSpan loc1 loc1
+ liftP (setLastToken span 0)
+ return (L span CmmT_EOF)
+ AlexError (loc2,_) -> liftP $ failLocMsgP loc1 loc2 "lexical error"
+ AlexSkip inp2 _ -> do
+ setInput inp2
+ lexToken
+ AlexToken inp2@(end,_buf2) len t -> do
+ setInput inp2
+ let span = mkRealSrcSpan loc1 end
+ span `seq` liftP (setLastToken span len)
+ t span buf len
+
+-- -----------------------------------------------------------------------------
+-- Monad stuff
+
+-- Stuff that Alex needs to know about our input type:
+type AlexInput = (RealSrcLoc,StringBuffer)
+
+alexInputPrevChar :: AlexInput -> Char
+alexInputPrevChar (_,s) = prevChar s '\n'
+
+-- backwards compatibility for Alex 2.x
+alexGetChar :: AlexInput -> Maybe (Char,AlexInput)
+alexGetChar inp = case alexGetByte inp of
+ Nothing -> Nothing
+ Just (b,i) -> c `seq` Just (c,i)
+ where c = chr $ fromIntegral b
+
+alexGetByte :: AlexInput -> Maybe (Word8,AlexInput)
+alexGetByte (loc,s)
+ | atEnd s = Nothing
+ | otherwise = b `seq` loc' `seq` s' `seq` Just (b, (loc', s'))
+ where c = currentChar s
+ b = fromIntegral $ ord $ c
+ loc' = advanceSrcLoc loc c
+ s' = stepOn s
+
+getInput :: PD AlexInput
+getInput = PD $ \_ s@PState{ loc=l, buffer=b } -> POk s (l,b)
+
+setInput :: AlexInput -> PD ()
+setInput (l,b) = PD $ \_ s -> POk s{ loc=l, buffer=b } ()
+}
diff --git a/cmm/CmmLint.hs b/cmm/CmmLint.hs
new file mode 100644
--- /dev/null
+++ b/cmm/CmmLint.hs
@@ -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))
+-}
+
diff --git a/cmm/CmmLive.hs b/cmm/CmmLive.hs
new file mode 100644
--- /dev/null
+++ b/cmm/CmmLive.hs
@@ -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) #-}
diff --git a/cmm/CmmMachOp.hs b/cmm/CmmMachOp.hs
new file mode 100644
--- /dev/null
+++ b/cmm/CmmMachOp.hs
@@ -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
diff --git a/cmm/CmmMonad.hs b/cmm/CmmMonad.hs
new file mode 100644
--- /dev/null
+++ b/cmm/CmmMonad.hs
@@ -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
diff --git a/cmm/CmmNode.hs b/cmm/CmmNode.hs
new file mode 100644
--- /dev/null
+++ b/cmm/CmmNode.hs
@@ -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 + 8)] = c1q9;
+-- foreign call "ccall" arg hints: [] result hints: [] (_c1q8::I64)(...)
+-- returns to c1q9 args: ([]) ress: ([])ret_args: 8ret_off: 8;
+-- c1q9:
+-- I64[(young + 8)] = c1qb;
+-- R1 = _s1pc::P64;
+-- call stg_makeStableName#(R1) returns to c1qb, args: 8, res: 8, upd: 8;
+--
+-- If we run sinking pass now (still before stack layout) we will get this:
+--
+-- c1q6:
+-- I64[(young + 8)] = c1q9;
+-- foreign call "ccall" arg hints: [] result hints: [] performMajorGC(...)
+-- returns to c1q9 args: ([]) ress: ([])ret_args: 8ret_off: 8;
+-- c1q9:
+-- I64[(young + 8)] = c1qb;
+-- _s1pf::P64 = R1; <------ _s1pf sunk past safe foreign call
+-- R1 = _s1pc::P64;
+-- call stg_makeStableName#(R1) returns to c1qb, args: 8, res: 8, upd: 8;
+--
+-- Notice that _s1pf was sunk past a foreign call. When we run stack layout
+-- safe call to performMajorGC will be turned into:
+--
+-- c1q6:
+-- _s1pc::P64 = P64[Sp + 8];
+-- I64[Sp - 8] = c1q9;
+-- Sp = Sp - 8;
+-- I64[I64[CurrentTSO + 24] + 16] = Sp;
+-- P64[CurrentNursery + 8] = Hp + 8;
+-- (_u1qI::I64) = call "ccall" arg hints: [PtrHint,]
+-- result hints: [PtrHint] suspendThread(BaseReg, 0);
+-- call "ccall" arg hints: [] result hints: [] performMajorGC();
+-- (_u1qJ::I64) = call "ccall" arg hints: [PtrHint]
+-- result hints: [PtrHint] resumeThread(_u1qI::I64);
+-- BaseReg = _u1qJ::I64;
+-- _u1qK::P64 = CurrentTSO;
+-- _u1qL::P64 = I64[_u1qK::P64 + 24];
+-- Sp = I64[_u1qL::P64 + 16];
+-- SpLim = _u1qL::P64 + 192;
+-- HpAlloc = 0;
+-- Hp = I64[CurrentNursery + 8] - 8;
+-- HpLim = I64[CurrentNursery] + (%MO_SS_Conv_W32_W64(I32[CurrentNursery + 48]) * 4096 - 1);
+-- call (I64[Sp])() returns to c1q9, args: 8, res: 8, upd: 8;
+-- c1q9:
+-- I64[(young + 8)] = c1qb;
+-- _s1pf::P64 = R1; <------ INCORRECT!
+-- R1 = _s1pc::P64;
+-- call stg_makeStableName#(R1) returns to c1qb, args: 8, res: 8, upd: 8;
+--
+-- Notice that c1q6 now ends with a call. Sinking _s1pf::P64 = R1 past that
+-- call is clearly incorrect. This is what would happen if we assumed that
+-- safe foreign call has the same semantics as unsafe foreign call. To prevent
+-- this we need to treat safe foreign call as if was normal call.
+
+-----------------------------------
+-- mapping Expr in CmmNode
+
+mapForeignTarget :: (CmmExpr -> CmmExpr) -> ForeignTarget -> ForeignTarget
+mapForeignTarget exp (ForeignTarget e c) = ForeignTarget (exp e) c
+mapForeignTarget _ m@(PrimTarget _) = m
+
+wrapRecExp :: (CmmExpr -> CmmExpr) -> CmmExpr -> CmmExpr
+-- Take a transformer on expressions and apply it recursively.
+-- (wrapRecExp f e) first recursively applies itself to sub-expressions of e
+-- then uses f to rewrite the resulting expression
+wrapRecExp f (CmmMachOp op es) = f (CmmMachOp op $ map (wrapRecExp f) es)
+wrapRecExp f (CmmLoad addr ty) = f (CmmLoad (wrapRecExp f addr) ty)
+wrapRecExp f e = f e
+
+mapExp :: (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
+mapExp _ f@(CmmEntry{}) = f
+mapExp _ m@(CmmComment _) = m
+mapExp _ m@(CmmTick _) = m
+mapExp f (CmmUnwind regs) = CmmUnwind (map (fmap (fmap f)) regs)
+mapExp f (CmmAssign r e) = CmmAssign r (f e)
+mapExp f (CmmStore addr e) = CmmStore (f addr) (f e)
+mapExp f (CmmUnsafeForeignCall tgt fs as) = CmmUnsafeForeignCall (mapForeignTarget f tgt) fs (map f as)
+mapExp _ l@(CmmBranch _) = l
+mapExp f (CmmCondBranch e ti fi l) = CmmCondBranch (f e) ti fi l
+mapExp f (CmmSwitch e ids) = CmmSwitch (f e) ids
+mapExp f n@CmmCall {cml_target=tgt} = n{cml_target = f tgt}
+mapExp f (CmmForeignCall tgt fs as succ ret_args updfr intrbl) = CmmForeignCall (mapForeignTarget f tgt) fs (map f as) succ ret_args updfr intrbl
+
+mapExpDeep :: (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
+mapExpDeep f = mapExp $ wrapRecExp f
+
+------------------------------------------------------------------------
+-- mapping Expr in CmmNode, but not performing allocation if no changes
+
+mapForeignTargetM :: (CmmExpr -> Maybe CmmExpr) -> ForeignTarget -> Maybe ForeignTarget
+mapForeignTargetM f (ForeignTarget e c) = (\x -> ForeignTarget x c) `fmap` f e
+mapForeignTargetM _ (PrimTarget _) = Nothing
+
+wrapRecExpM :: (CmmExpr -> Maybe CmmExpr) -> (CmmExpr -> Maybe CmmExpr)
+-- (wrapRecExpM f e) first recursively applies itself to sub-expressions of e
+-- then gives f a chance to rewrite the resulting expression
+wrapRecExpM f n@(CmmMachOp op es) = maybe (f n) (f . CmmMachOp op) (mapListM (wrapRecExpM f) es)
+wrapRecExpM f n@(CmmLoad addr ty) = maybe (f n) (f . flip CmmLoad ty) (wrapRecExpM f addr)
+wrapRecExpM f e = f e
+
+mapExpM :: (CmmExpr -> Maybe CmmExpr) -> CmmNode e x -> Maybe (CmmNode e x)
+mapExpM _ (CmmEntry{}) = Nothing
+mapExpM _ (CmmComment _) = Nothing
+mapExpM _ (CmmTick _) = Nothing
+mapExpM f (CmmUnwind regs) = CmmUnwind `fmap` mapM (\(r,e) -> mapM f e >>= \e' -> pure (r,e')) regs
+mapExpM f (CmmAssign r e) = CmmAssign r `fmap` f e
+mapExpM f (CmmStore addr e) = (\[addr', e'] -> CmmStore addr' e') `fmap` mapListM f [addr, e]
+mapExpM _ (CmmBranch _) = Nothing
+mapExpM f (CmmCondBranch e ti fi l) = (\x -> CmmCondBranch x ti fi l) `fmap` f e
+mapExpM f (CmmSwitch e tbl) = (\x -> CmmSwitch x tbl) `fmap` f e
+mapExpM f (CmmCall tgt mb_id r o i s) = (\x -> CmmCall x mb_id r o i s) `fmap` f tgt
+mapExpM f (CmmUnsafeForeignCall tgt fs as)
+ = case mapForeignTargetM f tgt of
+ Just tgt' -> Just (CmmUnsafeForeignCall tgt' fs (mapListJ f as))
+ Nothing -> (\xs -> CmmUnsafeForeignCall tgt fs xs) `fmap` mapListM f as
+mapExpM f (CmmForeignCall tgt fs as succ ret_args updfr intrbl)
+ = case mapForeignTargetM f tgt of
+ Just tgt' -> Just (CmmForeignCall tgt' fs (mapListJ f as) succ ret_args updfr intrbl)
+ Nothing -> (\xs -> CmmForeignCall tgt fs xs succ ret_args updfr intrbl) `fmap` mapListM f as
+
+-- share as much as possible
+mapListM :: (a -> Maybe a) -> [a] -> Maybe [a]
+mapListM f xs = let (b, r) = mapListT f xs
+ in if b then Just r else Nothing
+
+mapListJ :: (a -> Maybe a) -> [a] -> [a]
+mapListJ f xs = snd (mapListT f xs)
+
+mapListT :: (a -> Maybe a) -> [a] -> (Bool, [a])
+mapListT f xs = foldr g (False, []) (zip3 (tails xs) xs (map f xs))
+ where g (_, y, Nothing) (True, ys) = (True, y:ys)
+ g (_, _, Just y) (True, ys) = (True, y:ys)
+ g (ys', _, Nothing) (False, _) = (False, ys')
+ g (_, _, Just y) (False, ys) = (True, y:ys)
+
+mapExpDeepM :: (CmmExpr -> Maybe CmmExpr) -> CmmNode e x -> Maybe (CmmNode e x)
+mapExpDeepM f = mapExpM $ wrapRecExpM f
+
+-----------------------------------
+-- folding Expr in CmmNode
+
+foldExpForeignTarget :: (CmmExpr -> z -> z) -> ForeignTarget -> z -> z
+foldExpForeignTarget exp (ForeignTarget e _) z = exp e z
+foldExpForeignTarget _ (PrimTarget _) z = z
+
+-- Take a folder on expressions and apply it recursively.
+-- Specifically (wrapRecExpf f e z) deals with CmmMachOp and CmmLoad
+-- itself, delegating all the other CmmExpr forms to 'f'.
+wrapRecExpf :: (CmmExpr -> z -> z) -> CmmExpr -> z -> z
+wrapRecExpf f e@(CmmMachOp _ es) z = foldr (wrapRecExpf f) (f e z) es
+wrapRecExpf f e@(CmmLoad addr _) z = wrapRecExpf f addr (f e z)
+wrapRecExpf f e z = f e z
+
+foldExp :: (CmmExpr -> z -> z) -> CmmNode e x -> z -> z
+foldExp _ (CmmEntry {}) z = z
+foldExp _ (CmmComment {}) z = z
+foldExp _ (CmmTick {}) z = z
+foldExp f (CmmUnwind xs) z = foldr (maybe id f) z (map snd xs)
+foldExp f (CmmAssign _ e) z = f e z
+foldExp f (CmmStore addr e) z = f addr $ f e z
+foldExp f (CmmUnsafeForeignCall t _ as) z = foldr f (foldExpForeignTarget f t z) as
+foldExp _ (CmmBranch _) z = z
+foldExp f (CmmCondBranch e _ _ _) z = f e z
+foldExp f (CmmSwitch e _) z = f e z
+foldExp f (CmmCall {cml_target=tgt}) z = f tgt z
+foldExp f (CmmForeignCall {tgt=tgt, args=args}) z = foldr f (foldExpForeignTarget f tgt z) args
+
+foldExpDeep :: (CmmExpr -> z -> z) -> CmmNode e x -> z -> z
+foldExpDeep f = foldExp (wrapRecExpf f)
+
+-- -----------------------------------------------------------------------------
+
+mapSuccessors :: (Label -> Label) -> CmmNode O C -> CmmNode O C
+mapSuccessors f (CmmBranch bid) = CmmBranch (f bid)
+mapSuccessors f (CmmCondBranch p y n l) = CmmCondBranch p (f y) (f n) l
+mapSuccessors f (CmmSwitch e ids) = CmmSwitch e (mapSwitchTargets f ids)
+mapSuccessors _ n = n
+
+-- -----------------------------------------------------------------------------
+
+-- | Tickish in Cmm context (annotations only)
+type CmmTickish = Tickish ()
+
+-- | Tick scope identifier, allowing us to reason about what
+-- annotations in a Cmm block should scope over. We especially take
+-- care to allow optimisations to reorganise blocks without losing
+-- tick association in the process.
+data CmmTickScope
+ = GlobalScope
+ -- ^ The global scope is the "root" of the scope graph. Every
+ -- scope is a sub-scope of the global scope. It doesn't make sense
+ -- to add ticks to this scope. On the other hand, this means that
+ -- setting this scope on a block means no ticks apply to it.
+
+ | SubScope !U.Unique CmmTickScope
+ -- ^ Constructs a new sub-scope to an existing scope. This allows
+ -- us to translate Core-style scoping rules (see @tickishScoped@)
+ -- into the Cmm world. Suppose the following code:
+ --
+ -- tick<1> case ... of
+ -- A -> tick<2> ...
+ -- B -> tick<3> ...
+ --
+ -- We want the top-level tick annotation to apply to blocks
+ -- generated for the A and B alternatives. We can achieve that by
+ -- generating tick<1> into a block with scope a, while the code
+ -- for alternatives A and B gets generated into sub-scopes a/b and
+ -- a/c respectively.
+
+ | CombinedScope CmmTickScope CmmTickScope
+ -- ^ A combined scope scopes over everything that the two given
+ -- scopes cover. It is therefore a sub-scope of either scope. This
+ -- is required for optimisations. Consider common block elimination:
+ --
+ -- A -> tick<2> case ... of
+ -- C -> [common]
+ -- B -> tick<3> case ... of
+ -- D -> [common]
+ --
+ -- We will generate code for the C and D alternatives, and figure
+ -- out afterwards that it's actually common code. Scoping rules
+ -- dictate that the resulting common block needs to be covered by
+ -- both tick<2> and tick<3>, therefore we need to construct a
+ -- scope that is a child to *both* scope. Now we can do that - if
+ -- we assign the scopes a/c and b/d to the common-ed up blocks,
+ -- the new block could have a combined tick scope a/c+b/d, which
+ -- both tick<2> and tick<3> apply to.
+
+-- Note [CmmTick scoping details]:
+--
+-- The scope of a @CmmTick@ is given by the @CmmEntry@ node of the
+-- same block. Note that as a result of this, optimisations making
+-- tick scopes more specific can *reduce* the amount of code a tick
+-- scopes over. Fixing this would require a separate @CmmTickScope@
+-- field for @CmmTick@. Right now we do not do this simply because I
+-- couldn't find an example where it actually mattered -- multiple
+-- blocks within the same scope generally jump to each other, which
+-- prevents common block elimination from happening in the first
+-- place. But this is no strong reason, so if Cmm optimisations become
+-- more involved in future this might have to be revisited.
+
+-- | Output all scope paths.
+scopeToPaths :: CmmTickScope -> [[U.Unique]]
+scopeToPaths GlobalScope = [[]]
+scopeToPaths (SubScope u s) = map (u:) (scopeToPaths s)
+scopeToPaths (CombinedScope s1 s2) = scopeToPaths s1 ++ scopeToPaths s2
+
+-- | Returns the head uniques of the scopes. This is based on the
+-- assumption that the @Unique@ of @SubScope@ identifies the
+-- underlying super-scope. Used for efficient equality and comparison,
+-- see below.
+scopeUniques :: CmmTickScope -> [U.Unique]
+scopeUniques GlobalScope = []
+scopeUniques (SubScope u _) = [u]
+scopeUniques (CombinedScope s1 s2) = scopeUniques s1 ++ scopeUniques s2
+
+-- Equality and order is based on the head uniques defined above. We
+-- take care to short-cut the (extremly) common cases.
+instance Eq CmmTickScope where
+ GlobalScope == GlobalScope = True
+ GlobalScope == _ = False
+ _ == GlobalScope = False
+ (SubScope u _) == (SubScope u' _) = u == u'
+ (SubScope _ _) == _ = False
+ _ == (SubScope _ _) = False
+ scope == scope' =
+ sortBy nonDetCmpUnique (scopeUniques scope) ==
+ sortBy nonDetCmpUnique (scopeUniques scope')
+ -- This is still deterministic because
+ -- the order is the same for equal lists
+
+-- This is non-deterministic but we do not currently support deterministic
+-- code-generation. See Note [Unique Determinism and code generation]
+-- See Note [No Ord for Unique]
+instance Ord CmmTickScope where
+ compare GlobalScope GlobalScope = EQ
+ compare GlobalScope _ = LT
+ compare _ GlobalScope = GT
+ compare (SubScope u _) (SubScope u' _) = nonDetCmpUnique u u'
+ compare scope scope' = cmpList nonDetCmpUnique
+ (sortBy nonDetCmpUnique $ scopeUniques scope)
+ (sortBy nonDetCmpUnique $ scopeUniques scope')
+
+instance Outputable CmmTickScope where
+ ppr GlobalScope = text "global"
+ ppr (SubScope us GlobalScope)
+ = ppr us
+ ppr (SubScope us s) = ppr s <> char '/' <> ppr us
+ ppr combined = parens $ hcat $ punctuate (char '+') $
+ map (hcat . punctuate (char '/') . map ppr . reverse) $
+ scopeToPaths combined
+
+-- | Checks whether two tick scopes are sub-scopes of each other. True
+-- if the two scopes are equal.
+isTickSubScope :: CmmTickScope -> CmmTickScope -> Bool
+isTickSubScope = cmp
+ where cmp _ GlobalScope = True
+ cmp GlobalScope _ = False
+ cmp (CombinedScope s1 s2) s' = cmp s1 s' && cmp s2 s'
+ cmp s (CombinedScope s1' s2') = cmp s s1' || cmp s s2'
+ cmp (SubScope u s) s'@(SubScope u' _) = u == u' || cmp s s'
+
+-- | Combine two tick scopes. The new scope should be sub-scope of
+-- both parameters. We simplfy automatically if one tick scope is a
+-- sub-scope of the other already.
+combineTickScopes :: CmmTickScope -> CmmTickScope -> CmmTickScope
+combineTickScopes s1 s2
+ | s1 `isTickSubScope` s2 = s1
+ | s2 `isTickSubScope` s1 = s2
+ | otherwise = CombinedScope s1 s2
diff --git a/cmm/CmmOpt.hs b/cmm/CmmOpt.hs
new file mode 100644
--- /dev/null
+++ b/cmm/CmmOpt.hs
@@ -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
diff --git a/cmm/CmmParse.y b/cmm/CmmParse.y
new file mode 100644
--- /dev/null
+++ b/cmm/CmmParse.y
@@ -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"
+}
diff --git a/cmm/CmmPipeline.hs b/cmm/CmmPipeline.hs
new file mode 100644
--- /dev/null
+++ b/cmm/CmmPipeline.hs
@@ -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 + 8)] = c1D;
+-- call stg_gc_noregs() returns to c1D, args: 8, res: 8, upd: 8;
+-- c1D:
+-- R3 = _c1C::P64;
+-- R2 = _c1B::P64;
+-- R1 = _c1A::P64;
+-- call (P64[(old + 8)])(R3, R2, R1) args: 8, res: 0, upd: 8;
+--
+-- Stack layout pass will save all local variables live across a call
+-- (_c1C, _c1B and _c1A in this example) on the stack just before
+-- making a call and reload them from the stack after returning from a
+-- call:
+--
+-- c1E:
+-- _c1C::P64 = R3;
+-- _c1B::P64 = R2;
+-- _c1A::P64 = R1;
+-- I64[Sp - 32] = c1D;
+-- P64[Sp - 24] = _c1A::P64;
+-- P64[Sp - 16] = _c1B::P64;
+-- P64[Sp - 8] = _c1C::P64;
+-- Sp = Sp - 32;
+-- call stg_gc_noregs() returns to c1D, args: 8, res: 8, upd: 8;
+-- c1D:
+-- _c1A::P64 = P64[Sp + 8];
+-- _c1B::P64 = P64[Sp + 16];
+-- _c1C::P64 = P64[Sp + 24];
+-- R3 = _c1C::P64;
+-- R2 = _c1B::P64;
+-- R1 = _c1A::P64;
+-- Sp = Sp + 32;
+-- call (P64[Sp])(R3, R2, R1) args: 8, res: 0, upd: 8;
+--
+-- If we don't run sinking pass after stack layout we are basically
+-- left with such code. However, running sinking on this code can lead
+-- to significant improvements:
+--
+-- c1E:
+-- I64[Sp - 32] = c1D;
+-- P64[Sp - 24] = R1;
+-- P64[Sp - 16] = R2;
+-- P64[Sp - 8] = R3;
+-- Sp = Sp - 32;
+-- call stg_gc_noregs() returns to c1D, args: 8, res: 8, upd: 8;
+-- c1D:
+-- R3 = P64[Sp + 24];
+-- R2 = P64[Sp + 16];
+-- R1 = P64[Sp + 8];
+-- Sp = Sp + 32;
+-- call (P64[Sp])(R3, R2, R1) args: 8, res: 0, upd: 8;
+--
+-- Now we only have 9 assignments instead of 15.
+--
+-- There is one case when running sinking before stack layout could
+-- be beneficial. Consider this:
+--
+-- L1:
+-- x = y
+-- call f() returns L2
+-- L2: ...x...y...
+--
+-- Since both x and y are live across a call to f, they will be stored
+-- on the stack during stack layout and restored after the call:
+--
+-- L1:
+-- x = y
+-- P64[Sp - 24] = L2
+-- P64[Sp - 16] = x
+-- P64[Sp - 8] = y
+-- Sp = Sp - 24
+-- call f() returns L2
+-- L2:
+-- y = P64[Sp + 16]
+-- x = P64[Sp + 8]
+-- Sp = Sp + 24
+-- ...x...y...
+--
+-- However, if we run sinking before stack layout we would propagate x
+-- to its usage place (both x and y must be local register for this to
+-- be possible - global registers cannot be floated past a call):
+--
+-- L1:
+-- x = y
+-- call f() returns L2
+-- L2: ...y...y...
+--
+-- Thus making x dead at the call to f(). If we ran stack layout now
+-- we would generate less stores and loads:
+--
+-- L1:
+-- x = y
+-- P64[Sp - 16] = L2
+-- P64[Sp - 8] = y
+-- Sp = Sp - 16
+-- call f() returns L2
+-- L2:
+-- y = P64[Sp + 8]
+-- Sp = Sp + 16
+-- ...y...y...
+--
+-- But since we don't see any benefits from running sinking befroe stack
+-- layout, this situation probably doesn't arise too often in practice.
+--
+
+{- Note [inconsistent-pic-reg]
+
+On x86/Darwin, PIC is implemented by inserting a sequence like
+
+ call 1f
+ 1: popl %reg
+
+at the proc entry point, and then referring to labels as offsets from
+%reg. If we don't split proc points, then we could have many entry
+points in a proc that would need this sequence, and each entry point
+would then get a different value for %reg. If there are any join
+points, then at the join point we don't have a consistent value for
+%reg, so we don't know how to refer to labels.
+
+Hence, on x86/Darwin, we have to split proc points, and then each proc
+point will get its own PIC initialisation sequence.
+
+The situation is the same for ppc/Darwin. We use essentially the same
+sequence to load the program counter onto reg:
+
+ bcl 20,31,1f
+ 1: mflr reg
+
+This isn't an issue on x86/ELF, where the sequence is
+
+ call 1f
+ 1: popl %reg
+ addl $_GLOBAL_OFFSET_TABLE_+(.-1b), %reg
+
+so %reg always has a consistent value: the address of
+_GLOBAL_OFFSET_TABLE_, regardless of which entry point we arrived via.
+
+-}
+
+{- Note [unreachable blocks]
+
+The control-flow optimiser sometimes leaves unreachable blocks behind
+containing junk code. These aren't necessarily a problem, but
+removing them is good because it might save time in the native code
+generator later.
+
+-}
+
+runUniqSM :: UniqSM a -> IO a
+runUniqSM m = do
+ us <- mkSplitUniqSupply 'u'
+ return (initUs_ us m)
+
+
+dumpGraph :: DynFlags -> DumpFlag -> String -> CmmGraph -> IO ()
+dumpGraph dflags flag name g = do
+ when (gopt Opt_DoCmmLinting dflags) $ do_lint g
+ dumpWith dflags flag name (ppr g)
+ where
+ do_lint g = case cmmLintGraph dflags g of
+ Just err -> do { fatalErrorMsg dflags err
+ ; ghcExit dflags 1
+ }
+ Nothing -> return ()
+
+dumpWith :: DynFlags -> DumpFlag -> String -> SDoc -> IO ()
+dumpWith dflags flag txt sdoc = do
+ -- ToDo: No easy way of say "dump all the cmm, *and* split
+ -- them into files." Also, -ddump-cmm-verbose doesn't play
+ -- nicely with -ddump-to-file, since the headers get omitted.
+ dumpIfSet_dyn dflags flag txt sdoc
+ when (not (dopt flag dflags)) $
+ dumpIfSet_dyn dflags Opt_D_dump_cmm_verbose txt sdoc
diff --git a/cmm/CmmProcPoint.hs b/cmm/CmmProcPoint.hs
new file mode 100644
--- /dev/null
+++ b/cmm/CmmProcPoint.hs
@@ -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 ""
+ | otherwise = text "reached by" <+>
+ (hsep $ punctuate comma $ map ppr $ setElems ps)
+ ppr ProcPoint = text ""
+
+--------------------------------------------------
+-- Proc point analysis
+
+-- Once you know what the proc-points are, figure out
+-- what proc-points each block is reachable from
+-- See Note [Proc-point analysis]
+procPointAnalysis :: ProcPointSet -> CmmGraph -> LabelMap Status
+procPointAnalysis procPoints cmmGraph@(CmmGraph {g_graph = graph}) =
+ analyzeCmmFwd procPointLattice procPointTransfer cmmGraph initProcPoints
+ where
+ initProcPoints =
+ mkFactBase
+ procPointLattice
+ [ (id, ProcPoint)
+ | id <- setElems procPoints
+ -- See Note [Non-existing proc-points]
+ , id `setMember` labelsInGraph
+ ]
+ labelsInGraph = labelsDefined graph
+
+procPointTransfer :: TransferFun Status
+procPointTransfer block facts =
+ let label = entryLabel block
+ !fact = case getFact procPointLattice label facts of
+ ProcPoint -> ReachedBy $! setSingleton label
+ f -> f
+ result = map (\id -> (id, fact)) (successors block)
+ in mkFactBase procPointLattice result
+
+procPointLattice :: DataflowLattice Status
+procPointLattice = DataflowLattice unreached add_to
+ where
+ unreached = ReachedBy setEmpty
+ add_to (OldFact ProcPoint) _ = NotChanged ProcPoint
+ add_to _ (NewFact ProcPoint) = Changed ProcPoint -- because of previous case
+ add_to (OldFact (ReachedBy p)) (NewFact (ReachedBy p'))
+ | setSize union > setSize p = Changed (ReachedBy union)
+ | otherwise = NotChanged (ReachedBy p)
+ where
+ union = setUnion p' p
+
+----------------------------------------------------------------------
+
+-- It is worth distinguishing two sets of proc points: those that are
+-- induced by calls in the original graph and those that are
+-- introduced because they're reachable from multiple proc points.
+--
+-- Extract the set of Continuation BlockIds, see Note [Continuation BlockIds].
+callProcPoints :: CmmGraph -> ProcPointSet
+callProcPoints g = foldGraphBlocks add (setSingleton (g_entry g)) g
+ where add :: CmmBlock -> LabelSet -> LabelSet
+ add b set = case lastNode b of
+ CmmCall {cml_cont = Just k} -> setInsert k set
+ CmmForeignCall {succ=k} -> setInsert k set
+ _ -> set
+
+minimalProcPointSet :: Platform -> ProcPointSet -> CmmGraph
+ -> UniqSM ProcPointSet
+-- Given the set of successors of calls (which must be proc-points)
+-- figure out the minimal set of necessary proc-points
+minimalProcPointSet platform callProcPoints g
+ = extendPPSet platform g (postorderDfs g) callProcPoints
+
+extendPPSet
+ :: Platform -> CmmGraph -> [CmmBlock] -> ProcPointSet -> UniqSM ProcPointSet
+extendPPSet platform g blocks procPoints =
+ let env = procPointAnalysis procPoints g
+ add block pps = let id = entryLabel block
+ in case mapLookup id env of
+ Just ProcPoint -> setInsert id pps
+ _ -> pps
+ procPoints' = foldGraphBlocks add setEmpty g
+ newPoints = mapMaybe ppSuccessor blocks
+ newPoint = listToMaybe newPoints
+ ppSuccessor b =
+ let nreached id = case mapLookup id env `orElse`
+ pprPanic "no ppt" (ppr id <+> ppr b) of
+ ProcPoint -> 1
+ ReachedBy ps -> setSize ps
+ block_procpoints = nreached (entryLabel b)
+ -- | Looking for a successor of b that is reached by
+ -- more proc points than b and is not already a proc
+ -- point. If found, it can become a proc point.
+ newId succ_id = not (setMember succ_id procPoints') &&
+ nreached succ_id > block_procpoints
+ in listToMaybe $ filter newId $ successors b
+
+ in case newPoint of
+ Just id ->
+ if setMember id procPoints'
+ then panic "added old proc pt"
+ else extendPPSet platform g blocks (setInsert id procPoints')
+ Nothing -> return procPoints'
+
+
+-- At this point, we have found a set of procpoints, each of which should be
+-- the entry point of a procedure.
+-- Now, we create the procedure for each proc point,
+-- which requires that we:
+-- 1. build a map from proc points to the blocks reachable from the proc point
+-- 2. turn each branch to a proc point into a jump
+-- 3. turn calls and returns into jumps
+-- 4. build info tables for the procedures -- and update the info table for
+-- the SRTs in the entry procedure as well.
+-- Input invariant: A block should only be reachable from a single ProcPoint.
+-- ToDo: use the _ret naming convention that the old code generator
+-- used. -- EZY
+splitAtProcPoints :: DynFlags -> CLabel -> ProcPointSet-> ProcPointSet -> LabelMap Status ->
+ CmmDecl -> UniqSM [CmmDecl]
+splitAtProcPoints dflags entry_label callPPs procPoints procMap
+ (CmmProc (TopInfo {info_tbls = info_tbls})
+ top_l _ g@(CmmGraph {g_entry=entry})) =
+ do -- Build a map from procpoints to the blocks they reach
+ let addBlock
+ :: CmmBlock
+ -> LabelMap (LabelMap CmmBlock)
+ -> LabelMap (LabelMap CmmBlock)
+ addBlock b graphEnv =
+ case mapLookup bid procMap of
+ Just ProcPoint -> add graphEnv bid bid b
+ Just (ReachedBy set) ->
+ case setElems set of
+ [] -> graphEnv
+ [id] -> add graphEnv id bid b
+ _ -> panic "Each block should be reachable from only one ProcPoint"
+ Nothing -> graphEnv
+ where bid = entryLabel b
+ add graphEnv procId bid b = mapInsert procId graph' graphEnv
+ where graph = mapLookup procId graphEnv `orElse` mapEmpty
+ graph' = mapInsert bid b graph
+
+ let liveness = cmmGlobalLiveness dflags g
+ let ppLiveness pp = filter isArgReg $
+ regSetToList $
+ expectJust "ppLiveness" $ mapLookup pp liveness
+
+ graphEnv <- return $ foldGraphBlocks addBlock mapEmpty g
+
+ -- Build a map from proc point BlockId to pairs of:
+ -- * Labels for their new procedures
+ -- * Labels for the info tables of their new procedures (only if
+ -- the proc point is a callPP)
+ -- Due to common blockification, we may overestimate the set of procpoints.
+ let add_label map pp = mapInsert pp lbls map
+ where lbls | pp == entry = (entry_label, fmap cit_lbl (mapLookup entry info_tbls))
+ | otherwise = (block_lbl, guard (setMember pp callPPs) >>
+ Just (toInfoLbl block_lbl))
+ where block_lbl = blockLbl pp
+
+ procLabels :: LabelMap (CLabel, Maybe CLabel)
+ procLabels = foldl add_label mapEmpty
+ (filter (flip mapMember (toBlockMap g)) (setElems procPoints))
+
+ -- In each new graph, add blocks jumping off to the new procedures,
+ -- and replace branches to procpoints with branches to the jump-off blocks
+ let add_jump_block
+ :: (LabelMap Label, [CmmBlock])
+ -> (Label, CLabel)
+ -> UniqSM (LabelMap Label, [CmmBlock])
+ add_jump_block (env, bs) (pp, l) =
+ do bid <- liftM mkBlockId getUniqueM
+ let b = blockJoin (CmmEntry bid GlobalScope) emptyBlock jump
+ live = ppLiveness pp
+ jump = CmmCall (CmmLit (CmmLabel l)) Nothing live 0 0 0
+ return (mapInsert pp bid env, b : bs)
+
+ add_jumps
+ :: LabelMap CmmGraph
+ -> (Label, LabelMap CmmBlock)
+ -> UniqSM (LabelMap CmmGraph)
+ add_jumps newGraphEnv (ppId, blockEnv) =
+ do let needed_jumps = -- find which procpoints we currently branch to
+ mapFold add_if_branch_to_pp [] blockEnv
+ add_if_branch_to_pp :: CmmBlock -> [(BlockId, CLabel)] -> [(BlockId, CLabel)]
+ add_if_branch_to_pp block rst =
+ case lastNode block of
+ CmmBranch id -> add_if_pp id rst
+ CmmCondBranch _ ti fi _ -> add_if_pp ti (add_if_pp fi rst)
+ CmmSwitch _ ids -> foldr add_if_pp rst $ switchTargetsToList ids
+ _ -> rst
+
+ -- when jumping to a PP that has an info table, if
+ -- tablesNextToCode is off we must jump to the entry
+ -- label instead.
+ jump_label (Just info_lbl) _
+ | tablesNextToCode dflags = info_lbl
+ | otherwise = toEntryLbl info_lbl
+ jump_label Nothing block_lbl = block_lbl
+
+ add_if_pp id rst = case mapLookup id procLabels of
+ Just (lbl, mb_info_lbl) -> (id, jump_label mb_info_lbl lbl) : rst
+ Nothing -> rst
+ (jumpEnv, jumpBlocks) <-
+ foldM add_jump_block (mapEmpty, []) needed_jumps
+ -- update the entry block
+ let b = expectJust "block in env" $ mapLookup ppId blockEnv
+ blockEnv' = mapInsert ppId b blockEnv
+ -- replace branches to procpoints with branches to jumps
+ blockEnv'' = toBlockMap $ replaceBranches jumpEnv $ ofBlockMap ppId blockEnv'
+ -- add the jump blocks to the graph
+ blockEnv''' = foldl (flip insertBlock) blockEnv'' jumpBlocks
+ let g' = ofBlockMap ppId blockEnv'''
+ -- pprTrace "g' pre jumps" (ppr g') $ do
+ return (mapInsert ppId g' newGraphEnv)
+
+ graphEnv <- foldM add_jumps mapEmpty $ mapToList graphEnv
+
+ let to_proc (bid, g)
+ | bid == entry
+ = CmmProc (TopInfo {info_tbls = info_tbls,
+ stack_info = stack_info})
+ top_l live g'
+ | otherwise
+ = case expectJust "pp label" $ mapLookup bid procLabels of
+ (lbl, Just info_lbl)
+ -> CmmProc (TopInfo { info_tbls = mapSingleton (g_entry g) (mkEmptyContInfoTable info_lbl)
+ , stack_info=stack_info})
+ lbl live g'
+ (lbl, Nothing)
+ -> CmmProc (TopInfo {info_tbls = mapEmpty, stack_info=stack_info})
+ lbl live g'
+ where
+ g' = replacePPIds g
+ live = ppLiveness (g_entry g')
+ stack_info = StackInfo { arg_space = 0
+ , updfr_space = Nothing
+ , do_layout = True }
+ -- cannot use panic, this is printed by -ddump-cmm
+
+ -- References to procpoint IDs can now be replaced with the
+ -- infotable's label
+ replacePPIds g = {-# SCC "replacePPIds" #-}
+ mapGraphNodes (id, mapExp repl, mapExp repl) g
+ where repl e@(CmmLit (CmmBlock bid)) =
+ case mapLookup bid procLabels of
+ Just (_, Just info_lbl) -> CmmLit (CmmLabel info_lbl)
+ _ -> e
+ repl e = e
+
+ -- The C back end expects to see return continuations before the
+ -- call sites. Here, we sort them in reverse order -- it gets
+ -- reversed later.
+ let (_, block_order) =
+ foldl add_block_num (0::Int, mapEmpty :: LabelMap Int)
+ (postorderDfs g)
+ add_block_num (i, map) block = (i+1, mapInsert (entryLabel block) i map)
+ sort_fn (bid, _) (bid', _) =
+ compare (expectJust "block_order" $ mapLookup bid block_order)
+ (expectJust "block_order" $ mapLookup bid' block_order)
+ procs <- return $ map to_proc $ sortBy sort_fn $ mapToList graphEnv
+ return -- pprTrace "procLabels" (ppr procLabels)
+ -- pprTrace "splitting graphs" (ppr procs)
+ procs
+splitAtProcPoints _ _ _ _ _ t@(CmmData _ _) = return [t]
+
+-- Only called from CmmProcPoint.splitAtProcPoints. NB. does a
+-- recursive lookup, see comment below.
+replaceBranches :: LabelMap BlockId -> CmmGraph -> CmmGraph
+replaceBranches env cmmg
+ = {-# SCC "replaceBranches" #-}
+ ofBlockMap (g_entry cmmg) $ mapMap f $ toBlockMap cmmg
+ where
+ f block = replaceLastNode block $ last (lastNode block)
+
+ last :: CmmNode O C -> CmmNode O C
+ last (CmmBranch id) = CmmBranch (lookup id)
+ last (CmmCondBranch e ti fi l) = CmmCondBranch e (lookup ti) (lookup fi) l
+ last (CmmSwitch e ids) = CmmSwitch e (mapSwitchTargets lookup ids)
+ last l@(CmmCall {}) = l { cml_cont = Nothing }
+ -- NB. remove the continuation of a CmmCall, since this
+ -- label will now be in a different CmmProc. Not only
+ -- is this tidier, it stops CmmLint from complaining.
+ last l@(CmmForeignCall {}) = l
+ lookup id = fmap lookup (mapLookup id env) `orElse` id
+ -- XXX: this is a recursive lookup, it follows chains
+ -- until the lookup returns Nothing, at which point we
+ -- return the last BlockId
+
+-- --------------------------------------------------------------
+-- Not splitting proc points: add info tables for continuations
+
+attachContInfoTables :: ProcPointSet -> CmmDecl -> CmmDecl
+attachContInfoTables call_proc_points (CmmProc top_info top_l live g)
+ = CmmProc top_info{info_tbls = info_tbls'} top_l live g
+ where
+ info_tbls' = mapUnion (info_tbls top_info) $
+ mapFromList [ (l, mkEmptyContInfoTable (infoTblLbl l))
+ | l <- setElems call_proc_points
+ , l /= g_entry g ]
+attachContInfoTables _ other_decl
+ = other_decl
+
+----------------------------------------------------------------
+
+{-
+Note [Direct reachability]
+
+Block B is directly reachable from proc point P iff control can flow
+from P to B without passing through an intervening proc point.
+-}
+
+----------------------------------------------------------------
+
+{-
+Note [No simple dataflow]
+
+Sadly, it seems impossible to compute the proc points using a single
+dataflow pass. One might attempt to use this simple lattice:
+
+ data Location = Unknown
+ | InProc BlockId -- node is in procedure headed by the named proc point
+ | ProcPoint -- node is itself a proc point
+
+At a join, a node in two different blocks becomes a proc point.
+The difficulty is that the change of information during iterative
+computation may promote a node prematurely. Here's a program that
+illustrates the difficulty:
+
+ f () {
+ entry:
+ ....
+ L1:
+ if (...) { ... }
+ else { ... }
+
+ L2: if (...) { g(); goto L1; }
+ return x + y;
+ }
+
+The only proc-point needed (besides the entry) is L1. But in an
+iterative analysis, consider what happens to L2. On the first pass
+through, it rises from Unknown to 'InProc entry', but when L1 is
+promoted to a proc point (because it's the successor of g()), L1's
+successors will be promoted to 'InProc L1'. The problem hits when the
+new fact 'InProc L1' flows into L2 which is already bound to 'InProc entry'.
+The join operation makes it a proc point when in fact it needn't be,
+because its immediate dominator L1 is already a proc point and there
+are no other proc points that directly reach L2.
+-}
+
+
+
+{- Note [Separate Adams optimization]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+It may be worthwhile to attempt the Adams optimization by rewriting
+the graph before the assignment of proc-point protocols. Here are a
+couple of rules:
+
+ g() returns to k; g() returns to L;
+ k: CopyIn c ress; goto L:
+ ... ==> ...
+ L: // no CopyIn node here L: CopyIn c ress;
+
+
+And when c == c' and ress == ress', this also:
+
+ g() returns to k; g() returns to L;
+ k: CopyIn c ress; goto L:
+ ... ==> ...
+ L: CopyIn c' ress' L: CopyIn c' ress' ;
+
+In both cases the goal is to eliminate k.
+-}
diff --git a/cmm/CmmSink.hs b/cmm/CmmSink.hs
new file mode 100644
--- /dev/null
+++ b/cmm/CmmSink.hs
@@ -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 -- [Sp+n]
+ {-# UNPACK #-} !Int
+ {-# UNPACK #-} !Int
+
+-- Having SpMem is important because it lets us float loads from Sp
+-- past stores to Sp as long as they don't overlap, and this helps to
+-- unravel some long sequences of
+-- x1 = [Sp + 8]
+-- x2 = [Sp + 16]
+-- ...
+-- [Sp + 8] = xi
+-- [Sp + 16] = xj
+--
+-- Note that SpMem is invalidated if Sp is changed, but the definition
+-- of 'conflicts' above handles that.
+
+-- ToDo: this won't currently fix the following commonly occurring code:
+-- x1 = [R1 + 8]
+-- x2 = [R1 + 16]
+-- ..
+-- [Hp - 8] = x1
+-- [Hp - 16] = x2
+-- ..
+
+-- because [R1 + 8] and [Hp - 8] are both HeapMem. We know that
+-- assignments to [Hp + n] do not conflict with any other heap memory,
+-- but this is tricky to nail down. What if we had
+--
+-- x = Hp + n
+-- [x] = ...
+--
+-- the store to [x] should be "new heap", not "old heap".
+-- Furthermore, you could imagine that if we started inlining
+-- functions in Cmm then there might well be reads of heap memory
+-- that was written in the same basic block. To take advantage of
+-- non-aliasing of heap memory we will have to be more clever.
+
+-- Note [Foreign calls clobber heap]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- It is tempting to say that foreign calls clobber only
+-- non-heap/stack memory, but unfortunately we break this invariant in
+-- the RTS. For example, in stg_catch_retry_frame we call
+-- stmCommitNestedTransaction() which modifies the contents of the
+-- TRec it is passed (this actually caused incorrect code to be
+-- generated).
+--
+-- Since the invariant is true for the majority of foreign calls,
+-- perhaps we ought to have a special annotation for calls that can
+-- modify heap/stack memory. For now we just use the conservative
+-- definition here.
+--
+-- Some CallishMachOp imply a memory barrier e.g. AtomicRMW and
+-- therefore we should never float any memory operations across one of
+-- these calls.
+
+
+bothMems :: AbsMem -> AbsMem -> AbsMem
+bothMems NoMem x = x
+bothMems x NoMem = x
+bothMems HeapMem HeapMem = HeapMem
+bothMems StackMem StackMem = StackMem
+bothMems (SpMem o1 w1) (SpMem o2 w2)
+ | o1 == o2 = SpMem o1 (max w1 w2)
+ | otherwise = StackMem
+bothMems SpMem{} StackMem = StackMem
+bothMems StackMem SpMem{} = StackMem
+bothMems _ _ = AnyMem
+
+memConflicts :: AbsMem -> AbsMem -> Bool
+memConflicts NoMem _ = False
+memConflicts _ NoMem = False
+memConflicts HeapMem StackMem = False
+memConflicts StackMem HeapMem = False
+memConflicts SpMem{} HeapMem = False
+memConflicts HeapMem SpMem{} = False
+memConflicts (SpMem o1 w1) (SpMem o2 w2)
+ | o1 < o2 = o1 + w1 > o2
+ | otherwise = o2 + w2 > o1
+memConflicts _ _ = True
+
+exprMem :: DynFlags -> CmmExpr -> AbsMem
+exprMem dflags (CmmLoad addr w) = bothMems (loadAddr dflags addr (typeWidth w)) (exprMem dflags addr)
+exprMem dflags (CmmMachOp _ es) = foldr bothMems NoMem (map (exprMem dflags) es)
+exprMem _ _ = NoMem
+
+loadAddr :: DynFlags -> CmmExpr -> Width -> AbsMem
+loadAddr dflags e w =
+ case e of
+ CmmReg r -> regAddr dflags r 0 w
+ CmmRegOff r i -> regAddr dflags r i w
+ _other | regUsedIn dflags (CmmGlobal Sp) e -> StackMem
+ | otherwise -> AnyMem
+
+regAddr :: DynFlags -> CmmReg -> Int -> Width -> AbsMem
+regAddr _ (CmmGlobal Sp) i w = SpMem i (widthInBytes w)
+regAddr _ (CmmGlobal Hp) _ _ = HeapMem
+regAddr _ (CmmGlobal CurrentTSO) _ _ = HeapMem -- important for PrimOps
+regAddr dflags r _ _ | isGcPtrType (cmmRegType dflags r) = HeapMem -- yay! GCPtr pays for itself
+regAddr _ _ _ _ = AnyMem
+
+{-
+Note [Inline GlobalRegs?]
+
+Should we freely inline GlobalRegs?
+
+Actually it doesn't make a huge amount of difference either way, so we
+*do* currently treat GlobalRegs as "trivial" and inline them
+everywhere, but for what it's worth, here is what I discovered when I
+(SimonM) looked into this:
+
+Common sense says we should not inline GlobalRegs, because when we
+have
+
+ x = R1
+
+the register allocator will coalesce this assignment, generating no
+code, and simply record the fact that x is bound to $rbx (or
+whatever). Furthermore, if we were to sink this assignment, then the
+range of code over which R1 is live increases, and the range of code
+over which x is live decreases. All things being equal, it is better
+for x to be live than R1, because R1 is a fixed register whereas x can
+live in any register. So we should neither sink nor inline 'x = R1'.
+
+However, not inlining GlobalRegs can have surprising
+consequences. e.g. (cgrun020)
+
+ c3EN:
+ _s3DB::P64 = R1;
+ _c3ES::P64 = _s3DB::P64 & 7;
+ if (_c3ES::P64 >= 2) goto c3EU; else goto c3EV;
+ c3EU:
+ _s3DD::P64 = P64[_s3DB::P64 + 6];
+ _s3DE::P64 = P64[_s3DB::P64 + 14];
+ I64[Sp - 8] = c3F0;
+ R1 = _s3DE::P64;
+ P64[Sp] = _s3DD::P64;
+
+inlining the GlobalReg gives:
+
+ c3EN:
+ if (R1 & 7 >= 2) goto c3EU; else goto c3EV;
+ c3EU:
+ I64[Sp - 8] = c3F0;
+ _s3DD::P64 = P64[R1 + 6];
+ R1 = P64[R1 + 14];
+ P64[Sp] = _s3DD::P64;
+
+but if we don't inline the GlobalReg, instead we get:
+
+ _s3DB::P64 = R1;
+ if (_s3DB::P64 & 7 >= 2) goto c3EU; else goto c3EV;
+ c3EU:
+ I64[Sp - 8] = c3F0;
+ R1 = P64[_s3DB::P64 + 14];
+ P64[Sp] = P64[_s3DB::P64 + 6];
+
+This looks better - we managed to inline _s3DD - but in fact it
+generates an extra reg-reg move:
+
+.Lc3EU:
+ movq $c3F0_info,-8(%rbp)
+ movq %rbx,%rax
+ movq 14(%rbx),%rbx
+ movq 6(%rax),%rax
+ movq %rax,(%rbp)
+
+because _s3DB is now live across the R1 assignment, we lost the
+benefit of coalescing.
+
+Who is at fault here? Perhaps if we knew that _s3DB was an alias for
+R1, then we would not sink a reference to _s3DB past the R1
+assignment. Or perhaps we *should* do that - we might gain by sinking
+it, despite losing the coalescing opportunity.
+
+Sometimes not inlining global registers wins by virtue of the rule
+about not inlining into arguments of a foreign call, e.g. (T7163) this
+is what happens when we inlined F1:
+
+ _s3L2::F32 = F1;
+ _c3O3::F32 = %MO_F_Mul_W32(F1, 10.0 :: W32);
+ (_s3L7::F32) = call "ccall" arg hints: [] result hints: [] rintFloat(_c3O3::F32);
+
+but if we don't inline F1:
+
+ (_s3L7::F32) = call "ccall" arg hints: [] result hints: [] rintFloat(%MO_F_Mul_W32(_s3L2::F32,
+ 10.0 :: W32));
+-}
diff --git a/cmm/CmmSwitch.hs b/cmm/CmmSwitch.hs
new file mode 100644
--- /dev/null
+++ b/cmm/CmmSwitch.hs
@@ -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.
diff --git a/cmm/CmmType.hs b/cmm/CmmType.hs
new file mode 100644
--- /dev/null
+++ b/cmm/CmmType.hs
@@ -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.
+
+-}
+
diff --git a/cmm/CmmUtils.hs b/cmm/CmmUtils.hs
new file mode 100644
--- /dev/null
+++ b/cmm/CmmUtils.hs
@@ -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
diff --git a/cmm/Debug.hs b/cmm/Debug.hs
new file mode 100644
--- /dev/null
+++ b/cmm/Debug.hs
@@ -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)
diff --git a/cmm/Hoopl.hs b/cmm/Hoopl.hs
new file mode 100644
--- /dev/null
+++ b/cmm/Hoopl.hs
@@ -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
diff --git a/cmm/Hoopl/Dataflow.hs b/cmm/Hoopl/Dataflow.hs
new file mode 100644
--- /dev/null
+++ b/cmm/Hoopl/Dataflow.hs
@@ -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
diff --git a/cmm/MkGraph.hs b/cmm/MkGraph.hs
new file mode 100644
--- /dev/null
+++ b/cmm/MkGraph.hs
@@ -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
diff --git a/cmm/PprC.hs b/cmm/PprC.hs
new file mode 100644
--- /dev/null
+++ b/cmm/PprC.hs
@@ -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
+ -- see #1861
+
+ CmmVec {} -> panic "PprC printing vector literal"
+
+ CmmBlock bid -> mkW_ <> pprCLabelAddr (infoTblLbl bid)
+ CmmHighStackMark -> panic "PprC printing high stack mark"
+ CmmLabel clbl -> mkW_ <> pprCLabelAddr clbl
+ CmmLabelOff clbl i -> mkW_ <> pprCLabelAddr clbl <> char '+' <> int i
+ CmmLabelDiffOff clbl1 _ i
+ -- WARNING:
+ -- * the lit must occur in the info table clbl2
+ -- * clbl1 must be an SRT, a slow entry point or a large bitmap
+ -> mkW_ <> pprCLabelAddr clbl1 <> char '+' <> int i
+
+ where
+ pprCLabelAddr lbl = char '&' <> ppr lbl
+
+pprLit1 :: CmmLit -> SDoc
+pprLit1 lit@(CmmLabelOff _ _) = parens (pprLit lit)
+pprLit1 lit@(CmmLabelDiffOff _ _ _) = parens (pprLit lit)
+pprLit1 lit@(CmmFloat _ _) = parens (pprLit lit)
+pprLit1 other = pprLit other
+
+-- ---------------------------------------------------------------------------
+-- Static data
+
+pprStatics :: DynFlags -> [CmmStatic] -> [SDoc]
+pprStatics _ [] = []
+pprStatics dflags (CmmStaticLit (CmmFloat f W32) : rest)
+ -- floats are padded to a word by padLitToWord, see #1852
+ | wORD_SIZE dflags == 8, CmmStaticLit (CmmInt 0 W32) : rest' <- rest
+ = pprLit1 (floatToWord dflags f) : pprStatics dflags rest'
+ | wORD_SIZE dflags == 4
+ = pprLit1 (floatToWord dflags f) : pprStatics dflags rest
+ | otherwise
+ = pprPanic "pprStatics: float" (vcat (map ppr' rest))
+ where ppr' (CmmStaticLit l) = sdocWithDynFlags $ \dflags ->
+ ppr (cmmLitType dflags l)
+ ppr' _other = text "bad static!"
+pprStatics dflags (CmmStaticLit (CmmFloat f W64) : rest)
+ = map pprLit1 (doubleToWords dflags f) ++ pprStatics dflags rest
+
+pprStatics dflags (CmmStaticLit (CmmInt i W64) : rest)
+ | wordWidth dflags == W32
+ = if wORDS_BIGENDIAN dflags
+ then pprStatics dflags (CmmStaticLit (CmmInt q W32) :
+ CmmStaticLit (CmmInt r W32) : rest)
+ else pprStatics dflags (CmmStaticLit (CmmInt r W32) :
+ CmmStaticLit (CmmInt q W32) : rest)
+ where r = i .&. 0xffffffff
+ q = i `shiftR` 32
+pprStatics dflags (CmmStaticLit (CmmInt _ w) : _)
+ | w /= wordWidth dflags
+ = panic "pprStatics: cannot emit a non-word-sized static literal"
+pprStatics dflags (CmmStaticLit lit : rest)
+ = pprLit1 lit : pprStatics dflags rest
+pprStatics _ (other : _)
+ = pprPanic "pprWord" (pprStatic other)
+
+pprStatic :: CmmStatic -> SDoc
+pprStatic s = case s of
+
+ CmmStaticLit lit -> nest 4 (pprLit lit)
+ CmmUninitialised i -> nest 4 (mkC_ <> brackets (int i))
+
+ -- these should be inlined, like the old .hc
+ CmmString s' -> nest 4 (mkW_ <> parens(pprStringInCStyle s'))
+
+
+-- ---------------------------------------------------------------------------
+-- Block Ids
+
+pprBlockId :: BlockId -> SDoc
+pprBlockId b = char '_' <> ppr (getUnique b)
+
+-- --------------------------------------------------------------------------
+-- Print a MachOp in a way suitable for emitting via C.
+--
+
+pprMachOp_for_C :: MachOp -> SDoc
+
+pprMachOp_for_C mop = case mop of
+
+ -- Integer operations
+ MO_Add _ -> char '+'
+ MO_Sub _ -> char '-'
+ MO_Eq _ -> text "=="
+ MO_Ne _ -> text "!="
+ MO_Mul _ -> char '*'
+
+ MO_S_Quot _ -> char '/'
+ MO_S_Rem _ -> char '%'
+ MO_S_Neg _ -> char '-'
+
+ MO_U_Quot _ -> char '/'
+ MO_U_Rem _ -> char '%'
+
+ -- & Floating-point operations
+ MO_F_Add _ -> char '+'
+ MO_F_Sub _ -> char '-'
+ MO_F_Neg _ -> char '-'
+ MO_F_Mul _ -> char '*'
+ MO_F_Quot _ -> char '/'
+
+ -- Signed comparisons
+ MO_S_Ge _ -> text ">="
+ MO_S_Le _ -> text "<="
+ MO_S_Gt _ -> char '>'
+ MO_S_Lt _ -> char '<'
+
+ -- & Unsigned comparisons
+ MO_U_Ge _ -> text ">="
+ MO_U_Le _ -> text "<="
+ MO_U_Gt _ -> char '>'
+ MO_U_Lt _ -> char '<'
+
+ -- & Floating-point comparisons
+ MO_F_Eq _ -> text "=="
+ MO_F_Ne _ -> text "!="
+ MO_F_Ge _ -> text ">="
+ MO_F_Le _ -> text "<="
+ MO_F_Gt _ -> char '>'
+ MO_F_Lt _ -> char '<'
+
+ -- Bitwise operations. Not all of these may be supported at all
+ -- sizes, and only integral MachReps are valid.
+ MO_And _ -> char '&'
+ MO_Or _ -> char '|'
+ MO_Xor _ -> char '^'
+ MO_Not _ -> char '~'
+ MO_Shl _ -> text "<<"
+ MO_U_Shr _ -> text ">>" -- unsigned shift right
+ MO_S_Shr _ -> text ">>" -- signed shift right
+
+-- Conversions. Some of these will be NOPs, but never those that convert
+-- between ints and floats.
+-- Floating-point conversions use the signed variant.
+-- We won't know to generate (void*) casts here, but maybe from
+-- context elsewhere
+
+-- noop casts
+ MO_UU_Conv from to | from == to -> empty
+ MO_UU_Conv _from to -> parens (machRep_U_CType to)
+
+ MO_SS_Conv from to | from == to -> empty
+ MO_SS_Conv _from to -> parens (machRep_S_CType to)
+
+ MO_FF_Conv from to | from == to -> empty
+ MO_FF_Conv _from to -> parens (machRep_F_CType to)
+
+ MO_SF_Conv _from to -> parens (machRep_F_CType to)
+ MO_FS_Conv _from to -> parens (machRep_S_CType to)
+
+ MO_S_MulMayOflo _ -> pprTrace "offending mop:"
+ (text "MO_S_MulMayOflo")
+ (panic $ "PprC.pprMachOp_for_C: MO_S_MulMayOflo"
+ ++ " should have been handled earlier!")
+ MO_U_MulMayOflo _ -> pprTrace "offending mop:"
+ (text "MO_U_MulMayOflo")
+ (panic $ "PprC.pprMachOp_for_C: MO_U_MulMayOflo"
+ ++ " should have been handled earlier!")
+
+ MO_V_Insert {} -> pprTrace "offending mop:"
+ (text "MO_V_Insert")
+ (panic $ "PprC.pprMachOp_for_C: MO_V_Insert"
+ ++ " should have been handled earlier!")
+ MO_V_Extract {} -> pprTrace "offending mop:"
+ (text "MO_V_Extract")
+ (panic $ "PprC.pprMachOp_for_C: MO_V_Extract"
+ ++ " should have been handled earlier!")
+
+ MO_V_Add {} -> pprTrace "offending mop:"
+ (text "MO_V_Add")
+ (panic $ "PprC.pprMachOp_for_C: MO_V_Add"
+ ++ " should have been handled earlier!")
+ MO_V_Sub {} -> pprTrace "offending mop:"
+ (text "MO_V_Sub")
+ (panic $ "PprC.pprMachOp_for_C: MO_V_Sub"
+ ++ " should have been handled earlier!")
+ MO_V_Mul {} -> pprTrace "offending mop:"
+ (text "MO_V_Mul")
+ (panic $ "PprC.pprMachOp_for_C: MO_V_Mul"
+ ++ " should have been handled earlier!")
+
+ MO_VS_Quot {} -> pprTrace "offending mop:"
+ (text "MO_VS_Quot")
+ (panic $ "PprC.pprMachOp_for_C: MO_VS_Quot"
+ ++ " should have been handled earlier!")
+ MO_VS_Rem {} -> pprTrace "offending mop:"
+ (text "MO_VS_Rem")
+ (panic $ "PprC.pprMachOp_for_C: MO_VS_Rem"
+ ++ " should have been handled earlier!")
+ MO_VS_Neg {} -> pprTrace "offending mop:"
+ (text "MO_VS_Neg")
+ (panic $ "PprC.pprMachOp_for_C: MO_VS_Neg"
+ ++ " should have been handled earlier!")
+
+ MO_VU_Quot {} -> pprTrace "offending mop:"
+ (text "MO_VU_Quot")
+ (panic $ "PprC.pprMachOp_for_C: MO_VU_Quot"
+ ++ " should have been handled earlier!")
+ MO_VU_Rem {} -> pprTrace "offending mop:"
+ (text "MO_VU_Rem")
+ (panic $ "PprC.pprMachOp_for_C: MO_VU_Rem"
+ ++ " should have been handled earlier!")
+
+ MO_VF_Insert {} -> pprTrace "offending mop:"
+ (text "MO_VF_Insert")
+ (panic $ "PprC.pprMachOp_for_C: MO_VF_Insert"
+ ++ " should have been handled earlier!")
+ MO_VF_Extract {} -> pprTrace "offending mop:"
+ (text "MO_VF_Extract")
+ (panic $ "PprC.pprMachOp_for_C: MO_VF_Extract"
+ ++ " should have been handled earlier!")
+
+ MO_VF_Add {} -> pprTrace "offending mop:"
+ (text "MO_VF_Add")
+ (panic $ "PprC.pprMachOp_for_C: MO_VF_Add"
+ ++ " should have been handled earlier!")
+ MO_VF_Sub {} -> pprTrace "offending mop:"
+ (text "MO_VF_Sub")
+ (panic $ "PprC.pprMachOp_for_C: MO_VF_Sub"
+ ++ " should have been handled earlier!")
+ MO_VF_Neg {} -> pprTrace "offending mop:"
+ (text "MO_VF_Neg")
+ (panic $ "PprC.pprMachOp_for_C: MO_VF_Neg"
+ ++ " should have been handled earlier!")
+ MO_VF_Mul {} -> pprTrace "offending mop:"
+ (text "MO_VF_Mul")
+ (panic $ "PprC.pprMachOp_for_C: MO_VF_Mul"
+ ++ " should have been handled earlier!")
+ MO_VF_Quot {} -> pprTrace "offending mop:"
+ (text "MO_VF_Quot")
+ (panic $ "PprC.pprMachOp_for_C: MO_VF_Quot"
+ ++ " should have been handled earlier!")
+
+signedOp :: MachOp -> Bool -- Argument type(s) are signed ints
+signedOp (MO_S_Quot _) = True
+signedOp (MO_S_Rem _) = True
+signedOp (MO_S_Neg _) = True
+signedOp (MO_S_Ge _) = True
+signedOp (MO_S_Le _) = True
+signedOp (MO_S_Gt _) = True
+signedOp (MO_S_Lt _) = True
+signedOp (MO_S_Shr _) = True
+signedOp (MO_SS_Conv _ _) = True
+signedOp (MO_SF_Conv _ _) = True
+signedOp _ = False
+
+floatComparison :: MachOp -> Bool -- comparison between float args
+floatComparison (MO_F_Eq _) = True
+floatComparison (MO_F_Ne _) = True
+floatComparison (MO_F_Ge _) = True
+floatComparison (MO_F_Le _) = True
+floatComparison (MO_F_Gt _) = True
+floatComparison (MO_F_Lt _) = True
+floatComparison _ = False
+
+-- ---------------------------------------------------------------------
+-- tend to be implemented by foreign calls
+
+pprCallishMachOp_for_C :: CallishMachOp -> SDoc
+
+pprCallishMachOp_for_C mop
+ = case mop of
+ MO_F64_Pwr -> text "pow"
+ MO_F64_Sin -> text "sin"
+ MO_F64_Cos -> text "cos"
+ MO_F64_Tan -> text "tan"
+ MO_F64_Sinh -> text "sinh"
+ MO_F64_Cosh -> text "cosh"
+ MO_F64_Tanh -> text "tanh"
+ MO_F64_Asin -> text "asin"
+ MO_F64_Acos -> text "acos"
+ MO_F64_Atan -> text "atan"
+ MO_F64_Log -> text "log"
+ MO_F64_Exp -> text "exp"
+ MO_F64_Sqrt -> text "sqrt"
+ MO_F64_Fabs -> text "fabs"
+ MO_F32_Pwr -> text "powf"
+ MO_F32_Sin -> text "sinf"
+ MO_F32_Cos -> text "cosf"
+ MO_F32_Tan -> text "tanf"
+ MO_F32_Sinh -> text "sinhf"
+ MO_F32_Cosh -> text "coshf"
+ MO_F32_Tanh -> text "tanhf"
+ MO_F32_Asin -> text "asinf"
+ MO_F32_Acos -> text "acosf"
+ MO_F32_Atan -> text "atanf"
+ MO_F32_Log -> text "logf"
+ MO_F32_Exp -> text "expf"
+ MO_F32_Sqrt -> text "sqrtf"
+ MO_F32_Fabs -> text "fabsf"
+ MO_WriteBarrier -> text "write_barrier"
+ MO_Memcpy _ -> text "memcpy"
+ MO_Memset _ -> text "memset"
+ MO_Memmove _ -> text "memmove"
+ (MO_BSwap w) -> ptext (sLit $ bSwapLabel w)
+ (MO_PopCnt w) -> ptext (sLit $ popCntLabel w)
+ (MO_Clz w) -> ptext (sLit $ clzLabel w)
+ (MO_Ctz w) -> ptext (sLit $ ctzLabel w)
+ (MO_AtomicRMW w amop) -> ptext (sLit $ atomicRMWLabel w amop)
+ (MO_Cmpxchg w) -> ptext (sLit $ cmpxchgLabel w)
+ (MO_AtomicRead w) -> ptext (sLit $ atomicReadLabel w)
+ (MO_AtomicWrite w) -> ptext (sLit $ atomicWriteLabel w)
+ (MO_UF_Conv w) -> ptext (sLit $ word2FloatLabel w)
+
+ MO_S_QuotRem {} -> unsupported
+ MO_U_QuotRem {} -> unsupported
+ MO_U_QuotRem2 {} -> unsupported
+ MO_Add2 {} -> unsupported
+ MO_SubWordC {} -> unsupported
+ MO_AddIntC {} -> unsupported
+ MO_SubIntC {} -> unsupported
+ MO_U_Mul2 {} -> unsupported
+ MO_Touch -> unsupported
+ (MO_Prefetch_Data _ ) -> unsupported
+ --- we could support prefetch via "__builtin_prefetch"
+ --- Not adding it for now
+ where unsupported = panic ("pprCallishMachOp_for_C: " ++ show mop
+ ++ " not supported!")
+
+-- ---------------------------------------------------------------------
+-- Useful #defines
+--
+
+mkJMP_, mkFN_, mkIF_ :: SDoc -> SDoc
+
+mkJMP_ i = text "JMP_" <> parens i
+mkFN_ i = text "FN_" <> parens i -- externally visible function
+mkIF_ i = text "IF_" <> parens i -- locally visible
+
+-- from includes/Stg.h
+--
+mkC_,mkW_,mkP_ :: SDoc
+
+mkC_ = text "(C_)" -- StgChar
+mkW_ = text "(W_)" -- StgWord
+mkP_ = text "(P_)" -- StgWord*
+
+-- ---------------------------------------------------------------------
+--
+-- Assignments
+--
+-- Generating assignments is what we're all about, here
+--
+pprAssign :: DynFlags -> CmmReg -> CmmExpr -> SDoc
+
+-- dest is a reg, rhs is a reg
+pprAssign _ r1 (CmmReg r2)
+ | isPtrReg r1 && isPtrReg r2
+ = hcat [ pprAsPtrReg r1, equals, pprAsPtrReg r2, semi ]
+
+-- dest is a reg, rhs is a CmmRegOff
+pprAssign dflags r1 (CmmRegOff r2 off)
+ | isPtrReg r1 && isPtrReg r2 && (off `rem` wORD_SIZE dflags == 0)
+ = hcat [ pprAsPtrReg r1, equals, pprAsPtrReg r2, op, int off', semi ]
+ where
+ off1 = off `shiftR` wordShift dflags
+
+ (op,off') | off >= 0 = (char '+', off1)
+ | otherwise = (char '-', -off1)
+
+-- dest is a reg, rhs is anything.
+-- We can't cast the lvalue, so we have to cast the rhs if necessary. Casting
+-- the lvalue elicits a warning from new GCC versions (3.4+).
+pprAssign _ r1 r2
+ | isFixedPtrReg r1 = mkAssign (mkP_ <> pprExpr1 r2)
+ | Just ty <- strangeRegType r1 = mkAssign (parens ty <> pprExpr1 r2)
+ | otherwise = mkAssign (pprExpr r2)
+ where mkAssign x = if r1 == CmmGlobal BaseReg
+ then text "ASSIGN_BaseReg" <> parens x <> semi
+ else pprReg r1 <> text " = " <> x <> semi
+
+-- ---------------------------------------------------------------------
+-- Registers
+
+pprCastReg :: CmmReg -> SDoc
+pprCastReg reg
+ | isStrangeTypeReg reg = mkW_ <> pprReg reg
+ | otherwise = pprReg reg
+
+-- True if (pprReg reg) will give an expression with type StgPtr. We
+-- need to take care with pointer arithmetic on registers with type
+-- StgPtr.
+isFixedPtrReg :: CmmReg -> Bool
+isFixedPtrReg (CmmLocal _) = False
+isFixedPtrReg (CmmGlobal r) = isFixedPtrGlobalReg r
+
+-- True if (pprAsPtrReg reg) will give an expression with type StgPtr
+-- JD: THIS IS HORRIBLE AND SHOULD BE RENAMED, AT THE VERY LEAST.
+-- THE GARBAGE WITH THE VNonGcPtr HELPS MATCH THE OLD CODE GENERATOR'S OUTPUT;
+-- I'M NOT SURE IF IT SHOULD REALLY STAY THAT WAY.
+isPtrReg :: CmmReg -> Bool
+isPtrReg (CmmLocal _) = False
+isPtrReg (CmmGlobal (VanillaReg _ VGcPtr)) = True -- if we print via pprAsPtrReg
+isPtrReg (CmmGlobal (VanillaReg _ VNonGcPtr)) = False -- if we print via pprAsPtrReg
+isPtrReg (CmmGlobal reg) = isFixedPtrGlobalReg reg
+
+-- True if this global reg has type StgPtr
+isFixedPtrGlobalReg :: GlobalReg -> Bool
+isFixedPtrGlobalReg Sp = True
+isFixedPtrGlobalReg Hp = True
+isFixedPtrGlobalReg HpLim = True
+isFixedPtrGlobalReg SpLim = True
+isFixedPtrGlobalReg _ = False
+
+-- True if in C this register doesn't have the type given by
+-- (machRepCType (cmmRegType reg)), so it has to be cast.
+isStrangeTypeReg :: CmmReg -> Bool
+isStrangeTypeReg (CmmLocal _) = False
+isStrangeTypeReg (CmmGlobal g) = isStrangeTypeGlobal g
+
+isStrangeTypeGlobal :: GlobalReg -> Bool
+isStrangeTypeGlobal CCCS = True
+isStrangeTypeGlobal CurrentTSO = True
+isStrangeTypeGlobal CurrentNursery = True
+isStrangeTypeGlobal BaseReg = True
+isStrangeTypeGlobal r = isFixedPtrGlobalReg r
+
+strangeRegType :: CmmReg -> Maybe SDoc
+strangeRegType (CmmGlobal CCCS) = Just (text "struct CostCentreStack_ *")
+strangeRegType (CmmGlobal CurrentTSO) = Just (text "struct StgTSO_ *")
+strangeRegType (CmmGlobal CurrentNursery) = Just (text "struct bdescr_ *")
+strangeRegType (CmmGlobal BaseReg) = Just (text "struct StgRegTable_ *")
+strangeRegType _ = Nothing
+
+-- pprReg just prints the register name.
+--
+pprReg :: CmmReg -> SDoc
+pprReg r = case r of
+ CmmLocal local -> pprLocalReg local
+ CmmGlobal global -> pprGlobalReg global
+
+pprAsPtrReg :: CmmReg -> SDoc
+pprAsPtrReg (CmmGlobal (VanillaReg n gcp))
+ = WARN( gcp /= VGcPtr, ppr n ) char 'R' <> int n <> text ".p"
+pprAsPtrReg other_reg = pprReg other_reg
+
+pprGlobalReg :: GlobalReg -> SDoc
+pprGlobalReg gr = case gr of
+ VanillaReg n _ -> char 'R' <> int n <> text ".w"
+ -- pprGlobalReg prints a VanillaReg as a .w regardless
+ -- Example: R1.w = R1.w & (-0x8UL);
+ -- JMP_(*R1.p);
+ FloatReg n -> char 'F' <> int n
+ DoubleReg n -> char 'D' <> int n
+ LongReg n -> char 'L' <> int n
+ Sp -> text "Sp"
+ SpLim -> text "SpLim"
+ Hp -> text "Hp"
+ HpLim -> text "HpLim"
+ CCCS -> text "CCCS"
+ CurrentTSO -> text "CurrentTSO"
+ CurrentNursery -> text "CurrentNursery"
+ HpAlloc -> text "HpAlloc"
+ BaseReg -> text "BaseReg"
+ EagerBlackholeInfo -> text "stg_EAGER_BLACKHOLE_info"
+ GCEnter1 -> text "stg_gc_enter_1"
+ GCFun -> text "stg_gc_fun"
+ other -> panic $ "pprGlobalReg: Unsupported register: " ++ show other
+
+pprLocalReg :: LocalReg -> SDoc
+pprLocalReg (LocalReg uniq _) = char '_' <> ppr uniq
+
+-- -----------------------------------------------------------------------------
+-- Foreign Calls
+
+pprCall :: SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual] -> SDoc
+pprCall ppr_fn cconv results args
+ | not (is_cishCC cconv)
+ = panic $ "pprCall: unknown calling convention"
+
+ | otherwise
+ =
+ ppr_assign results (ppr_fn <> parens (commafy (map pprArg args))) <> semi
+ where
+ ppr_assign [] rhs = rhs
+ ppr_assign [(one,hint)] rhs
+ = pprLocalReg one <> text " = "
+ <> pprUnHint hint (localRegType one) <> rhs
+ ppr_assign _other _rhs = panic "pprCall: multiple results"
+
+ pprArg (expr, AddrHint)
+ = cCast (text "void *") expr
+ -- see comment by machRepHintCType below
+ pprArg (expr, SignedHint)
+ = sdocWithDynFlags $ \dflags ->
+ cCast (machRep_S_CType $ typeWidth $ cmmExprType dflags expr) expr
+ pprArg (expr, _other)
+ = pprExpr expr
+
+ pprUnHint AddrHint rep = parens (machRepCType rep)
+ pprUnHint SignedHint rep = parens (machRepCType rep)
+ pprUnHint _ _ = empty
+
+-- Currently we only have these two calling conventions, but this might
+-- change in the future...
+is_cishCC :: CCallConv -> Bool
+is_cishCC CCallConv = True
+is_cishCC CApiConv = True
+is_cishCC StdCallConv = True
+is_cishCC PrimCallConv = False
+is_cishCC JavaScriptCallConv = False
+
+-- ---------------------------------------------------------------------
+-- Find and print local and external declarations for a list of
+-- Cmm statements.
+--
+pprTempAndExternDecls :: [CmmBlock] -> (SDoc{-temps-}, SDoc{-externs-})
+pprTempAndExternDecls stmts
+ = (pprUFM (getUniqSet temps) (vcat . map pprTempDecl),
+ vcat (map (pprExternDecl False{-ToDo-}) (Map.keys lbls)))
+ where (temps, lbls) = runTE (mapM_ te_BB stmts)
+
+pprDataExterns :: [CmmStatic] -> SDoc
+pprDataExterns statics
+ = vcat (map (pprExternDecl False{-ToDo-}) (Map.keys lbls))
+ where (_, lbls) = runTE (mapM_ te_Static statics)
+
+pprTempDecl :: LocalReg -> SDoc
+pprTempDecl l@(LocalReg _ rep)
+ = hcat [ machRepCType rep, space, pprLocalReg l, semi ]
+
+pprExternDecl :: Bool -> CLabel -> SDoc
+pprExternDecl _in_srt lbl
+ -- do not print anything for "known external" things
+ | not (needsCDecl lbl) = empty
+ | Just sz <- foreignLabelStdcallInfo lbl = stdcall_decl sz
+ | otherwise =
+ hcat [ visibility, label_type lbl,
+ lparen, ppr lbl, text ");" ]
+ where
+ label_type lbl | isBytesLabel lbl = text "B_"
+ | isForeignLabel lbl && isCFunctionLabel lbl = text "FF_"
+ | isCFunctionLabel lbl = text "F_"
+ | otherwise = text "I_"
+
+ visibility
+ | externallyVisibleCLabel lbl = char 'E'
+ | otherwise = char 'I'
+
+ -- If the label we want to refer to is a stdcall function (on Windows) then
+ -- we must generate an appropriate prototype for it, so that the C compiler will
+ -- add the @n suffix to the label (#2276)
+ stdcall_decl sz = sdocWithDynFlags $ \dflags ->
+ text "extern __attribute__((stdcall)) void " <> ppr lbl
+ <> parens (commafy (replicate (sz `quot` wORD_SIZE dflags) (machRep_U_CType (wordWidth dflags))))
+ <> semi
+
+type TEState = (UniqSet LocalReg, Map CLabel ())
+newtype TE a = TE { unTE :: TEState -> (a, TEState) }
+
+instance Functor TE where
+ fmap = liftM
+
+instance Applicative TE where
+ pure a = TE $ \s -> (a, s)
+ (<*>) = ap
+
+instance Monad TE where
+ TE m >>= k = TE $ \s -> case m s of (a, s') -> unTE (k a) s'
+
+te_lbl :: CLabel -> TE ()
+te_lbl lbl = TE $ \(temps,lbls) -> ((), (temps, Map.insert lbl () lbls))
+
+te_temp :: LocalReg -> TE ()
+te_temp r = TE $ \(temps,lbls) -> ((), (addOneToUniqSet temps r, lbls))
+
+runTE :: TE () -> TEState
+runTE (TE m) = snd (m (emptyUniqSet, Map.empty))
+
+te_Static :: CmmStatic -> TE ()
+te_Static (CmmStaticLit lit) = te_Lit lit
+te_Static _ = return ()
+
+te_BB :: CmmBlock -> TE ()
+te_BB block = mapM_ te_Stmt (blockToList mid) >> te_Stmt last
+ where (_, mid, last) = blockSplit block
+
+te_Lit :: CmmLit -> TE ()
+te_Lit (CmmLabel l) = te_lbl l
+te_Lit (CmmLabelOff l _) = te_lbl l
+te_Lit (CmmLabelDiffOff l1 _ _) = te_lbl l1
+te_Lit _ = return ()
+
+te_Stmt :: CmmNode e x -> TE ()
+te_Stmt (CmmAssign r e) = te_Reg r >> te_Expr e
+te_Stmt (CmmStore l r) = te_Expr l >> te_Expr r
+te_Stmt (CmmUnsafeForeignCall target rs es)
+ = do te_Target target
+ mapM_ te_temp rs
+ mapM_ te_Expr es
+te_Stmt (CmmCondBranch e _ _ _) = te_Expr e
+te_Stmt (CmmSwitch e _) = te_Expr e
+te_Stmt (CmmCall { cml_target = e }) = te_Expr e
+te_Stmt _ = return ()
+
+te_Target :: ForeignTarget -> TE ()
+te_Target (ForeignTarget e _) = te_Expr e
+te_Target (PrimTarget{}) = return ()
+
+te_Expr :: CmmExpr -> TE ()
+te_Expr (CmmLit lit) = te_Lit lit
+te_Expr (CmmLoad e _) = te_Expr e
+te_Expr (CmmReg r) = te_Reg r
+te_Expr (CmmMachOp _ es) = mapM_ te_Expr es
+te_Expr (CmmRegOff r _) = te_Reg r
+te_Expr (CmmStackSlot _ _) = panic "te_Expr: CmmStackSlot not supported!"
+
+te_Reg :: CmmReg -> TE ()
+te_Reg (CmmLocal l) = te_temp l
+te_Reg _ = return ()
+
+
+-- ---------------------------------------------------------------------
+-- C types for MachReps
+
+cCast :: SDoc -> CmmExpr -> SDoc
+cCast ty expr = parens ty <> pprExpr1 expr
+
+cLoad :: CmmExpr -> CmmType -> SDoc
+cLoad expr rep
+ = sdocWithPlatform $ \platform ->
+ if bewareLoadStoreAlignment (platformArch platform)
+ then let decl = machRepCType rep <+> text "x" <> semi
+ struct = text "struct" <+> braces (decl)
+ packed_attr = text "__attribute__((packed))"
+ cast = parens (struct <+> packed_attr <> char '*')
+ in parens (cast <+> pprExpr1 expr) <> text "->x"
+ else char '*' <> parens (cCast (machRepPtrCType rep) expr)
+ where -- On these platforms, unaligned loads are known to cause problems
+ bewareLoadStoreAlignment ArchAlpha = True
+ bewareLoadStoreAlignment ArchMipseb = True
+ bewareLoadStoreAlignment ArchMipsel = True
+ bewareLoadStoreAlignment (ArchARM {}) = True
+ bewareLoadStoreAlignment ArchARM64 = True
+ bewareLoadStoreAlignment ArchSPARC = True
+ bewareLoadStoreAlignment ArchSPARC64 = True
+ -- Pessimistically assume that they will also cause problems
+ -- on unknown arches
+ bewareLoadStoreAlignment ArchUnknown = True
+ bewareLoadStoreAlignment _ = False
+
+isCmmWordType :: DynFlags -> CmmType -> Bool
+-- True of GcPtrReg/NonGcReg of native word size
+isCmmWordType dflags ty = not (isFloatType ty)
+ && typeWidth ty == wordWidth dflags
+
+-- This is for finding the types of foreign call arguments. For a pointer
+-- argument, we always cast the argument to (void *), to avoid warnings from
+-- the C compiler.
+machRepHintCType :: CmmType -> ForeignHint -> SDoc
+machRepHintCType _ AddrHint = text "void *"
+machRepHintCType rep SignedHint = machRep_S_CType (typeWidth rep)
+machRepHintCType rep _other = machRepCType rep
+
+machRepPtrCType :: CmmType -> SDoc
+machRepPtrCType r
+ = sdocWithDynFlags $ \dflags ->
+ if isCmmWordType dflags r then text "P_"
+ else machRepCType r <> char '*'
+
+machRepCType :: CmmType -> SDoc
+machRepCType ty | isFloatType ty = machRep_F_CType w
+ | otherwise = machRep_U_CType w
+ where
+ w = typeWidth ty
+
+machRep_F_CType :: Width -> SDoc
+machRep_F_CType W32 = text "StgFloat" -- ToDo: correct?
+machRep_F_CType W64 = text "StgDouble"
+machRep_F_CType _ = panic "machRep_F_CType"
+
+machRep_U_CType :: Width -> SDoc
+machRep_U_CType w
+ = sdocWithDynFlags $ \dflags ->
+ case w of
+ _ | w == wordWidth dflags -> text "W_"
+ W8 -> text "StgWord8"
+ W16 -> text "StgWord16"
+ W32 -> text "StgWord32"
+ W64 -> text "StgWord64"
+ _ -> panic "machRep_U_CType"
+
+machRep_S_CType :: Width -> SDoc
+machRep_S_CType w
+ = sdocWithDynFlags $ \dflags ->
+ case w of
+ _ | w == wordWidth dflags -> text "I_"
+ W8 -> text "StgInt8"
+ W16 -> text "StgInt16"
+ W32 -> text "StgInt32"
+ W64 -> text "StgInt64"
+ _ -> panic "machRep_S_CType"
+
+
+-- ---------------------------------------------------------------------
+-- print strings as valid C strings
+
+pprStringInCStyle :: [Word8] -> SDoc
+pprStringInCStyle s = doubleQuotes (text (concatMap charToC s))
+
+-- ---------------------------------------------------------------------------
+-- Initialising static objects with floating-point numbers. We can't
+-- just emit the floating point number, because C will cast it to an int
+-- by rounding it. We want the actual bit-representation of the float.
+--
+-- Consider a concrete C example:
+-- double d = 2.5e-10;
+-- float f = 2.5e-10f;
+--
+-- int * i2 = &d; printf ("i2: %08X %08X\n", i2[0], i2[1]);
+-- long long * l = &d; printf (" l: %016llX\n", l[0]);
+-- int * i = &f; printf (" i: %08X\n", i[0]);
+-- Result on 64-bit LE (x86_64):
+-- i2: E826D695 3DF12E0B
+-- l: 3DF12E0BE826D695
+-- i: 2F89705F
+-- Result on 32-bit BE (m68k):
+-- i2: 3DF12E0B E826D695
+-- l: 3DF12E0BE826D695
+-- i: 2F89705F
+--
+-- The trick here is to notice that binary representation does not
+-- change much: only Word32 values get swapped on LE hosts / targets.
+
+-- This is a hack to turn the floating point numbers into ints that we
+-- can safely initialise to static locations.
+
+castFloatToWord32Array :: STUArray s Int Float -> ST s (STUArray s Int Word32)
+castFloatToWord32Array = U.castSTUArray
+
+castDoubleToWord64Array :: STUArray s Int Double -> ST s (STUArray s Int Word64)
+castDoubleToWord64Array = U.castSTUArray
+
+floatToWord :: DynFlags -> Rational -> CmmLit
+floatToWord dflags r
+ = runST (do
+ arr <- newArray_ ((0::Int),0)
+ writeArray arr 0 (fromRational r)
+ arr' <- castFloatToWord32Array arr
+ w32 <- readArray arr' 0
+ return (CmmInt (toInteger w32 `shiftL` wo) (wordWidth dflags))
+ )
+ where wo | wordWidth dflags == W64
+ , wORDS_BIGENDIAN dflags = 32
+ | otherwise = 0
+
+doubleToWords :: DynFlags -> Rational -> [CmmLit]
+doubleToWords dflags r
+ = runST (do
+ arr <- newArray_ ((0::Int),1)
+ writeArray arr 0 (fromRational r)
+ arr' <- castDoubleToWord64Array arr
+ w64 <- readArray arr' 0
+ return (pprWord64 w64)
+ )
+ where targetWidth = wordWidth dflags
+ targetBE = wORDS_BIGENDIAN dflags
+ pprWord64 w64
+ | targetWidth == W64 =
+ [ CmmInt (toInteger w64) targetWidth ]
+ | targetWidth == W32 =
+ [ CmmInt (toInteger targetW1) targetWidth
+ , CmmInt (toInteger targetW2) targetWidth
+ ]
+ | otherwise = panic "doubleToWords.pprWord64"
+ where (targetW1, targetW2)
+ | targetBE = (wHi, wLo)
+ | otherwise = (wLo, wHi)
+ wHi = w64 `shiftR` 32
+ wLo = w64 .&. 0xFFFFffff
+
+-- ---------------------------------------------------------------------------
+-- Utils
+
+wordShift :: DynFlags -> Int
+wordShift dflags = widthInLog (wordWidth dflags)
+
+commafy :: [SDoc] -> SDoc
+commafy xs = hsep $ punctuate comma xs
+
+-- Print in C hex format: 0x13fa
+pprHexVal :: Integer -> Width -> SDoc
+pprHexVal w rep
+ | w < 0 = parens (char '-' <>
+ text "0x" <> intToDoc (-w) <> repsuffix rep)
+ | otherwise = text "0x" <> intToDoc w <> repsuffix rep
+ where
+ -- type suffix for literals:
+ -- Integer literals are unsigned in Cmm/C. We explicitly cast to
+ -- signed values for doing signed operations, but at all other
+ -- times values are unsigned. This also helps eliminate occasional
+ -- warnings about integer overflow from gcc.
+
+ repsuffix W64 = sdocWithDynFlags $ \dflags ->
+ if cINT_SIZE dflags == 8 then char 'U'
+ else if cLONG_SIZE dflags == 8 then text "UL"
+ else if cLONG_LONG_SIZE dflags == 8 then text "ULL"
+ else panic "pprHexVal: Can't find a 64-bit type"
+ repsuffix _ = char 'U'
+
+ intToDoc :: Integer -> SDoc
+ intToDoc i = case truncInt i of
+ 0 -> char '0'
+ v -> go v
+
+ -- We need to truncate value as Cmm backend does not drop
+ -- redundant bits to ease handling of negative values.
+ -- Thus the following Cmm code on 64-bit arch, like amd64:
+ -- CInt v;
+ -- v = {something};
+ -- if (v == %lobits32(-1)) { ...
+ -- leads to the following C code:
+ -- StgWord64 v = (StgWord32)({something});
+ -- if (v == 0xFFFFffffFFFFffffU) { ...
+ -- Such code is incorrect as it promotes both operands to StgWord64
+ -- and the whole condition is always false.
+ truncInt :: Integer -> Integer
+ truncInt i =
+ case rep of
+ W8 -> i `rem` (2^(8 :: Int))
+ W16 -> i `rem` (2^(16 :: Int))
+ W32 -> i `rem` (2^(32 :: Int))
+ W64 -> i `rem` (2^(64 :: Int))
+ _ -> panic ("pprHexVal/truncInt: C backend can't encode "
+ ++ show rep ++ " literals")
+
+ go 0 = empty
+ go w' = go q <> dig
+ where
+ (q,r) = w' `quotRem` 16
+ dig | r < 10 = char (chr (fromInteger r + ord '0'))
+ | otherwise = char (chr (fromInteger r - 10 + ord 'a'))
diff --git a/cmm/PprCmm.hs b/cmm/PprCmm.hs
new file mode 100644
--- /dev/null
+++ b/cmm/PprCmm.hs
@@ -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 ""
+pprConvention (NativeDirectCall {}) = text ""
+pprConvention (NativeReturn {}) = text ""
+pprConvention Slow = text ""
+pprConvention GC = text ""
+
+pprForeignConvention :: ForeignConvention -> SDoc
+pprForeignConvention (ForeignConvention c args res ret) =
+ doubleQuotes (ppr c) <+> text "arg hints: " <+> ppr args <+> text " result hints: " <+> ppr res <+> ppr ret
+
+pprReturnInfo :: CmmReturnInfo -> SDoc
+pprReturnInfo CmmMayReturn = empty
+pprReturnInfo CmmNeverReturns = text "never returns"
+
+pprForeignTarget :: ForeignTarget -> SDoc
+pprForeignTarget (ForeignTarget fn c) = ppr c <+> ppr_target fn
+ where
+ ppr_target :: CmmExpr -> SDoc
+ ppr_target t@(CmmLit _) = ppr t
+ ppr_target fn' = parens (ppr fn')
+
+pprForeignTarget (PrimTarget op)
+ -- HACK: We're just using a ForeignLabel to get this printed, the label
+ -- might not really be foreign.
+ = ppr
+ (CmmLabel (mkForeignLabel
+ (mkFastString (show op))
+ Nothing ForeignLabelInThisPackage IsFunction))
+
+pprNode :: CmmNode e x -> SDoc
+pprNode node = pp_node <+> pp_debug
+ where
+ pp_node :: SDoc
+ pp_node = sdocWithDynFlags $ \dflags -> case node of
+ -- label:
+ CmmEntry id tscope -> ppr id <> colon <+>
+ (sdocWithDynFlags $ \dflags ->
+ ppUnless (gopt Opt_SuppressTicks dflags) (text "//" <+> ppr tscope))
+
+ -- // text
+ CmmComment s -> text "//" <+> ftext s
+
+ -- //tick bla<...>
+ CmmTick t -> ppUnless (gopt Opt_SuppressTicks dflags) $
+ text "//tick" <+> ppr t
+
+ -- unwind reg = expr;
+ CmmUnwind regs ->
+ text "unwind "
+ <> commafy (map (\(r,e) -> ppr r <+> char '=' <+> ppr e) regs) <> semi
+
+ -- reg = expr;
+ CmmAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi
+
+ -- rep[lv] = expr;
+ CmmStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi
+ where
+ rep = sdocWithDynFlags $ \dflags ->
+ ppr ( cmmExprType dflags expr )
+
+ -- call "ccall" foo(x, y)[r1, r2];
+ -- ToDo ppr volatile
+ CmmUnsafeForeignCall target results args ->
+ hsep [ ppUnless (null results) $
+ parens (commafy $ map ppr results) <+> equals,
+ text "call",
+ ppr target <> parens (commafy $ map ppr args) <> semi]
+
+ -- goto label;
+ CmmBranch ident -> text "goto" <+> ppr ident <> semi
+
+ -- if (expr) goto t; else goto f;
+ CmmCondBranch expr t f l ->
+ hsep [ text "if"
+ , parens(ppr expr)
+ , case l of
+ Nothing -> empty
+ Just b -> parens (text "likely:" <+> ppr b)
+ , text "goto"
+ , ppr t <> semi
+ , text "else goto"
+ , ppr f <> semi
+ ]
+
+ CmmSwitch expr ids ->
+ hang (hsep [ text "switch"
+ , range
+ , if isTrivialCmmExpr expr
+ then ppr expr
+ else parens (ppr expr)
+ , text "{"
+ ])
+ 4 (vcat (map ppCase cases) $$ def) $$ rbrace
+ where
+ (cases, mbdef) = switchTargetsFallThrough ids
+ ppCase (is,l) = hsep
+ [ text "case"
+ , commafy $ map integer is
+ , text ": goto"
+ , ppr l <> semi
+ ]
+ def | Just l <- mbdef = hsep
+ [ text "default: goto"
+ , ppr l <> semi
+ ]
+ | otherwise = empty
+
+ range = brackets $ hsep [integer lo, text "..", integer hi]
+ where (lo,hi) = switchTargetsRange ids
+
+ CmmCall tgt k regs out res updfr_off ->
+ hcat [ text "call", space
+ , pprFun tgt, parens (interpp'SP regs), space
+ , returns <+>
+ text "args: " <> ppr out <> comma <+>
+ text "res: " <> ppr res <> comma <+>
+ text "upd: " <> ppr updfr_off
+ , semi ]
+ where pprFun f@(CmmLit _) = ppr f
+ pprFun f = parens (ppr f)
+
+ returns
+ | Just r <- k = text "returns to" <+> ppr r <> comma
+ | otherwise = empty
+
+ CmmForeignCall {tgt=t, res=rs, args=as, succ=s, ret_args=a, ret_off=u, intrbl=i} ->
+ hcat $ if i then [text "interruptible", space] else [] ++
+ [ text "foreign call", space
+ , ppr t, text "(...)", space
+ , text "returns to" <+> ppr s
+ <+> text "args:" <+> parens (ppr as)
+ <+> text "ress:" <+> parens (ppr rs)
+ , text "ret_args:" <+> ppr a
+ , text "ret_off:" <+> ppr u
+ , semi ]
+
+ pp_debug :: SDoc
+ pp_debug =
+ if not debugIsOn then empty
+ else case node of
+ CmmEntry {} -> empty -- Looks terrible with text " // CmmEntry"
+ CmmComment {} -> empty -- Looks also terrible with text " // CmmComment"
+ CmmTick {} -> empty
+ CmmUnwind {} -> text " // CmmUnwind"
+ CmmAssign {} -> text " // CmmAssign"
+ CmmStore {} -> text " // CmmStore"
+ CmmUnsafeForeignCall {} -> text " // CmmUnsafeForeignCall"
+ CmmBranch {} -> text " // CmmBranch"
+ CmmCondBranch {} -> text " // CmmCondBranch"
+ CmmSwitch {} -> text " // CmmSwitch"
+ CmmCall {} -> text " // CmmCall"
+ CmmForeignCall {} -> text " // CmmForeignCall"
+
+ commafy :: [SDoc] -> SDoc
+ commafy xs = hsep $ punctuate comma xs
diff --git a/cmm/PprCmmDecl.hs b/cmm/PprCmmDecl.hs
new file mode 100644
--- /dev/null
+++ b/cmm/PprCmmDecl.hs
@@ -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.
diff --git a/cmm/PprCmmExpr.hs b/cmm/PprCmmExpr.hs
new file mode 100644
--- /dev/null
+++ b/cmm/PprCmmExpr.hs
@@ -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 ""
+
+pprLit1 :: CmmLit -> SDoc
+pprLit1 lit@(CmmLabelOff {}) = parens (pprLit lit)
+pprLit1 lit = pprLit lit
+
+ppr_offset :: Int -> SDoc
+ppr_offset i
+ | i==0 = empty
+ | i>=0 = char '+' <> int i
+ | otherwise = char '-' <> int (-i)
+
+-- --------------------------------------------------------------------------
+-- Registers, whether local (temps) or global
+--
+pprReg :: CmmReg -> SDoc
+pprReg r
+ = case r of
+ CmmLocal local -> pprLocalReg local
+ CmmGlobal global -> pprGlobalReg global
+
+--
+-- We only print the type of the local reg if it isn't wordRep
+--
+pprLocalReg :: LocalReg -> SDoc
+pprLocalReg (LocalReg uniq rep)
+-- = ppr rep <> char '_' <> ppr uniq
+-- Temp Jan08
+ = char '_' <> ppr uniq <>
+ (if isWord32 rep -- && not (isGcPtrType rep) -- Temp Jan08 -- sigh
+ then dcolon <> ptr <> ppr rep
+ else dcolon <> ptr <> ppr rep)
+ where
+ ptr = empty
+ --if isGcPtrType rep
+ -- then doubleQuotes (text "ptr")
+ -- else empty
+
+-- Stack areas
+pprArea :: Area -> SDoc
+pprArea Old = text "old"
+pprArea (Young id) = hcat [ text "young<", ppr id, text ">" ]
+
+-- needs to be kept in syn with CmmExpr.hs.GlobalReg
+--
+pprGlobalReg :: GlobalReg -> SDoc
+pprGlobalReg gr
+ = case gr of
+ VanillaReg n _ -> char 'R' <> int n
+-- Temp Jan08
+-- VanillaReg n VNonGcPtr -> char 'R' <> int n
+-- VanillaReg n VGcPtr -> char 'P' <> int n
+ FloatReg n -> char 'F' <> int n
+ DoubleReg n -> char 'D' <> int n
+ LongReg n -> char 'L' <> int n
+ XmmReg n -> text "XMM" <> int n
+ YmmReg n -> text "YMM" <> int n
+ ZmmReg n -> text "ZMM" <> int n
+ Sp -> text "Sp"
+ SpLim -> text "SpLim"
+ Hp -> text "Hp"
+ HpLim -> text "HpLim"
+ MachSp -> text "MachSp"
+ UnwindReturnReg-> text "UnwindReturnReg"
+ CCCS -> text "CCCS"
+ CurrentTSO -> text "CurrentTSO"
+ CurrentNursery -> text "CurrentNursery"
+ HpAlloc -> text "HpAlloc"
+ EagerBlackholeInfo -> text "stg_EAGER_BLACKHOLE_info"
+ GCEnter1 -> text "stg_gc_enter_1"
+ GCFun -> text "stg_gc_fun"
+ BaseReg -> text "BaseReg"
+ PicBaseReg -> text "PicBaseReg"
+
+-----------------------------------------------------------------------------
+
+commafy :: [SDoc] -> SDoc
+commafy xs = fsep $ punctuate comma xs
diff --git a/cmm/SMRep.hs b/cmm/SMRep.hs
new file mode 100644
--- /dev/null
+++ b/cmm/SMRep.hs
@@ -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)
diff --git a/codeGen/CgUtils.hs b/codeGen/CgUtils.hs
new file mode 100644
--- /dev/null
+++ b/codeGen/CgUtils.hs
@@ -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
+
diff --git a/codeGen/CodeGen/Platform.hs b/codeGen/CodeGen/Platform.hs
new file mode 100644
--- /dev/null
+++ b/codeGen/CodeGen/Platform.hs
@@ -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
+
diff --git a/codeGen/CodeGen/Platform/ARM.hs b/codeGen/CodeGen/Platform/ARM.hs
new file mode 100644
--- /dev/null
+++ b/codeGen/CodeGen/Platform/ARM.hs
@@ -0,0 +1,8 @@
+{-# LANGUAGE CPP #-}
+
+module CodeGen.Platform.ARM where
+
+#define MACHREGS_NO_REGS 0
+#define MACHREGS_arm 1
+#include "CodeGen.Platform.hs"
+
diff --git a/codeGen/CodeGen/Platform/ARM64.hs b/codeGen/CodeGen/Platform/ARM64.hs
new file mode 100644
--- /dev/null
+++ b/codeGen/CodeGen/Platform/ARM64.hs
@@ -0,0 +1,8 @@
+{-# LANGUAGE CPP #-}
+
+module CodeGen.Platform.ARM64 where
+
+#define MACHREGS_NO_REGS 0
+#define MACHREGS_aarch64 1
+#include "CodeGen.Platform.hs"
+
diff --git a/codeGen/CodeGen/Platform/NoRegs.hs b/codeGen/CodeGen/Platform/NoRegs.hs
new file mode 100644
--- /dev/null
+++ b/codeGen/CodeGen/Platform/NoRegs.hs
@@ -0,0 +1,7 @@
+{-# LANGUAGE CPP #-}
+
+module CodeGen.Platform.NoRegs where
+
+#define MACHREGS_NO_REGS 1
+#include "CodeGen.Platform.hs"
+
diff --git a/codeGen/CodeGen/Platform/PPC.hs b/codeGen/CodeGen/Platform/PPC.hs
new file mode 100644
--- /dev/null
+++ b/codeGen/CodeGen/Platform/PPC.hs
@@ -0,0 +1,8 @@
+{-# LANGUAGE CPP #-}
+
+module CodeGen.Platform.PPC where
+
+#define MACHREGS_NO_REGS 0
+#define MACHREGS_powerpc 1
+#include "CodeGen.Platform.hs"
+
diff --git a/codeGen/CodeGen/Platform/PPC_Darwin.hs b/codeGen/CodeGen/Platform/PPC_Darwin.hs
new file mode 100644
--- /dev/null
+++ b/codeGen/CodeGen/Platform/PPC_Darwin.hs
@@ -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"
+
diff --git a/codeGen/CodeGen/Platform/SPARC.hs b/codeGen/CodeGen/Platform/SPARC.hs
new file mode 100644
--- /dev/null
+++ b/codeGen/CodeGen/Platform/SPARC.hs
@@ -0,0 +1,8 @@
+{-# LANGUAGE CPP #-}
+
+module CodeGen.Platform.SPARC where
+
+#define MACHREGS_NO_REGS 0
+#define MACHREGS_sparc 1
+#include "CodeGen.Platform.hs"
+
diff --git a/codeGen/CodeGen/Platform/X86.hs b/codeGen/CodeGen/Platform/X86.hs
new file mode 100644
--- /dev/null
+++ b/codeGen/CodeGen/Platform/X86.hs
@@ -0,0 +1,8 @@
+{-# LANGUAGE CPP #-}
+
+module CodeGen.Platform.X86 where
+
+#define MACHREGS_NO_REGS 0
+#define MACHREGS_i386 1
+#include "CodeGen.Platform.hs"
+
diff --git a/codeGen/CodeGen/Platform/X86_64.hs b/codeGen/CodeGen/Platform/X86_64.hs
new file mode 100644
--- /dev/null
+++ b/codeGen/CodeGen/Platform/X86_64.hs
@@ -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"
+
diff --git a/codeGen/StgCmm.hs b/codeGen/StgCmm.hs
new file mode 100644
--- /dev/null
+++ b/codeGen/StgCmm.hs
@@ -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.
diff --git a/codeGen/StgCmmArgRep.hs b/codeGen/StgCmmArgRep.hs
new file mode 100644
--- /dev/null
+++ b/codeGen/StgCmmArgRep.hs
@@ -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)
diff --git a/codeGen/StgCmmBind.hs b/codeGen/StgCmmBind.hs
new file mode 100644
--- /dev/null
+++ b/codeGen/StgCmmBind.hs
@@ -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.
diff --git a/codeGen/StgCmmBind.hs-boot b/codeGen/StgCmmBind.hs-boot
new file mode 100644
--- /dev/null
+++ b/codeGen/StgCmmBind.hs-boot
@@ -0,0 +1,6 @@
+module StgCmmBind where
+
+import StgCmmMonad( FCode )
+import StgSyn( StgBinding )
+
+cgBind :: StgBinding -> FCode ()
diff --git a/codeGen/StgCmmClosure.hs b/codeGen/StgCmmClosure.hs
new file mode 100644
--- /dev/null
+++ b/codeGen/StgCmmClosure.hs
@@ -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 = in ...
+AND allocates, then the heap-overflow check needs to know how
+to re-start the evaluation. It uses the "self" pointer to do this.
+So even if there are no free variables in , we still make
+nodeMustPointToIt be True for non-top-level bindings.
+
+Why do any such bindings exist? After all, let-floating should have
+floated them out. Well, a clever optimiser might leave one there to
+avoid a space leak, deliberately recomputing a thunk. Also (and this
+really does happen occasionally) let-floating may make a function f smaller
+so it can be inlined, so now (f True) may generate a local no-fv closure.
+This actually happened during bootstrapping GHC itself, with f=mkRdrFunBind
+in TcGenDeriv.) -}
+
+-----------------------------------------------------------------------------
+-- getCallMethod
+-----------------------------------------------------------------------------
+
+{- The entry conventions depend on the type of closure being entered,
+whether or not it has free variables, and whether we're running
+sequentially or in parallel.
+
+Closure Node Argument Enter
+Characteristics Par Req'd Passing Via
+---------------------------------------------------------------------------
+Unknown & no & yes & stack & node
+Known fun (>1 arg), no fvs & no & no & registers & fast entry (enough args)
+ & slow entry (otherwise)
+Known fun (>1 arg), fvs & no & yes & registers & fast entry (enough args)
+0 arg, no fvs \r,\s & no & no & n/a & direct entry
+0 arg, no fvs \u & no & yes & n/a & node
+0 arg, fvs \r,\s,selector & no & yes & n/a & node
+0 arg, fvs \r,\s & no & yes & n/a & direct entry
+0 arg, fvs \u & no & yes & n/a & node
+Unknown & yes & yes & stack & node
+Known fun (>1 arg), no fvs & yes & no & registers & fast entry (enough args)
+ & slow entry (otherwise)
+Known fun (>1 arg), fvs & yes & yes & registers & node
+0 arg, fvs \r,\s,selector & yes & yes & n/a & node
+0 arg, no fvs \r,\s & yes & no & n/a & direct entry
+0 arg, no fvs \u & yes & yes & n/a & node
+0 arg, fvs \r,\s & yes & yes & n/a & node
+0 arg, fvs \u & yes & yes & n/a & node
+
+When black-holing, single-entry closures could also be entered via node
+(rather than directly) to catch double-entry. -}
+
+data CallMethod
+ = EnterIt -- No args, not a function
+
+ | JumpToIt BlockId [LocalReg] -- A join point or a header of a local loop
+
+ | ReturnIt -- It's a value (function, unboxed value,
+ -- or constructor), so just return it.
+
+ | SlowCall -- Unknown fun, or known fun with
+ -- too few args.
+
+ | DirectEntry -- Jump directly, with args in regs
+ CLabel -- The code label
+ RepArity -- Its arity
+
+getCallMethod :: DynFlags
+ -> Name -- Function being applied
+ -> Id -- Function Id used to chech if it can refer to
+ -- CAF's and whether the function is tail-calling
+ -- itself
+ -> LambdaFormInfo -- Its info
+ -> RepArity -- Number of available arguments
+ -> RepArity -- Number of them being void arguments
+ -> CgLoc -- Passed in from cgIdApp so that we can
+ -- handle let-no-escape bindings and self-recursive
+ -- tail calls using the same data constructor,
+ -- JumpToIt. This saves us one case branch in
+ -- cgIdApp
+ -> Maybe SelfLoopInfo -- can we perform a self-recursive tail call?
+ -> CallMethod
+
+getCallMethod dflags _ id _ n_args v_args _cg_loc
+ (Just (self_loop_id, block_id, args))
+ | gopt Opt_Loopification dflags
+ , id == self_loop_id
+ , n_args - v_args == length args
+ -- If these patterns match then we know that:
+ -- * loopification optimisation is turned on
+ -- * function is performing a self-recursive call in a tail position
+ -- * number of non-void parameters of the function matches functions arity.
+ -- See Note [Self-recursive tail calls] and Note [Void arguments in
+ -- self-recursive tail calls] in StgCmmExpr for more details
+ = JumpToIt block_id args
+
+getCallMethod dflags name id (LFReEntrant _ _ arity _ _) n_args _v_args _cg_loc
+ _self_loop_info
+ | n_args == 0 -- No args at all
+ && not (gopt Opt_SccProfilingOn dflags)
+ -- See Note [Evaluating functions with profiling] in rts/Apply.cmm
+ = ASSERT( arity /= 0 ) ReturnIt
+ | n_args < arity = SlowCall -- Not enough args
+ | otherwise = DirectEntry (enterIdLabel dflags name (idCafInfo id)) arity
+
+getCallMethod _ _name _ LFUnlifted n_args _v_args _cg_loc _self_loop_info
+ = ASSERT( n_args == 0 ) ReturnIt
+
+getCallMethod _ _name _ (LFCon _) n_args _v_args _cg_loc _self_loop_info
+ = ASSERT( n_args == 0 ) ReturnIt
+ -- n_args=0 because it'd be ill-typed to apply a saturated
+ -- constructor application to anything
+
+getCallMethod dflags name id (LFThunk _ _ updatable std_form_info is_fun)
+ n_args _v_args _cg_loc _self_loop_info
+ | is_fun -- it *might* be a function, so we must "call" it (which is always safe)
+ = SlowCall -- We cannot just enter it [in eval/apply, the entry code
+ -- is the fast-entry code]
+
+ -- Since is_fun is False, we are *definitely* looking at a data value
+ | updatable || gopt Opt_Ticky dflags -- to catch double entry
+ {- OLD: || opt_SMP
+ I decided to remove this, because in SMP mode it doesn't matter
+ if we enter the same thunk multiple times, so the optimisation
+ of jumping directly to the entry code is still valid. --SDM
+ -}
+ = EnterIt
+
+ -- even a non-updatable selector thunk can be updated by the garbage
+ -- collector, so we must enter it. (#8817)
+ | SelectorThunk{} <- std_form_info
+ = EnterIt
+
+ -- We used to have ASSERT( n_args == 0 ), but actually it is
+ -- possible for the optimiser to generate
+ -- let bot :: Int = error Int "urk"
+ -- in (bot `cast` unsafeCoerce Int (Int -> Int)) 3
+ -- This happens as a result of the case-of-error transformation
+ -- So the right thing to do is just to enter the thing
+
+ | otherwise -- Jump direct to code for single-entry thunks
+ = ASSERT( n_args == 0 )
+ DirectEntry (thunkEntryLabel dflags name (idCafInfo id) std_form_info
+ updatable) 0
+
+getCallMethod _ _name _ (LFUnknown True) _n_arg _v_args _cg_locs _self_loop_info
+ = SlowCall -- might be a function
+
+getCallMethod _ name _ (LFUnknown False) n_args _v_args _cg_loc _self_loop_info
+ = ASSERT2( n_args == 0, ppr name <+> ppr n_args )
+ EnterIt -- Not a function
+
+getCallMethod _ _name _ LFLetNoEscape _n_args _v_args (LneLoc blk_id lne_regs)
+ _self_loop_info
+ = JumpToIt blk_id lne_regs
+
+getCallMethod _ _ _ _ _ _ _ _ = panic "Unknown call method"
+
+-----------------------------------------------------------------------------
+-- staticClosureRequired
+-----------------------------------------------------------------------------
+
+{- staticClosureRequired is never called (hence commented out)
+
+ SimonMar writes (Sept 07) It's an optimisation we used to apply at
+ one time, I believe, but it got lost probably in the rewrite of
+ the RTS/code generator. I left that code there to remind me to
+ look into whether it was worth doing sometime
+
+{- Avoiding generating entries and info tables
+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+At present, for every function we generate all of the following,
+just in case. But they aren't always all needed, as noted below:
+
+[NB1: all of this applies only to *functions*. Thunks always
+have closure, info table, and entry code.]
+
+[NB2: All are needed if the function is *exported*, just to play safe.]
+
+* Fast-entry code ALWAYS NEEDED
+
+* Slow-entry code
+ Needed iff (a) we have any un-saturated calls to the function
+ OR (b) the function is passed as an arg
+ OR (c) we're in the parallel world and the function has free vars
+ [Reason: in parallel world, we always enter functions
+ with free vars via the closure.]
+
+* The function closure
+ Needed iff (a) we have any un-saturated calls to the function
+ OR (b) the function is passed as an arg
+ OR (c) if the function has free vars (ie not top level)
+
+ Why case (a) here? Because if the arg-satis check fails,
+ UpdatePAP stuffs a pointer to the function closure in the PAP.
+ [Could be changed; UpdatePAP could stuff in a code ptr instead,
+ but doesn't seem worth it.]
+
+ [NB: these conditions imply that we might need the closure
+ without the slow-entry code. Here's how.
+
+ f x y = let g w = ...x..y..w...
+ in
+ ...(g t)...
+
+ Here we need a closure for g which contains x and y,
+ but since the calls are all saturated we just jump to the
+ fast entry point for g, with R1 pointing to the closure for g.]
+
+
+* Standard info table
+ Needed iff (a) we have any un-saturated calls to the function
+ OR (b) the function is passed as an arg
+ OR (c) the function has free vars (ie not top level)
+
+ NB. In the sequential world, (c) is only required so that the function closure has
+ an info table to point to, to keep the storage manager happy.
+ If (c) alone is true we could fake up an info table by choosing
+ one of a standard family of info tables, whose entry code just
+ bombs out.
+
+ [NB In the parallel world (c) is needed regardless because
+ we enter functions with free vars via the closure.]
+
+ If (c) is retained, then we'll sometimes generate an info table
+ (for storage mgr purposes) without slow-entry code. Then we need
+ to use an error label in the info table to substitute for the absent
+ slow entry code.
+-}
+
+staticClosureRequired
+ :: Name
+ -> StgBinderInfo
+ -> LambdaFormInfo
+ -> Bool
+staticClosureRequired binder bndr_info
+ (LFReEntrant top_level _ _ _ _) -- It's a function
+ = ASSERT( isTopLevel top_level )
+ -- Assumption: it's a top-level, no-free-var binding
+ not (satCallsOnly bndr_info)
+
+staticClosureRequired binder other_binder_info other_lf_info = True
+-}
+
+-----------------------------------------------------------------------------
+-- Data types for closure information
+-----------------------------------------------------------------------------
+
+
+{- ClosureInfo: information about a binding
+
+ We make a ClosureInfo for each let binding (both top level and not),
+ but not bindings for data constructors: for those we build a CmmInfoTable
+ directly (see mkDataConInfoTable).
+
+ To a first approximation:
+ ClosureInfo = (LambdaFormInfo, CmmInfoTable)
+
+ A ClosureInfo has enough information
+ a) to construct the info table itself, and build other things
+ related to the binding (e.g. slow entry points for a function)
+ b) to allocate a closure containing that info pointer (i.e.
+ it knows the info table label)
+-}
+
+data ClosureInfo
+ = ClosureInfo {
+ closureName :: !Name, -- The thing bound to this closure
+ -- we don't really need this field: it's only used in generating
+ -- code for ticky and profiling, and we could pass the information
+ -- around separately, but it doesn't do much harm to keep it here.
+
+ closureLFInfo :: !LambdaFormInfo, -- NOTE: not an LFCon
+ -- this tells us about what the closure contains: it's right-hand-side.
+
+ -- the rest is just an unpacked CmmInfoTable.
+ closureInfoLabel :: !CLabel,
+ closureSMRep :: !SMRep, -- representation used by storage mgr
+ closureProf :: !ProfilingInfo
+ }
+
+-- | Convert from 'ClosureInfo' to 'CmmInfoTable'.
+mkCmmInfo :: ClosureInfo -> CmmInfoTable
+mkCmmInfo ClosureInfo {..}
+ = CmmInfoTable { cit_lbl = closureInfoLabel
+ , cit_rep = closureSMRep
+ , cit_prof = closureProf
+ , cit_srt = NoC_SRT }
+
+--------------------------------------
+-- Building ClosureInfos
+--------------------------------------
+
+mkClosureInfo :: DynFlags
+ -> Bool -- Is static
+ -> Id
+ -> LambdaFormInfo
+ -> Int -> Int -- Total and pointer words
+ -> String -- String descriptor
+ -> ClosureInfo
+mkClosureInfo dflags is_static id lf_info tot_wds ptr_wds val_descr
+ = ClosureInfo { closureName = name
+ , closureLFInfo = lf_info
+ , closureInfoLabel = info_lbl -- These three fields are
+ , closureSMRep = sm_rep -- (almost) an info table
+ , closureProf = prof } -- (we don't have an SRT yet)
+ where
+ name = idName id
+ sm_rep = mkHeapRep dflags is_static ptr_wds nonptr_wds (lfClosureType lf_info)
+ prof = mkProfilingInfo dflags id val_descr
+ nonptr_wds = tot_wds - ptr_wds
+
+ info_lbl = mkClosureInfoTableLabel id lf_info
+
+--------------------------------------
+-- Other functions over ClosureInfo
+--------------------------------------
+
+-- Eager blackholing is normally disabled, but can be turned on with
+-- -feager-blackholing. When it is on, we replace the info pointer of
+-- the thunk with stg_EAGER_BLACKHOLE_info on entry.
+
+-- If we wanted to do eager blackholing with slop filling,
+-- we'd need to do it at the *end* of a basic block, otherwise
+-- we overwrite the free variables in the thunk that we still
+-- need. We have a patch for this from Andy Cheadle, but not
+-- incorporated yet. --SDM [6/2004]
+--
+-- Previously, eager blackholing was enabled when ticky-ticky
+-- was on. But it didn't work, and it wasn't strictly necessary
+-- to bring back minimal ticky-ticky, so now EAGER_BLACKHOLING
+-- is unconditionally disabled. -- krc 1/2007
+--
+-- Static closures are never themselves black-holed.
+
+blackHoleOnEntry :: ClosureInfo -> Bool
+blackHoleOnEntry cl_info
+ | isStaticRep (closureSMRep cl_info)
+ = False -- Never black-hole a static closure
+
+ | otherwise
+ = case closureLFInfo cl_info of
+ LFReEntrant {} -> False
+ LFLetNoEscape -> False
+ LFThunk _ _no_fvs upd _ _ -> upd -- See Note [Black-holing non-updatable thunks]
+ _other -> panic "blackHoleOnEntry"
+
+{- Note [Black-holing non-updatable thunks]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We must not black-hole non-updatable (single-entry) thunks otherwise
+we run into issues like Trac #10414. Specifically:
+
+ * There is no reason to black-hole a non-updatable thunk: it should
+ not be competed for by multiple threads
+
+ * It could, conceivably, cause a space leak if we don't black-hole
+ it, if there was a live but never-followed pointer pointing to it.
+ Let's hope that doesn't happen.
+
+ * It is dangerous to black-hole a non-updatable thunk because
+ - is not updated (of course)
+ - hence, if it is black-holed and another thread tries to evaluate
+ it, that thread will block forever
+ This actually happened in Trac #10414. So we do not black-hole
+ non-updatable thunks.
+
+ * How could two threads evaluate the same non-updatable (single-entry)
+ thunk? See Reid Barton's example below.
+
+ * Only eager blackholing could possibly black-hole a non-updatable
+ thunk, because lazy black-holing only affects thunks with an
+ update frame on the stack.
+
+Here is and example due to Reid Barton (Trac #10414):
+ x = \u [] concat [[1], []]
+with the following definitions,
+
+ concat x = case x of
+ [] -> []
+ (:) x xs -> (++) x (concat xs)
+
+ (++) xs ys = case xs of
+ [] -> ys
+ (:) x rest -> (:) x ((++) rest ys)
+
+Where we use the syntax @\u []@ to denote an updatable thunk and @\s []@ to
+denote a single-entry (i.e. non-updatable) thunk. After a thread evaluates @x@
+to WHNF and calls @(++)@ the heap will contain the following thunks,
+
+ x = 1 : y
+ y = \u [] (++) [] z
+ z = \s [] concat []
+
+Now that the stage is set, consider the follow evaluations by two racing threads
+A and B,
+
+ 1. Both threads enter @y@ before either is able to replace it with an
+ indirection
+
+ 2. Thread A does the case analysis in @(++)@ and consequently enters @z@,
+ replacing it with a black-hole
+
+ 3. At some later point thread B does the same case analysis and also attempts
+ to enter @z@. However, it finds that it has been replaced with a black-hole
+ so it blocks.
+
+ 4. Thread A eventually finishes evaluating @z@ (to @[]@) and updates @y@
+ accordingly. It does *not* update @z@, however, as it is single-entry. This
+ leaves Thread B blocked forever on a black-hole which will never be
+ updated.
+
+To avoid this sort of condition we never black-hole non-updatable thunks.
+-}
+
+isStaticClosure :: ClosureInfo -> Bool
+isStaticClosure cl_info = isStaticRep (closureSMRep cl_info)
+
+closureUpdReqd :: ClosureInfo -> Bool
+closureUpdReqd ClosureInfo{ closureLFInfo = lf_info } = lfUpdatable lf_info
+
+lfUpdatable :: LambdaFormInfo -> Bool
+lfUpdatable (LFThunk _ _ upd _ _) = upd
+lfUpdatable _ = False
+
+closureSingleEntry :: ClosureInfo -> Bool
+closureSingleEntry (ClosureInfo { closureLFInfo = LFThunk _ _ upd _ _}) = not upd
+closureSingleEntry (ClosureInfo { closureLFInfo = LFReEntrant _ OneShotLam _ _ _}) = True
+closureSingleEntry _ = False
+
+closureReEntrant :: ClosureInfo -> Bool
+closureReEntrant (ClosureInfo { closureLFInfo = LFReEntrant {} }) = True
+closureReEntrant _ = False
+
+closureFunInfo :: ClosureInfo -> Maybe (RepArity, ArgDescr)
+closureFunInfo (ClosureInfo { closureLFInfo = lf_info }) = lfFunInfo lf_info
+
+lfFunInfo :: LambdaFormInfo -> Maybe (RepArity, ArgDescr)
+lfFunInfo (LFReEntrant _ _ arity _ arg_desc) = Just (arity, arg_desc)
+lfFunInfo _ = Nothing
+
+funTag :: DynFlags -> ClosureInfo -> DynTag
+funTag dflags (ClosureInfo { closureLFInfo = lf_info })
+ = lfDynTag dflags lf_info
+
+isToplevClosure :: ClosureInfo -> Bool
+isToplevClosure (ClosureInfo { closureLFInfo = lf_info })
+ = case lf_info of
+ LFReEntrant TopLevel _ _ _ _ -> True
+ LFThunk TopLevel _ _ _ _ -> True
+ _other -> False
+
+--------------------------------------
+-- Label generation
+--------------------------------------
+
+staticClosureLabel :: ClosureInfo -> CLabel
+staticClosureLabel = toClosureLbl . closureInfoLabel
+
+closureSlowEntryLabel :: ClosureInfo -> CLabel
+closureSlowEntryLabel = toSlowEntryLbl . closureInfoLabel
+
+closureLocalEntryLabel :: DynFlags -> ClosureInfo -> CLabel
+closureLocalEntryLabel dflags
+ | tablesNextToCode dflags = toInfoLbl . closureInfoLabel
+ | otherwise = toEntryLbl . closureInfoLabel
+
+mkClosureInfoTableLabel :: Id -> LambdaFormInfo -> CLabel
+mkClosureInfoTableLabel id lf_info
+ = case lf_info of
+ LFThunk _ _ upd_flag (SelectorThunk offset) _
+ -> mkSelectorInfoLabel upd_flag offset
+
+ LFThunk _ _ upd_flag (ApThunk arity) _
+ -> mkApInfoTableLabel upd_flag arity
+
+ LFThunk{} -> std_mk_lbl name cafs
+ LFReEntrant{} -> std_mk_lbl name cafs
+ _other -> panic "closureInfoTableLabel"
+
+ where
+ name = idName id
+
+ std_mk_lbl | is_local = mkLocalInfoTableLabel
+ | otherwise = mkInfoTableLabel
+
+ cafs = idCafInfo id
+ is_local = isDataConWorkId id
+ -- Make the _info pointer for the implicit datacon worker
+ -- binding local. The reason we can do this is that importing
+ -- code always either uses the _closure or _con_info. By the
+ -- invariants in CorePrep anything else gets eta expanded.
+
+
+thunkEntryLabel :: DynFlags -> Name -> CafInfo -> StandardFormInfo -> Bool -> CLabel
+-- thunkEntryLabel is a local help function, not exported. It's used from
+-- getCallMethod.
+thunkEntryLabel dflags _thunk_id _ (ApThunk arity) upd_flag
+ = enterApLabel dflags upd_flag arity
+thunkEntryLabel dflags _thunk_id _ (SelectorThunk offset) upd_flag
+ = enterSelectorLabel dflags upd_flag offset
+thunkEntryLabel dflags thunk_id c _ _
+ = enterIdLabel dflags thunk_id c
+
+enterApLabel :: DynFlags -> Bool -> Arity -> CLabel
+enterApLabel dflags is_updatable arity
+ | tablesNextToCode dflags = mkApInfoTableLabel is_updatable arity
+ | otherwise = mkApEntryLabel is_updatable arity
+
+enterSelectorLabel :: DynFlags -> Bool -> WordOff -> CLabel
+enterSelectorLabel dflags upd_flag offset
+ | tablesNextToCode dflags = mkSelectorInfoLabel upd_flag offset
+ | otherwise = mkSelectorEntryLabel upd_flag offset
+
+enterIdLabel :: DynFlags -> Name -> CafInfo -> CLabel
+enterIdLabel dflags id c
+ | tablesNextToCode dflags = mkInfoTableLabel id c
+ | otherwise = mkEntryLabel id c
+
+
+--------------------------------------
+-- Profiling
+--------------------------------------
+
+-- Profiling requires two pieces of information to be determined for
+-- each closure's info table --- description and type.
+
+-- The description is stored directly in the @CClosureInfoTable@ when the
+-- info table is built.
+
+-- The type is determined from the type information stored with the @Id@
+-- in the closure info using @closureTypeDescr@.
+
+mkProfilingInfo :: DynFlags -> Id -> String -> ProfilingInfo
+mkProfilingInfo dflags id val_descr
+ | not (gopt Opt_SccProfilingOn dflags) = NoProfilingInfo
+ | otherwise = ProfilingInfo ty_descr_w8 val_descr_w8
+ where
+ ty_descr_w8 = stringToWord8s (getTyDescription (idType id))
+ val_descr_w8 = stringToWord8s val_descr
+
+getTyDescription :: Type -> String
+getTyDescription ty
+ = case (tcSplitSigmaTy ty) of { (_, _, tau_ty) ->
+ case tau_ty of
+ TyVarTy _ -> "*"
+ AppTy fun _ -> getTyDescription fun
+ TyConApp tycon _ -> getOccString tycon
+ FunTy _ res -> '-' : '>' : fun_result res
+ ForAllTy _ ty -> getTyDescription ty
+ LitTy n -> getTyLitDescription n
+ CastTy ty _ -> getTyDescription ty
+ CoercionTy co -> pprPanic "getTyDescription" (ppr co)
+ }
+ where
+ fun_result (FunTy _ res) = '>' : fun_result res
+ fun_result other = getTyDescription other
+
+getTyLitDescription :: TyLit -> String
+getTyLitDescription l =
+ case l of
+ NumTyLit n -> show n
+ StrTyLit n -> show n
+
+--------------------------------------
+-- CmmInfoTable-related things
+--------------------------------------
+
+mkDataConInfoTable :: DynFlags -> DataCon -> Bool -> Int -> Int -> CmmInfoTable
+mkDataConInfoTable dflags data_con is_static ptr_wds nonptr_wds
+ = CmmInfoTable { cit_lbl = info_lbl
+ , cit_rep = sm_rep
+ , cit_prof = prof
+ , cit_srt = NoC_SRT }
+ where
+ name = dataConName data_con
+ info_lbl = mkConInfoTableLabel name NoCafRefs
+ sm_rep = mkHeapRep dflags is_static ptr_wds nonptr_wds cl_type
+ cl_type = Constr (dataConTagZ data_con) (dataConIdentity data_con)
+
+ prof | not (gopt Opt_SccProfilingOn dflags) = NoProfilingInfo
+ | otherwise = ProfilingInfo ty_descr val_descr
+
+ ty_descr = stringToWord8s $ occNameString $ getOccName $ dataConTyCon data_con
+ val_descr = stringToWord8s $ occNameString $ getOccName data_con
+
+-- We need a black-hole closure info to pass to @allocDynClosure@ when we
+-- want to allocate the black hole on entry to a CAF.
+
+cafBlackHoleInfoTable :: CmmInfoTable
+cafBlackHoleInfoTable
+ = CmmInfoTable { cit_lbl = mkCAFBlackHoleInfoTableLabel
+ , cit_rep = blackHoleRep
+ , cit_prof = NoProfilingInfo
+ , cit_srt = NoC_SRT }
+
+indStaticInfoTable :: CmmInfoTable
+indStaticInfoTable
+ = CmmInfoTable { cit_lbl = mkIndStaticInfoLabel
+ , cit_rep = indStaticRep
+ , cit_prof = NoProfilingInfo
+ , cit_srt = NoC_SRT }
+
+staticClosureNeedsLink :: Bool -> CmmInfoTable -> Bool
+-- A static closure needs a link field to aid the GC when traversing
+-- the static closure graph. But it only needs such a field if either
+-- a) it has an SRT
+-- b) it's a constructor with one or more pointer fields
+-- In case (b), the constructor's fields themselves play the role
+-- of the SRT.
+staticClosureNeedsLink has_srt CmmInfoTable{ cit_rep = smrep }
+ | isConRep smrep = not (isStaticNoCafCon smrep)
+ | otherwise = has_srt -- needsSRT (cit_srt info_tbl)
diff --git a/codeGen/StgCmmCon.hs b/codeGen/StgCmmCon.hs
new file mode 100644
--- /dev/null
+++ b/codeGen/StgCmmCon.hs
@@ -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 []
diff --git a/codeGen/StgCmmEnv.hs b/codeGen/StgCmmEnv.hs
new file mode 100644
--- /dev/null
+++ b/codeGen/StgCmmEnv.hs
@@ -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))
diff --git a/codeGen/StgCmmExpr.hs b/codeGen/StgCmmExpr.hs
new file mode 100644
--- /dev/null
+++ b/codeGen/StgCmmExpr.hs
@@ -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
+ }
diff --git a/codeGen/StgCmmExtCode.hs b/codeGen/StgCmmExtCode.hs
new file mode 100644
--- /dev/null
+++ b/codeGen/StgCmmExtCode.hs
@@ -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
diff --git a/codeGen/StgCmmForeign.hs b/codeGen/StgCmmForeign.hs
new file mode 100644
--- /dev/null
+++ b/codeGen/StgCmmForeign.hs
@@ -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
diff --git a/codeGen/StgCmmHeap.hs b/codeGen/StgCmmHeap.hs
new file mode 100644
--- /dev/null
+++ b/codeGen/StgCmmHeap.hs
@@ -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.
diff --git a/codeGen/StgCmmHpc.hs b/codeGen/StgCmmHpc.hs
new file mode 100644
--- /dev/null
+++ b/codeGen/StgCmmHpc.hs
@@ -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 ..]
+ ]
+
diff --git a/codeGen/StgCmmLayout.hs b/codeGen/StgCmmLayout.hs
new file mode 100644
--- /dev/null
+++ b/codeGen/StgCmmLayout.hs
@@ -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__fast (slowCall)
+-- Any left-over arguments will be pushed on the stack,
+--
+-- e.g. Sp[old+8] = arg1
+-- Sp[old+16] = arg2
+-- Sp[old+32] = stg_ap_pp_info
+-- R2 = arg3
+-- R3 = arg4
+-- call f() return to Nothing updfr_off: 32
+
+
+directCall :: Convention -> CLabel -> RepArity -> [StgArg] -> FCode ReturnKind
+-- (directCall f n args)
+-- calls f(arg1, ..., argn), and applies the result to the remaining args
+-- The function f has arity n, and there are guaranteed at least n args
+-- Both arity and args include void args
+directCall conv lbl arity stg_args
+ = do { argreps <- getArgRepsAmodes stg_args
+ ; direct_call "directCall" conv lbl arity argreps }
+
+
+slowCall :: CmmExpr -> [StgArg] -> FCode ReturnKind
+-- (slowCall fun args) applies fun to args, returning the results to Sequel
+slowCall fun stg_args
+ = do dflags <- getDynFlags
+ argsreps <- getArgRepsAmodes stg_args
+ let (rts_fun, arity) = slowCallPattern (map fst argsreps)
+
+ (r, slow_code) <- getCodeR $ do
+ r <- direct_call "slow_call" NativeNodeCall
+ (mkRtsApFastLabel rts_fun) arity ((P,Just fun):argsreps)
+ emitComment $ mkFastString ("slow_call for " ++
+ showSDoc dflags (ppr fun) ++
+ " with pat " ++ unpackFS rts_fun)
+ return r
+
+ -- Note [avoid intermediate PAPs]
+ let n_args = length stg_args
+ if n_args > arity && optLevel dflags >= 2
+ then do
+ funv <- (CmmReg . CmmLocal) `fmap` assignTemp fun
+ fun_iptr <- (CmmReg . CmmLocal) `fmap`
+ assignTemp (closureInfoPtr dflags (cmmUntag dflags funv))
+
+ -- ToDo: we could do slightly better here by reusing the
+ -- continuation from the slow call, which we have in r.
+ -- Also we'd like to push the continuation on the stack
+ -- before the branch, so that we only get one copy of the
+ -- code that saves all the live variables across the
+ -- call, but that might need some improvements to the
+ -- special case in the stack layout code to handle this
+ -- (see Note [diamond proc point]).
+
+ fast_code <- getCode $
+ emitCall (NativeNodeCall, NativeReturn)
+ (entryCode dflags fun_iptr)
+ (nonVArgs ((P,Just funv):argsreps))
+
+ slow_lbl <- newBlockId
+ fast_lbl <- newBlockId
+ is_tagged_lbl <- newBlockId
+ end_lbl <- newBlockId
+
+ let correct_arity = cmmEqWord dflags (funInfoArity dflags fun_iptr)
+ (mkIntExpr dflags n_args)
+
+ tscope <- getTickScope
+ emit (mkCbranch (cmmIsTagged dflags funv)
+ is_tagged_lbl slow_lbl (Just True)
+ <*> mkLabel is_tagged_lbl tscope
+ <*> mkCbranch correct_arity fast_lbl slow_lbl (Just True)
+ <*> mkLabel fast_lbl tscope
+ <*> fast_code
+ <*> mkBranch end_lbl
+ <*> mkLabel slow_lbl tscope
+ <*> slow_code
+ <*> mkLabel end_lbl tscope)
+ return r
+
+ else do
+ emit slow_code
+ return r
+
+
+-- Note [avoid intermediate PAPs]
+--
+-- A slow call which needs multiple generic apply patterns will be
+-- almost guaranteed to create one or more intermediate PAPs when
+-- applied to a function that takes the correct number of arguments.
+-- We try to avoid this situation by generating code to test whether
+-- we are calling a function with the correct number of arguments
+-- first, i.e.:
+--
+-- if (TAG(f) != 0} { // f is not a thunk
+-- if (f->info.arity == n) {
+-- ... make a fast call to f ...
+-- }
+-- }
+-- ... otherwise make the slow call ...
+--
+-- We *only* do this when the call requires multiple generic apply
+-- functions, which requires pushing extra stack frames and probably
+-- results in intermediate PAPs. (I say probably, because it might be
+-- that we're over-applying a function, but that seems even less
+-- likely).
+--
+-- This very rarely applies, but if it does happen in an inner loop it
+-- can have a severe impact on performance (#6084).
+
+
+--------------
+direct_call :: String
+ -> Convention -- e.g. NativeNodeCall or NativeDirectCall
+ -> CLabel -> RepArity
+ -> [(ArgRep,Maybe CmmExpr)] -> FCode ReturnKind
+direct_call caller call_conv lbl arity args
+ | debugIsOn && real_arity > length args -- Too few args
+ = do -- Caller should ensure that there enough args!
+ pprPanic "direct_call" $
+ text caller <+> ppr arity <+>
+ ppr lbl <+> ppr (length args) <+>
+ ppr (map snd args) <+> ppr (map fst args)
+
+ | null rest_args -- Precisely the right number of arguments
+ = emitCall (call_conv, NativeReturn) target (nonVArgs args)
+
+ | otherwise -- Note [over-saturated calls]
+ = do dflags <- getDynFlags
+ emitCallWithExtraStack (call_conv, NativeReturn)
+ target
+ (nonVArgs fast_args)
+ (nonVArgs (stack_args dflags))
+ where
+ target = CmmLit (CmmLabel lbl)
+ (fast_args, rest_args) = splitAt real_arity args
+ stack_args dflags = slowArgs dflags rest_args
+ real_arity = case call_conv of
+ NativeNodeCall -> arity+1
+ _ -> arity
+
+
+-- When constructing calls, it is easier to keep the ArgReps and the
+-- CmmExprs zipped together. However, a void argument has no
+-- representation, so we need to use Maybe CmmExpr (the alternative of
+-- using zeroCLit or even undefined would work, but would be ugly).
+--
+getArgRepsAmodes :: [StgArg] -> FCode [(ArgRep, Maybe CmmExpr)]
+getArgRepsAmodes = mapM getArgRepAmode
+ where getArgRepAmode arg
+ | V <- rep = return (V, Nothing)
+ | otherwise = do expr <- getArgAmode (NonVoid arg)
+ return (rep, Just expr)
+ where rep = toArgRep (argPrimRep arg)
+
+nonVArgs :: [(ArgRep, Maybe CmmExpr)] -> [CmmExpr]
+nonVArgs [] = []
+nonVArgs ((_,Nothing) : args) = nonVArgs args
+nonVArgs ((_,Just arg) : args) = arg : nonVArgs args
+
+{-
+Note [over-saturated calls]
+
+The natural thing to do for an over-saturated call would be to call
+the function with the correct number of arguments, and then apply the
+remaining arguments to the value returned, e.g.
+
+ f a b c d (where f has arity 2)
+ -->
+ r = call f(a,b)
+ call r(c,d)
+
+but this entails
+ - saving c and d on the stack
+ - making a continuation info table
+ - at the continuation, loading c and d off the stack into regs
+ - finally, call r
+
+Note that since there are a fixed number of different r's
+(e.g. stg_ap_pp_fast), we can also pre-compile continuations
+that correspond to each of them, rather than generating a fresh
+one for each over-saturated call.
+
+Not only does this generate much less code, it is faster too. We will
+generate something like:
+
+Sp[old+16] = c
+Sp[old+24] = d
+Sp[old+32] = stg_ap_pp_info
+call f(a,b) -- usual calling convention
+
+For the purposes of the CmmCall node, we count this extra stack as
+just more arguments that we are passing on the stack (cml_args).
+-}
+
+-- | 'slowArgs' takes a list of function arguments and prepares them for
+-- pushing on the stack for "extra" arguments to a function which requires
+-- fewer arguments than we currently have.
+slowArgs :: DynFlags -> [(ArgRep, Maybe CmmExpr)] -> [(ArgRep, Maybe CmmExpr)]
+slowArgs _ [] = []
+slowArgs dflags args -- careful: reps contains voids (V), but args does not
+ | gopt Opt_SccProfilingOn dflags
+ = save_cccs ++ this_pat ++ slowArgs dflags rest_args
+ | otherwise = this_pat ++ slowArgs dflags rest_args
+ where
+ (arg_pat, n) = slowCallPattern (map fst args)
+ (call_args, rest_args) = splitAt n args
+
+ stg_ap_pat = mkCmmRetInfoLabel rtsUnitId arg_pat
+ this_pat = (N, Just (mkLblExpr stg_ap_pat)) : call_args
+ save_cccs = [(N, Just (mkLblExpr save_cccs_lbl)), (N, Just curCCS)]
+ save_cccs_lbl = mkCmmRetInfoLabel rtsUnitId (fsLit "stg_restore_cccs")
+
+-------------------------------------------------------------------------
+---- Laying out objects on the heap and stack
+-------------------------------------------------------------------------
+
+-- The heap always grows upwards, so hpRel is easy to compute
+hpRel :: VirtualHpOffset -- virtual offset of Hp
+ -> VirtualHpOffset -- virtual offset of The Thing
+ -> WordOff -- integer word offset
+hpRel hp off = off - hp
+
+getHpRelOffset :: VirtualHpOffset -> FCode CmmExpr
+-- See Note [Virtual and real heap pointers] in StgCmmMonad
+getHpRelOffset virtual_offset
+ = do dflags <- getDynFlags
+ hp_usg <- getHpUsage
+ return (cmmRegOffW dflags hpReg (hpRel (realHp hp_usg) virtual_offset))
+
+mkVirtHeapOffsets
+ :: DynFlags
+ -> Bool -- True <=> is a thunk
+ -> [NonVoid (PrimRep,a)] -- Things to make offsets for
+ -> (WordOff, -- _Total_ number of words allocated
+ WordOff, -- Number of words allocated for *pointers*
+ [(NonVoid a, ByteOff)])
+
+-- Things with their offsets from start of object in order of
+-- increasing offset; BUT THIS MAY BE DIFFERENT TO INPUT ORDER
+-- First in list gets lowest offset, which is initial offset + 1.
+--
+-- mkVirtHeapOffsets always returns boxed things with smaller offsets
+-- than the unboxed things
+
+mkVirtHeapOffsets dflags is_thunk things
+ = ASSERT(not (any (isVoidRep . fst . fromNonVoid) things))
+ ( bytesToWordsRoundUp dflags tot_bytes
+ , bytesToWordsRoundUp dflags bytes_of_ptrs
+ , ptrs_w_offsets ++ non_ptrs_w_offsets
+ )
+ where
+ hdr_words | is_thunk = thunkHdrSize dflags
+ | otherwise = fixedHdrSizeW dflags
+ hdr_bytes = wordsToBytes dflags hdr_words
+
+ (ptrs, non_ptrs) = partition (isGcPtrRep . fst . fromNonVoid) things
+
+ (bytes_of_ptrs, ptrs_w_offsets) =
+ mapAccumL computeOffset 0 ptrs
+ (tot_bytes, non_ptrs_w_offsets) =
+ mapAccumL computeOffset bytes_of_ptrs non_ptrs
+
+ computeOffset bytes_so_far nv_thing
+ = (bytes_so_far + wordsToBytes dflags (argRepSizeW dflags (toArgRep rep)),
+ (NonVoid thing, hdr_bytes + bytes_so_far))
+ where (rep,thing) = fromNonVoid nv_thing
+
+-- | Just like mkVirtHeapOffsets, but for constructors
+mkVirtConstrOffsets
+ :: DynFlags -> [NonVoid (PrimRep, a)]
+ -> (WordOff, WordOff, [(NonVoid a, ByteOff)])
+mkVirtConstrOffsets dflags = mkVirtHeapOffsets dflags False
+
+-- | Just like mkVirtConstrOffsets, but used when we don't have the actual
+-- arguments. Useful when e.g. generating info tables; we just need to know
+-- sizes of pointer and non-pointer fields.
+mkVirtConstrSizes :: DynFlags -> [NonVoid PrimRep] -> (WordOff, WordOff)
+mkVirtConstrSizes dflags field_reps
+ = (tot_wds, ptr_wds)
+ where
+ (tot_wds, ptr_wds, _) =
+ mkVirtConstrOffsets dflags
+ (map (\nv_rep -> NonVoid (fromNonVoid nv_rep, ())) field_reps)
+
+-------------------------------------------------------------------------
+--
+-- Making argument descriptors
+--
+-- An argument descriptor describes the layout of args on the stack,
+-- both for * GC (stack-layout) purposes, and
+-- * saving/restoring registers when a heap-check fails
+--
+-- Void arguments aren't important, therefore (contrast constructSlowCall)
+--
+-------------------------------------------------------------------------
+
+-- bring in ARG_P, ARG_N, etc.
+#include "rts/storage/FunTypes.h"
+
+mkArgDescr :: DynFlags -> [Id] -> ArgDescr
+mkArgDescr dflags args
+ = let arg_bits = argBits dflags arg_reps
+ arg_reps = filter isNonV (map idArgRep args)
+ -- Getting rid of voids eases matching of standard patterns
+ in case stdPattern arg_reps of
+ Just spec_id -> ArgSpec spec_id
+ Nothing -> ArgGen arg_bits
+
+argBits :: DynFlags -> [ArgRep] -> [Bool] -- True for non-ptr, False for ptr
+argBits _ [] = []
+argBits dflags (P : args) = False : argBits dflags args
+argBits dflags (arg : args) = take (argRepSizeW dflags arg) (repeat True)
+ ++ argBits dflags args
+
+----------------------
+stdPattern :: [ArgRep] -> Maybe Int
+stdPattern reps
+ = case reps of
+ [] -> Just ARG_NONE -- just void args, probably
+ [N] -> Just ARG_N
+ [P] -> Just ARG_P
+ [F] -> Just ARG_F
+ [D] -> Just ARG_D
+ [L] -> Just ARG_L
+ [V16] -> Just ARG_V16
+ [V32] -> Just ARG_V32
+ [V64] -> Just ARG_V64
+
+ [N,N] -> Just ARG_NN
+ [N,P] -> Just ARG_NP
+ [P,N] -> Just ARG_PN
+ [P,P] -> Just ARG_PP
+
+ [N,N,N] -> Just ARG_NNN
+ [N,N,P] -> Just ARG_NNP
+ [N,P,N] -> Just ARG_NPN
+ [N,P,P] -> Just ARG_NPP
+ [P,N,N] -> Just ARG_PNN
+ [P,N,P] -> Just ARG_PNP
+ [P,P,N] -> Just ARG_PPN
+ [P,P,P] -> Just ARG_PPP
+
+ [P,P,P,P] -> Just ARG_PPPP
+ [P,P,P,P,P] -> Just ARG_PPPPP
+ [P,P,P,P,P,P] -> Just ARG_PPPPPP
+
+ _ -> Nothing
+
+-------------------------------------------------------------------------
+--
+-- Generating the info table and code for a closure
+--
+-------------------------------------------------------------------------
+
+-- Here we make an info table of type 'CmmInfo'. The concrete
+-- representation as a list of 'CmmAddr' is handled later
+-- in the pipeline by 'cmmToRawCmm'.
+-- When loading the free variables, a function closure pointer may be tagged,
+-- so we must take it into account.
+
+emitClosureProcAndInfoTable :: Bool -- top-level?
+ -> Id -- name of the closure
+ -> LambdaFormInfo
+ -> CmmInfoTable
+ -> [NonVoid Id] -- incoming arguments
+ -> ((Int, LocalReg, [LocalReg]) -> FCode ()) -- function body
+ -> FCode ()
+emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl args body
+ = do { dflags <- getDynFlags
+ -- Bind the binder itself, but only if it's not a top-level
+ -- binding. We need non-top let-bindings to refer to the
+ -- top-level binding, which this binding would incorrectly shadow.
+ ; node <- if top_lvl then return $ idToReg dflags (NonVoid bndr)
+ else bindToReg (NonVoid bndr) lf_info
+ ; let node_points = nodeMustPointToIt dflags lf_info
+ ; arg_regs <- bindArgsToRegs args
+ ; let args' = if node_points then (node : arg_regs) else arg_regs
+ conv = if nodeMustPointToIt dflags lf_info then NativeNodeCall
+ else NativeDirectCall
+ (offset, _, _) = mkCallEntry dflags conv args' []
+ ; emitClosureAndInfoTable info_tbl conv args' $ body (offset, node, arg_regs)
+ }
+
+-- Data constructors need closures, but not with all the argument handling
+-- needed for functions. The shared part goes here.
+emitClosureAndInfoTable ::
+ CmmInfoTable -> Convention -> [LocalReg] -> FCode () -> FCode ()
+emitClosureAndInfoTable info_tbl conv args body
+ = do { (_, blks) <- getCodeScoped body
+ ; let entry_lbl = toEntryLbl (cit_lbl info_tbl)
+ ; emitProcWithConvention conv (Just info_tbl) entry_lbl args blks
+ }
diff --git a/codeGen/StgCmmMonad.hs b/codeGen/StgCmmMonad.hs
new file mode 100644
--- /dev/null
+++ b/codeGen/StgCmmMonad.hs
@@ -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 ->
+-- False ->
+--
+-- Naively we would generate
+--
+-- R2 = x -- argument to f
+-- Sp[young(L1)] = L1
+-- call f returns to L1
+-- L1:
+-- z = R1
+-- if (z & 1) then Ltrue else Lfalse
+-- Ltrue:
+-- Hp = Hp + 24
+-- if (Hp > HpLim) then L4 else L7
+-- L4:
+-- HpAlloc = 24
+-- goto L5
+-- L5:
+-- R1 = z
+-- Sp[young(L6)] = L6
+-- call stg_gc_unpt_r1 returns to L6
+-- L6:
+-- z = R1
+-- goto L1
+-- L7:
+--
+-- Lfalse:
+--
+--
+-- We want the gc call in L4 to return to L1, and discard L6. Note
+-- that not only can we share L1 and L6, but the assignment of the
+-- return address in L4 is unnecessary because the return address for
+-- L1 is already on the stack. We used to catch the sharing of L1 and
+-- L6 in the common-block-eliminator, but not the unnecessary return
+-- address assignment.
+--
+-- Since this case is so common I decided to make it more explicit and
+-- robust by programming the sharing directly, rather than relying on
+-- the common-block elimiantor to catch it. This makes
+-- common-block-elimianteion an optional optimisation, and furthermore
+-- generates less code in the first place that we have to subsequently
+-- clean up.
+--
+-- There are some rarer cases of common blocks that we don't catch
+-- this way, but that's ok. Common-block-elimination is still available
+-- to catch them when optimisation is enabled. Some examples are:
+--
+-- - when both the True and False branches do a heap check, we
+-- can share the heap-check failure code L4a and maybe L4
+--
+-- - in a case-of-case, there might be multiple continuations that
+-- we can common up.
+--
+-- It is always safe to use AssignedDirectly. Expressions that jump
+-- to the continuation from multiple places (e.g. case expressions)
+-- fall back to AssignedDirectly.
+--
+
+
+initCgInfoDown :: DynFlags -> Module -> CgInfoDownwards
+initCgInfoDown dflags mod
+ = MkCgInfoDown { cgd_dflags = dflags
+ , cgd_mod = mod
+ , cgd_updfr_off = initUpdFrameOff dflags
+ , cgd_ticky = mkTopTickyCtrLabel
+ , cgd_sequel = initSequel
+ , cgd_self_loop = Nothing
+ , cgd_tick_scope= GlobalScope }
+
+initSequel :: Sequel
+initSequel = Return
+
+initUpdFrameOff :: DynFlags -> UpdFrameOffset
+initUpdFrameOff dflags = widthInBytes (wordWidth dflags) -- space for the RA
+
+
+--------------------------------------------------------
+-- The code generator state
+--------------------------------------------------------
+
+data CgState
+ = MkCgState {
+ cgs_stmts :: CmmAGraph, -- Current procedure
+
+ cgs_tops :: OrdList CmmDecl,
+ -- Other procedures and data blocks in this compilation unit
+ -- Both are ordered only so that we can
+ -- reduce forward references, when it's easy to do so
+
+ cgs_binds :: CgBindings,
+
+ cgs_hp_usg :: HeapUsage,
+
+ cgs_uniqs :: UniqSupply }
+
+data HeapUsage -- See Note [Virtual and real heap pointers]
+ = HeapUsage {
+ virtHp :: VirtualHpOffset, -- Virtual offset of highest-allocated word
+ -- Incremented whenever we allocate
+ realHp :: VirtualHpOffset -- realHp: Virtual offset of real heap ptr
+ -- Used in instruction addressing modes
+ }
+
+type VirtualHpOffset = WordOff
+
+
+{- Note [Virtual and real heap pointers]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The code generator can allocate one or more objects contiguously, performing
+one heap check to cover allocation of all the objects at once. Let's call
+this little chunk of heap space an "allocation chunk". The code generator
+will emit code to
+ * Perform a heap-exhaustion check
+ * Move the heap pointer to the end of the allocation chunk
+ * Allocate multiple objects within the chunk
+
+The code generator uses VirtualHpOffsets to address words within a
+single allocation chunk; these start at one and increase positively.
+The first word of the chunk has VirtualHpOffset=1, the second has
+VirtualHpOffset=2, and so on.
+
+ * The field realHp tracks (the VirtualHpOffset) where the real Hp
+ register is pointing. Typically it'll be pointing to the end of the
+ allocation chunk.
+
+ * The field virtHp gives the VirtualHpOffset of the highest-allocated
+ word so far. It starts at zero (meaning no word has been allocated),
+ and increases whenever an object is allocated.
+
+The difference between realHp and virtHp gives the offset from the
+real Hp register of a particular word in the allocation chunk. This
+is what getHpRelOffset does. Since the returned offset is relative
+to the real Hp register, it is valid only until you change the real
+Hp register. (Changing virtHp doesn't matter.)
+-}
+
+
+initCgState :: UniqSupply -> CgState
+initCgState uniqs
+ = MkCgState { cgs_stmts = mkNop
+ , cgs_tops = nilOL
+ , cgs_binds = emptyVarEnv
+ , cgs_hp_usg = initHpUsage
+ , cgs_uniqs = uniqs }
+
+stateIncUsage :: CgState -> CgState -> CgState
+-- stateIncUsage@ e1 e2 incorporates in e1
+-- the heap high water mark found in e2.
+stateIncUsage s1 s2@(MkCgState { cgs_hp_usg = hp_usg })
+ = s1 { cgs_hp_usg = cgs_hp_usg s1 `maxHpHw` virtHp hp_usg }
+ `addCodeBlocksFrom` s2
+
+addCodeBlocksFrom :: CgState -> CgState -> CgState
+-- Add code blocks from the latter to the former
+-- (The cgs_stmts will often be empty, but not always; see codeOnly)
+s1 `addCodeBlocksFrom` s2
+ = s1 { cgs_stmts = cgs_stmts s1 MkGraph.<*> cgs_stmts s2,
+ cgs_tops = cgs_tops s1 `appOL` cgs_tops s2 }
+
+
+-- The heap high water mark is the larger of virtHp and hwHp. The latter is
+-- only records the high water marks of forked-off branches, so to find the
+-- heap high water mark you have to take the max of virtHp and hwHp. Remember,
+-- virtHp never retreats!
+--
+-- Note Jan 04: ok, so why do we only look at the virtual Hp??
+
+heapHWM :: HeapUsage -> VirtualHpOffset
+heapHWM = virtHp
+
+initHpUsage :: HeapUsage
+initHpUsage = HeapUsage { virtHp = 0, realHp = 0 }
+
+maxHpHw :: HeapUsage -> VirtualHpOffset -> HeapUsage
+hp_usg `maxHpHw` hw = hp_usg { virtHp = virtHp hp_usg `max` hw }
+
+--------------------------------------------------------
+-- Operators for getting and setting the state and "info_down".
+--------------------------------------------------------
+
+getState :: FCode CgState
+getState = FCode $ \_info_down state -> (# state, state #)
+
+setState :: CgState -> FCode ()
+setState state = FCode $ \_info_down _ -> (# (), state #)
+
+getHpUsage :: FCode HeapUsage
+getHpUsage = do
+ state <- getState
+ return $ cgs_hp_usg state
+
+setHpUsage :: HeapUsage -> FCode ()
+setHpUsage new_hp_usg = do
+ state <- getState
+ setState $ state {cgs_hp_usg = new_hp_usg}
+
+setVirtHp :: VirtualHpOffset -> FCode ()
+setVirtHp new_virtHp
+ = do { hp_usage <- getHpUsage
+ ; setHpUsage (hp_usage {virtHp = new_virtHp}) }
+
+getVirtHp :: FCode VirtualHpOffset
+getVirtHp
+ = do { hp_usage <- getHpUsage
+ ; return (virtHp hp_usage) }
+
+setRealHp :: VirtualHpOffset -> FCode ()
+setRealHp new_realHp
+ = do { hp_usage <- getHpUsage
+ ; setHpUsage (hp_usage {realHp = new_realHp}) }
+
+getBinds :: FCode CgBindings
+getBinds = do
+ state <- getState
+ return $ cgs_binds state
+
+setBinds :: CgBindings -> FCode ()
+setBinds new_binds = do
+ state <- getState
+ setState $ state {cgs_binds = new_binds}
+
+withState :: FCode a -> CgState -> FCode (a,CgState)
+withState (FCode fcode) newstate = FCode $ \info_down state ->
+ case fcode info_down newstate of
+ (# retval, state2 #) -> (# (retval,state2), state #)
+
+newUniqSupply :: FCode UniqSupply
+newUniqSupply = do
+ state <- getState
+ let (us1, us2) = splitUniqSupply (cgs_uniqs state)
+ setState $ state { cgs_uniqs = us1 }
+ return us2
+
+newUnique :: FCode Unique
+newUnique = do
+ state <- getState
+ let (u,us') = takeUniqFromSupply (cgs_uniqs state)
+ setState $ state { cgs_uniqs = us' }
+ return u
+
+------------------
+getInfoDown :: FCode CgInfoDownwards
+getInfoDown = FCode $ \info_down state -> (# info_down,state #)
+
+getSelfLoop :: FCode (Maybe SelfLoopInfo)
+getSelfLoop = do
+ info_down <- getInfoDown
+ return $ cgd_self_loop info_down
+
+withSelfLoop :: SelfLoopInfo -> FCode a -> FCode a
+withSelfLoop self_loop code = do
+ info_down <- getInfoDown
+ withInfoDown code (info_down {cgd_self_loop = Just self_loop})
+
+instance HasDynFlags FCode where
+ getDynFlags = liftM cgd_dflags getInfoDown
+
+getThisPackage :: FCode UnitId
+getThisPackage = liftM thisPackage getDynFlags
+
+withInfoDown :: FCode a -> CgInfoDownwards -> FCode a
+withInfoDown (FCode fcode) info_down = FCode $ \_ state -> fcode info_down state
+
+doFCode :: FCode a -> CgInfoDownwards -> CgState -> (a,CgState)
+doFCode (FCode fcode) info_down state =
+ case fcode info_down state of
+ (# a, s #) -> ( a, s )
+
+-- ----------------------------------------------------------------------------
+-- Get the current module name
+
+getModuleName :: FCode Module
+getModuleName = do { info <- getInfoDown; return (cgd_mod info) }
+
+-- ----------------------------------------------------------------------------
+-- Get/set the end-of-block info
+
+withSequel :: Sequel -> FCode a -> FCode a
+withSequel sequel code
+ = do { info <- getInfoDown
+ ; withInfoDown code (info {cgd_sequel = sequel, cgd_self_loop = Nothing }) }
+
+getSequel :: FCode Sequel
+getSequel = do { info <- getInfoDown
+ ; return (cgd_sequel info) }
+
+-- ----------------------------------------------------------------------------
+-- Get/set the size of the update frame
+
+-- We keep track of the size of the update frame so that we
+-- can set the stack pointer to the proper address on return
+-- (or tail call) from the closure.
+-- There should be at most one update frame for each closure.
+-- Note: I'm including the size of the original return address
+-- in the size of the update frame -- hence the default case on `get'.
+
+withUpdFrameOff :: UpdFrameOffset -> FCode a -> FCode a
+withUpdFrameOff size code
+ = do { info <- getInfoDown
+ ; withInfoDown code (info {cgd_updfr_off = size }) }
+
+getUpdFrameOff :: FCode UpdFrameOffset
+getUpdFrameOff
+ = do { info <- getInfoDown
+ ; return $ cgd_updfr_off info }
+
+-- ----------------------------------------------------------------------------
+-- Get/set the current ticky counter label
+
+getTickyCtrLabel :: FCode CLabel
+getTickyCtrLabel = do
+ info <- getInfoDown
+ return (cgd_ticky info)
+
+setTickyCtrLabel :: CLabel -> FCode a -> FCode a
+setTickyCtrLabel ticky code = do
+ info <- getInfoDown
+ withInfoDown code (info {cgd_ticky = ticky})
+
+-- ----------------------------------------------------------------------------
+-- Manage tick scopes
+
+-- | The current tick scope. We will assign this to generated blocks.
+getTickScope :: FCode CmmTickScope
+getTickScope = do
+ info <- getInfoDown
+ return (cgd_tick_scope info)
+
+-- | Places blocks generated by the given code into a fresh
+-- (sub-)scope. This will make sure that Cmm annotations in our scope
+-- will apply to the Cmm blocks generated therein - but not the other
+-- way around.
+tickScope :: FCode a -> FCode a
+tickScope code = do
+ info <- getInfoDown
+ if debugLevel (cgd_dflags info) == 0 then code else do
+ u <- newUnique
+ let scope' = SubScope u (cgd_tick_scope info)
+ withInfoDown code info{ cgd_tick_scope = scope' }
+
+
+--------------------------------------------------------
+-- Forking
+--------------------------------------------------------
+
+forkClosureBody :: FCode () -> FCode ()
+-- forkClosureBody compiles body_code in environment where:
+-- - sequel, update stack frame and self loop info are
+-- set to fresh values
+-- - state is set to a fresh value, except for local bindings
+-- that are passed in unchanged. It's up to the enclosed code to
+-- re-bind the free variables to a field of the closure.
+
+forkClosureBody body_code
+ = do { dflags <- getDynFlags
+ ; info <- getInfoDown
+ ; us <- newUniqSupply
+ ; state <- getState
+ ; let body_info_down = info { cgd_sequel = initSequel
+ , cgd_updfr_off = initUpdFrameOff dflags
+ , cgd_self_loop = Nothing }
+ fork_state_in = (initCgState us) { cgs_binds = cgs_binds state }
+ ((),fork_state_out) = doFCode body_code body_info_down fork_state_in
+ ; setState $ state `addCodeBlocksFrom` fork_state_out }
+
+forkLneBody :: FCode a -> FCode a
+-- 'forkLneBody' takes a body of let-no-escape binding and compiles
+-- it in the *current* environment, returning the graph thus constructed.
+--
+-- The current environment is passed on completely unchanged to
+-- the successor. In particular, any heap usage from the enclosed
+-- code is discarded; it should deal with its own heap consumption.
+forkLneBody body_code
+ = do { info_down <- getInfoDown
+ ; us <- newUniqSupply
+ ; state <- getState
+ ; let fork_state_in = (initCgState us) { cgs_binds = cgs_binds state }
+ (result, fork_state_out) = doFCode body_code info_down fork_state_in
+ ; setState $ state `addCodeBlocksFrom` fork_state_out
+ ; return result }
+
+codeOnly :: FCode () -> FCode ()
+-- Emit any code from the inner thing into the outer thing
+-- Do not affect anything else in the outer state
+-- Used in almost-circular code to prevent false loop dependencies
+codeOnly body_code
+ = do { info_down <- getInfoDown
+ ; us <- newUniqSupply
+ ; state <- getState
+ ; let fork_state_in = (initCgState us) { cgs_binds = cgs_binds state
+ , cgs_hp_usg = cgs_hp_usg state }
+ ((), fork_state_out) = doFCode body_code info_down fork_state_in
+ ; setState $ state `addCodeBlocksFrom` fork_state_out }
+
+forkAlts :: [FCode a] -> FCode [a]
+-- (forkAlts' bs d) takes fcodes 'bs' for the branches of a 'case', and
+-- an fcode for the default case 'd', and compiles each in the current
+-- environment. The current environment is passed on unmodified, except
+-- that the virtual Hp is moved on to the worst virtual Hp for the branches
+
+forkAlts branch_fcodes
+ = do { info_down <- getInfoDown
+ ; us <- newUniqSupply
+ ; state <- getState
+ ; let compile us branch
+ = (us2, doFCode branch info_down branch_state)
+ where
+ (us1,us2) = splitUniqSupply us
+ branch_state = (initCgState us1) {
+ cgs_binds = cgs_binds state
+ , cgs_hp_usg = cgs_hp_usg state }
+ (_us, results) = mapAccumL compile us branch_fcodes
+ (branch_results, branch_out_states) = unzip results
+ ; setState $ foldl stateIncUsage state branch_out_states
+ -- NB foldl. state is the *left* argument to stateIncUsage
+ ; return branch_results }
+
+-- collect the code emitted by an FCode computation
+getCodeR :: FCode a -> FCode (a, CmmAGraph)
+getCodeR fcode
+ = do { state1 <- getState
+ ; (a, state2) <- withState fcode (state1 { cgs_stmts = mkNop })
+ ; setState $ state2 { cgs_stmts = cgs_stmts state1 }
+ ; return (a, cgs_stmts state2) }
+
+getCode :: FCode a -> FCode CmmAGraph
+getCode fcode = do { (_,stmts) <- getCodeR fcode; return stmts }
+
+-- | Generate code into a fresh tick (sub-)scope and gather generated code
+getCodeScoped :: FCode a -> FCode (a, CmmAGraphScoped)
+getCodeScoped fcode
+ = do { state1 <- getState
+ ; ((a, tscope), state2) <-
+ tickScope $
+ flip withState state1 { cgs_stmts = mkNop } $
+ do { a <- fcode
+ ; scp <- getTickScope
+ ; return (a, scp) }
+ ; setState $ state2 { cgs_stmts = cgs_stmts state1 }
+ ; return (a, (cgs_stmts state2, tscope)) }
+
+
+-- 'getHeapUsage' applies a function to the amount of heap that it uses.
+-- It initialises the heap usage to zeros, and passes on an unchanged
+-- heap usage.
+--
+-- It is usually a prelude to performing a GC check, so everything must
+-- be in a tidy and consistent state.
+--
+-- Note the slightly subtle fixed point behaviour needed here
+
+getHeapUsage :: (VirtualHpOffset -> FCode a) -> FCode a
+getHeapUsage fcode
+ = do { info_down <- getInfoDown
+ ; state <- getState
+ ; let fstate_in = state { cgs_hp_usg = initHpUsage }
+ (r, fstate_out) = doFCode (fcode hp_hw) info_down fstate_in
+ hp_hw = heapHWM (cgs_hp_usg fstate_out) -- Loop here!
+
+ ; setState $ fstate_out { cgs_hp_usg = cgs_hp_usg state }
+ ; return r }
+
+-- ----------------------------------------------------------------------------
+-- Combinators for emitting code
+
+emitCgStmt :: CgStmt -> FCode ()
+emitCgStmt stmt
+ = do { state <- getState
+ ; setState $ state { cgs_stmts = cgs_stmts state `snocOL` stmt }
+ }
+
+emitLabel :: BlockId -> FCode ()
+emitLabel id = do tscope <- getTickScope
+ emitCgStmt (CgLabel id tscope)
+
+emitComment :: FastString -> FCode ()
+#if 0 /* def DEBUG */
+emitComment s = emitCgStmt (CgStmt (CmmComment s))
+#else
+emitComment _ = return ()
+#endif
+
+emitTick :: CmmTickish -> FCode ()
+emitTick = emitCgStmt . CgStmt . CmmTick
+
+emitUnwind :: [(GlobalReg, Maybe CmmExpr)] -> FCode ()
+emitUnwind regs = do
+ dflags <- getDynFlags
+ when (debugLevel dflags > 0) $ do
+ emitCgStmt $ CgStmt $ CmmUnwind regs
+
+emitAssign :: CmmReg -> CmmExpr -> FCode ()
+emitAssign l r = emitCgStmt (CgStmt (CmmAssign l r))
+
+emitStore :: CmmExpr -> CmmExpr -> FCode ()
+emitStore l r = emitCgStmt (CgStmt (CmmStore l r))
+
+emit :: CmmAGraph -> FCode ()
+emit ag
+ = do { state <- getState
+ ; setState $ state { cgs_stmts = cgs_stmts state MkGraph.<*> ag } }
+
+emitDecl :: CmmDecl -> FCode ()
+emitDecl decl
+ = do { state <- getState
+ ; setState $ state { cgs_tops = cgs_tops state `snocOL` decl } }
+
+emitOutOfLine :: BlockId -> CmmAGraphScoped -> FCode ()
+emitOutOfLine l (stmts, tscope) = emitCgStmt (CgFork l stmts tscope)
+
+emitProcWithStackFrame
+ :: Convention -- entry convention
+ -> Maybe CmmInfoTable -- info table?
+ -> CLabel -- label for the proc
+ -> [CmmFormal] -- stack frame
+ -> [CmmFormal] -- arguments
+ -> CmmAGraphScoped -- code
+ -> Bool -- do stack layout?
+ -> FCode ()
+
+emitProcWithStackFrame _conv mb_info lbl _stk_args [] blocks False
+ = do { dflags <- getDynFlags
+ ; emitProc_ mb_info lbl [] blocks (widthInBytes (wordWidth dflags)) False
+ }
+emitProcWithStackFrame conv mb_info lbl stk_args args (graph, tscope) True
+ -- do layout
+ = do { dflags <- getDynFlags
+ ; let (offset, live, entry) = mkCallEntry dflags conv args stk_args
+ graph' = entry MkGraph.<*> graph
+ ; emitProc_ mb_info lbl live (graph', tscope) offset True
+ }
+emitProcWithStackFrame _ _ _ _ _ _ _ = panic "emitProcWithStackFrame"
+
+emitProcWithConvention :: Convention -> Maybe CmmInfoTable -> CLabel
+ -> [CmmFormal]
+ -> CmmAGraphScoped
+ -> FCode ()
+emitProcWithConvention conv mb_info lbl args blocks
+ = emitProcWithStackFrame conv mb_info lbl [] args blocks True
+
+emitProc :: Maybe CmmInfoTable -> CLabel -> [GlobalReg] -> CmmAGraphScoped
+ -> Int -> FCode ()
+emitProc mb_info lbl live blocks offset
+ = emitProc_ mb_info lbl live blocks offset True
+
+emitProc_ :: Maybe CmmInfoTable -> CLabel -> [GlobalReg] -> CmmAGraphScoped
+ -> Int -> Bool -> FCode ()
+emitProc_ mb_info lbl live blocks offset do_layout
+ = do { dflags <- getDynFlags
+ ; l <- newBlockId
+ ; let
+ blks = labelAGraph l blocks
+
+ infos | Just info <- mb_info = mapSingleton (g_entry blks) info
+ | otherwise = mapEmpty
+
+ sinfo = StackInfo { arg_space = offset
+ , updfr_space = Just (initUpdFrameOff dflags)
+ , do_layout = do_layout }
+
+ tinfo = TopInfo { info_tbls = infos
+ , stack_info=sinfo}
+
+ proc_block = CmmProc tinfo lbl live blks
+
+ ; state <- getState
+ ; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } }
+
+getCmm :: FCode () -> FCode CmmGroup
+-- Get all the CmmTops (there should be no stmts)
+-- Return a single Cmm which may be split from other Cmms by
+-- object splitting (at a later stage)
+getCmm code
+ = do { state1 <- getState
+ ; ((), state2) <- withState code (state1 { cgs_tops = nilOL })
+ ; setState $ state2 { cgs_tops = cgs_tops state1 }
+ ; return (fromOL (cgs_tops state2)) }
+
+
+mkCmmIfThenElse :: CmmExpr -> CmmAGraph -> CmmAGraph -> FCode CmmAGraph
+mkCmmIfThenElse e tbranch fbranch = mkCmmIfThenElse' e tbranch fbranch Nothing
+
+mkCmmIfThenElse' :: CmmExpr -> CmmAGraph -> CmmAGraph
+ -> Maybe Bool -> FCode CmmAGraph
+mkCmmIfThenElse' e tbranch fbranch likely = do
+ tscp <- getTickScope
+ endif <- newBlockId
+ tid <- newBlockId
+ fid <- newBlockId
+
+ let
+ (test, then_, else_, likely') = case likely of
+ Just False | Just e' <- maybeInvertCmmExpr e
+ -- currently NCG doesn't know about likely
+ -- annotations. We manually switch then and
+ -- else branch so the likely false branch
+ -- becomes a fallthrough.
+ -> (e', fbranch, tbranch, Just True)
+ _ -> (e, tbranch, fbranch, likely)
+
+ return $ catAGraphs [ mkCbranch test tid fid likely'
+ , mkLabel tid tscp, then_, mkBranch endif
+ , mkLabel fid tscp, else_, mkLabel endif tscp ]
+
+mkCmmIfGoto :: CmmExpr -> BlockId -> FCode CmmAGraph
+mkCmmIfGoto e tid = mkCmmIfGoto' e tid Nothing
+
+mkCmmIfGoto' :: CmmExpr -> BlockId -> Maybe Bool -> FCode CmmAGraph
+mkCmmIfGoto' e tid l = do
+ endif <- newBlockId
+ tscp <- getTickScope
+ return $ catAGraphs [ mkCbranch e tid endif l, mkLabel endif tscp ]
+
+mkCmmIfThen :: CmmExpr -> CmmAGraph -> FCode CmmAGraph
+mkCmmIfThen e tbranch = mkCmmIfThen' e tbranch Nothing
+
+mkCmmIfThen' :: CmmExpr -> CmmAGraph -> Maybe Bool -> FCode CmmAGraph
+mkCmmIfThen' e tbranch l = do
+ endif <- newBlockId
+ tid <- newBlockId
+ tscp <- getTickScope
+ return $ catAGraphs [ mkCbranch e tid endif l
+ , mkLabel tid tscp, tbranch, mkLabel endif tscp ]
+
+mkCall :: CmmExpr -> (Convention, Convention) -> [CmmFormal] -> [CmmExpr]
+ -> UpdFrameOffset -> [CmmExpr] -> FCode CmmAGraph
+mkCall f (callConv, retConv) results actuals updfr_off extra_stack = do
+ dflags <- getDynFlags
+ k <- newBlockId
+ tscp <- getTickScope
+ let area = Young k
+ (off, _, copyin) = copyInOflow dflags retConv area results []
+ copyout = mkCallReturnsTo dflags f callConv actuals k off updfr_off extra_stack
+ return $ catAGraphs [copyout, mkLabel k tscp, copyin]
+
+mkCmmCall :: CmmExpr -> [CmmFormal] -> [CmmExpr] -> UpdFrameOffset
+ -> FCode CmmAGraph
+mkCmmCall f results actuals updfr_off
+ = mkCall f (NativeDirectCall, NativeReturn) results actuals updfr_off []
+
+
+-- ----------------------------------------------------------------------------
+-- turn CmmAGraph into CmmGraph, for making a new proc.
+
+aGraphToGraph :: CmmAGraphScoped -> FCode CmmGraph
+aGraphToGraph stmts
+ = do { l <- newBlockId
+ ; return (labelAGraph l stmts) }
diff --git a/codeGen/StgCmmPrim.hs b/codeGen/StgCmmPrim.hs
new file mode 100644
--- /dev/null
+++ b/codeGen/StgCmmPrim.hs
@@ -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 ]
diff --git a/codeGen/StgCmmProf.hs b/codeGen/StgCmmProf.hs
new file mode 100644
--- /dev/null
+++ b/codeGen/StgCmmProf.hs
@@ -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)
diff --git a/codeGen/StgCmmTicky.hs b/codeGen/StgCmmTicky.hs
new file mode 100644
--- /dev/null
+++ b/codeGen/StgCmmTicky.hs
@@ -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 -RTS
+
+The rts/Ticky.c function that generates the report includes an
+STG-declaration's ticky counters if
+
+ * that declaration was entered, or
+
+ * it was allocated (if -ticky-allocd)
+
+On either of those events, the counter is "registered" by adding it to
+a linked list; cf the CMM generated by registerTickyCtr.
+
+Ticky-ticky profiling has evolved over many years. Many of the
+counters from its most sophisticated days are no longer
+active/accurate. As the RTS has changed, sometimes the ticky code for
+relevant counters was not accordingly updated. Unfortunately, neither
+were the comments.
+
+As of March 2013, there still exist deprecated code and comments in
+the code generator as well as the RTS because:
+
+ * I don't know what is out-of-date versus merely commented out for
+ momentary convenience, and
+
+ * someone else might know how to repair it!
+
+-}
+
+module StgCmmTicky (
+ withNewTickyCounterFun,
+ withNewTickyCounterLNE,
+ withNewTickyCounterThunk,
+ withNewTickyCounterStdThunk,
+ withNewTickyCounterCon,
+
+ tickyDynAlloc,
+ tickyAllocHeap,
+
+ tickyAllocPrim,
+ tickyAllocThunk,
+ tickyAllocPAP,
+ tickyHeapCheck,
+ tickyStackCheck,
+
+ tickyUnknownCall, tickyDirectCall,
+
+ tickyPushUpdateFrame,
+ tickyUpdateFrameOmitted,
+
+ tickyEnterDynCon,
+ tickyEnterStaticCon,
+ tickyEnterViaNode,
+
+ tickyEnterFun,
+ tickyEnterThunk, tickyEnterStdThunk, -- dynamic non-value
+ -- thunks only
+ tickyEnterLNE,
+
+ tickyUpdateBhCaf,
+ tickyBlackHole,
+ tickyUnboxedTupleReturn,
+ tickyReturnOldCon, tickyReturnNewCon,
+
+ tickyKnownCallTooFewArgs, tickyKnownCallExact, tickyKnownCallExtraArgs,
+ tickySlowCall, tickySlowCallPat,
+ ) where
+
+#include "HsVersions.h"
+
+import StgCmmArgRep ( slowCallPattern , toArgRep , argRepString )
+import StgCmmClosure
+import StgCmmUtils
+import StgCmmMonad
+
+import StgSyn
+import CmmExpr
+import MkGraph
+import CmmUtils
+import CLabel
+import SMRep
+
+import Module
+import Name
+import Id
+import BasicTypes
+import FastString
+import Outputable
+
+import DynFlags
+
+-- Turgid imports for showTypeCategory
+import PrelNames
+import TcType
+import Type
+import TyCon
+
+import Data.Maybe
+import qualified Data.Char
+import Control.Monad ( unless, when )
+
+-----------------------------------------------------------------------------
+--
+-- Ticky-ticky profiling
+--
+-----------------------------------------------------------------------------
+
+data TickyClosureType
+ = TickyFun
+ Bool -- True <-> single entry
+ | TickyCon
+ | TickyThunk
+ Bool -- True <-> updateable
+ Bool -- True <-> standard thunk (AP or selector), has no entry counter
+ | TickyLNE
+
+withNewTickyCounterFun :: Bool -> Name -> [NonVoid Id] -> FCode a -> FCode a
+withNewTickyCounterFun single_entry = withNewTickyCounter (TickyFun single_entry)
+
+withNewTickyCounterLNE :: Name -> [NonVoid Id] -> FCode a -> FCode a
+withNewTickyCounterLNE nm args code = do
+ b <- tickyLNEIsOn
+ if not b then code else withNewTickyCounter TickyLNE nm args code
+
+withNewTickyCounterThunk
+ :: Bool -- ^ static
+ -> Bool -- ^ updateable
+ -> Name
+ -> FCode a
+ -> FCode a
+withNewTickyCounterThunk isStatic isUpdatable name code = do
+ b <- tickyDynThunkIsOn
+ if isStatic || not b -- ignore static thunks
+ then code
+ else withNewTickyCounter (TickyThunk isUpdatable False) name [] code
+
+withNewTickyCounterStdThunk
+ :: Bool -- ^ updateable
+ -> Name
+ -> FCode a
+ -> FCode a
+withNewTickyCounterStdThunk isUpdatable name code = do
+ b <- tickyDynThunkIsOn
+ if not b
+ then code
+ else withNewTickyCounter (TickyThunk isUpdatable True) name [] code
+
+withNewTickyCounterCon
+ :: Name
+ -> FCode a
+ -> FCode a
+withNewTickyCounterCon name code = do
+ b <- tickyDynThunkIsOn
+ if not b
+ then code
+ else withNewTickyCounter TickyCon name [] code
+
+-- args does not include the void arguments
+withNewTickyCounter :: TickyClosureType -> Name -> [NonVoid Id] -> FCode a -> FCode a
+withNewTickyCounter cloType name args m = do
+ lbl <- emitTickyCounter cloType name args
+ setTickyCtrLabel lbl m
+
+emitTickyCounter :: TickyClosureType -> Name -> [NonVoid Id] -> FCode CLabel
+emitTickyCounter cloType name args
+ = let ctr_lbl = mkRednCountsLabel name in
+ (>> return ctr_lbl) $
+ ifTicky $ do
+ { dflags <- getDynFlags
+ ; parent <- getTickyCtrLabel
+ ; mod_name <- getModuleName
+
+ -- When printing the name of a thing in a ticky file, we
+ -- want to give the module name even for *local* things. We
+ -- print just "x (M)" rather that "M.x" to distinguish them
+ -- from the global kind.
+ ; let ppr_for_ticky_name :: SDoc
+ ppr_for_ticky_name =
+ let n = ppr name
+ ext = case cloType of
+ TickyFun single_entry -> parens $ hcat $ punctuate comma $
+ [text "fun"] ++ [text "se"|single_entry]
+ TickyCon -> parens (text "con")
+ TickyThunk upd std -> parens $ hcat $ punctuate comma $
+ [text "thk"] ++ [text "se"|not upd] ++ [text "std"|std]
+ TickyLNE | isInternalName name -> parens (text "LNE")
+ | otherwise -> panic "emitTickyCounter: how is this an external LNE?"
+ p = case hasHaskellName parent of
+ -- NB the default "top" ticky ctr does not
+ -- have a Haskell name
+ Just pname -> text "in" <+> ppr (nameUnique pname)
+ _ -> empty
+ in if isInternalName name
+ then n <+> parens (ppr mod_name) <+> ext <+> p
+ else n <+> ext <+> p
+
+ ; fun_descr_lit <- newStringCLit $ showSDocDebug dflags ppr_for_ticky_name
+ ; arg_descr_lit <- newStringCLit $ map (showTypeCategory . idType . fromNonVoid) args
+ ; emitDataLits ctr_lbl
+ -- Must match layout of includes/rts/Ticky.h's StgEntCounter
+ --
+ -- krc: note that all the fields are I32 now; some were I16
+ -- before, but the code generator wasn't handling that
+ -- properly and it led to chaos, panic and disorder.
+ [ mkIntCLit dflags 0, -- registered?
+ mkIntCLit dflags (length args), -- Arity
+ mkIntCLit dflags 0, -- Heap allocated for this thing
+ fun_descr_lit,
+ arg_descr_lit,
+ zeroCLit dflags, -- Entries into this thing
+ zeroCLit dflags, -- Heap allocated by this thing
+ zeroCLit dflags -- Link to next StgEntCounter
+ ]
+ }
+
+-- -----------------------------------------------------------------------------
+-- Ticky stack frames
+
+tickyPushUpdateFrame, tickyUpdateFrameOmitted :: FCode ()
+tickyPushUpdateFrame = ifTicky $ bumpTickyCounter (fsLit "UPDF_PUSHED_ctr")
+tickyUpdateFrameOmitted = ifTicky $ bumpTickyCounter (fsLit "UPDF_OMITTED_ctr")
+
+-- -----------------------------------------------------------------------------
+-- Ticky entries
+
+-- NB the name-specific entries are only available for names that have
+-- dedicated Cmm code. As far as I know, this just rules out
+-- constructor thunks. For them, there is no CMM code block to put the
+-- bump of name-specific ticky counter into. On the other hand, we can
+-- still track allocation their allocation.
+
+tickyEnterDynCon, tickyEnterStaticCon, tickyEnterViaNode :: FCode ()
+tickyEnterDynCon = ifTicky $ bumpTickyCounter (fsLit "ENT_DYN_CON_ctr")
+tickyEnterStaticCon = ifTicky $ bumpTickyCounter (fsLit "ENT_STATIC_CON_ctr")
+tickyEnterViaNode = ifTicky $ bumpTickyCounter (fsLit "ENT_VIA_NODE_ctr")
+
+tickyEnterThunk :: ClosureInfo -> FCode ()
+tickyEnterThunk cl_info
+ = ifTicky $ do
+ { bumpTickyCounter ctr
+ ; unless static $ do
+ ticky_ctr_lbl <- getTickyCtrLabel
+ registerTickyCtrAtEntryDyn ticky_ctr_lbl
+ bumpTickyEntryCount ticky_ctr_lbl }
+ where
+ updatable = closureSingleEntry cl_info
+ static = isStaticClosure cl_info
+
+ ctr | static = if updatable then fsLit "ENT_STATIC_THK_SINGLE_ctr"
+ else fsLit "ENT_STATIC_THK_MANY_ctr"
+ | otherwise = if updatable then fsLit "ENT_DYN_THK_SINGLE_ctr"
+ else fsLit "ENT_DYN_THK_MANY_ctr"
+
+tickyEnterStdThunk :: ClosureInfo -> FCode ()
+tickyEnterStdThunk = tickyEnterThunk
+
+tickyBlackHole :: Bool{-updatable-} -> FCode ()
+tickyBlackHole updatable
+ = ifTicky (bumpTickyCounter ctr)
+ where
+ ctr | updatable = (fsLit "UPD_BH_SINGLE_ENTRY_ctr")
+ | otherwise = (fsLit "UPD_BH_UPDATABLE_ctr")
+
+tickyUpdateBhCaf :: ClosureInfo -> FCode ()
+tickyUpdateBhCaf cl_info
+ = ifTicky (bumpTickyCounter ctr)
+ where
+ ctr | closureUpdReqd cl_info = (fsLit "UPD_CAF_BH_SINGLE_ENTRY_ctr")
+ | otherwise = (fsLit "UPD_CAF_BH_UPDATABLE_ctr")
+
+tickyEnterFun :: ClosureInfo -> FCode ()
+tickyEnterFun cl_info = ifTicky $ do
+ ctr_lbl <- getTickyCtrLabel
+
+ if isStaticClosure cl_info
+ then do bumpTickyCounter (fsLit "ENT_STATIC_FUN_DIRECT_ctr")
+ registerTickyCtr ctr_lbl
+ else do bumpTickyCounter (fsLit "ENT_DYN_FUN_DIRECT_ctr")
+ registerTickyCtrAtEntryDyn ctr_lbl
+
+ bumpTickyEntryCount ctr_lbl
+
+tickyEnterLNE :: FCode ()
+tickyEnterLNE = ifTicky $ do
+ bumpTickyCounter (fsLit "ENT_LNE_ctr")
+ ifTickyLNE $ do
+ ctr_lbl <- getTickyCtrLabel
+ registerTickyCtr ctr_lbl
+ bumpTickyEntryCount ctr_lbl
+
+-- needn't register a counter upon entry if
+--
+-- 1) it's for a dynamic closure, and
+--
+-- 2) -ticky-allocd is on
+--
+-- since the counter was registered already upon being alloc'd
+registerTickyCtrAtEntryDyn :: CLabel -> FCode ()
+registerTickyCtrAtEntryDyn ctr_lbl = do
+ already_registered <- tickyAllocdIsOn
+ when (not already_registered) $ registerTickyCtr ctr_lbl
+
+registerTickyCtr :: CLabel -> FCode ()
+-- Register a ticky counter
+-- if ( ! f_ct.registeredp ) {
+-- f_ct.link = ticky_entry_ctrs; /* hook this one onto the front of the list */
+-- ticky_entry_ctrs = & (f_ct); /* mark it as "registered" */
+-- f_ct.registeredp = 1 }
+registerTickyCtr ctr_lbl = do
+ dflags <- getDynFlags
+ let
+ -- krc: code generator doesn't handle Not, so we test for Eq 0 instead
+ test = CmmMachOp (MO_Eq (wordWidth dflags))
+ [CmmLoad (CmmLit (cmmLabelOffB ctr_lbl
+ (oFFSET_StgEntCounter_registeredp dflags))) (bWord dflags),
+ zeroExpr dflags]
+ register_stmts
+ = [ mkStore (CmmLit (cmmLabelOffB ctr_lbl (oFFSET_StgEntCounter_link dflags)))
+ (CmmLoad ticky_entry_ctrs (bWord dflags))
+ , mkStore ticky_entry_ctrs (mkLblExpr ctr_lbl)
+ , mkStore (CmmLit (cmmLabelOffB ctr_lbl
+ (oFFSET_StgEntCounter_registeredp dflags)))
+ (mkIntExpr dflags 1) ]
+ ticky_entry_ctrs = mkLblExpr (mkCmmDataLabel rtsUnitId (fsLit "ticky_entry_ctrs"))
+ emit =<< mkCmmIfThen test (catAGraphs register_stmts)
+
+tickyReturnOldCon, tickyReturnNewCon :: RepArity -> FCode ()
+tickyReturnOldCon arity
+ = ifTicky $ do { bumpTickyCounter (fsLit "RET_OLD_ctr")
+ ; bumpHistogram (fsLit "RET_OLD_hst") arity }
+tickyReturnNewCon arity
+ = ifTicky $ do { bumpTickyCounter (fsLit "RET_NEW_ctr")
+ ; bumpHistogram (fsLit "RET_NEW_hst") arity }
+
+tickyUnboxedTupleReturn :: RepArity -> FCode ()
+tickyUnboxedTupleReturn arity
+ = ifTicky $ do { bumpTickyCounter (fsLit "RET_UNBOXED_TUP_ctr")
+ ; bumpHistogram (fsLit "RET_UNBOXED_TUP_hst") arity }
+
+-- -----------------------------------------------------------------------------
+-- Ticky calls
+
+-- Ticks at a *call site*:
+tickyDirectCall :: RepArity -> [StgArg] -> FCode ()
+tickyDirectCall arity args
+ | arity == length args = tickyKnownCallExact
+ | otherwise = do tickyKnownCallExtraArgs
+ tickySlowCallPat (map argPrimRep (drop arity args))
+
+tickyKnownCallTooFewArgs :: FCode ()
+tickyKnownCallTooFewArgs = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_TOO_FEW_ARGS_ctr")
+
+tickyKnownCallExact :: FCode ()
+tickyKnownCallExact = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_ctr")
+
+tickyKnownCallExtraArgs :: FCode ()
+tickyKnownCallExtraArgs = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_EXTRA_ARGS_ctr")
+
+tickyUnknownCall :: FCode ()
+tickyUnknownCall = ifTicky $ bumpTickyCounter (fsLit "UNKNOWN_CALL_ctr")
+
+-- Tick for the call pattern at slow call site (i.e. in addition to
+-- tickyUnknownCall, tickyKnownCallExtraArgs, etc.)
+tickySlowCall :: LambdaFormInfo -> [StgArg] -> FCode ()
+tickySlowCall _ [] = return ()
+tickySlowCall lf_info args = do
+ -- see Note [Ticky for slow calls]
+ if isKnownFun lf_info
+ then tickyKnownCallTooFewArgs
+ else tickyUnknownCall
+ tickySlowCallPat (map argPrimRep args)
+
+tickySlowCallPat :: [PrimRep] -> FCode ()
+tickySlowCallPat args = ifTicky $
+ let argReps = map toArgRep args
+ (_, n_matched) = slowCallPattern argReps
+ in if n_matched > 0 && n_matched == length args
+ then bumpTickyLbl $ mkRtsSlowFastTickyCtrLabel $ concatMap (map Data.Char.toLower . argRepString) argReps
+ else bumpTickyCounter $ fsLit "VERY_SLOW_CALL_ctr"
+
+{-
+
+Note [Ticky for slow calls]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Terminology is unfortunately a bit mixed up for these calls. codeGen
+uses "slow call" to refer to unknown calls and under-saturated known
+calls.
+
+Nowadays, though (ie as of the eval/apply paper), the significantly
+slower calls are actually just a subset of these: the ones with no
+built-in argument pattern (cf StgCmmArgRep.slowCallPattern)
+
+So for ticky profiling, we split slow calls into
+"SLOW_CALL_fast__ctr" (those matching a built-in pattern) and
+VERY_SLOW_CALL_ctr (those without a built-in pattern; these are very
+bad for both space and time).
+
+-}
+
+-- -----------------------------------------------------------------------------
+-- Ticky allocation
+
+tickyDynAlloc :: Maybe Id -> SMRep -> LambdaFormInfo -> FCode ()
+-- Called when doing a dynamic heap allocation; the LambdaFormInfo
+-- used to distinguish between closure types
+--
+-- TODO what else to count while we're here?
+tickyDynAlloc mb_id rep lf = ifTicky $ getDynFlags >>= \dflags ->
+ let bytes = wORD_SIZE dflags * heapClosureSizeW dflags rep
+
+ countGlobal tot ctr = do
+ bumpTickyCounterBy tot bytes
+ bumpTickyCounter ctr
+ countSpecific = ifTickyAllocd $ case mb_id of
+ Nothing -> return ()
+ Just id -> do
+ let ctr_lbl = mkRednCountsLabel (idName id)
+ registerTickyCtr ctr_lbl
+ bumpTickyAllocd ctr_lbl bytes
+
+ -- TODO are we still tracking "good stuff" (_gds) versus
+ -- administrative (_adm) versus slop (_slp)? I'm going with all _gds
+ -- for now, since I don't currently know neither if we do nor how to
+ -- distinguish. NSF Mar 2013
+
+ in case () of
+ _ | isConRep rep ->
+ ifTickyDynThunk countSpecific >>
+ countGlobal (fsLit "ALLOC_CON_gds") (fsLit "ALLOC_CON_ctr")
+ | isThunkRep rep ->
+ ifTickyDynThunk countSpecific >>
+ if lfUpdatable lf
+ then countGlobal (fsLit "ALLOC_THK_gds") (fsLit "ALLOC_UP_THK_ctr")
+ else countGlobal (fsLit "ALLOC_THK_gds") (fsLit "ALLOC_SE_THK_ctr")
+ | isFunRep rep ->
+ countSpecific >>
+ countGlobal (fsLit "ALLOC_FUN_gds") (fsLit "ALLOC_FUN_ctr")
+ | otherwise -> panic "How is this heap object not a con, thunk, or fun?"
+
+
+
+tickyAllocHeap ::
+ Bool -> -- is this a genuine allocation? As opposed to
+ -- StgCmmLayout.adjustHpBackwards
+ VirtualHpOffset -> FCode ()
+-- Called when doing a heap check [TICK_ALLOC_HEAP]
+-- Must be lazy in the amount of allocation!
+tickyAllocHeap genuine hp
+ = ifTicky $
+ do { dflags <- getDynFlags
+ ; ticky_ctr <- getTickyCtrLabel
+ ; emit $ catAGraphs $
+ -- only test hp from within the emit so that the monadic
+ -- computation itself is not strict in hp (cf knot in
+ -- StgCmmMonad.getHeapUsage)
+ if hp == 0 then []
+ else let !bytes = wORD_SIZE dflags * hp in [
+ -- Bump the allocation total in the closure's StgEntCounter
+ addToMem (rEP_StgEntCounter_allocs dflags)
+ (CmmLit (cmmLabelOffB ticky_ctr (oFFSET_StgEntCounter_allocs dflags)))
+ bytes,
+ -- Bump the global allocation total ALLOC_HEAP_tot
+ addToMemLbl (bWord dflags)
+ (mkCmmDataLabel rtsUnitId (fsLit "ALLOC_HEAP_tot"))
+ bytes,
+ -- Bump the global allocation counter ALLOC_HEAP_ctr
+ if not genuine then mkNop
+ else addToMemLbl (bWord dflags)
+ (mkCmmDataLabel rtsUnitId (fsLit "ALLOC_HEAP_ctr"))
+ 1
+ ]}
+
+
+--------------------------------------------------------------------------------
+-- these three are only called from CmmParse.y (ie ultimately from the RTS)
+
+-- the units are bytes
+
+tickyAllocPrim :: CmmExpr -- ^ size of the full header, in bytes
+ -> CmmExpr -- ^ size of the payload, in bytes
+ -> CmmExpr -> FCode ()
+tickyAllocPrim _hdr _goods _slop = ifTicky $ do
+ bumpTickyCounter (fsLit "ALLOC_PRIM_ctr")
+ bumpTickyCounterByE (fsLit "ALLOC_PRIM_adm") _hdr
+ bumpTickyCounterByE (fsLit "ALLOC_PRIM_gds") _goods
+ bumpTickyCounterByE (fsLit "ALLOC_PRIM_slp") _slop
+
+tickyAllocThunk :: CmmExpr -> CmmExpr -> FCode ()
+tickyAllocThunk _goods _slop = ifTicky $ do
+ -- TODO is it ever called with a Single-Entry thunk?
+ bumpTickyCounter (fsLit "ALLOC_UP_THK_ctr")
+ bumpTickyCounterByE (fsLit "ALLOC_THK_gds") _goods
+ bumpTickyCounterByE (fsLit "ALLOC_THK_slp") _slop
+
+tickyAllocPAP :: CmmExpr -> CmmExpr -> FCode ()
+tickyAllocPAP _goods _slop = ifTicky $ do
+ bumpTickyCounter (fsLit "ALLOC_PAP_ctr")
+ bumpTickyCounterByE (fsLit "ALLOC_PAP_gds") _goods
+ bumpTickyCounterByE (fsLit "ALLOC_PAP_slp") _slop
+
+tickyHeapCheck :: FCode ()
+tickyHeapCheck = ifTicky $ bumpTickyCounter (fsLit "HEAP_CHK_ctr")
+
+tickyStackCheck :: FCode ()
+tickyStackCheck = ifTicky $ bumpTickyCounter (fsLit "STK_CHK_ctr")
+
+-- -----------------------------------------------------------------------------
+-- Ticky utils
+
+ifTicky :: FCode () -> FCode ()
+ifTicky code =
+ getDynFlags >>= \dflags -> when (gopt Opt_Ticky dflags) code
+
+tickyAllocdIsOn :: FCode Bool
+tickyAllocdIsOn = gopt Opt_Ticky_Allocd `fmap` getDynFlags
+
+tickyLNEIsOn :: FCode Bool
+tickyLNEIsOn = gopt Opt_Ticky_LNE `fmap` getDynFlags
+
+tickyDynThunkIsOn :: FCode Bool
+tickyDynThunkIsOn = gopt Opt_Ticky_Dyn_Thunk `fmap` getDynFlags
+
+ifTickyAllocd :: FCode () -> FCode ()
+ifTickyAllocd code = tickyAllocdIsOn >>= \b -> when b code
+
+ifTickyLNE :: FCode () -> FCode ()
+ifTickyLNE code = tickyLNEIsOn >>= \b -> when b code
+
+ifTickyDynThunk :: FCode () -> FCode ()
+ifTickyDynThunk code = tickyDynThunkIsOn >>= \b -> when b code
+
+bumpTickyCounter :: FastString -> FCode ()
+bumpTickyCounter lbl = bumpTickyLbl (mkCmmDataLabel rtsUnitId lbl)
+
+bumpTickyCounterBy :: FastString -> Int -> FCode ()
+bumpTickyCounterBy lbl = bumpTickyLblBy (mkCmmDataLabel rtsUnitId lbl)
+
+bumpTickyCounterByE :: FastString -> CmmExpr -> FCode ()
+bumpTickyCounterByE lbl = bumpTickyLblByE (mkCmmDataLabel rtsUnitId lbl)
+
+bumpTickyEntryCount :: CLabel -> FCode ()
+bumpTickyEntryCount lbl = do
+ dflags <- getDynFlags
+ bumpTickyLit (cmmLabelOffB lbl (oFFSET_StgEntCounter_entry_count dflags))
+
+bumpTickyAllocd :: CLabel -> Int -> FCode ()
+bumpTickyAllocd lbl bytes = do
+ dflags <- getDynFlags
+ bumpTickyLitBy (cmmLabelOffB lbl (oFFSET_StgEntCounter_allocd dflags)) bytes
+
+bumpTickyLbl :: CLabel -> FCode ()
+bumpTickyLbl lhs = bumpTickyLitBy (cmmLabelOffB lhs 0) 1
+
+bumpTickyLblBy :: CLabel -> Int -> FCode ()
+bumpTickyLblBy lhs = bumpTickyLitBy (cmmLabelOffB lhs 0)
+
+bumpTickyLblByE :: CLabel -> CmmExpr -> FCode ()
+bumpTickyLblByE lhs = bumpTickyLitByE (cmmLabelOffB lhs 0)
+
+bumpTickyLit :: CmmLit -> FCode ()
+bumpTickyLit lhs = bumpTickyLitBy lhs 1
+
+bumpTickyLitBy :: CmmLit -> Int -> FCode ()
+bumpTickyLitBy lhs n = do
+ dflags <- getDynFlags
+ emit (addToMem (bWord dflags) (CmmLit lhs) n)
+
+bumpTickyLitByE :: CmmLit -> CmmExpr -> FCode ()
+bumpTickyLitByE lhs e = do
+ dflags <- getDynFlags
+ emit (addToMemE (bWord dflags) (CmmLit lhs) e)
+
+bumpHistogram :: FastString -> Int -> FCode ()
+bumpHistogram lbl n = do
+ dflags <- getDynFlags
+ let offset = n `min` (tICKY_BIN_COUNT dflags - 1)
+ emit (addToMem (bWord dflags)
+ (cmmIndexExpr dflags
+ (wordWidth dflags)
+ (CmmLit (CmmLabel (mkCmmDataLabel rtsUnitId lbl)))
+ (CmmLit (CmmInt (fromIntegral offset) (wordWidth dflags))))
+ 1)
+
+------------------------------------------------------------------
+-- Showing the "type category" for ticky-ticky profiling
+
+showTypeCategory :: Type -> Char
+ {-
+ + dictionary
+
+ > function
+
+ {C,I,F,D,W} char, int, float, double, word
+ {c,i,f,d,w} unboxed ditto
+
+ T tuple
+
+ P other primitive type
+ p unboxed ditto
+
+ L list
+ E enumeration type
+ S other single-constructor type
+ M other multi-constructor data-con type
+
+ . other type
+
+ - reserved for others to mark as "uninteresting"
+
+ Accurate as of Mar 2013, but I eliminated the Array category instead
+ of updating it, for simplicity. It's in P/p, I think --NSF
+
+ -}
+showTypeCategory ty
+ | isDictTy ty = '+'
+ | otherwise = case tcSplitTyConApp_maybe ty of
+ Nothing -> '.'
+ Just (tycon, _) ->
+ (if isUnliftedTyCon tycon then Data.Char.toLower else id) $
+ let anyOf us = getUnique tycon `elem` us in
+ case () of
+ _ | anyOf [funTyConKey] -> '>'
+ | anyOf [charPrimTyConKey, charTyConKey] -> 'C'
+ | anyOf [doublePrimTyConKey, doubleTyConKey] -> 'D'
+ | anyOf [floatPrimTyConKey, floatTyConKey] -> 'F'
+ | anyOf [intPrimTyConKey, int32PrimTyConKey, int64PrimTyConKey,
+ intTyConKey, int8TyConKey, int16TyConKey, int32TyConKey, int64TyConKey
+ ] -> 'I'
+ | anyOf [wordPrimTyConKey, word32PrimTyConKey, word64PrimTyConKey, wordTyConKey,
+ word8TyConKey, word16TyConKey, word32TyConKey, word64TyConKey
+ ] -> 'W'
+ | anyOf [listTyConKey] -> 'L'
+ | isTupleTyCon tycon -> 'T'
+ | isPrimTyCon tycon -> 'P'
+ | isEnumerationTyCon tycon -> 'E'
+ | isJust (tyConSingleDataCon_maybe tycon) -> 'S'
+ | otherwise -> 'M' -- oh, well...
diff --git a/codeGen/StgCmmUtils.hs b/codeGen/StgCmmUtils.hs
new file mode 100644
--- /dev/null
+++ b/codeGen/StgCmmUtils.hs
@@ -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)
diff --git a/coreSyn/CoreArity.hs b/coreSyn/CoreArity.hs
new file mode 100644
--- /dev/null
+++ b/coreSyn/CoreArity.hs
@@ -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.
+ which has arity 0. And we try to maintain the invariant that we don't
+ have arity decreases.
+
+* The `max 0` is important! (\x y -> f x) has arity 2, even if f is
+ unknown, hence arity 0
+
+
+************************************************************************
+* *
+ Computing the "arity" of an expression
+* *
+************************************************************************
+
+Note [Definition of arity]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+The "arity" of an expression 'e' is n if
+ applying 'e' to *fewer* than n *value* arguments
+ converges rapidly
+
+Or, to put it another way
+
+ there is no work lost in duplicating the partial
+ application (e x1 .. x(n-1))
+
+In the divegent case, no work is lost by duplicating because if the thing
+is evaluated once, that's the end of the program.
+
+Or, to put it another way, in any context C
+
+ C[ (\x1 .. xn. e x1 .. xn) ]
+ is as efficient as
+ C[ e ]
+
+It's all a bit more subtle than it looks:
+
+Note [One-shot lambdas]
+~~~~~~~~~~~~~~~~~~~~~~~
+Consider one-shot lambdas
+ let x = expensive in \y z -> E
+We want this to have arity 1 if the \y-abstraction is a 1-shot lambda.
+
+Note [Dealing with bottom]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+A Big Deal with computing arities is expressions like
+
+ f = \x -> case x of
+ True -> \s -> e1
+ False -> \s -> e2
+
+This happens all the time when f :: Bool -> IO ()
+In this case we do eta-expand, in order to get that \s to the
+top, and give f arity 2.
+
+This isn't really right in the presence of seq. Consider
+ (f bot) `seq` 1
+
+This should diverge! But if we eta-expand, it won't. We ignore this
+"problem" (unless -fpedantic-bottoms is on), because being scrupulous
+would lose an important transformation for many programs. (See
+Trac #5587 for an example.)
+
+Consider also
+ f = \x -> error "foo"
+Here, arity 1 is fine. But if it is
+ f = \x -> case x of
+ True -> error "foo"
+ False -> \y -> x+y
+then we want to get arity 2. Technically, this isn't quite right, because
+ (f True) `seq` 1
+should diverge, but it'll converge if we eta-expand f. Nevertheless, we
+do so; it improves some programs significantly, and increasing convergence
+isn't a bad thing. Hence the ABot/ATop in ArityType.
+
+So these two transformations aren't always the Right Thing, and we
+have several tickets reporting unexpected bahaviour resulting from
+this transformation. So we try to limit it as much as possible:
+
+ (1) Do NOT move a lambda outside a known-bottom case expression
+ case undefined of { (a,b) -> \y -> e }
+ This showed up in Trac #5557
+
+ (2) Do NOT move a lambda outside a case if all the branches of
+ the case are known to return bottom.
+ case x of { (a,b) -> \y -> error "urk" }
+ This case is less important, but the idea is that if the fn is
+ going to diverge eventually anyway then getting the best arity
+ isn't an issue, so we might as well play safe
+
+ (3) Do NOT move a lambda outside a case unless
+ (a) The scrutinee is ok-for-speculation, or
+ (b) more liberally: the scrutinee is cheap (e.g. a variable), and
+ -fpedantic-bottoms is not enforced (see Trac #2915 for an example)
+
+Of course both (1) and (2) are readily defeated by disguising the bottoms.
+
+4. Note [Newtype arity]
+~~~~~~~~~~~~~~~~~~~~~~~~
+Non-recursive newtypes are transparent, and should not get in the way.
+We do (currently) eta-expand recursive newtypes too. So if we have, say
+
+ newtype T = MkT ([T] -> Int)
+
+Suppose we have
+ e = coerce T f
+where f has arity 1. Then: etaExpandArity e = 1;
+that is, etaExpandArity looks through the coerce.
+
+When we eta-expand e to arity 1: eta_expand 1 e T
+we want to get: coerce T (\x::[T] -> (coerce ([T]->Int) e) x)
+
+ HOWEVER, note that if you use coerce bogusly you can ge
+ coerce Int negate
+ And since negate has arity 2, you might try to eta expand. But you can't
+ decopose Int to a function type. Hence the final case in eta_expand.
+
+Note [The state-transformer hack]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have
+ f = e
+where e has arity n. Then, if we know from the context that f has
+a usage type like
+ t1 -> ... -> tn -1-> t(n+1) -1-> ... -1-> tm -> ...
+then we can expand the arity to m. This usage type says that
+any application (x e1 .. en) will be applied to uniquely to (m-n) more args
+Consider f = \x. let y =
+ in case x of
+ True -> foo
+ False -> \(s:RealWorld) -> e
+where foo has arity 1. Then we want the state hack to
+apply to foo too, so we can eta expand the case.
+
+Then we expect that if f is applied to one arg, it'll be applied to two
+(that's the hack -- we don't really know, and sometimes it's false)
+See also Id.isOneShotBndr.
+
+Note [State hack and bottoming functions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+It's a terrible idea to use the state hack on a bottoming function.
+Here's what happens (Trac #2861):
+
+ f :: String -> IO T
+ f = \p. error "..."
+
+Eta-expand, using the state hack:
+
+ f = \p. (\s. ((error "...") |> g1) s) |> g2
+ g1 :: IO T ~ (S -> (S,T))
+ g2 :: (S -> (S,T)) ~ IO T
+
+Extrude the g2
+
+ f' = \p. \s. ((error "...") |> g1) s
+ f = f' |> (String -> g2)
+
+Discard args for bottomming function
+
+ f' = \p. \s. ((error "...") |> g1 |> g3
+ g3 :: (S -> (S,T)) ~ (S,T)
+
+Extrude g1.g3
+
+ f'' = \p. \s. (error "...")
+ f' = f'' |> (String -> S -> g1.g3)
+
+And now we can repeat the whole loop. Aargh! The bug is in applying the
+state hack to a function which then swallows the argument.
+
+This arose in another guise in Trac #3959. Here we had
+
+ catch# (throw exn >> return ())
+
+Note that (throw :: forall a e. Exn e => e -> a) is called with [a = IO ()].
+After inlining (>>) we get
+
+ catch# (\_. throw {IO ()} exn)
+
+We must *not* eta-expand to
+
+ catch# (\_ _. throw {...} exn)
+
+because 'catch#' expects to get a (# _,_ #) after applying its argument to
+a State#, not another function!
+
+In short, we use the state hack to allow us to push let inside a lambda,
+but not to introduce a new lambda.
+
+
+Note [ArityType]
+~~~~~~~~~~~~~~~~
+ArityType is the result of a compositional analysis on expressions,
+from which we can decide the real arity of the expression (extracted
+with function exprEtaExpandArity).
+
+Here is what the fields mean. If an arbitrary expression 'f' has
+ArityType 'at', then
+
+ * If at = ABot n, then (f x1..xn) definitely diverges. Partial
+ applications to fewer than n args may *or may not* diverge.
+
+ We allow ourselves to eta-expand bottoming functions, even
+ if doing so may lose some `seq` sharing,
+ let x = in \y. error (g x y)
+ ==> \y. let x = in error (g x y)
+
+ * If at = ATop as, and n=length as,
+ then expanding 'f' to (\x1..xn. f x1 .. xn) loses no sharing,
+ assuming the calls of f respect the one-shot-ness of
+ its definition.
+
+ NB 'f' is an arbitrary expression, eg (f = g e1 e2). This 'f'
+ can have ArityType as ATop, with length as > 0, only if e1 e2 are
+ themselves.
+
+ * In both cases, f, (f x1), ... (f x1 ... f(n-1)) are definitely
+ really functions, or bottom, but *not* casts from a data type, in
+ at least one case branch. (If it's a function in one case branch but
+ an unsafe cast from a data type in another, the program is bogus.)
+ So eta expansion is dynamically ok; see Note [State hack and
+ bottoming functions], the part about catch#
+
+Example:
+ f = \x\y. let v = in
+ \s(one-shot) \t(one-shot). blah
+ 'f' has ArityType [ManyShot,ManyShot,OneShot,OneShot]
+ The one-shot-ness means we can, in effect, push that
+ 'let' inside the \st.
+
+
+Suppose f = \xy. x+y
+Then f :: AT [False,False] ATop
+ f v :: AT [False] ATop
+ f :: AT [] ATop
+
+-------------------- Main arity code ----------------------------
+-}
+
+-- See Note [ArityType]
+data ArityType = ATop [OneShotInfo] | ABot Arity
+ -- There is always an explicit lambda
+ -- to justify the [OneShot], or the Arity
+
+vanillaArityType :: ArityType
+vanillaArityType = ATop [] -- Totally uninformative
+
+-- ^ The Arity returned is the number of value args the
+-- expression can be applied to without doing much work
+exprEtaExpandArity :: DynFlags -> CoreExpr -> Arity
+-- exprEtaExpandArity is used when eta expanding
+-- e ==> \xy -> e x y
+exprEtaExpandArity dflags e
+ = case (arityType env e) of
+ ATop oss -> length oss
+ ABot n -> n
+ where
+ env = AE { ae_cheap_fn = mk_cheap_fn dflags isCheapApp
+ , ae_ped_bot = gopt Opt_PedanticBottoms dflags }
+
+getBotArity :: ArityType -> Maybe Arity
+-- Arity of a divergent function
+getBotArity (ABot n) = Just n
+getBotArity _ = Nothing
+
+mk_cheap_fn :: DynFlags -> CheapAppFun -> CheapFun
+mk_cheap_fn dflags cheap_app
+ | not (gopt Opt_DictsCheap dflags)
+ = \e _ -> exprIsOk cheap_app e
+ | otherwise
+ = \e mb_ty -> exprIsOk cheap_app e
+ || case mb_ty of
+ Nothing -> False
+ Just ty -> isDictLikeTy ty
+
+
+----------------------
+findRhsArity :: DynFlags -> Id -> CoreExpr -> Arity -> Arity
+-- This implements the fixpoint loop for arity analysis
+-- See Note [Arity analysis]
+findRhsArity dflags bndr rhs old_arity
+ = go (rhsEtaExpandArity dflags init_cheap_app rhs)
+ -- We always call exprEtaExpandArity once, but usually
+ -- that produces a result equal to old_arity, and then
+ -- we stop right away (since arities should not decrease)
+ -- Result: the common case is that there is just one iteration
+ where
+ init_cheap_app :: CheapAppFun
+ init_cheap_app fn n_val_args
+ | fn == bndr = True -- On the first pass, this binder gets infinite arity
+ | otherwise = isCheapApp fn n_val_args
+
+ go :: Arity -> Arity
+ go cur_arity
+ | cur_arity <= old_arity = cur_arity
+ | new_arity == cur_arity = cur_arity
+ | otherwise = ASSERT( new_arity < cur_arity )
+#ifdef DEBUG
+ pprTrace "Exciting arity"
+ (vcat [ ppr bndr <+> ppr cur_arity <+> ppr new_arity
+ , ppr rhs])
+#endif
+ go new_arity
+ where
+ new_arity = rhsEtaExpandArity dflags cheap_app rhs
+
+ cheap_app :: CheapAppFun
+ cheap_app fn n_val_args
+ | fn == bndr = n_val_args < cur_arity
+ | otherwise = isCheapApp fn n_val_args
+
+-- ^ The Arity returned is the number of value args the
+-- expression can be applied to without doing much work
+rhsEtaExpandArity :: DynFlags -> CheapAppFun -> CoreExpr -> Arity
+-- exprEtaExpandArity is used when eta expanding
+-- e ==> \xy -> e x y
+rhsEtaExpandArity dflags cheap_app e
+ = case (arityType env e) of
+ ATop (os:oss)
+ | isOneShotInfo os || has_lam e -> 1 + length oss
+ -- Don't expand PAPs/thunks
+ -- Note [Eta expanding thunks]
+ | otherwise -> 0
+ ATop [] -> 0
+ ABot n -> n
+ where
+ env = AE { ae_cheap_fn = mk_cheap_fn dflags cheap_app
+ , ae_ped_bot = gopt Opt_PedanticBottoms dflags }
+
+ has_lam (Tick _ e) = has_lam e
+ has_lam (Lam b e) = isId b || has_lam e
+ has_lam _ = False
+
+{-
+Note [Arity analysis]
+~~~~~~~~~~~~~~~~~~~~~
+The motivating example for arity analysis is this:
+
+ f = \x. let g = f (x+1)
+ in \y. ...g...
+
+What arity does f have? Really it should have arity 2, but a naive
+look at the RHS won't see that. You need a fixpoint analysis which
+says it has arity "infinity" the first time round.
+
+This example happens a lot; it first showed up in Andy Gill's thesis,
+fifteen years ago! It also shows up in the code for 'rnf' on lists
+in Trac #4138.
+
+The analysis is easy to achieve because exprEtaExpandArity takes an
+argument
+ type CheapFun = CoreExpr -> Maybe Type -> Bool
+used to decide if an expression is cheap enough to push inside a
+lambda. And exprIsCheap' in turn takes an argument
+ type CheapAppFun = Id -> Int -> Bool
+which tells when an application is cheap. This makes it easy to
+write the analysis loop.
+
+The analysis is cheap-and-cheerful because it doesn't deal with
+mutual recursion. But the self-recursive case is the important one.
+
+
+Note [Eta expanding through dictionaries]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If the experimental -fdicts-cheap flag is on, we eta-expand through
+dictionary bindings. This improves arities. Thereby, it also
+means that full laziness is less prone to floating out the
+application of a function to its dictionary arguments, which
+can thereby lose opportunities for fusion. Example:
+ foo :: Ord a => a -> ...
+ foo = /\a \(d:Ord a). let d' = ...d... in \(x:a). ....
+ -- So foo has arity 1
+
+ f = \x. foo dInt $ bar x
+
+The (foo DInt) is floated out, and makes ineffective a RULE
+ foo (bar x) = ...
+
+One could go further and make exprIsCheap reply True to any
+dictionary-typed expression, but that's more work.
+
+See Note [Dictionary-like types] in TcType.hs for why we use
+isDictLikeTy here rather than isDictTy
+
+Note [Eta expanding thunks]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We don't eta-expand
+ * Trivial RHSs x = y
+ * PAPs x = map g
+ * Thunks f = case y of p -> \x -> blah
+
+When we see
+ f = case y of p -> \x -> blah
+should we eta-expand it? Well, if 'x' is a one-shot state token
+then 'yes' because 'f' will only be applied once. But otherwise
+we (conservatively) say no. My main reason is to avoid expanding
+PAPSs
+ f = g d ==> f = \x. g d x
+because that might in turn make g inline (if it has an inline pragma),
+which we might not want. After all, INLINE pragmas say "inline only
+when saturated" so we don't want to be too gung-ho about saturating!
+-}
+
+arityLam :: Id -> ArityType -> ArityType
+arityLam id (ATop as) = ATop (idStateHackOneShotInfo id : as)
+arityLam _ (ABot n) = ABot (n+1)
+
+floatIn :: Bool -> ArityType -> ArityType
+-- We have something like (let x = E in b),
+-- where b has the given arity type.
+floatIn _ (ABot n) = ABot n
+floatIn True (ATop as) = ATop as
+floatIn False (ATop as) = ATop (takeWhile isOneShotInfo as)
+ -- If E is not cheap, keep arity only for one-shots
+
+arityApp :: ArityType -> Bool -> ArityType
+-- Processing (fun arg) where at is the ArityType of fun,
+-- Knock off an argument and behave like 'let'
+arityApp (ABot 0) _ = ABot 0
+arityApp (ABot n) _ = ABot (n-1)
+arityApp (ATop []) _ = ATop []
+arityApp (ATop (_:as)) cheap = floatIn cheap (ATop as)
+
+andArityType :: ArityType -> ArityType -> ArityType -- Used for branches of a 'case'
+andArityType (ABot n1) (ABot n2) = ABot (n1 `max` n2) -- Note [ABot branches: use max]
+andArityType (ATop as) (ABot _) = ATop as
+andArityType (ABot _) (ATop bs) = ATop bs
+andArityType (ATop as) (ATop bs) = ATop (as `combine` bs)
+ where -- See Note [Combining case branches]
+ combine (a:as) (b:bs) = (a `bestOneShot` b) : combine as bs
+ combine [] bs = takeWhile isOneShotInfo bs
+ combine as [] = takeWhile isOneShotInfo as
+
+{- Note [ABot branches: use max]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider case x of
+ True -> \x. error "urk"
+ False -> \xy. error "urk2"
+
+Remember: ABot n means "if you apply to n args, it'll definitely diverge".
+So we need (ABot 2) for the whole thing, the /max/ of the ABot arities.
+
+Note [Combining case branches]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+ go = \x. let z = go e0
+ go2 = \x. case x of
+ True -> z
+ False -> \s(one-shot). e1
+ in go2 x
+We *really* want to eta-expand go and go2.
+When combining the barnches of the case we have
+ ATop [] `andAT` ATop [OneShotLam]
+and we want to get ATop [OneShotLam]. But if the inner
+lambda wasn't one-shot we don't want to do this.
+(We need a proper arity analysis to justify that.)
+
+So we combine the best of the two branches, on the (slightly dodgy)
+basis that if we know one branch is one-shot, then they all must be.
+-}
+
+---------------------------
+type CheapFun = CoreExpr -> Maybe Type -> Bool
+ -- How to decide if an expression is cheap
+ -- If the Maybe is Just, the type is the type
+ -- of the expression; Nothing means "don't know"
+
+data ArityEnv
+ = AE { ae_cheap_fn :: CheapFun
+ , ae_ped_bot :: Bool -- True <=> be pedantic about bottoms
+ }
+
+arityType :: ArityEnv -> CoreExpr -> ArityType
+
+arityType env (Cast e co)
+ = case arityType env e of
+ ATop os -> ATop (take co_arity os)
+ ABot n -> ABot (n `min` co_arity)
+ where
+ co_arity = length (typeArity (pSnd (coercionKind co)))
+ -- See Note [exprArity invariant] (2); must be true of
+ -- arityType too, since that is how we compute the arity
+ -- of variables, and they in turn affect result of exprArity
+ -- Trac #5441 is a nice demo
+ -- However, do make sure that ATop -> ATop and ABot -> ABot!
+ -- Casts don't affect that part. Getting this wrong provoked #5475
+
+arityType _ (Var v)
+ | strict_sig <- idStrictness v
+ , not $ isTopSig strict_sig
+ , (ds, res) <- splitStrictSig strict_sig
+ , let arity = length ds
+ = if isBotRes res then ABot arity
+ else ATop (take arity one_shots)
+ | otherwise
+ = ATop (take (idArity v) one_shots)
+ where
+ one_shots :: [OneShotInfo] -- One-shot-ness derived from the type
+ one_shots = typeArity (idType v)
+
+ -- Lambdas; increase arity
+arityType env (Lam x e)
+ | isId x = arityLam x (arityType env e)
+ | otherwise = arityType env e
+
+ -- Applications; decrease arity, except for types
+arityType env (App fun (Type _))
+ = arityType env fun
+arityType env (App fun arg )
+ = arityApp (arityType env fun) (ae_cheap_fn env arg Nothing)
+
+ -- Case/Let; keep arity if either the expression is cheap
+ -- or it's a 1-shot lambda
+ -- The former is not really right for Haskell
+ -- f x = case x of { (a,b) -> \y. e }
+ -- ===>
+ -- f x y = case x of { (a,b) -> e }
+ -- The difference is observable using 'seq'
+ --
+arityType env (Case scrut _ _ alts)
+ | exprIsBottom scrut || null alts
+ = ABot 0 -- Do not eta expand
+ -- See Note [Dealing with bottom (1)]
+ | otherwise
+ = case alts_type of
+ ABot n | n>0 -> ATop [] -- Don't eta expand
+ | otherwise -> ABot 0 -- if RHS is bottomming
+ -- See Note [Dealing with bottom (2)]
+
+ ATop as | not (ae_ped_bot env) -- See Note [Dealing with bottom (3)]
+ , ae_cheap_fn env scrut Nothing -> ATop as
+ | exprOkForSpeculation scrut -> ATop as
+ | otherwise -> ATop (takeWhile isOneShotInfo as)
+ where
+ alts_type = foldr1 andArityType [arityType env rhs | (_,_,rhs) <- alts]
+
+arityType env (Let b e)
+ = floatIn (cheap_bind b) (arityType env e)
+ where
+ cheap_bind (NonRec b e) = is_cheap (b,e)
+ cheap_bind (Rec prs) = all is_cheap prs
+ is_cheap (b,e) = ae_cheap_fn env e (Just (idType b))
+
+arityType env (Tick t e)
+ | not (tickishIsCode t) = arityType env e
+
+arityType _ _ = vanillaArityType
+
+{-
+%************************************************************************
+%* *
+ The main eta-expander
+%* *
+%************************************************************************
+
+We go for:
+ f = \x1..xn -> N ==> f = \x1..xn y1..ym -> N y1..ym
+ (n >= 0)
+
+where (in both cases)
+
+ * The xi can include type variables
+
+ * The yi are all value variables
+
+ * N is a NORMAL FORM (i.e. no redexes anywhere)
+ wanting a suitable number of extra args.
+
+The biggest reason for doing this is for cases like
+
+ f = \x -> case x of
+ True -> \y -> e1
+ False -> \y -> e2
+
+Here we want to get the lambdas together. A good example is the nofib
+program fibheaps, which gets 25% more allocation if you don't do this
+eta-expansion.
+
+We may have to sandwich some coerces between the lambdas
+to make the types work. exprEtaExpandArity looks through coerces
+when computing arity; and etaExpand adds the coerces as necessary when
+actually computing the expansion.
+
+Note [No crap in eta-expanded code]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The eta expander is careful not to introduce "crap". In particular,
+given a CoreExpr satisfying the 'CpeRhs' invariant (in CorePrep), it
+returns a CoreExpr satisfying the same invariant. See Note [Eta
+expansion and the CorePrep invariants] in CorePrep.
+
+This means the eta-expander has to do a bit of on-the-fly
+simplification but it's not too hard. The alernative, of relying on
+a subsequent clean-up phase of the Simplifier to de-crapify the result,
+means you can't really use it in CorePrep, which is painful.
+
+Note [Eta expansion and SCCs]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Note that SCCs are not treated specially by etaExpand. If we have
+ etaExpand 2 (\x -> scc "foo" e)
+ = (\xy -> (scc "foo" e) y)
+So the costs of evaluating 'e' (not 'e y') are attributed to "foo"
+
+Note [Eta expansion and source notes]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+CorePrep puts floatable ticks outside of value applications, but not
+type applications. As a result we might be trying to eta-expand an
+expression like
+
+ (src<...> v) @a
+
+which we want to lead to code like
+
+ \x -> src<...> v @a x
+
+This means that we need to look through type applications and be ready
+to re-add floats on the top.
+
+-}
+
+-- | @etaExpand n e@ returns an expression with
+-- the same meaning as @e@, but with arity @n@.
+--
+-- Given:
+--
+-- > e' = etaExpand n e
+--
+-- We should have that:
+--
+-- > ty = exprType e = exprType e'
+etaExpand :: Arity -- ^ Result should have this number of value args
+ -> CoreExpr -- ^ Expression to expand
+ -> CoreExpr
+-- etaExpand arity e = res
+-- Then 'res' has at least 'arity' lambdas at the top
+--
+-- etaExpand deals with for-alls. For example:
+-- etaExpand 1 E
+-- where E :: forall a. a -> a
+-- would return
+-- (/\b. \y::a -> E b y)
+--
+-- It deals with coerces too, though they are now rare
+-- so perhaps the extra code isn't worth it
+
+etaExpand n orig_expr
+ = go n orig_expr
+ where
+ -- Strip off existing lambdas and casts
+ -- Note [Eta expansion and SCCs]
+ go 0 expr = expr
+ go n (Lam v body) | isTyVar v = Lam v (go n body)
+ | otherwise = Lam v (go (n-1) body)
+ go n (Cast expr co) = Cast (go n expr) co
+ go n expr
+ = -- pprTrace "ee" (vcat [ppr orig_expr, ppr expr, ppr etas]) $
+ retick $ etaInfoAbs etas (etaInfoApp subst' sexpr etas)
+ where
+ in_scope = mkInScopeSet (exprFreeVars expr)
+ (in_scope', etas) = mkEtaWW n orig_expr in_scope (exprType expr)
+ subst' = mkEmptySubst in_scope'
+
+ -- Find ticks behind type apps.
+ -- See Note [Eta expansion and source notes]
+ (expr', args) = collectArgs expr
+ (ticks, expr'') = stripTicksTop tickishFloatable expr'
+ sexpr = foldl App expr'' args
+ retick expr = foldr mkTick expr ticks
+
+ -- Wrapper Unwrapper
+--------------
+data EtaInfo = EtaVar Var -- /\a. [], [] a
+ -- \x. [], [] x
+ | EtaCo Coercion -- [] |> co, [] |> (sym co)
+
+instance Outputable EtaInfo where
+ ppr (EtaVar v) = text "EtaVar" <+> ppr v
+ ppr (EtaCo co) = text "EtaCo" <+> ppr co
+
+pushCoercion :: Coercion -> [EtaInfo] -> [EtaInfo]
+pushCoercion co1 (EtaCo co2 : eis)
+ | isReflCo co = eis
+ | otherwise = EtaCo co : eis
+ where
+ co = co1 `mkTransCo` co2
+
+pushCoercion co eis = EtaCo co : eis
+
+--------------
+etaInfoAbs :: [EtaInfo] -> CoreExpr -> CoreExpr
+etaInfoAbs [] expr = expr
+etaInfoAbs (EtaVar v : eis) expr = Lam v (etaInfoAbs eis expr)
+etaInfoAbs (EtaCo co : eis) expr = Cast (etaInfoAbs eis expr) (mkSymCo co)
+
+--------------
+etaInfoApp :: Subst -> CoreExpr -> [EtaInfo] -> CoreExpr
+-- (etaInfoApp s e eis) returns something equivalent to
+-- ((substExpr s e) `appliedto` eis)
+
+etaInfoApp subst (Lam v1 e) (EtaVar v2 : eis)
+ = etaInfoApp (CoreSubst.extendSubstWithVar subst v1 v2) e eis
+
+etaInfoApp subst (Cast e co1) eis
+ = etaInfoApp subst e (pushCoercion co' eis)
+ where
+ co' = CoreSubst.substCo subst co1
+
+etaInfoApp subst (Case e b ty alts) eis
+ = Case (subst_expr subst e) b1 (mk_alts_ty (CoreSubst.substTy subst ty) eis) alts'
+ where
+ (subst1, b1) = substBndr subst b
+ alts' = map subst_alt alts
+ subst_alt (con, bs, rhs) = (con, bs', etaInfoApp subst2 rhs eis)
+ where
+ (subst2,bs') = substBndrs subst1 bs
+
+ mk_alts_ty ty [] = ty
+ mk_alts_ty ty (EtaVar v : eis) = mk_alts_ty (applyTypeToArg ty (varToCoreExpr v)) eis
+ mk_alts_ty _ (EtaCo co : eis) = mk_alts_ty (pSnd (coercionKind co)) eis
+
+etaInfoApp subst (Let b e) eis
+ = Let b' (etaInfoApp subst' e eis)
+ where
+ (subst', b') = etaInfoAppBind subst b eis
+
+etaInfoApp subst (Tick t e) eis
+ = Tick (substTickish subst t) (etaInfoApp subst e eis)
+
+etaInfoApp subst expr _
+ | (Var fun, _) <- collectArgs expr
+ , Var fun' <- lookupIdSubst (text "etaInfoApp" <+> ppr fun) subst fun
+ , isJoinId fun'
+ = subst_expr subst expr
+
+etaInfoApp subst e eis
+ = go (subst_expr subst e) eis
+ where
+ go e [] = e
+ go e (EtaVar v : eis) = go (App e (varToCoreExpr v)) eis
+ go e (EtaCo co : eis) = go (Cast e co) eis
+
+--------------
+-- | Apply the eta info to a local binding. Mostly delegates to
+-- `etaInfoAppLocalBndr` and `etaInfoAppRhs`.
+etaInfoAppBind :: Subst -> CoreBind -> [EtaInfo] -> (Subst, CoreBind)
+etaInfoAppBind subst (NonRec bndr rhs) eis
+ = (subst', NonRec bndr' rhs')
+ where
+ bndr_w_new_type = etaInfoAppLocalBndr bndr eis
+ (subst', bndr1) = substBndr subst bndr_w_new_type
+ rhs' = etaInfoAppRhs subst bndr1 rhs eis
+ bndr' | isJoinId bndr = bndr1 `setIdArity` manifestArity rhs'
+ -- Arity may have changed
+ -- (see etaInfoAppRhs example)
+ | otherwise = bndr1
+etaInfoAppBind subst (Rec pairs) eis
+ = (subst', Rec (bndrs' `zip` rhss'))
+ where
+ (bndrs, rhss) = unzip pairs
+ bndrs_w_new_types = map (\bndr -> etaInfoAppLocalBndr bndr eis) bndrs
+ (subst', bndrs1) = substRecBndrs subst bndrs_w_new_types
+ rhss' = zipWith process bndrs1 rhss
+ process bndr' rhs = etaInfoAppRhs subst' bndr' rhs eis
+ bndrs' | isJoinId (head bndrs)
+ = [ bndr1 `setIdArity` manifestArity rhs'
+ | (bndr1, rhs') <- bndrs1 `zip` rhss' ]
+ -- Arities may have changed
+ -- (see etaInfoAppRhs example)
+ | otherwise
+ = bndrs1
+
+--------------
+-- | Apply the eta info to a binder's RHS. Only interesting for a join point,
+-- where we might have this:
+-- join j :: a -> [a] -> [a]
+-- j x = \xs -> x : xs in jump j z
+-- Eta-expanding produces this:
+-- \ys -> (join j :: a -> [a] -> [a]
+-- j x = \xs -> x : xs in jump j z) ys
+-- Now when we push the application to ys inward (see Note [No crap in
+-- eta-expanded code]), it goes to the body of the RHS of the join point (after
+-- the lambda x!):
+-- \ys -> join j :: a -> [a]
+-- j x = x : ys in jump j z
+-- Note that the type and arity of j have both changed.
+etaInfoAppRhs :: Subst -> CoreBndr -> CoreExpr -> [EtaInfo] -> CoreExpr
+etaInfoAppRhs subst bndr expr eis
+ | Just arity <- isJoinId_maybe bndr
+ = do_join_point arity
+ | otherwise
+ = subst_expr subst expr
+ where
+ do_join_point arity = mkLams join_bndrs' join_body'
+ where
+ (join_bndrs, join_body) = collectNBinders arity expr
+ (subst', join_bndrs') = substBndrs subst join_bndrs
+ join_body' = etaInfoApp subst' join_body eis
+
+
+--------------
+-- | Apply the eta info to a local binder. A join point will have the EtaInfos
+-- applied to its RHS, so its type may change. See comment on etaInfoAppRhs for
+-- an example. See Note [No crap in eta-expanded code] for why all this is
+-- necessary.
+etaInfoAppLocalBndr :: CoreBndr -> [EtaInfo] -> CoreBndr
+etaInfoAppLocalBndr bndr orig_eis
+ = case isJoinId_maybe bndr of
+ Just arity -> bndr `setIdType` modifyJoinResTy arity (app orig_eis) ty
+ Nothing -> bndr
+ where
+ ty = idType bndr
+
+ -- | Apply the given EtaInfos to the result type of the join point.
+ app :: [EtaInfo] -- To apply
+ -> Type -- Result type of join point
+ -> Type -- New result type
+ app [] ty
+ = ty
+ app (EtaVar v : eis) ty
+ | isId v = app eis (funResultTy ty)
+ | otherwise = app eis (piResultTy ty (mkTyVarTy v))
+ app (EtaCo co : eis) ty
+ = ASSERT2(from_ty `eqType` ty, fsep ([text "can't apply", ppr orig_eis,
+ text "to", ppr bndr <+> dcolon <+>
+ ppr (idType bndr)]))
+ app eis to_ty
+ where
+ Pair from_ty to_ty = coercionKind co
+
+--------------
+mkEtaWW :: Arity -> CoreExpr -> InScopeSet -> Type
+ -> (InScopeSet, [EtaInfo])
+ -- EtaInfo contains fresh variables,
+ -- not free in the incoming CoreExpr
+ -- Outgoing InScopeSet includes the EtaInfo vars
+ -- and the original free vars
+
+mkEtaWW orig_n orig_expr in_scope orig_ty
+ = go orig_n empty_subst orig_ty []
+ where
+ empty_subst = mkEmptyTCvSubst in_scope
+
+ go n subst ty eis -- See Note [exprArity invariant]
+ | n == 0
+ = (getTCvInScope subst, reverse eis)
+
+ | Just (tv,ty') <- splitForAllTy_maybe ty
+ , let (subst', tv') = Type.substTyVarBndr subst tv
+ -- Avoid free vars of the original expression
+ = go n subst' ty' (EtaVar tv' : eis)
+
+ | Just (arg_ty, res_ty) <- splitFunTy_maybe ty
+ , not (isTypeLevPoly arg_ty)
+ -- See Note [Levity polymorphism invariants] in CoreSyn
+ -- See also test case typecheck/should_run/EtaExpandLevPoly
+
+ , let (subst', eta_id') = freshEtaId n subst arg_ty
+ -- Avoid free vars of the original expression
+ = go (n-1) subst' res_ty (EtaVar eta_id' : eis)
+
+ | Just (co, ty') <- topNormaliseNewType_maybe ty
+ = -- Given this:
+ -- newtype T = MkT ([T] -> Int)
+ -- Consider eta-expanding this
+ -- eta_expand 1 e T
+ -- We want to get
+ -- coerce T (\x::[T] -> (coerce ([T]->Int) e) x)
+ go n subst ty' (EtaCo co : eis)
+
+ | otherwise -- We have an expression of arity > 0,
+ -- but its type isn't a function, or a binder
+ -- is levity-polymorphic
+ = WARN( True, (ppr orig_n <+> ppr orig_ty) $$ ppr orig_expr )
+ (getTCvInScope subst, reverse eis)
+ -- This *can* legitmately happen:
+ -- e.g. coerce Int (\x. x) Essentially the programmer is
+ -- playing fast and loose with types (Happy does this a lot).
+ -- So we simply decline to eta-expand. Otherwise we'd end up
+ -- with an explicit lambda having a non-function type
+
+
+
+--------------
+-- Don't use short-cutting substitution - we may be changing the types of join
+-- points, so applying the in-scope set is necessary
+-- TODO Check if we actually *are* changing any join points' types
+
+subst_expr :: Subst -> CoreExpr -> CoreExpr
+subst_expr = substExpr (text "CoreArity:substExpr")
+
+
+--------------
+
+-- | Split an expression into the given number of binders and a body,
+-- eta-expanding if necessary. Counts value *and* type binders.
+etaExpandToJoinPoint :: JoinArity -> CoreExpr -> ([CoreBndr], CoreExpr)
+etaExpandToJoinPoint join_arity expr
+ = go join_arity [] expr
+ where
+ go 0 rev_bs e = (reverse rev_bs, e)
+ go n rev_bs (Lam b e) = go (n-1) (b : rev_bs) e
+ go n rev_bs e = case etaBodyForJoinPoint n e of
+ (bs, e') -> (reverse rev_bs ++ bs, e')
+
+etaExpandToJoinPointRule :: JoinArity -> CoreRule -> CoreRule
+etaExpandToJoinPointRule _ rule@(BuiltinRule {})
+ = WARN(True, (sep [text "Can't eta-expand built-in rule:", ppr rule]))
+ -- How did a local binding get a built-in rule anyway? Probably a plugin.
+ rule
+etaExpandToJoinPointRule join_arity rule@(Rule { ru_bndrs = bndrs, ru_rhs = rhs
+ , ru_args = args })
+ | need_args == 0
+ = rule
+ | need_args < 0
+ = pprPanic "etaExpandToJoinPointRule" (ppr join_arity $$ ppr rule)
+ | otherwise
+ = rule { ru_bndrs = bndrs ++ new_bndrs, ru_args = args ++ new_args
+ , ru_rhs = new_rhs }
+ where
+ need_args = join_arity - length args
+ (new_bndrs, new_rhs) = etaBodyForJoinPoint need_args rhs
+ new_args = varsToCoreExprs new_bndrs
+
+-- Adds as many binders as asked for; assumes expr is not a lambda
+etaBodyForJoinPoint :: Int -> CoreExpr -> ([CoreBndr], CoreExpr)
+etaBodyForJoinPoint need_args body
+ = go need_args (exprType body) (init_subst body) [] body
+ where
+ go 0 _ _ rev_bs e
+ = (reverse rev_bs, e)
+ go n ty subst rev_bs e
+ | Just (tv, res_ty) <- splitForAllTy_maybe ty
+ , let (subst', tv') = Type.substTyVarBndr subst tv
+ = go (n-1) res_ty subst' (tv' : rev_bs) (e `App` Type (mkTyVarTy tv'))
+ | Just (arg_ty, res_ty) <- splitFunTy_maybe ty
+ , let (subst', b) = freshEtaId n subst arg_ty
+ = go (n-1) res_ty subst' (b : rev_bs) (e `App` Var b)
+ | otherwise
+ = pprPanic "etaBodyForJoinPoint" $ int need_args $$
+ ppr body $$ ppr (exprType body)
+
+ init_subst e = mkEmptyTCvSubst (mkInScopeSet (exprFreeVars e))
+
+--------------
+freshEtaId :: Int -> TCvSubst -> Type -> (TCvSubst, Id)
+-- Make a fresh Id, with specified type (after applying substitution)
+-- It should be "fresh" in the sense that it's not in the in-scope set
+-- of the TvSubstEnv; and it should itself then be added to the in-scope
+-- set of the TvSubstEnv
+--
+-- The Int is just a reasonable starting point for generating a unique;
+-- it does not necessarily have to be unique itself.
+freshEtaId n subst ty
+ = (subst', eta_id')
+ where
+ ty' = Type.substTy subst ty
+ eta_id' = uniqAway (getTCvInScope subst) $
+ mkSysLocalOrCoVar (fsLit "eta") (mkBuiltinUnique n) ty'
+ subst' = extendTCvInScope subst eta_id'
diff --git a/coreSyn/CoreFVs.hs b/coreSyn/CoreFVs.hs
new file mode 100644
--- /dev/null
+++ b/coreSyn/CoreFVs.hs
@@ -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
diff --git a/coreSyn/CoreLint.hs b/coreSyn/CoreLint.hs
new file mode 100644
--- /dev/null
+++ b/coreSyn/CoreLint.hs
@@ -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
+That is, use a type let. See Note [Type let] in CoreSyn.
+
+However, when linting we need to remember that a=Int, else we might
+reject a correct program. So we carry a type substitution (in this example
+[a -> Int]) and apply this substitution before comparing types. The functin
+ lintInTy :: Type -> LintM (Type, Kind)
+returns a substituted type.
+
+When we encounter a binder (like x::a) we must apply the substitution
+to the type of the binding variable. lintBinders does this.
+
+For Ids, the type-substituted Id is added to the in_scope set (which
+itself is part of the TCvSubst we are carrying down), and when we
+find an occurrence of an Id, we fetch it from the in-scope set.
+
+Note [Bad unsafe coercion]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+For discussion see https://ghc.haskell.org/trac/ghc/wiki/BadUnsafeCoercions
+Linter introduces additional rules that checks improper coercion between
+different types, called bad coercions. Following coercions are forbidden:
+
+ (a) coercions between boxed and unboxed values;
+ (b) coercions between unlifted values of the different sizes, here
+ active size is checked, i.e. size of the actual value but not
+ the space allocated for value;
+ (c) coercions between floating and integral boxed values, this check
+ is not yet supported for unboxed tuples, as no semantics were
+ specified for that;
+ (d) coercions from / to vector type
+ (e) If types are unboxed tuples then tuple (# A_1,..,A_n #) can be
+ coerced to (# B_1,..,B_m #) if n=m and for each pair A_i, B_i rules
+ (a-e) holds.
+
+Note [Join points]
+~~~~~~~~~~~~~~~~~~
+We check the rules listed in Note [Invariants on join points] in CoreSyn. The
+only one that causes any difficulty is the first: All occurrences must be tail
+calls. To this end, along with the in-scope set, we remember in le_joins the
+subset of in-scope Ids that are valid join ids. For example:
+
+ join j x = ... in
+ case e of
+ A -> jump j y -- good
+ B -> case (jump j z) of -- BAD
+ C -> join h = jump j w in ... -- good
+ D -> let x = jump j v in ... -- BAD
+
+A join point remains valid in case branches, so when checking the A
+branch, j is still valid. When we check the scrutinee of the inner
+case, however, we set le_joins to empty, and catch the
+error. Similarly, join points can occur free in RHSes of other join
+points but not the RHSes of value bindings (thunks and functions).
+
+************************************************************************
+* *
+ Beginning and ending passes
+* *
+************************************************************************
+
+These functions are not CoreM monad stuff, but they probably ought to
+be, and it makes a conveneint place. place for them. They print out
+stuff before and after core passes, and do Core Lint when necessary.
+-}
+
+endPass :: CoreToDo -> CoreProgram -> [CoreRule] -> CoreM ()
+endPass pass binds rules
+ = do { hsc_env <- getHscEnv
+ ; print_unqual <- getPrintUnqualified
+ ; liftIO $ endPassIO hsc_env print_unqual pass binds rules }
+
+endPassIO :: HscEnv -> PrintUnqualified
+ -> CoreToDo -> CoreProgram -> [CoreRule] -> IO ()
+-- Used by the IO-is CorePrep too
+endPassIO hsc_env print_unqual pass binds rules
+ = do { dumpPassResult dflags print_unqual mb_flag
+ (ppr pass) (pprPassDetails pass) binds rules
+ ; lintPassResult hsc_env pass binds }
+ where
+ dflags = hsc_dflags hsc_env
+ mb_flag = case coreDumpFlag pass of
+ Just flag | dopt flag dflags -> Just flag
+ | dopt Opt_D_verbose_core2core dflags -> Just flag
+ _ -> Nothing
+
+dumpIfSet :: DynFlags -> Bool -> CoreToDo -> SDoc -> SDoc -> IO ()
+dumpIfSet dflags dump_me pass extra_info doc
+ = Err.dumpIfSet dflags dump_me (showSDoc dflags (ppr pass <+> extra_info)) doc
+
+dumpPassResult :: DynFlags
+ -> PrintUnqualified
+ -> Maybe DumpFlag -- Just df => show details in a file whose
+ -- name is specified by df
+ -> SDoc -- Header
+ -> SDoc -- Extra info to appear after header
+ -> CoreProgram -> [CoreRule]
+ -> IO ()
+dumpPassResult dflags unqual mb_flag hdr extra_info binds rules
+ = do { forM_ mb_flag $ \flag ->
+ Err.dumpSDoc dflags unqual flag (showSDoc dflags hdr) dump_doc
+
+ -- Report result size
+ -- This has the side effect of forcing the intermediate to be evaluated
+ -- if it's not already forced by a -ddump flag.
+ ; Err.debugTraceMsg dflags 2 size_doc
+ }
+
+ where
+ size_doc = sep [text "Result size of" <+> hdr, nest 2 (equals <+> ppr (coreBindsStats binds))]
+
+ dump_doc = vcat [ nest 2 extra_info
+ , size_doc
+ , blankLine
+ , pprCoreBindingsWithSize binds
+ , ppUnless (null rules) pp_rules ]
+ pp_rules = vcat [ blankLine
+ , text "------ Local rules for imported ids --------"
+ , pprRules rules ]
+
+coreDumpFlag :: CoreToDo -> Maybe DumpFlag
+coreDumpFlag (CoreDoSimplify {}) = Just Opt_D_verbose_core2core
+coreDumpFlag (CoreDoPluginPass {}) = Just Opt_D_verbose_core2core
+coreDumpFlag CoreDoFloatInwards = Just Opt_D_verbose_core2core
+coreDumpFlag (CoreDoFloatOutwards {}) = Just Opt_D_verbose_core2core
+coreDumpFlag CoreLiberateCase = Just Opt_D_verbose_core2core
+coreDumpFlag CoreDoStaticArgs = Just Opt_D_verbose_core2core
+coreDumpFlag CoreDoCallArity = Just Opt_D_dump_call_arity
+coreDumpFlag CoreDoStrictness = Just Opt_D_dump_stranal
+coreDumpFlag CoreDoWorkerWrapper = Just Opt_D_dump_worker_wrapper
+coreDumpFlag CoreDoSpecialising = Just Opt_D_dump_spec
+coreDumpFlag CoreDoSpecConstr = Just Opt_D_dump_spec
+coreDumpFlag CoreCSE = Just Opt_D_dump_cse
+coreDumpFlag CoreDoVectorisation = Just Opt_D_dump_vect
+coreDumpFlag CoreDesugar = Just Opt_D_dump_ds
+coreDumpFlag CoreDesugarOpt = Just Opt_D_dump_ds
+coreDumpFlag CoreTidy = Just Opt_D_dump_simpl
+coreDumpFlag CorePrep = Just Opt_D_dump_prep
+coreDumpFlag CoreOccurAnal = Just Opt_D_dump_occur_anal
+
+coreDumpFlag CoreDoPrintCore = Nothing
+coreDumpFlag (CoreDoRuleCheck {}) = Nothing
+coreDumpFlag CoreDoNothing = Nothing
+coreDumpFlag (CoreDoPasses {}) = Nothing
+
+{-
+************************************************************************
+* *
+ Top-level interfaces
+* *
+************************************************************************
+-}
+
+lintPassResult :: HscEnv -> CoreToDo -> CoreProgram -> IO ()
+lintPassResult hsc_env pass binds
+ | not (gopt Opt_DoCoreLinting dflags)
+ = return ()
+ | otherwise
+ = do { let (warns, errs) = lintCoreBindings dflags pass (interactiveInScope hsc_env) binds
+ ; Err.showPass dflags ("Core Linted result of " ++ showPpr dflags pass)
+ ; displayLintResults dflags pass warns errs binds }
+ where
+ dflags = hsc_dflags hsc_env
+
+displayLintResults :: DynFlags -> CoreToDo
+ -> Bag Err.MsgDoc -> Bag Err.MsgDoc -> CoreProgram
+ -> IO ()
+displayLintResults dflags pass warns errs binds
+ | not (isEmptyBag errs)
+ = do { putLogMsg dflags NoReason Err.SevDump noSrcSpan
+ (defaultDumpStyle dflags)
+ (vcat [ lint_banner "errors" (ppr pass), Err.pprMessageBag errs
+ , text "*** Offending Program ***"
+ , pprCoreBindings binds
+ , text "*** End of Offense ***" ])
+ ; Err.ghcExit dflags 1 }
+
+ | not (isEmptyBag warns)
+ , not (hasNoDebugOutput dflags)
+ , showLintWarnings pass
+ = putLogMsg dflags NoReason Err.SevDump noSrcSpan
+ (defaultDumpStyle dflags)
+ (lint_banner "warnings" (ppr pass) $$ Err.pprMessageBag warns)
+
+ | otherwise = return ()
+ where
+
+lint_banner :: String -> SDoc -> SDoc
+lint_banner string pass = text "*** Core Lint" <+> text string
+ <+> text ": in result of" <+> pass
+ <+> text "***"
+
+showLintWarnings :: CoreToDo -> Bool
+-- Disable Lint warnings on the first simplifier pass, because
+-- there may be some INLINE knots still tied, which is tiresomely noisy
+showLintWarnings (CoreDoSimplify _ (SimplMode { sm_phase = InitialPhase })) = False
+showLintWarnings _ = True
+
+lintInteractiveExpr :: String -> HscEnv -> CoreExpr -> IO ()
+lintInteractiveExpr what hsc_env expr
+ | not (gopt Opt_DoCoreLinting dflags)
+ = return ()
+ | Just err <- lintExpr dflags (interactiveInScope hsc_env) expr
+ = do { display_lint_err err
+ ; Err.ghcExit dflags 1 }
+ | otherwise
+ = return ()
+ where
+ dflags = hsc_dflags hsc_env
+
+ display_lint_err err
+ = do { putLogMsg dflags NoReason Err.SevDump
+ noSrcSpan (defaultDumpStyle dflags)
+ (vcat [ lint_banner "errors" (text what)
+ , err
+ , text "*** Offending Program ***"
+ , pprCoreExpr expr
+ , text "*** End of Offense ***" ])
+ ; Err.ghcExit dflags 1 }
+
+interactiveInScope :: HscEnv -> [Var]
+-- In GHCi we may lint expressions, or bindings arising from 'deriving'
+-- clauses, that mention variables bound in the interactive context.
+-- These are Local things (see Note [Interactively-bound Ids in GHCi] in HscTypes).
+-- So we have to tell Lint about them, lest it reports them as out of scope.
+--
+-- We do this by find local-named things that may appear free in interactive
+-- context. This function is pretty revolting and quite possibly not quite right.
+-- When we are not in GHCi, the interactive context (hsc_IC hsc_env) is empty
+-- so this is a (cheap) no-op.
+--
+-- See Trac #8215 for an example
+interactiveInScope hsc_env
+ = tyvars ++ ids
+ where
+ -- C.f. TcRnDriver.setInteractiveContext, Desugar.deSugarExpr
+ ictxt = hsc_IC hsc_env
+ (cls_insts, _fam_insts) = ic_instances ictxt
+ te1 = mkTypeEnvWithImplicits (ic_tythings ictxt)
+ te = extendTypeEnvWithIds te1 (map instanceDFunId cls_insts)
+ ids = typeEnvIds te
+ tyvars = tyCoVarsOfTypesList $ map idType ids
+ -- Why the type variables? How can the top level envt have free tyvars?
+ -- I think it's because of the GHCi debugger, which can bind variables
+ -- f :: [t] -> [t]
+ -- where t is a RuntimeUnk (see TcType)
+
+lintCoreBindings :: DynFlags -> CoreToDo -> [Var] -> CoreProgram -> (Bag MsgDoc, Bag MsgDoc)
+-- Returns (warnings, errors)
+-- If you edit this function, you may need to update the GHC formalism
+-- See Note [GHC Formalism]
+lintCoreBindings dflags pass local_in_scope binds
+ = initL dflags flags in_scope_set $
+ addLoc TopLevelBindings $
+ lintLetBndrs TopLevel binders $
+ -- Put all the top-level binders in scope at the start
+ -- This is because transformation rules can bring something
+ -- into use 'unexpectedly'
+ do { checkL (null dups) (dupVars dups)
+ ; checkL (null ext_dups) (dupExtVars ext_dups)
+ ; mapM lint_bind binds }
+ where
+ in_scope_set = mkInScopeSet (mkVarSet local_in_scope)
+
+ flags = LF { lf_check_global_ids = check_globals
+ , lf_check_inline_loop_breakers = check_lbs
+ , lf_check_static_ptrs = check_static_ptrs }
+
+ -- See Note [Checking for global Ids]
+ check_globals = case pass of
+ CoreTidy -> False
+ CorePrep -> False
+ _ -> True
+
+ -- See Note [Checking for INLINE loop breakers]
+ check_lbs = case pass of
+ CoreDesugar -> False
+ CoreDesugarOpt -> False
+ _ -> True
+
+ -- See Note [Checking StaticPtrs]
+ check_static_ptrs | not (xopt LangExt.StaticPointers dflags) = AllowAnywhere
+ | otherwise = case pass of
+ CoreDoFloatOutwards _ -> AllowAtTopLevel
+ CoreTidy -> RejectEverywhere
+ CorePrep -> AllowAtTopLevel
+ _ -> AllowAnywhere
+
+ binders = bindersOfBinds binds
+ (_, dups) = removeDups compare binders
+
+ -- dups_ext checks for names with different uniques
+ -- but but the same External name M.n. We don't
+ -- allow this at top level:
+ -- M.n{r3} = ...
+ -- M.n{r29} = ...
+ -- because they both get the same linker symbol
+ ext_dups = snd (removeDups ord_ext (map Var.varName binders))
+ ord_ext n1 n2 | Just m1 <- nameModule_maybe n1
+ , Just m2 <- nameModule_maybe n2
+ = compare (m1, nameOccName n1) (m2, nameOccName n2)
+ | otherwise = LT
+
+ -- If you edit this function, you may need to update the GHC formalism
+ -- See Note [GHC Formalism]
+ lint_bind (Rec prs) = mapM_ (lintSingleBinding TopLevel Recursive) prs
+ lint_bind (NonRec bndr rhs) = lintSingleBinding TopLevel NonRecursive (bndr,rhs)
+
+{-
+************************************************************************
+* *
+\subsection[lintUnfolding]{lintUnfolding}
+* *
+************************************************************************
+
+We use this to check all unfoldings that come in from interfaces
+(it is very painful to catch errors otherwise):
+-}
+
+lintUnfolding :: DynFlags
+ -> SrcLoc
+ -> VarSet -- Treat these as in scope
+ -> CoreExpr
+ -> Maybe MsgDoc -- Nothing => OK
+
+lintUnfolding dflags locn vars expr
+ | isEmptyBag errs = Nothing
+ | otherwise = Just (pprMessageBag errs)
+ where
+ in_scope = mkInScopeSet vars
+ (_warns, errs) = initL dflags defaultLintFlags in_scope linter
+ linter = addLoc (ImportedUnfolding locn) $
+ lintCoreExpr expr
+
+lintExpr :: DynFlags
+ -> [Var] -- Treat these as in scope
+ -> CoreExpr
+ -> Maybe MsgDoc -- Nothing => OK
+
+lintExpr dflags vars expr
+ | isEmptyBag errs = Nothing
+ | otherwise = Just (pprMessageBag errs)
+ where
+ in_scope = mkInScopeSet (mkVarSet vars)
+ (_warns, errs) = initL dflags defaultLintFlags in_scope linter
+ linter = addLoc TopLevelBindings $
+ lintCoreExpr expr
+
+{-
+************************************************************************
+* *
+\subsection[lintCoreBinding]{lintCoreBinding}
+* *
+************************************************************************
+
+Check a core binding, returning the list of variables bound.
+-}
+
+lintSingleBinding :: TopLevelFlag -> RecFlag -> (Id, CoreExpr) -> LintM ()
+-- If you edit this function, you may need to update the GHC formalism
+-- See Note [GHC Formalism]
+lintSingleBinding top_lvl_flag rec_flag (binder,rhs)
+ = addLoc (RhsOf binder) $
+ -- Check the rhs
+ do { ty <- lintRhs binder rhs
+ ; binder_ty <- applySubstTy (idType binder)
+ ; ensureEqTys binder_ty ty (mkRhsMsg binder (text "RHS") ty)
+
+ -- Check that it's not levity-polymorphic
+ -- Do this first, because otherwise isUnliftedType panics
+ -- Annoyingly, this duplicates the test in lintIdBdr,
+ -- because for non-rec lets we call lintSingleBinding first
+ ; checkL (isJoinId binder || not (isTypeLevPoly binder_ty))
+ (badBndrTyMsg binder (text "levity-polymorphic"))
+
+ -- Check the let/app invariant
+ -- See Note [CoreSyn let/app invariant] in CoreSyn
+ ; checkL ( isJoinId binder
+ || not (isUnliftedType binder_ty)
+ || (isNonRec rec_flag && exprOkForSpeculation rhs)
+ || exprIsLiteralString rhs)
+ (badBndrTyMsg binder (text "unlifted"))
+
+ -- Check that if the binder is top-level or recursive, it's not
+ -- demanded. Primitive string literals are exempt as there is no
+ -- computation to perform, see Note [CoreSyn top-level string literals].
+ ; checkL (not (isStrictId binder)
+ || (isNonRec rec_flag && not (isTopLevel top_lvl_flag))
+ || exprIsLiteralString rhs)
+ (mkStrictMsg binder)
+
+ -- Check that if the binder is at the top level and has type Addr#,
+ -- that it is a string literal, see
+ -- Note [CoreSyn top-level string literals].
+ ; checkL (not (isTopLevel top_lvl_flag && binder_ty `eqType` addrPrimTy)
+ || exprIsLiteralString rhs)
+ (mkTopNonLitStrMsg binder)
+
+ ; flags <- getLintFlags
+
+ -- Check that a join-point binder has a valid type
+ -- NB: lintIdBinder has checked that it is not top-level bound
+ ; case isJoinId_maybe binder of
+ Nothing -> return ()
+ Just arity -> checkL (isValidJoinPointType arity binder_ty)
+ (mkInvalidJoinPointMsg binder binder_ty)
+
+ ; when (lf_check_inline_loop_breakers flags
+ && isStrongLoopBreaker (idOccInfo binder)
+ && isInlinePragma (idInlinePragma binder))
+ (addWarnL (text "INLINE binder is (non-rule) loop breaker:" <+> ppr binder))
+ -- Only non-rule loop breakers inhibit inlining
+
+ -- Check whether arity and demand type are consistent (only if demand analysis
+ -- already happened)
+ --
+ -- Note (Apr 2014): this is actually ok. See Note [Demand analysis for trivial right-hand sides]
+ -- in DmdAnal. After eta-expansion in CorePrep the rhs is no longer trivial.
+ -- ; let dmdTy = idStrictness binder
+ -- ; checkL (case dmdTy of
+ -- StrictSig dmd_ty -> idArity binder >= dmdTypeDepth dmd_ty || exprIsTrivial rhs)
+ -- (mkArityMsg binder)
+
+ -- Check that the binder's arity is within the bounds imposed by
+ -- the type and the strictness signature. See Note [exprArity invariant]
+ -- and Note [Trimming arity]
+ ; checkL (idArity binder <= length (typeArity (idType binder)))
+ (text "idArity" <+> ppr (idArity binder) <+>
+ text "exceeds typeArity" <+>
+ ppr (length (typeArity (idType binder))) <> colon <+>
+ ppr binder)
+
+ ; case splitStrictSig (idStrictness binder) of
+ (demands, result_info) | isBotRes result_info ->
+ checkL (idArity binder <= length demands)
+ (text "idArity" <+> ppr (idArity binder) <+>
+ text "exceeds arity imposed by the strictness signature" <+>
+ ppr (idStrictness binder) <> colon <+>
+ ppr binder)
+ _ -> return ()
+
+ ; mapM_ (lintCoreRule binder binder_ty) (idCoreRules binder)
+ ; lintIdUnfolding binder binder_ty (idUnfolding binder) }
+
+ -- We should check the unfolding, if any, but this is tricky because
+ -- the unfolding is a SimplifiableCoreExpr. Give up for now.
+
+-- | Checks the RHS of bindings. It only differs from 'lintCoreExpr'
+-- in that it doesn't reject occurrences of the function 'makeStatic' when they
+-- appear at the top level and @lf_check_static_ptrs == AllowAtTopLevel@, and
+-- for join points, it skips the outer lambdas that take arguments to the
+-- join point.
+--
+-- See Note [Checking StaticPtrs].
+lintRhs :: Id -> CoreExpr -> LintM OutType
+lintRhs bndr rhs
+ | Just arity <- isJoinId_maybe bndr
+ = lint_join_lams arity arity True rhs
+ | AlwaysTailCalled arity <- tailCallInfo (idOccInfo bndr)
+ = lint_join_lams arity arity False rhs
+ where
+ lint_join_lams 0 _ _ rhs
+ = lintCoreExpr rhs
+
+ lint_join_lams n tot enforce (Lam var expr)
+ = addLoc (LambdaBodyOf var) $
+ lintBinder LambdaBind var $ \ var' ->
+ do { body_ty <- lint_join_lams (n-1) tot enforce expr
+ ; return $ mkLamType var' body_ty }
+
+ lint_join_lams n tot True _other
+ = failWithL $ mkBadJoinArityMsg bndr tot (tot-n)
+ lint_join_lams _ _ False rhs
+ = markAllJoinsBad $ lintCoreExpr rhs
+ -- Future join point, not yet eta-expanded
+ -- Body is not a tail position
+
+-- Allow applications of the data constructor @StaticPtr@ at the top
+-- but produce errors otherwise.
+lintRhs _bndr rhs = fmap lf_check_static_ptrs getLintFlags >>= go
+ where
+ -- Allow occurrences of 'makeStatic' at the top-level but produce errors
+ -- otherwise.
+ go AllowAtTopLevel
+ | (binders0, rhs') <- collectTyBinders rhs
+ , Just (fun, t, info, e) <- collectMakeStaticArgs rhs'
+ = markAllJoinsBad $
+ foldr
+ -- imitate @lintCoreExpr (Lam ...)@
+ (\var loopBinders ->
+ addLoc (LambdaBodyOf var) $
+ lintBinder LambdaBind var $ \var' ->
+ do { body_ty <- loopBinders
+ ; return $ mkLamType var' body_ty }
+ )
+ -- imitate @lintCoreExpr (App ...)@
+ (do fun_ty <- lintCoreExpr fun
+ addLoc (AnExpr rhs') $ lintCoreArgs fun_ty [Type t, info, e]
+ )
+ binders0
+ go _ = markAllJoinsBad $ lintCoreExpr rhs
+
+lintIdUnfolding :: Id -> Type -> Unfolding -> LintM ()
+lintIdUnfolding bndr bndr_ty (CoreUnfolding { uf_tmpl = rhs, uf_src = src })
+ | isStableSource src
+ = do { ty <- lintRhs bndr rhs
+ ; ensureEqTys bndr_ty ty (mkRhsMsg bndr (text "unfolding") ty) }
+
+lintIdUnfolding bndr bndr_ty (DFunUnfolding { df_con = con, df_bndrs = bndrs
+ , df_args = args })
+ = do { ty <- lintBinders LambdaBind bndrs $ \ bndrs' ->
+ do { res_ty <- lintCoreArgs (dataConRepType con) args
+ ; return (mkLamTypes bndrs' res_ty) }
+ ; ensureEqTys bndr_ty ty (mkRhsMsg bndr (text "dfun unfolding") ty) }
+
+lintIdUnfolding _ _ _
+ = return () -- Do not Lint unstable unfoldings, because that leads
+ -- to exponential behaviour; c.f. CoreFVs.idUnfoldingVars
+
+{-
+Note [Checking for INLINE loop breakers]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+It's very suspicious if a strong loop breaker is marked INLINE.
+
+However, the desugarer generates instance methods with INLINE pragmas
+that form a mutually recursive group. Only after a round of
+simplification are they unravelled. So we suppress the test for
+the desugarer.
+
+************************************************************************
+* *
+\subsection[lintCoreExpr]{lintCoreExpr}
+* *
+************************************************************************
+-}
+
+-- For OutType, OutKind, the substitution has been applied,
+-- but has not been linted yet
+
+type LintedType = Type -- Substitution applied, and type is linted
+type LintedKind = Kind
+
+lintCoreExpr :: CoreExpr -> LintM OutType
+-- The returned type has the substitution from the monad
+-- already applied to it:
+-- lintCoreExpr e subst = exprType (subst e)
+--
+-- The returned "type" can be a kind, if the expression is (Type ty)
+
+-- If you edit this function, you may need to update the GHC formalism
+-- See Note [GHC Formalism]
+lintCoreExpr (Var var)
+ = lintVarOcc var 0
+
+lintCoreExpr (Lit lit)
+ = return (literalType lit)
+
+lintCoreExpr (Cast expr co)
+ = do { expr_ty <- markAllJoinsBad $ lintCoreExpr expr
+ ; co' <- applySubstCo co
+ ; (_, k2, from_ty, to_ty, r) <- lintCoercion co'
+ ; lintL (classifiesTypeWithValues k2)
+ (text "Target of cast not # or *:" <+> ppr co)
+ ; lintRole co' Representational r
+ ; ensureEqTys from_ty expr_ty (mkCastErr expr co' from_ty expr_ty)
+ ; return to_ty }
+
+lintCoreExpr (Tick tickish expr)
+ = do case tickish of
+ Breakpoint _ ids -> forM_ ids $ \id -> do
+ checkDeadIdOcc id
+ lookupIdInScope id
+ _ -> return ()
+ markAllJoinsBadIf block_joins $ lintCoreExpr expr
+ where
+ block_joins = not (tickish `tickishScopesLike` SoftScope)
+ -- TODO Consider whether this is the correct rule. It is consistent with
+ -- the simplifier's behaviour - cost-centre-scoped ticks become part of
+ -- the continuation, and thus they behave like part of an evaluation
+ -- context, but soft-scoped and non-scoped ticks simply wrap the result
+ -- (see Simplify.simplTick).
+
+lintCoreExpr (Let (NonRec tv (Type ty)) body)
+ | isTyVar tv
+ = -- See Note [Linting type lets]
+ do { ty' <- applySubstTy ty
+ ; lintTyBndr tv $ \ tv' ->
+ do { addLoc (RhsOf tv) $ lintTyKind tv' ty'
+ -- Now extend the substitution so we
+ -- take advantage of it in the body
+ ; extendSubstL tv ty' $
+ addLoc (BodyOfLetRec [tv]) $
+ lintCoreExpr body } }
+
+lintCoreExpr (Let (NonRec bndr rhs) body)
+ | isId bndr
+ = do { lintSingleBinding NotTopLevel NonRecursive (bndr,rhs)
+ ; addLoc (BodyOfLetRec [bndr])
+ (lintIdBndr NotTopLevel LetBind bndr $ \_ ->
+ addGoodJoins [bndr] $
+ lintCoreExpr body) }
+
+ | otherwise
+ = failWithL (mkLetErr bndr rhs) -- Not quite accurate
+
+lintCoreExpr e@(Let (Rec pairs) body)
+ = lintLetBndrs NotTopLevel bndrs $
+ addGoodJoins bndrs $
+ do { -- Check that the list of pairs is non-empty
+ checkL (not (null pairs)) (emptyRec e)
+
+ -- Check that there are no duplicated binders
+ ; checkL (null dups) (dupVars dups)
+
+ -- Check that either all the binders are joins, or none
+ ; checkL (all isJoinId bndrs || all (not . isJoinId) bndrs) $
+ mkInconsistentRecMsg bndrs
+
+ ; mapM_ (lintSingleBinding NotTopLevel Recursive) pairs
+ ; addLoc (BodyOfLetRec bndrs) (lintCoreExpr body) }
+ where
+ bndrs = map fst pairs
+ (_, dups) = removeDups compare bndrs
+
+lintCoreExpr e@(App _ _)
+ = addLoc (AnExpr e) $
+ do { fun_ty <- lintCoreFun fun (length args)
+ ; lintCoreArgs fun_ty args }
+ where
+ (fun, args) = collectArgs e
+
+lintCoreExpr (Lam var expr)
+ = addLoc (LambdaBodyOf var) $
+ markAllJoinsBad $
+ lintBinder LambdaBind var $ \ var' ->
+ do { body_ty <- lintCoreExpr expr
+ ; return $ mkLamType var' body_ty }
+
+lintCoreExpr e@(Case scrut var alt_ty alts) =
+ -- Check the scrutinee
+ do { let scrut_diverges = exprIsBottom scrut
+ ; scrut_ty <- markAllJoinsBad $ lintCoreExpr scrut
+ ; (alt_ty, _) <- lintInTy alt_ty
+ ; (var_ty, _) <- lintInTy (idType var)
+
+ -- See Note [No alternatives lint check]
+ ; when (null alts) $
+ do { checkL (not (exprIsHNF scrut))
+ (text "No alternatives for a case scrutinee in head-normal form:" <+> ppr scrut)
+ ; checkWarnL scrut_diverges
+ (text "No alternatives for a case scrutinee not known to diverge for sure:" <+> ppr scrut)
+ }
+
+ -- See Note [Rules for floating-point comparisons] in PrelRules
+ ; let isLitPat (LitAlt _, _ , _) = True
+ isLitPat _ = False
+ ; checkL (not $ isFloatingTy scrut_ty && any isLitPat alts)
+ (ptext (sLit $ "Lint warning: Scrutinising floating-point " ++
+ "expression with literal pattern in case " ++
+ "analysis (see Trac #9238).")
+ $$ text "scrut" <+> ppr scrut)
+
+ ; case tyConAppTyCon_maybe (idType var) of
+ Just tycon
+ | debugIsOn
+ , isAlgTyCon tycon
+ , not (isAbstractTyCon tycon)
+ , null (tyConDataCons tycon)
+ , not scrut_diverges
+ -> pprTrace "Lint warning: case binder's type has no constructors" (ppr var <+> ppr (idType var))
+ -- This can legitimately happen for type families
+ $ return ()
+ _otherwise -> return ()
+
+ -- Don't use lintIdBndr on var, because unboxed tuple is legitimate
+
+ ; subst <- getTCvSubst
+ ; ensureEqTys var_ty scrut_ty (mkScrutMsg var var_ty scrut_ty subst)
+
+ ; lintIdBndr NotTopLevel CaseBind var $ \_ ->
+ do { -- Check the alternatives
+ mapM_ (lintCoreAlt scrut_ty alt_ty) alts
+ ; checkCaseAlts e scrut_ty alts
+ ; return alt_ty } }
+
+-- This case can't happen; linting types in expressions gets routed through
+-- lintCoreArgs
+lintCoreExpr (Type ty)
+ = failWithL (text "Type found as expression" <+> ppr ty)
+
+lintCoreExpr (Coercion co)
+ = do { (k1, k2, ty1, ty2, role) <- lintInCo co
+ ; return (mkHeteroCoercionType role k1 k2 ty1 ty2) }
+
+----------------------
+lintVarOcc :: Var -> Int -- Number of arguments (type or value) being passed
+ -> LintM Type -- returns type of the *variable*
+lintVarOcc var nargs
+ = do { checkL (isNonCoVarId var)
+ (text "Non term variable" <+> ppr var)
+
+ -- Cneck that the type of the occurrence is the same
+ -- as the type of the binding site
+ ; ty <- applySubstTy (idType var)
+ ; var' <- lookupIdInScope var
+ ; let ty' = idType var'
+ ; ensureEqTys ty ty' $ mkBndrOccTypeMismatchMsg var' var ty' ty
+
+ -- Check for a nested occurrence of the StaticPtr constructor.
+ -- See Note [Checking StaticPtrs].
+ ; lf <- getLintFlags
+ ; when (nargs /= 0 && lf_check_static_ptrs lf /= AllowAnywhere) $
+ checkL (idName var /= makeStaticName) $
+ text "Found makeStatic nested in an expression"
+
+ ; checkDeadIdOcc var
+ ; checkJoinOcc var nargs
+
+ ; return (idType var') }
+
+lintCoreFun :: CoreExpr
+ -> Int -- Number of arguments (type or val) being passed
+ -> LintM Type -- Returns type of the *function*
+lintCoreFun (Var var) nargs
+ = lintVarOcc var nargs
+
+lintCoreFun (Lam var body) nargs
+ -- Act like lintCoreExpr of Lam, but *don't* call markAllJoinsBad; see
+ -- Note [Beta redexes]
+ | nargs /= 0
+ = addLoc (LambdaBodyOf var) $
+ lintBinder LambdaBind var $ \ var' ->
+ do { body_ty <- lintCoreFun body (nargs - 1)
+ ; return $ mkLamType var' body_ty }
+
+lintCoreFun expr nargs
+ = markAllJoinsBadIf (nargs /= 0) $
+ lintCoreExpr expr
+
+------------------
+checkDeadIdOcc :: Id -> LintM ()
+-- Occurrences of an Id should never be dead....
+-- except when we are checking a case pattern
+checkDeadIdOcc id
+ | isDeadOcc (idOccInfo id)
+ = do { in_case <- inCasePat
+ ; checkL in_case
+ (text "Occurrence of a dead Id" <+> ppr id) }
+ | otherwise
+ = return ()
+
+------------------
+checkJoinOcc :: Id -> JoinArity -> LintM ()
+-- Check that if the occurrence is a JoinId, then so is the
+-- binding site, and it's a valid join Id
+checkJoinOcc var n_args
+ | Just join_arity_occ <- isJoinId_maybe var
+ = do { mb_join_arity_bndr <- lookupJoinId var
+ ; case mb_join_arity_bndr of {
+ Nothing -> -- Binder is not a join point
+ addErrL (invalidJoinOcc var) ;
+
+ Just join_arity_bndr ->
+
+ do { checkL (join_arity_bndr == join_arity_occ) $
+ -- Arity differs at binding site and occurrence
+ mkJoinBndrOccMismatchMsg var join_arity_bndr join_arity_occ
+
+ ; checkL (n_args == join_arity_occ) $
+ -- Arity doesn't match #args
+ mkBadJumpMsg var join_arity_occ n_args } } }
+
+ | otherwise
+ = return ()
+
+{-
+Note [No alternatives lint check]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Case expressions with no alternatives are odd beasts, and worth looking at
+in the linter (cf Trac #10180). We check two things:
+
+* exprIsHNF is false: certainly, it would be terribly wrong if the
+ scrutinee was already in head normal form.
+
+* exprIsBottom is true: we should be able to see why GHC believes the
+ scrutinee is diverging for sure.
+
+In principle, the first check is redundant: exprIsBottom == True will
+always imply exprIsHNF == False. But the first check is reliable: If
+exprIsHNF == True, then there definitely is a problem (exprIsHNF errs
+on the right side). If the second check triggers then it may be the
+case that the compiler got smarter elsewhere, and the empty case is
+correct, but that exprIsBottom is unable to see it. In particular, the
+empty-type check in exprIsBottom is an approximation. Therefore, this
+check is not fully reliable, and we keep both around.
+
+Note [Beta redexes]
+~~~~~~~~~~~~~~~~~~~
+Consider:
+
+ join j @x y z = ... in
+ (\@x y z -> jump j @x y z) @t e1 e2
+
+This is clearly ill-typed, since the jump is inside both an application and a
+lambda, either of which is enough to disqualify it as a tail call (see Note
+[Invariants on join points] in CoreSyn). However, strictly from a
+lambda-calculus perspective, the term doesn't go wrong---after the two beta
+reductions, the jump *is* a tail call and everything is fine.
+
+Why would we want to allow this when we have let? One reason is that a compound
+beta redex (that is, one with more than one argument) has different scoping
+rules: naively reducing the above example using lets will capture any free
+occurrence of y in e2. More fundamentally, type lets are tricky; many passes,
+such as Float Out, tacitly assume that the incoming program's type lets have
+all been dealt with by the simplifier. Thus we don't want to let-bind any types
+in, say, CoreSubst.simpleOptPgm, which in some circumstances can run immediately
+before Float Out.
+
+All that said, currently CoreSubst.simpleOptPgm is the only thing using this
+loophole, doing so to avoid re-traversing large functions (beta-reducing a type
+lambda without introducing a type let requires a substitution). TODO: Improve
+simpleOptPgm so that we can forget all this ever happened.
+
+************************************************************************
+* *
+\subsection[lintCoreArgs]{lintCoreArgs}
+* *
+************************************************************************
+
+The basic version of these functions checks that the argument is a
+subtype of the required type, as one would expect.
+-}
+
+
+lintCoreArgs :: OutType -> [CoreArg] -> LintM OutType
+lintCoreArgs fun_ty args = foldM lintCoreArg fun_ty args
+
+lintCoreArg :: OutType -> CoreArg -> LintM OutType
+lintCoreArg fun_ty (Type arg_ty)
+ = do { checkL (not (isCoercionTy arg_ty))
+ (text "Unnecessary coercion-to-type injection:"
+ <+> ppr arg_ty)
+ ; arg_ty' <- applySubstTy arg_ty
+ ; lintTyApp fun_ty arg_ty' }
+
+lintCoreArg fun_ty arg
+ = do { arg_ty <- markAllJoinsBad $ lintCoreExpr arg
+ -- See Note [Levity polymorphism invariants] in CoreSyn
+ ; lintL (not (isTypeLevPoly arg_ty))
+ (text "Levity-polymorphic argument:" <+>
+ (ppr arg <+> dcolon <+> parens (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))))
+ -- check for levity polymorphism first, because otherwise isUnliftedType panics
+
+ ; checkL (not (isUnliftedType arg_ty) || exprOkForSpeculation arg)
+ (mkLetAppMsg arg)
+ ; lintValApp arg fun_ty arg_ty }
+
+-----------------
+lintAltBinders :: OutType -- Scrutinee type
+ -> OutType -- Constructor type
+ -> [OutVar] -- Binders
+ -> LintM ()
+-- If you edit this function, you may need to update the GHC formalism
+-- See Note [GHC Formalism]
+lintAltBinders scrut_ty con_ty []
+ = ensureEqTys con_ty scrut_ty (mkBadPatMsg con_ty scrut_ty)
+lintAltBinders scrut_ty con_ty (bndr:bndrs)
+ | isTyVar bndr
+ = do { con_ty' <- lintTyApp con_ty (mkTyVarTy bndr)
+ ; lintAltBinders scrut_ty con_ty' bndrs }
+ | otherwise
+ = do { con_ty' <- lintValApp (Var bndr) con_ty (idType bndr)
+ ; lintAltBinders scrut_ty con_ty' bndrs }
+
+-----------------
+lintTyApp :: OutType -> OutType -> LintM OutType
+lintTyApp fun_ty arg_ty
+ | Just (tv,body_ty) <- splitForAllTy_maybe fun_ty
+ = do { lintTyKind tv arg_ty
+ ; in_scope <- getInScope
+ -- substTy needs the set of tyvars in scope to avoid generating
+ -- uniques that are already in scope.
+ -- See Note [The substitution invariant] in TyCoRep
+ ; return (substTyWithInScope in_scope [tv] [arg_ty] body_ty) }
+
+ | otherwise
+ = failWithL (mkTyAppMsg fun_ty arg_ty)
+
+-----------------
+lintValApp :: CoreExpr -> OutType -> OutType -> LintM OutType
+lintValApp arg fun_ty arg_ty
+ | Just (arg,res) <- splitFunTy_maybe fun_ty
+ = do { ensureEqTys arg arg_ty err1
+ ; return res }
+ | otherwise
+ = failWithL err2
+ where
+ err1 = mkAppMsg fun_ty arg_ty arg
+ err2 = mkNonFunAppMsg fun_ty arg_ty arg
+
+lintTyKind :: OutTyVar -> OutType -> LintM ()
+-- Both args have had substitution applied
+
+-- If you edit this function, you may need to update the GHC formalism
+-- See Note [GHC Formalism]
+lintTyKind tyvar arg_ty
+ -- Arg type might be boxed for a function with an uncommitted
+ -- tyvar; notably this is used so that we can give
+ -- error :: forall a:*. String -> a
+ -- and then apply it to both boxed and unboxed types.
+ = do { arg_kind <- lintType arg_ty
+ ; unless (arg_kind `eqType` tyvar_kind)
+ (addErrL (mkKindErrMsg tyvar arg_ty $$ (text "Linted Arg kind:" <+> ppr arg_kind))) }
+ where
+ tyvar_kind = tyVarKind tyvar
+
+{-
+************************************************************************
+* *
+\subsection[lintCoreAlts]{lintCoreAlts}
+* *
+************************************************************************
+-}
+
+checkCaseAlts :: CoreExpr -> OutType -> [CoreAlt] -> LintM ()
+-- a) Check that the alts are non-empty
+-- b1) Check that the DEFAULT comes first, if it exists
+-- b2) Check that the others are in increasing order
+-- c) Check that there's a default for infinite types
+-- NB: Algebraic cases are not necessarily exhaustive, because
+-- the simplifier correctly eliminates case that can't
+-- possibly match.
+
+checkCaseAlts e ty alts =
+ do { checkL (all non_deflt con_alts) (mkNonDefltMsg e)
+ ; checkL (increasing_tag con_alts) (mkNonIncreasingAltsMsg e)
+
+ -- For types Int#, Word# with an infinite (well, large!) number of
+ -- possible values, there should usually be a DEFAULT case
+ -- But (see Note [Empty case alternatives] in CoreSyn) it's ok to
+ -- have *no* case alternatives.
+ -- In effect, this is a kind of partial test. I suppose it's possible
+ -- that we might *know* that 'x' was 1 or 2, in which case
+ -- case x of { 1 -> e1; 2 -> e2 }
+ -- would be fine.
+ ; checkL (isJust maybe_deflt || not is_infinite_ty || null alts)
+ (nonExhaustiveAltsMsg e) }
+ where
+ (con_alts, maybe_deflt) = findDefault alts
+
+ -- Check that successive alternatives have increasing tags
+ increasing_tag (alt1 : rest@( alt2 : _)) = alt1 `ltAlt` alt2 && increasing_tag rest
+ increasing_tag _ = True
+
+ non_deflt (DEFAULT, _, _) = False
+ non_deflt _ = True
+
+ is_infinite_ty = case tyConAppTyCon_maybe ty of
+ Nothing -> False
+ Just tycon -> isPrimTyCon tycon
+
+lintAltExpr :: CoreExpr -> OutType -> LintM ()
+lintAltExpr expr ann_ty
+ = do { actual_ty <- lintCoreExpr expr
+ ; ensureEqTys actual_ty ann_ty (mkCaseAltMsg expr actual_ty ann_ty) }
+
+lintCoreAlt :: OutType -- Type of scrutinee
+ -> OutType -- Type of the alternative
+ -> CoreAlt
+ -> LintM ()
+-- If you edit this function, you may need to update the GHC formalism
+-- See Note [GHC Formalism]
+lintCoreAlt _ alt_ty (DEFAULT, args, rhs) =
+ do { lintL (null args) (mkDefaultArgsMsg args)
+ ; lintAltExpr rhs alt_ty }
+
+lintCoreAlt scrut_ty alt_ty (LitAlt lit, args, rhs)
+ | litIsLifted lit
+ = failWithL integerScrutinisedMsg
+ | otherwise
+ = do { lintL (null args) (mkDefaultArgsMsg args)
+ ; ensureEqTys lit_ty scrut_ty (mkBadPatMsg lit_ty scrut_ty)
+ ; lintAltExpr rhs alt_ty }
+ where
+ lit_ty = literalType lit
+
+lintCoreAlt scrut_ty alt_ty alt@(DataAlt con, args, rhs)
+ | isNewTyCon (dataConTyCon con)
+ = addErrL (mkNewTyDataConAltMsg scrut_ty alt)
+ | Just (tycon, tycon_arg_tys) <- splitTyConApp_maybe scrut_ty
+ = addLoc (CaseAlt alt) $ do
+ { -- First instantiate the universally quantified
+ -- type variables of the data constructor
+ -- We've already check
+ lintL (tycon == dataConTyCon con) (mkBadConMsg tycon con)
+ ; let con_payload_ty = piResultTys (dataConRepType con) tycon_arg_tys
+
+ -- And now bring the new binders into scope
+ ; lintBinders CasePatBind args $ \ args' -> do
+ { addLoc (CasePat alt) (lintAltBinders scrut_ty con_payload_ty args')
+ ; lintAltExpr rhs alt_ty } }
+
+ | otherwise -- Scrut-ty is wrong shape
+ = addErrL (mkBadAltMsg scrut_ty alt)
+
+{-
+************************************************************************
+* *
+\subsection[lint-types]{Types}
+* *
+************************************************************************
+-}
+
+-- When we lint binders, we (one at a time and in order):
+-- 1. Lint var types or kinds (possibly substituting)
+-- 2. Add the binder to the in scope set, and if its a coercion var,
+-- we may extend the substitution to reflect its (possibly) new kind
+lintBinders :: BindingSite -> [Var] -> ([Var] -> LintM a) -> LintM a
+lintBinders _ [] linterF = linterF []
+lintBinders site (var:vars) linterF = lintBinder site var $ \var' ->
+ lintBinders site vars $ \ vars' ->
+ linterF (var':vars')
+
+-- If you edit this function, you may need to update the GHC formalism
+-- See Note [GHC Formalism]
+lintBinder :: BindingSite -> Var -> (Var -> LintM a) -> LintM a
+lintBinder site var linterF
+ | isTyVar var = lintTyBndr var linterF
+ | isCoVar var = lintCoBndr var linterF
+ | otherwise = lintIdBndr NotTopLevel site var linterF
+
+lintTyBndr :: InTyVar -> (OutTyVar -> LintM a) -> LintM a
+lintTyBndr tv thing_inside
+ = do { subst <- getTCvSubst
+ ; let (subst', tv') = substTyVarBndr subst tv
+ ; lintKind (varType tv')
+ ; updateTCvSubst subst' (thing_inside tv') }
+
+lintCoBndr :: InCoVar -> (OutCoVar -> LintM a) -> LintM a
+lintCoBndr cv thing_inside
+ = do { subst <- getTCvSubst
+ ; let (subst', cv') = substCoVarBndr subst cv
+ ; lintKind (varType cv')
+ ; lintL (isCoercionType (varType cv'))
+ (text "CoVar with non-coercion type:" <+> pprTyVar cv)
+ ; updateTCvSubst subst' (thing_inside cv') }
+
+lintLetBndrs :: TopLevelFlag -> [Var] -> LintM a -> LintM a
+lintLetBndrs top_lvl ids linterF
+ = go ids
+ where
+ go [] = linterF
+ go (id:ids) = lintIdBndr top_lvl LetBind id $ \_ ->
+ go ids
+
+lintIdBndr :: TopLevelFlag -> BindingSite
+ -> InVar -> (OutVar -> LintM a) -> LintM a
+-- Do substitution on the type of a binder and add the var with this
+-- new type to the in-scope set of the second argument
+-- ToDo: lint its rules
+lintIdBndr top_lvl bind_site id linterF
+ = ASSERT2( isId id, ppr id )
+ do { flags <- getLintFlags
+ ; checkL (not (lf_check_global_ids flags) || isLocalId id)
+ (text "Non-local Id binder" <+> ppr id)
+ -- See Note [Checking for global Ids]
+
+ -- Check that if the binder is nested, it is not marked as exported
+ ; checkL (not (isExportedId id) || is_top_lvl)
+ (mkNonTopExportedMsg id)
+
+ -- Check that if the binder is nested, it does not have an external name
+ ; checkL (not (isExternalName (Var.varName id)) || is_top_lvl)
+ (mkNonTopExternalNameMsg id)
+
+ ; (ty, k) <- lintInTy (idType id)
+ -- See Note [Levity polymorphism invariants] in CoreSyn
+ ; lintL (isJoinId id || not (isKindLevPoly k))
+ (text "Levity-polymorphic binder:" <+>
+ (ppr id <+> dcolon <+> parens (ppr ty <+> dcolon <+> ppr k)))
+
+ -- Check that a join-id is a not-top-level let-binding
+ ; when (isJoinId id) $
+ checkL (not is_top_lvl && is_let_bind) $
+ mkBadJoinBindMsg id
+
+ ; let id' = setIdType id ty
+ ; addInScopeVar id' $ (linterF id') }
+ where
+ is_top_lvl = isTopLevel top_lvl
+ is_let_bind = case bind_site of
+ LetBind -> True
+ _ -> False
+
+{-
+%************************************************************************
+%* *
+ Types
+%* *
+%************************************************************************
+-}
+
+lintInTy :: InType -> LintM (LintedType, LintedKind)
+-- Types only, not kinds
+-- Check the type, and apply the substitution to it
+-- See Note [Linting type lets]
+lintInTy ty
+ = addLoc (InType ty) $
+ do { ty' <- applySubstTy ty
+ ; k <- lintType ty'
+ ; lintKind k
+ ; return (ty', k) }
+
+checkTyCon :: TyCon -> LintM ()
+checkTyCon tc
+ = checkL (not (isTcTyCon tc)) (text "Found TcTyCon:" <+> ppr tc)
+
+-------------------
+lintType :: OutType -> LintM LintedKind
+-- The returned Kind has itself been linted
+
+-- If you edit this function, you may need to update the GHC formalism
+-- See Note [GHC Formalism]
+lintType (TyVarTy tv)
+ = do { checkL (isTyVar tv) (mkBadTyVarMsg tv)
+ ; lintTyCoVarInScope tv
+ ; return (tyVarKind tv) }
+ -- We checked its kind when we added it to the envt
+
+lintType ty@(AppTy t1 t2)
+ | TyConApp {} <- t1
+ = failWithL $ text "TyConApp to the left of AppTy:" <+> ppr ty
+ | otherwise
+ = do { k1 <- lintType t1
+ ; k2 <- lintType t2
+ ; lint_ty_app ty k1 [(t2,k2)] }
+
+lintType ty@(TyConApp tc tys)
+ | Just ty' <- coreView ty
+ = lintType ty' -- Expand type synonyms, so that we do not bogusly complain
+ -- about un-saturated type synonyms
+
+ -- We should never see a saturated application of funTyCon; such applications
+ -- should be represented with the FunTy constructor. See Note [Linting
+ -- function types] and Note [Representation of function types].
+ | isFunTyCon tc
+ , length tys == 4
+ = failWithL (hang (text "Saturated application of (->)") 2 (ppr ty))
+
+ | isTypeSynonymTyCon tc || isTypeFamilyTyCon tc
+ -- Also type synonyms and type families
+ , length tys < tyConArity tc
+ = failWithL (hang (text "Un-saturated type application") 2 (ppr ty))
+
+ | otherwise
+ = do { checkTyCon tc
+ ; ks <- mapM lintType tys
+ ; lint_ty_app ty (tyConKind tc) (tys `zip` ks) }
+
+-- arrows can related *unlifted* kinds, so this has to be separate from
+-- a dependent forall.
+lintType ty@(FunTy t1 t2)
+ = do { k1 <- lintType t1
+ ; k2 <- lintType t2
+ ; lintArrow (text "type or kind" <+> quotes (ppr ty)) k1 k2 }
+
+lintType t@(ForAllTy (TvBndr tv _vis) ty)
+ = do { lintL (isTyVar tv) (text "Covar bound in type:" <+> ppr t)
+ ; lintTyBndr tv $ \tv' ->
+ do { k <- lintType ty
+ ; lintL (not (tv' `elemVarSet` tyCoVarsOfType k))
+ (text "Variable escape in forall:" <+> ppr t)
+ ; lintL (classifiesTypeWithValues k)
+ (text "Non-* and non-# kind in forall:" <+> ppr t)
+ ; return k }}
+
+lintType ty@(LitTy l) = lintTyLit l >> return (typeKind ty)
+
+lintType (CastTy ty co)
+ = do { k1 <- lintType ty
+ ; (k1', k2) <- lintStarCoercion co
+ ; ensureEqTys k1 k1' (mkCastErr ty co k1' k1)
+ ; return k2 }
+
+lintType (CoercionTy co)
+ = do { (k1, k2, ty1, ty2, r) <- lintCoercion co
+ ; return $ mkHeteroCoercionType r k1 k2 ty1 ty2 }
+
+lintKind :: OutKind -> LintM ()
+-- If you edit this function, you may need to update the GHC formalism
+-- See Note [GHC Formalism]
+lintKind k = do { sk <- lintType k
+ ; unless (classifiesTypeWithValues sk)
+ (addErrL (hang (text "Ill-kinded kind:" <+> ppr k)
+ 2 (text "has kind:" <+> ppr sk))) }
+
+-- confirms that a type is really *
+lintStar :: SDoc -> OutKind -> LintM ()
+lintStar doc k
+ = lintL (classifiesTypeWithValues k)
+ (text "Non-*-like kind when *-like expected:" <+> ppr k $$
+ text "when checking" <+> doc)
+
+lintArrow :: SDoc -> LintedKind -> LintedKind -> LintM LintedKind
+-- If you edit this function, you may need to update the GHC formalism
+-- See Note [GHC Formalism]
+lintArrow what k1 k2 -- Eg lintArrow "type or kind `blah'" k1 k2
+ -- or lintarrow "coercion `blah'" k1 k2
+ = do { unless (okArrowArgKind k1) (addErrL (msg (text "argument") k1))
+ ; unless (okArrowResultKind k2) (addErrL (msg (text "result") k2))
+ ; return liftedTypeKind }
+ where
+ msg ar k
+ = vcat [ hang (text "Ill-kinded" <+> ar)
+ 2 (text "in" <+> what)
+ , what <+> text "kind:" <+> ppr k ]
+
+lint_ty_app :: Type -> LintedKind -> [(LintedType,LintedKind)] -> LintM LintedKind
+lint_ty_app ty k tys
+ = lint_app (text "type" <+> quotes (ppr ty)) k tys
+
+----------------
+lint_co_app :: Coercion -> LintedKind -> [(LintedType,LintedKind)] -> LintM LintedKind
+lint_co_app ty k tys
+ = lint_app (text "coercion" <+> quotes (ppr ty)) k tys
+
+----------------
+lintTyLit :: TyLit -> LintM ()
+lintTyLit (NumTyLit n)
+ | n >= 0 = return ()
+ | otherwise = failWithL msg
+ where msg = text "Negative type literal:" <+> integer n
+lintTyLit (StrTyLit _) = return ()
+
+lint_app :: SDoc -> LintedKind -> [(LintedType,LintedKind)] -> LintM Kind
+-- (lint_app d fun_kind arg_tys)
+-- We have an application (f arg_ty1 .. arg_tyn),
+-- where f :: fun_kind
+-- Takes care of linting the OutTypes
+
+-- If you edit this function, you may need to update the GHC formalism
+-- See Note [GHC Formalism]
+lint_app doc kfn kas
+ = do { in_scope <- getInScope
+ -- We need the in_scope set to satisfy the invariant in
+ -- Note [The substitution invariant] in TyCoRep
+ ; foldlM (go_app in_scope) kfn kas }
+ where
+ fail_msg = vcat [ hang (text "Kind application error in") 2 doc
+ , nest 2 (text "Function kind =" <+> ppr kfn)
+ , nest 2 (text "Arg kinds =" <+> ppr kas) ]
+
+ go_app in_scope kfn ka
+ | Just kfn' <- coreView kfn
+ = go_app in_scope kfn' ka
+
+ go_app _ (FunTy kfa kfb) (_,ka)
+ = do { unless (ka `eqType` kfa) (addErrL fail_msg)
+ ; return kfb }
+
+ go_app in_scope (ForAllTy (TvBndr kv _vis) kfn) (ta,ka)
+ = do { unless (ka `eqType` tyVarKind kv) (addErrL fail_msg)
+ ; return (substTyWithInScope in_scope [kv] [ta] kfn) }
+
+ go_app _ _ _ = failWithL fail_msg
+
+{- *********************************************************************
+* *
+ Linting rules
+* *
+********************************************************************* -}
+
+lintCoreRule :: OutVar -> OutType -> CoreRule -> LintM ()
+lintCoreRule _ _ (BuiltinRule {})
+ = return () -- Don't bother
+
+lintCoreRule fun fun_ty rule@(Rule { ru_name = name, ru_bndrs = bndrs
+ , ru_args = args, ru_rhs = rhs })
+ = lintBinders LambdaBind bndrs $ \ _ ->
+ do { lhs_ty <- foldM lintCoreArg fun_ty args
+ ; rhs_ty <- case isJoinId_maybe fun of
+ Just join_arity
+ -> do { checkL (args `lengthIs` join_arity) $
+ mkBadJoinPointRuleMsg fun join_arity rule
+ -- See Note [Rules for join points]
+ ; lintCoreExpr rhs }
+ _ -> markAllJoinsBad $ lintCoreExpr rhs
+ ; ensureEqTys lhs_ty rhs_ty $
+ (rule_doc <+> vcat [ text "lhs type:" <+> ppr lhs_ty
+ , text "rhs type:" <+> ppr rhs_ty ])
+ ; let bad_bndrs = filterOut (`elemVarSet` exprsFreeVars args) $
+ filter (`elemVarSet` exprFreeVars rhs) $
+ bndrs
+
+ ; checkL (null bad_bndrs)
+ (rule_doc <+> text "unbound" <+> ppr bad_bndrs)
+ -- See Note [Linting rules]
+ }
+ where
+ rule_doc = text "Rule" <+> doubleQuotes (ftext name) <> colon
+
+{- Note [Linting rules]
+~~~~~~~~~~~~~~~~~~~~~~~
+It's very bad if simplifying a rule means that one of the template
+variables (ru_bndrs) that /is/ mentioned on the RHS becomes
+not-mentioned in the LHS (ru_args). How can that happen? Well, in
+Trac #10602, SpecConstr stupidly constructed a rule like
+
+ forall x,c1,c2.
+ f (x |> c1 |> c2) = ....
+
+But simplExpr collapses those coercions into one. (Indeed in
+Trac #10602, it collapsed to the identity and was removed altogether.)
+
+We don't have a great story for what to do here, but at least
+this check will nail it.
+
+NB (Trac #11643): it's possible that a variable listed in the
+binders becomes not-mentioned on both LHS and RHS. Here's a silly
+example:
+ RULE forall x y. f (g x y) = g (x+1 (y-1)
+And suppose worker/wrapper decides that 'x' is Absent. Then
+we'll end up with
+ RULE forall x y. f ($gw y) = $gw (x+1)
+This seems sufficiently obscure that there isn't enough payoff to
+try to trim the forall'd binder list.
+
+Note [Rules for join points]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+A join point cannot be partially applied. However, the left-hand side of a rule
+for a join point is effectively a *pattern*, not a piece of code, so there's an
+argument to be made for allowing a situation like this:
+
+ join $sj :: Int -> Int -> String
+ $sj n m = ...
+ j :: forall a. Eq a => a -> a -> String
+ {-# RULES "SPEC j" jump j @ Int $dEq = jump $sj #-}
+ j @a $dEq x y = ...
+
+Applying this rule can't turn a well-typed program into an ill-typed one, so
+conceivably we could allow it. But we can always eta-expand such an
+"undersaturated" rule (see 'CoreArity.etaExpandToJoinPointRule'), and in fact
+the simplifier would have to in order to deal with the RHS. So we take a
+conservative view and don't allow undersaturated rules for join points. See
+Note [Rules and join points] in OccurAnal for further discussion.
+-}
+
+{-
+************************************************************************
+* *
+ Linting coercions
+* *
+************************************************************************
+-}
+
+lintInCo :: InCoercion -> LintM (LintedKind, LintedKind, LintedType, LintedType, Role)
+-- Check the coercion, and apply the substitution to it
+-- See Note [Linting type lets]
+lintInCo co
+ = addLoc (InCo co) $
+ do { co' <- applySubstCo co
+ ; lintCoercion co' }
+
+-- lints a coercion, confirming that its lh kind and its rh kind are both *
+-- also ensures that the role is Nominal
+lintStarCoercion :: OutCoercion -> LintM (LintedType, LintedType)
+lintStarCoercion g
+ = do { (k1, k2, t1, t2, r) <- lintCoercion g
+ ; lintStar (text "the kind of the left type in" <+> ppr g) k1
+ ; lintStar (text "the kind of the right type in" <+> ppr g) k2
+ ; lintRole g Nominal r
+ ; return (t1, t2) }
+
+lintCoercion :: OutCoercion -> LintM (LintedKind, LintedKind, LintedType, LintedType, Role)
+-- Check the kind of a coercion term, returning the kind
+-- Post-condition: the returned OutTypes are lint-free
+--
+-- If lintCoercion co = (k1, k2, s1, s2, r)
+-- then co :: s1 ~r s2
+-- s1 :: k2
+-- s2 :: k2
+
+-- If you edit this function, you may need to update the GHC formalism
+-- See Note [GHC Formalism]
+lintCoercion (Refl r ty)
+ = do { k <- lintType ty
+ ; return (k, k, ty, ty, r) }
+
+lintCoercion co@(TyConAppCo r tc cos)
+ | tc `hasKey` funTyConKey
+ , [_rep1,_rep2,_co1,_co2] <- cos
+ = do { failWithL (text "Saturated TyConAppCo (->):" <+> ppr co)
+ } -- All saturated TyConAppCos should be FunCos
+
+ | Just {} <- synTyConDefn_maybe tc
+ = failWithL (text "Synonym in TyConAppCo:" <+> ppr co)
+
+ | otherwise
+ = do { checkTyCon tc
+ ; (k's, ks, ss, ts, rs) <- mapAndUnzip5M lintCoercion cos
+ ; k' <- lint_co_app co (tyConKind tc) (ss `zip` k's)
+ ; k <- lint_co_app co (tyConKind tc) (ts `zip` ks)
+ ; _ <- zipWith3M lintRole cos (tyConRolesX r tc) rs
+ ; return (k', k, mkTyConApp tc ss, mkTyConApp tc ts, r) }
+
+lintCoercion co@(AppCo co1 co2)
+ | TyConAppCo {} <- co1
+ = failWithL (text "TyConAppCo to the left of AppCo:" <+> ppr co)
+ | Refl _ (TyConApp {}) <- co1
+ = failWithL (text "Refl (TyConApp ...) to the left of AppCo:" <+> ppr co)
+ | otherwise
+ = do { (k1, k2, s1, s2, r1) <- lintCoercion co1
+ ; (k'1, k'2, t1, t2, r2) <- lintCoercion co2
+ ; k3 <- lint_co_app co k1 [(t1,k'1)]
+ ; k4 <- lint_co_app co k2 [(t2,k'2)]
+ ; if r1 == Phantom
+ then lintL (r2 == Phantom || r2 == Nominal)
+ (text "Second argument in AppCo cannot be R:" $$
+ ppr co)
+ else lintRole co Nominal r2
+ ; return (k3, k4, mkAppTy s1 t1, mkAppTy s2 t2, r1) }
+
+----------
+lintCoercion (ForAllCo tv1 kind_co co)
+ = do { (_, k2) <- lintStarCoercion kind_co
+ ; let tv2 = setTyVarKind tv1 k2
+ ; addInScopeVar tv1 $
+ do {
+ ; (k3, k4, t1, t2, r) <- lintCoercion co
+ ; in_scope <- getInScope
+ ; let tyl = mkInvForAllTy tv1 t1
+ subst = mkTvSubst in_scope $
+ -- We need both the free vars of the `t2` and the
+ -- free vars of the range of the substitution in
+ -- scope. All the free vars of `t2` and `kind_co` should
+ -- already be in `in_scope`, because they've been
+ -- linted and `tv2` has the same unique as `tv1`.
+ -- See Note [The substitution invariant]
+ unitVarEnv tv1 (TyVarTy tv2 `mkCastTy` mkSymCo kind_co)
+ tyr = mkInvForAllTy tv2 $
+ substTy subst t2
+ ; return (k3, k4, tyl, tyr, r) } }
+
+lintCoercion co@(FunCo r co1 co2)
+ = do { (k1,k'1,s1,t1,r1) <- lintCoercion co1
+ ; (k2,k'2,s2,t2,r2) <- lintCoercion co2
+ ; k <- lintArrow (text "coercion" <+> quotes (ppr co)) k1 k2
+ ; k' <- lintArrow (text "coercion" <+> quotes (ppr co)) k'1 k'2
+ ; lintRole co1 r r1
+ ; lintRole co2 r r2
+ ; return (k, k', mkFunTy s1 s2, mkFunTy t1 t2, r) }
+
+lintCoercion (CoVarCo cv)
+ | not (isCoVar cv)
+ = failWithL (hang (text "Bad CoVarCo:" <+> ppr cv)
+ 2 (text "With offending type:" <+> ppr (varType cv)))
+ | otherwise
+ = do { lintTyCoVarInScope cv
+ ; cv' <- lookupIdInScope cv
+ ; lintUnliftedCoVar cv
+ ; return $ coVarKindsTypesRole cv' }
+
+-- See Note [Bad unsafe coercion]
+lintCoercion co@(UnivCo prov r ty1 ty2)
+ = do { k1 <- lintType ty1
+ ; k2 <- lintType ty2
+ ; case prov of
+ UnsafeCoerceProv -> return () -- no extra checks
+
+ PhantomProv kco -> do { lintRole co Phantom r
+ ; check_kinds kco k1 k2 }
+
+ ProofIrrelProv kco -> do { lintL (isCoercionTy ty1) $
+ mkBadProofIrrelMsg ty1 co
+ ; lintL (isCoercionTy ty2) $
+ mkBadProofIrrelMsg ty2 co
+ ; check_kinds kco k1 k2 }
+
+ PluginProv _ -> return () -- no extra checks
+ HoleProv h -> addErrL $
+ text "Unfilled coercion hole:" <+> ppr h
+
+ ; when (r /= Phantom && classifiesTypeWithValues k1
+ && classifiesTypeWithValues k2)
+ (checkTypes ty1 ty2)
+ ; return (k1, k2, ty1, ty2, r) }
+ where
+ report s = hang (text $ "Unsafe coercion between " ++ s)
+ 2 (vcat [ text "From:" <+> ppr ty1
+ , text " To:" <+> ppr ty2])
+ isUnBoxed :: PrimRep -> Bool
+ isUnBoxed = not . isGcPtrRep
+
+ -- see #9122 for discussion of these checks
+ checkTypes t1 t2
+ = do { checkWarnL (reps1 `equalLength` reps2)
+ (report "values with different # of reps")
+ ; zipWithM_ validateCoercion reps1 reps2 }
+ where
+ reps1 = typePrimRep t1
+ reps2 = typePrimRep t2
+
+ validateCoercion :: PrimRep -> PrimRep -> LintM ()
+ validateCoercion rep1 rep2
+ = do { dflags <- getDynFlags
+ ; checkWarnL (isUnBoxed rep1 == isUnBoxed rep2)
+ (report "unboxed and boxed value")
+ ; checkWarnL (TyCon.primRepSizeW dflags rep1
+ == TyCon.primRepSizeW dflags rep2)
+ (report "unboxed values of different size")
+ ; let fl = liftM2 (==) (TyCon.primRepIsFloat rep1)
+ (TyCon.primRepIsFloat rep2)
+ ; case fl of
+ Nothing -> addWarnL (report "vector types")
+ Just False -> addWarnL (report "float and integral values")
+ _ -> return ()
+ }
+
+ check_kinds kco k1 k2 = do { (k1', k2') <- lintStarCoercion kco
+ ; ensureEqTys k1 k1' (mkBadUnivCoMsg CLeft co)
+ ; ensureEqTys k2 k2' (mkBadUnivCoMsg CRight co) }
+
+
+lintCoercion (SymCo co)
+ = do { (k1, k2, ty1, ty2, r) <- lintCoercion co
+ ; return (k2, k1, ty2, ty1, r) }
+
+lintCoercion co@(TransCo co1 co2)
+ = do { (k1a, _k1b, ty1a, ty1b, r1) <- lintCoercion co1
+ ; (_k2a, k2b, ty2a, ty2b, r2) <- lintCoercion co2
+ ; ensureEqTys ty1b ty2a
+ (hang (text "Trans coercion mis-match:" <+> ppr co)
+ 2 (vcat [ppr ty1a, ppr ty1b, ppr ty2a, ppr ty2b]))
+ ; lintRole co r1 r2
+ ; return (k1a, k2b, ty1a, ty2b, r1) }
+
+lintCoercion the_co@(NthCo n co)
+ = do { (_, _, s, t, r) <- lintCoercion co
+ ; case (splitForAllTy_maybe s, splitForAllTy_maybe t) of
+ { (Just (tv_s, _ty_s), Just (tv_t, _ty_t))
+ | n == 0
+ -> return (ks, kt, ts, tt, Nominal)
+ where
+ ts = tyVarKind tv_s
+ tt = tyVarKind tv_t
+ ks = typeKind ts
+ kt = typeKind tt
+
+ ; _ -> case (splitTyConApp_maybe s, splitTyConApp_maybe t) of
+ { (Just (tc_s, tys_s), Just (tc_t, tys_t))
+ | tc_s == tc_t
+ , isInjectiveTyCon tc_s r
+ -- see Note [NthCo and newtypes] in TyCoRep
+ , tys_s `equalLength` tys_t
+ , n < length tys_s
+ -> return (ks, kt, ts, tt, tr)
+ where
+ ts = getNth tys_s n
+ tt = getNth tys_t n
+ tr = nthRole r tc_s n
+ ks = typeKind ts
+ kt = typeKind tt
+
+ ; _ -> failWithL (hang (text "Bad getNth:")
+ 2 (ppr the_co $$ ppr s $$ ppr t)) }}}
+
+lintCoercion the_co@(LRCo lr co)
+ = do { (_,_,s,t,r) <- lintCoercion co
+ ; lintRole co Nominal r
+ ; case (splitAppTy_maybe s, splitAppTy_maybe t) of
+ (Just s_pr, Just t_pr)
+ -> return (ks_pick, kt_pick, s_pick, t_pick, Nominal)
+ where
+ s_pick = pickLR lr s_pr
+ t_pick = pickLR lr t_pr
+ ks_pick = typeKind s_pick
+ kt_pick = typeKind t_pick
+
+ _ -> failWithL (hang (text "Bad LRCo:")
+ 2 (ppr the_co $$ ppr s $$ ppr t)) }
+
+lintCoercion (InstCo co arg)
+ = do { (k3, k4, t1',t2', r) <- lintCoercion co
+ ; (k1',k2',s1,s2, r') <- lintCoercion arg
+ ; lintRole arg Nominal r'
+ ; in_scope <- getInScope
+ ; case (splitForAllTy_maybe t1', splitForAllTy_maybe t2') of
+ (Just (tv1,t1), Just (tv2,t2))
+ | k1' `eqType` tyVarKind tv1
+ , k2' `eqType` tyVarKind tv2
+ -> return (k3, k4,
+ substTyWithInScope in_scope [tv1] [s1] t1,
+ substTyWithInScope in_scope [tv2] [s2] t2, r)
+ | otherwise
+ -> failWithL (text "Kind mis-match in inst coercion")
+ _ -> failWithL (text "Bad argument of inst") }
+
+lintCoercion co@(AxiomInstCo con ind cos)
+ = do { unless (0 <= ind && ind < numBranches (coAxiomBranches con))
+ (bad_ax (text "index out of range"))
+ ; let CoAxBranch { cab_tvs = ktvs
+ , cab_cvs = cvs
+ , cab_roles = roles
+ , cab_lhs = lhs
+ , cab_rhs = rhs } = coAxiomNthBranch con ind
+ ; unless (length ktvs + length cvs == length cos) $
+ bad_ax (text "lengths")
+ ; subst <- getTCvSubst
+ ; let empty_subst = zapTCvSubst subst
+ ; (subst_l, subst_r) <- foldlM check_ki
+ (empty_subst, empty_subst)
+ (zip3 (ktvs ++ cvs) roles cos)
+ ; let lhs' = substTys subst_l lhs
+ rhs' = substTy subst_r rhs
+ ; case checkAxInstCo co of
+ Just bad_branch -> bad_ax $ text "inconsistent with" <+>
+ pprCoAxBranch con bad_branch
+ Nothing -> return ()
+ ; let s2 = mkTyConApp (coAxiomTyCon con) lhs'
+ ; return (typeKind s2, typeKind rhs', s2, rhs', coAxiomRole con) }
+ where
+ bad_ax what = addErrL (hang (text "Bad axiom application" <+> parens what)
+ 2 (ppr co))
+
+ check_ki (subst_l, subst_r) (ktv, role, arg)
+ = do { (k', k'', s', t', r) <- lintCoercion arg
+ ; lintRole arg role r
+ ; let ktv_kind_l = substTy subst_l (tyVarKind ktv)
+ ktv_kind_r = substTy subst_r (tyVarKind ktv)
+ ; unless (k' `eqType` ktv_kind_l)
+ (bad_ax (text "check_ki1" <+> vcat [ ppr co, ppr k', ppr ktv, ppr ktv_kind_l ] ))
+ ; unless (k'' `eqType` ktv_kind_r)
+ (bad_ax (text "check_ki2" <+> vcat [ ppr co, ppr k'', ppr ktv, ppr ktv_kind_r ] ))
+ ; return (extendTCvSubst subst_l ktv s',
+ extendTCvSubst subst_r ktv t') }
+
+lintCoercion (CoherenceCo co1 co2)
+ = do { (_, k2, t1, t2, r) <- lintCoercion co1
+ ; let lhsty = mkCastTy t1 co2
+ ; k1' <- lintType lhsty
+ ; return (k1', k2, lhsty, t2, r) }
+
+lintCoercion (KindCo co)
+ = do { (k1, k2, _, _, _) <- lintCoercion co
+ ; return (liftedTypeKind, liftedTypeKind, k1, k2, Nominal) }
+
+lintCoercion (SubCo co')
+ = do { (k1,k2,s,t,r) <- lintCoercion co'
+ ; lintRole co' Nominal r
+ ; return (k1,k2,s,t,Representational) }
+
+lintCoercion this@(AxiomRuleCo co cs)
+ = do { eqs <- mapM lintCoercion cs
+ ; lintRoles 0 (coaxrAsmpRoles co) eqs
+ ; case coaxrProves co [ Pair l r | (_,_,l,r,_) <- eqs ] of
+ Nothing -> err "Malformed use of AxiomRuleCo" [ ppr this ]
+ Just (Pair l r) ->
+ return (typeKind l, typeKind r, l, r, coaxrRole co) }
+ where
+ err m xs = failWithL $
+ hang (text m) 2 $ vcat (text "Rule:" <+> ppr (coaxrName co) : xs)
+
+ lintRoles n (e : es) ((_,_,_,_,r) : rs)
+ | e == r = lintRoles (n+1) es rs
+ | otherwise = err "Argument roles mismatch"
+ [ text "In argument:" <+> int (n+1)
+ , text "Expected:" <+> ppr e
+ , text "Found:" <+> ppr r ]
+ lintRoles _ [] [] = return ()
+ lintRoles n [] rs = err "Too many coercion arguments"
+ [ text "Expected:" <+> int n
+ , text "Provided:" <+> int (n + length rs) ]
+
+ lintRoles n es [] = err "Not enough coercion arguments"
+ [ text "Expected:" <+> int (n + length es)
+ , text "Provided:" <+> int n ]
+
+----------
+lintUnliftedCoVar :: CoVar -> LintM ()
+lintUnliftedCoVar cv
+ = when (not (isUnliftedType (coVarKind cv))) $
+ failWithL (text "Bad lifted equality:" <+> ppr cv
+ <+> dcolon <+> ppr (coVarKind cv))
+
+{-
+************************************************************************
+* *
+\subsection[lint-monad]{The Lint monad}
+* *
+************************************************************************
+-}
+
+-- If you edit this type, you may need to update the GHC formalism
+-- See Note [GHC Formalism]
+data LintEnv
+ = LE { le_flags :: LintFlags -- Linting the result of this pass
+ , le_loc :: [LintLocInfo] -- Locations
+ , le_subst :: TCvSubst -- Current type substitution; we also use this
+ -- to keep track of all the variables in scope,
+ -- both Ids and TyVars
+ , le_joins :: IdSet -- Join points in scope that are valid
+ -- A subset of teh InScopeSet in le_subst
+ -- See Note [Join points]
+ , le_dynflags :: DynFlags -- DynamicFlags
+ }
+
+data LintFlags
+ = LF { lf_check_global_ids :: Bool -- See Note [Checking for global Ids]
+ , lf_check_inline_loop_breakers :: Bool -- See Note [Checking for INLINE loop breakers]
+ , lf_check_static_ptrs :: StaticPtrCheck
+ -- ^ See Note [Checking StaticPtrs]
+ }
+
+-- See Note [Checking StaticPtrs]
+data StaticPtrCheck
+ = AllowAnywhere
+ -- ^ Allow 'makeStatic' to occur anywhere.
+ | AllowAtTopLevel
+ -- ^ Allow 'makeStatic' calls at the top-level only.
+ | RejectEverywhere
+ -- ^ Reject any 'makeStatic' occurrence.
+ deriving Eq
+
+defaultLintFlags :: LintFlags
+defaultLintFlags = LF { lf_check_global_ids = False
+ , lf_check_inline_loop_breakers = True
+ , lf_check_static_ptrs = AllowAnywhere
+ }
+
+newtype LintM a =
+ LintM { unLintM ::
+ LintEnv ->
+ WarnsAndErrs -> -- Error and warning messages so far
+ (Maybe a, WarnsAndErrs) } -- Result and messages (if any)
+
+type WarnsAndErrs = (Bag MsgDoc, Bag MsgDoc)
+
+{- Note [Checking for global Ids]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Before CoreTidy, all locally-bound Ids must be LocalIds, even
+top-level ones. See Note [Exported LocalIds] and Trac #9857.
+
+Note [Checking StaticPtrs]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+See Note [Grand plan for static forms] in StaticPtrTable for an overview.
+
+Every occurrence of the function 'makeStatic' should be moved to the
+top level by the FloatOut pass. It's vital that we don't have nested
+'makeStatic' occurrences after CorePrep, because we populate the Static
+Pointer Table from the top-level bindings. See SimplCore Note [Grand
+plan for static forms].
+
+The linter checks that no occurrence is left behind, nested within an
+expression. The check is enabled only after the FloatOut, CorePrep,
+and CoreTidy passes and only if the module uses the StaticPointers
+language extension. Checking more often doesn't help since the condition
+doesn't hold until after the first FloatOut pass.
+
+Note [Type substitution]
+~~~~~~~~~~~~~~~~~~~~~~~~
+Why do we need a type substitution? Consider
+ /\(a:*). \(x:a). /\(a:*). id a x
+This is ill typed, because (renaming variables) it is really
+ /\(a:*). \(x:a). /\(b:*). id b x
+Hence, when checking an application, we can't naively compare x's type
+(at its binding site) with its expected type (at a use site). So we
+rename type binders as we go, maintaining a substitution.
+
+The same substitution also supports let-type, current expressed as
+ (/\(a:*). body) ty
+Here we substitute 'ty' for 'a' in 'body', on the fly.
+-}
+
+instance Functor LintM where
+ fmap = liftM
+
+instance Applicative LintM where
+ pure x = LintM $ \ _ errs -> (Just x, errs)
+ (<*>) = ap
+
+instance Monad LintM where
+ fail err = failWithL (text err)
+ m >>= k = LintM (\ env errs ->
+ let (res, errs') = unLintM m env errs in
+ case res of
+ Just r -> unLintM (k r) env errs'
+ Nothing -> (Nothing, errs'))
+
+#if __GLASGOW_HASKELL__ > 710
+instance MonadFail.MonadFail LintM where
+ fail err = failWithL (text err)
+#endif
+
+instance HasDynFlags LintM where
+ getDynFlags = LintM (\ e errs -> (Just (le_dynflags e), errs))
+
+data LintLocInfo
+ = RhsOf Id -- The variable bound
+ | LambdaBodyOf Id -- The lambda-binder
+ | BodyOfLetRec [Id] -- One of the binders
+ | CaseAlt CoreAlt -- Case alternative
+ | CasePat CoreAlt -- The *pattern* of the case alternative
+ | AnExpr CoreExpr -- Some expression
+ | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which)
+ | TopLevelBindings
+ | InType Type -- Inside a type
+ | InCo Coercion -- Inside a coercion
+
+initL :: DynFlags -> LintFlags -> InScopeSet
+ -> LintM a -> WarnsAndErrs -- Errors and warnings
+initL dflags flags in_scope m
+ = case unLintM m env (emptyBag, emptyBag) of
+ (_, errs) -> errs
+ where
+ env = LE { le_flags = flags
+ , le_subst = mkEmptyTCvSubst in_scope
+ , le_joins = emptyVarSet
+ , le_loc = []
+ , le_dynflags = dflags }
+
+getLintFlags :: LintM LintFlags
+getLintFlags = LintM $ \ env errs -> (Just (le_flags env), errs)
+
+checkL :: Bool -> MsgDoc -> LintM ()
+checkL True _ = return ()
+checkL False msg = failWithL msg
+
+-- like checkL, but relevant to type checking
+lintL :: Bool -> MsgDoc -> LintM ()
+lintL = checkL
+
+checkWarnL :: Bool -> MsgDoc -> LintM ()
+checkWarnL True _ = return ()
+checkWarnL False msg = addWarnL msg
+
+failWithL :: MsgDoc -> LintM a
+failWithL msg = LintM $ \ env (warns,errs) ->
+ (Nothing, (warns, addMsg env errs msg))
+
+addErrL :: MsgDoc -> LintM ()
+addErrL msg = LintM $ \ env (warns,errs) ->
+ (Just (), (warns, addMsg env errs msg))
+
+addWarnL :: MsgDoc -> LintM ()
+addWarnL msg = LintM $ \ env (warns,errs) ->
+ (Just (), (addMsg env warns msg, errs))
+
+addMsg :: LintEnv -> Bag MsgDoc -> MsgDoc -> Bag MsgDoc
+addMsg env msgs msg
+ = ASSERT( notNull locs )
+ msgs `snocBag` mk_msg msg
+ where
+ locs = le_loc env
+ (loc, cxt1) = dumpLoc (head locs)
+ cxts = [snd (dumpLoc loc) | loc <- locs]
+ context = sdocWithPprDebug $ \dbg -> if dbg
+ then vcat (reverse cxts) $$ cxt1 $$
+ text "Substitution:" <+> ppr (le_subst env)
+ else cxt1
+
+ mk_msg msg = mkLocMessage SevWarning (mkSrcSpan loc loc) (context $$ msg)
+
+addLoc :: LintLocInfo -> LintM a -> LintM a
+addLoc extra_loc m
+ = LintM $ \ env errs ->
+ unLintM m (env { le_loc = extra_loc : le_loc env }) errs
+
+inCasePat :: LintM Bool -- A slight hack; see the unique call site
+inCasePat = LintM $ \ env errs -> (Just (is_case_pat env), errs)
+ where
+ is_case_pat (LE { le_loc = CasePat {} : _ }) = True
+ is_case_pat _other = False
+
+addInScopeVar :: Var -> LintM a -> LintM a
+addInScopeVar var m
+ = LintM $ \ env errs ->
+ unLintM m (env { le_subst = extendTCvInScope (le_subst env) var
+ , le_joins = delVarSet (le_joins env) var
+ }) errs
+
+extendSubstL :: TyVar -> Type -> LintM a -> LintM a
+extendSubstL tv ty m
+ = LintM $ \ env errs ->
+ unLintM m (env { le_subst = Type.extendTvSubst (le_subst env) tv ty }) errs
+
+updateTCvSubst :: TCvSubst -> LintM a -> LintM a
+updateTCvSubst subst' m
+ = LintM $ \ env errs -> unLintM m (env { le_subst = subst' }) errs
+
+markAllJoinsBad :: LintM a -> LintM a
+markAllJoinsBad m
+ = LintM $ \ env errs -> unLintM m (env { le_joins = emptyVarSet }) errs
+
+markAllJoinsBadIf :: Bool -> LintM a -> LintM a
+markAllJoinsBadIf True m = markAllJoinsBad m
+markAllJoinsBadIf False m = m
+
+addGoodJoins :: [Var] -> LintM a -> LintM a
+addGoodJoins vars thing_inside
+ | null join_ids
+ = thing_inside
+ | otherwise
+ = LintM $ \ env errs -> unLintM thing_inside (add_joins env) errs
+ where
+ add_joins env = env { le_joins = le_joins env `extendVarSetList` join_ids }
+ join_ids = filter isJoinId vars
+
+getValidJoins :: LintM IdSet
+getValidJoins = LintM (\ env errs -> (Just (le_joins env), errs))
+
+getTCvSubst :: LintM TCvSubst
+getTCvSubst = LintM (\ env errs -> (Just (le_subst env), errs))
+
+getInScope :: LintM InScopeSet
+getInScope = LintM (\ env errs -> (Just (getTCvInScope $ le_subst env), errs))
+
+applySubstTy :: InType -> LintM OutType
+applySubstTy ty = do { subst <- getTCvSubst; return (substTy subst ty) }
+
+applySubstCo :: InCoercion -> LintM OutCoercion
+applySubstCo co = do { subst <- getTCvSubst; return (substCo subst co) }
+
+lookupIdInScope :: Id -> LintM Id
+lookupIdInScope id
+ | not (mustHaveLocalBinding id)
+ = return id -- An imported Id
+ | otherwise
+ = do { subst <- getTCvSubst
+ ; case lookupInScope (getTCvInScope subst) id of
+ Just v -> return v
+ Nothing -> do { addErrL out_of_scope
+ ; return id } }
+ where
+ out_of_scope = pprBndr LetBind id <+> text "is out of scope"
+
+lookupJoinId :: Id -> LintM (Maybe JoinArity)
+-- Look up an Id which should be a join point, valid here
+-- If so, return its arity, if not return Nothing
+lookupJoinId id
+ = do { join_set <- getValidJoins
+ ; case lookupVarSet join_set id of
+ Just id' -> return (isJoinId_maybe id')
+ Nothing -> return Nothing }
+
+lintTyCoVarInScope :: Var -> LintM ()
+lintTyCoVarInScope v = lintInScope (text "is out of scope") v
+
+lintInScope :: SDoc -> Var -> LintM ()
+lintInScope loc_msg var =
+ do { subst <- getTCvSubst
+ ; lintL (not (mustHaveLocalBinding var) || (var `isInScope` subst))
+ (hsep [pprBndr LetBind var, loc_msg]) }
+
+ensureEqTys :: OutType -> OutType -> MsgDoc -> LintM ()
+-- check ty2 is subtype of ty1 (ie, has same structure but usage
+-- annotations need only be consistent, not equal)
+-- Assumes ty1,ty2 are have already had the substitution applied
+ensureEqTys ty1 ty2 msg = lintL (ty1 `eqType` ty2) msg
+
+lintRole :: Outputable thing
+ => thing -- where the role appeared
+ -> Role -- expected
+ -> Role -- actual
+ -> LintM ()
+lintRole co r1 r2
+ = lintL (r1 == r2)
+ (text "Role incompatibility: expected" <+> ppr r1 <> comma <+>
+ text "got" <+> ppr r2 $$
+ text "in" <+> ppr co)
+
+{-
+************************************************************************
+* *
+\subsection{Error messages}
+* *
+************************************************************************
+-}
+
+dumpLoc :: LintLocInfo -> (SrcLoc, SDoc)
+
+dumpLoc (RhsOf v)
+ = (getSrcLoc v, brackets (text "RHS of" <+> pp_binders [v]))
+
+dumpLoc (LambdaBodyOf b)
+ = (getSrcLoc b, brackets (text "in body of lambda with binder" <+> pp_binder b))
+
+dumpLoc (BodyOfLetRec [])
+ = (noSrcLoc, brackets (text "In body of a letrec with no binders"))
+
+dumpLoc (BodyOfLetRec bs@(_:_))
+ = ( getSrcLoc (head bs), brackets (text "in body of letrec with binders" <+> pp_binders bs))
+
+dumpLoc (AnExpr e)
+ = (noSrcLoc, text "In the expression:" <+> ppr e)
+
+dumpLoc (CaseAlt (con, args, _))
+ = (noSrcLoc, text "In a case alternative:" <+> parens (ppr con <+> pp_binders args))
+
+dumpLoc (CasePat (con, args, _))
+ = (noSrcLoc, text "In the pattern of a case alternative:" <+> parens (ppr con <+> pp_binders args))
+
+dumpLoc (ImportedUnfolding locn)
+ = (locn, brackets (text "in an imported unfolding"))
+dumpLoc TopLevelBindings
+ = (noSrcLoc, Outputable.empty)
+dumpLoc (InType ty)
+ = (noSrcLoc, text "In the type" <+> quotes (ppr ty))
+dumpLoc (InCo co)
+ = (noSrcLoc, text "In the coercion" <+> quotes (ppr co))
+
+pp_binders :: [Var] -> SDoc
+pp_binders bs = sep (punctuate comma (map pp_binder bs))
+
+pp_binder :: Var -> SDoc
+pp_binder b | isId b = hsep [ppr b, dcolon, ppr (idType b)]
+ | otherwise = hsep [ppr b, dcolon, ppr (tyVarKind b)]
+
+------------------------------------------------------
+-- Messages for case expressions
+
+mkDefaultArgsMsg :: [Var] -> MsgDoc
+mkDefaultArgsMsg args
+ = hang (text "DEFAULT case with binders")
+ 4 (ppr args)
+
+mkCaseAltMsg :: CoreExpr -> Type -> Type -> MsgDoc
+mkCaseAltMsg e ty1 ty2
+ = hang (text "Type of case alternatives not the same as the annotation on case:")
+ 4 (vcat [ text "Actual type:" <+> ppr ty1,
+ text "Annotation on case:" <+> ppr ty2,
+ text "Alt Rhs:" <+> ppr e ])
+
+mkScrutMsg :: Id -> Type -> Type -> TCvSubst -> MsgDoc
+mkScrutMsg var var_ty scrut_ty subst
+ = vcat [text "Result binder in case doesn't match scrutinee:" <+> ppr var,
+ text "Result binder type:" <+> ppr var_ty,--(idType var),
+ text "Scrutinee type:" <+> ppr scrut_ty,
+ hsep [text "Current TCv subst", ppr subst]]
+
+mkNonDefltMsg, mkNonIncreasingAltsMsg :: CoreExpr -> MsgDoc
+mkNonDefltMsg e
+ = hang (text "Case expression with DEFAULT not at the beginnning") 4 (ppr e)
+mkNonIncreasingAltsMsg e
+ = hang (text "Case expression with badly-ordered alternatives") 4 (ppr e)
+
+nonExhaustiveAltsMsg :: CoreExpr -> MsgDoc
+nonExhaustiveAltsMsg e
+ = hang (text "Case expression with non-exhaustive alternatives") 4 (ppr e)
+
+mkBadConMsg :: TyCon -> DataCon -> MsgDoc
+mkBadConMsg tycon datacon
+ = vcat [
+ text "In a case alternative, data constructor isn't in scrutinee type:",
+ text "Scrutinee type constructor:" <+> ppr tycon,
+ text "Data con:" <+> ppr datacon
+ ]
+
+mkBadPatMsg :: Type -> Type -> MsgDoc
+mkBadPatMsg con_result_ty scrut_ty
+ = vcat [
+ text "In a case alternative, pattern result type doesn't match scrutinee type:",
+ text "Pattern result type:" <+> ppr con_result_ty,
+ text "Scrutinee type:" <+> ppr scrut_ty
+ ]
+
+integerScrutinisedMsg :: MsgDoc
+integerScrutinisedMsg
+ = text "In a LitAlt, the literal is lifted (probably Integer)"
+
+mkBadAltMsg :: Type -> CoreAlt -> MsgDoc
+mkBadAltMsg scrut_ty alt
+ = vcat [ text "Data alternative when scrutinee is not a tycon application",
+ text "Scrutinee type:" <+> ppr scrut_ty,
+ text "Alternative:" <+> pprCoreAlt alt ]
+
+mkNewTyDataConAltMsg :: Type -> CoreAlt -> MsgDoc
+mkNewTyDataConAltMsg scrut_ty alt
+ = vcat [ text "Data alternative for newtype datacon",
+ text "Scrutinee type:" <+> ppr scrut_ty,
+ text "Alternative:" <+> pprCoreAlt alt ]
+
+
+------------------------------------------------------
+-- Other error messages
+
+mkAppMsg :: Type -> Type -> CoreExpr -> MsgDoc
+mkAppMsg fun_ty arg_ty arg
+ = vcat [text "Argument value doesn't match argument type:",
+ hang (text "Fun type:") 4 (ppr fun_ty),
+ hang (text "Arg type:") 4 (ppr arg_ty),
+ hang (text "Arg:") 4 (ppr arg)]
+
+mkNonFunAppMsg :: Type -> Type -> CoreExpr -> MsgDoc
+mkNonFunAppMsg fun_ty arg_ty arg
+ = vcat [text "Non-function type in function position",
+ hang (text "Fun type:") 4 (ppr fun_ty),
+ hang (text "Arg type:") 4 (ppr arg_ty),
+ hang (text "Arg:") 4 (ppr arg)]
+
+mkLetErr :: TyVar -> CoreExpr -> MsgDoc
+mkLetErr bndr rhs
+ = vcat [text "Bad `let' binding:",
+ hang (text "Variable:")
+ 4 (ppr bndr <+> dcolon <+> ppr (varType bndr)),
+ hang (text "Rhs:")
+ 4 (ppr rhs)]
+
+mkTyAppMsg :: Type -> Type -> MsgDoc
+mkTyAppMsg ty arg_ty
+ = vcat [text "Illegal type application:",
+ hang (text "Exp type:")
+ 4 (ppr ty <+> dcolon <+> ppr (typeKind ty)),
+ hang (text "Arg type:")
+ 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
+
+emptyRec :: CoreExpr -> MsgDoc
+emptyRec e = hang (text "Empty Rec binding:") 2 (ppr e)
+
+mkRhsMsg :: Id -> SDoc -> Type -> MsgDoc
+mkRhsMsg binder what ty
+ = vcat
+ [hsep [text "The type of this binder doesn't match the type of its" <+> what <> colon,
+ ppr binder],
+ hsep [text "Binder's type:", ppr (idType binder)],
+ hsep [text "Rhs type:", ppr ty]]
+
+mkLetAppMsg :: CoreExpr -> MsgDoc
+mkLetAppMsg e
+ = hang (text "This argument does not satisfy the let/app invariant:")
+ 2 (ppr e)
+
+badBndrTyMsg :: Id -> SDoc -> MsgDoc
+badBndrTyMsg binder what
+ = vcat [ text "The type of this binder is" <+> what <> colon <+> ppr binder
+ , text "Binder's type:" <+> ppr (idType binder) ]
+
+mkStrictMsg :: Id -> MsgDoc
+mkStrictMsg binder
+ = vcat [hsep [text "Recursive or top-level binder has strict demand info:",
+ ppr binder],
+ hsep [text "Binder's demand info:", ppr (idDemandInfo binder)]
+ ]
+
+mkNonTopExportedMsg :: Id -> MsgDoc
+mkNonTopExportedMsg binder
+ = hsep [text "Non-top-level binder is marked as exported:", ppr binder]
+
+mkNonTopExternalNameMsg :: Id -> MsgDoc
+mkNonTopExternalNameMsg binder
+ = hsep [text "Non-top-level binder has an external name:", ppr binder]
+
+mkTopNonLitStrMsg :: Id -> MsgDoc
+mkTopNonLitStrMsg binder
+ = hsep [text "Top-level Addr# binder has a non-literal rhs:", ppr binder]
+
+mkKindErrMsg :: TyVar -> Type -> MsgDoc
+mkKindErrMsg tyvar arg_ty
+ = vcat [text "Kinds don't match in type application:",
+ hang (text "Type variable:")
+ 4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)),
+ hang (text "Arg type:")
+ 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
+
+{- Not needed now
+mkArityMsg :: Id -> MsgDoc
+mkArityMsg binder
+ = vcat [hsep [text "Demand type has",
+ ppr (dmdTypeDepth dmd_ty),
+ text "arguments, rhs has",
+ ppr (idArity binder),
+ text "arguments,",
+ ppr binder],
+ hsep [text "Binder's strictness signature:", ppr dmd_ty]
+
+ ]
+ where (StrictSig dmd_ty) = idStrictness binder
+-}
+mkCastErr :: Outputable casted => casted -> Coercion -> Type -> Type -> MsgDoc
+mkCastErr expr co from_ty expr_ty
+ = vcat [text "From-type of Cast differs from type of enclosed expression",
+ text "From-type:" <+> ppr from_ty,
+ text "Type of enclosed expr:" <+> ppr expr_ty,
+ text "Actual enclosed expr:" <+> ppr expr,
+ text "Coercion used in cast:" <+> ppr co
+ ]
+
+mkBadUnivCoMsg :: LeftOrRight -> Coercion -> SDoc
+mkBadUnivCoMsg lr co
+ = text "Kind mismatch on the" <+> pprLeftOrRight lr <+>
+ text "side of a UnivCo:" <+> ppr co
+
+mkBadProofIrrelMsg :: Type -> Coercion -> SDoc
+mkBadProofIrrelMsg ty co
+ = hang (text "Found a non-coercion in a proof-irrelevance UnivCo:")
+ 2 (vcat [ text "type:" <+> ppr ty
+ , text "co:" <+> ppr co ])
+
+mkBadTyVarMsg :: Var -> SDoc
+mkBadTyVarMsg tv
+ = text "Non-tyvar used in TyVarTy:"
+ <+> ppr tv <+> dcolon <+> ppr (varType tv)
+
+mkBadJoinBindMsg :: Var -> SDoc
+mkBadJoinBindMsg var
+ = vcat [ text "Bad join point binding:" <+> ppr var
+ , text "Join points can be bound only by a non-top-level let" ]
+
+mkInvalidJoinPointMsg :: Var -> Type -> SDoc
+mkInvalidJoinPointMsg var ty
+ = hang (text "Join point has invalid type:")
+ 2 (ppr var <+> dcolon <+> ppr ty)
+
+mkBadJoinArityMsg :: Var -> Int -> Int -> SDoc
+mkBadJoinArityMsg var ar nlams
+ = vcat [ text "Join point has too few lambdas",
+ text "Join var:" <+> ppr var,
+ text "Join arity:" <+> ppr ar,
+ text "Number of lambdas:" <+> ppr nlams ]
+
+invalidJoinOcc :: Var -> SDoc
+invalidJoinOcc var
+ = vcat [ text "Invalid occurrence of a join variable:" <+> ppr var
+ , text "The binder is either not a join point, or not valid here" ]
+
+mkBadJumpMsg :: Var -> Int -> Int -> SDoc
+mkBadJumpMsg var ar nargs
+ = vcat [ text "Join point invoked with wrong number of arguments",
+ text "Join var:" <+> ppr var,
+ text "Join arity:" <+> ppr ar,
+ text "Number of arguments:" <+> int nargs ]
+
+mkInconsistentRecMsg :: [Var] -> SDoc
+mkInconsistentRecMsg bndrs
+ = vcat [ text "Recursive let binders mix values and join points",
+ text "Binders:" <+> hsep (map ppr_with_details bndrs) ]
+ where
+ ppr_with_details bndr = ppr bndr <> ppr (idDetails bndr)
+
+mkJoinBndrOccMismatchMsg :: Var -> JoinArity -> JoinArity -> SDoc
+mkJoinBndrOccMismatchMsg bndr join_arity_bndr join_arity_occ
+ = vcat [ text "Mismatch in join point arity between binder and occurrence"
+ , text "Var:" <+> ppr bndr
+ , text "Arity at binding site:" <+> ppr join_arity_bndr
+ , text "Arity at occurrence: " <+> ppr join_arity_occ ]
+
+mkBndrOccTypeMismatchMsg :: Var -> Var -> OutType -> OutType -> SDoc
+mkBndrOccTypeMismatchMsg bndr var bndr_ty var_ty
+ = vcat [ text "Mismatch in type between binder and occurrence"
+ , text "Var:" <+> ppr bndr
+ , text "Binder type:" <+> ppr bndr_ty
+ , text "Occurrence type:" <+> ppr var_ty
+ , text " Before subst:" <+> ppr (idType var) ]
+
+mkBadJoinPointRuleMsg :: JoinId -> JoinArity -> CoreRule -> SDoc
+mkBadJoinPointRuleMsg bndr join_arity rule
+ = vcat [ text "Join point has rule with wrong number of arguments"
+ , text "Var:" <+> ppr bndr
+ , text "Join arity:" <+> ppr join_arity
+ , text "Rule:" <+> ppr rule ]
+
+pprLeftOrRight :: LeftOrRight -> MsgDoc
+pprLeftOrRight CLeft = text "left"
+pprLeftOrRight CRight = text "right"
+
+dupVars :: [[Var]] -> MsgDoc
+dupVars vars
+ = hang (text "Duplicate variables brought into scope")
+ 2 (ppr vars)
+
+dupExtVars :: [[Name]] -> MsgDoc
+dupExtVars vars
+ = hang (text "Duplicate top-level variables with the same qualified name")
+ 2 (ppr vars)
+
+{-
+************************************************************************
+* *
+\subsection{Annotation Linting}
+* *
+************************************************************************
+-}
+
+-- | This checks whether a pass correctly looks through debug
+-- annotations (@SourceNote@). This works a bit different from other
+-- consistency checks: We check this by running the given task twice,
+-- noting all differences between the results.
+lintAnnots :: SDoc -> (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
+lintAnnots pname pass guts = do
+ -- Run the pass as we normally would
+ dflags <- getDynFlags
+ when (gopt Opt_DoAnnotationLinting dflags) $
+ liftIO $ Err.showPass dflags "Annotation linting - first run"
+ nguts <- pass guts
+ -- If appropriate re-run it without debug annotations to make sure
+ -- that they made no difference.
+ when (gopt Opt_DoAnnotationLinting dflags) $ do
+ liftIO $ Err.showPass dflags "Annotation linting - second run"
+ nguts' <- withoutAnnots pass guts
+ -- Finally compare the resulting bindings
+ liftIO $ Err.showPass dflags "Annotation linting - comparison"
+ let binds = flattenBinds $ mg_binds nguts
+ binds' = flattenBinds $ mg_binds nguts'
+ (diffs,_) = diffBinds True (mkRnEnv2 emptyInScopeSet) binds binds'
+ when (not (null diffs)) $ CoreMonad.putMsg $ vcat
+ [ lint_banner "warning" pname
+ , text "Core changes with annotations:"
+ , withPprStyle (defaultDumpStyle dflags) $ nest 2 $ vcat diffs
+ ]
+ -- Return actual new guts
+ return nguts
+
+-- | Run the given pass without annotations. This means that we both
+-- set the debugLevel setting to 0 in the environment as well as all
+-- annotations from incoming modules.
+withoutAnnots :: (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
+withoutAnnots pass guts = do
+ -- Remove debug flag from environment.
+ dflags <- getDynFlags
+ let removeFlag env = env{ hsc_dflags = dflags{ debugLevel = 0} }
+ withoutFlag corem =
+ liftIO =<< runCoreM <$> fmap removeFlag getHscEnv <*> getRuleBase <*>
+ getUniqueSupplyM <*> getModule <*>
+ getVisibleOrphanMods <*>
+ getPrintUnqualified <*> getSrcSpanM <*>
+ pure corem
+ -- Nuke existing ticks in module.
+ -- TODO: Ticks in unfoldings. Maybe change unfolding so it removes
+ -- them in absence of debugLevel > 0.
+ let nukeTicks = stripTicksE (not . tickishIsCode)
+ nukeAnnotsBind :: CoreBind -> CoreBind
+ nukeAnnotsBind bind = case bind of
+ Rec bs -> Rec $ map (\(b,e) -> (b, nukeTicks e)) bs
+ NonRec b e -> NonRec b $ nukeTicks e
+ nukeAnnotsMod mg@ModGuts{mg_binds=binds}
+ = mg{mg_binds = map nukeAnnotsBind binds}
+ -- Perform pass with all changes applied
+ fmap fst $ withoutFlag $ pass (nukeAnnotsMod guts)
diff --git a/coreSyn/CoreOpt.hs b/coreSyn/CoreOpt.hs
new file mode 100644
--- /dev/null
+++ b/coreSyn/CoreOpt.hs
@@ -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
+ , let out_ty = substTy (soe_subst rhs_env) ty
+ = ASSERT( isTyVar in_bndr )
+ (env { soe_subst = extendTvSubst subst in_bndr out_ty }, Nothing)
+
+ | Coercion co <- in_rhs
+ , let out_co = optCoercion (getTCvSubst (soe_subst rhs_env)) co
+ = ASSERT( isCoVar in_bndr )
+ (env { soe_subst = extendCvSubst subst in_bndr out_co }, Nothing)
+
+ | pre_inline_unconditionally
+ = (env { soe_inl = extendVarEnv inl_env in_bndr clo }, Nothing)
+
+ | otherwise
+ = simple_out_bind_pair env in_bndr mb_out_bndr
+ (simple_opt_clo env clo)
+ occ active stable_unf
+ where
+ stable_unf = isStableUnfolding (idUnfolding in_bndr)
+ active = isAlwaysActive (idInlineActivation in_bndr)
+ occ = idOccInfo in_bndr
+
+ pre_inline_unconditionally :: Bool
+ pre_inline_unconditionally
+ | isCoVar in_bndr = False -- See Note [Do not inline CoVars unconditionally]
+ | isExportedId in_bndr = False -- in SimplUtils
+ | stable_unf = False
+ | not active = False -- Note [Inline prag in simplOpt]
+ | not (safe_to_inline occ) = False
+ | otherwise = True
+
+ -- Unconditionally safe to inline
+ safe_to_inline :: OccInfo -> Bool
+ safe_to_inline (IAmALoopBreaker {}) = False
+ safe_to_inline IAmDead = True
+ safe_to_inline occ@(OneOcc {}) = not (occ_in_lam occ)
+ && occ_one_br occ
+ safe_to_inline (ManyOccs {}) = False
+
+-------------------
+simple_out_bind :: SimpleOptEnv -> (InVar, OutExpr)
+ -> (SimpleOptEnv, Maybe (OutVar, OutExpr))
+simple_out_bind env@(SOE { soe_subst = subst }) (in_bndr, out_rhs)
+ | Type out_ty <- out_rhs
+ = ASSERT( isTyVar in_bndr )
+ (env { soe_subst = extendTvSubst subst in_bndr out_ty }, Nothing)
+
+ | Coercion out_co <- out_rhs
+ = ASSERT( isCoVar in_bndr )
+ (env { soe_subst = extendCvSubst subst in_bndr out_co }, Nothing)
+
+ | otherwise
+ = simple_out_bind_pair env in_bndr Nothing out_rhs
+ (idOccInfo in_bndr) True False
+
+-------------------
+simple_out_bind_pair :: SimpleOptEnv
+ -> InId -> Maybe OutId -> OutExpr
+ -> OccInfo -> Bool -> Bool
+ -> (SimpleOptEnv, Maybe (OutVar, OutExpr))
+simple_out_bind_pair env in_bndr mb_out_bndr out_rhs
+ occ_info active stable_unf
+ | post_inline_unconditionally
+ = ( env' { soe_subst = extendIdSubst (soe_subst env) in_bndr out_rhs }
+ , Nothing)
+
+ | otherwise
+ = ( env', Just (out_bndr, out_rhs) )
+ where
+ (env', bndr1) = case mb_out_bndr of
+ Just out_bndr -> (env, out_bndr)
+ Nothing -> subst_opt_bndr env in_bndr
+ out_bndr = add_info env' in_bndr bndr1
+
+ post_inline_unconditionally :: Bool
+ post_inline_unconditionally
+ | not active = False
+ | isWeakLoopBreaker occ_info = False -- If it's a loop-breaker of any kind, don't inline
+ -- because it might be referred to "earlier"
+ | stable_unf = False -- Note [Stable unfoldings and postInlineUnconditionally]
+ | isExportedId in_bndr = False -- Note [Exported Ids and trivial RHSs]
+ | exprIsTrivial out_rhs = True
+ | coercible_hack = True
+ | otherwise = False
+
+ -- See Note [Getting the map/coerce RULE to work]
+ coercible_hack | (Var fun, args) <- collectArgs out_rhs
+ , Just dc <- isDataConWorkId_maybe fun
+ , dc `hasKey` heqDataConKey || dc `hasKey` coercibleDataConKey
+ = all exprIsTrivial args
+ | otherwise
+ = False
+
+{- Note [Exported Ids and trivial RHSs]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We obviously do not want to unconditionally inline an Id that is exported.
+In SimplUtils, Note [Top level and postInlineUnconditionally], we
+explain why we don't inline /any/ top-level things unconditionally, even
+trivial ones. But we do here! Why? In the simple optimiser
+
+ * We do no rule rewrites
+ * We do no call-site inlining
+
+Those differences obviate the reasons for not inlining a trivial rhs,
+and increase the benefit for doing so. So we unconditionally inline trivial
+rhss here.
+-}
+
+----------------------
+subst_opt_bndrs :: SimpleOptEnv -> [InVar] -> (SimpleOptEnv, [OutVar])
+subst_opt_bndrs env bndrs = mapAccumL subst_opt_bndr env bndrs
+
+subst_opt_bndr :: SimpleOptEnv -> InVar -> (SimpleOptEnv, OutVar)
+subst_opt_bndr env bndr
+ | isTyVar bndr = (env { soe_subst = subst_tv }, tv')
+ | isCoVar bndr = (env { soe_subst = subst_cv }, cv')
+ | otherwise = subst_opt_id_bndr env bndr
+ where
+ subst = soe_subst env
+ (subst_tv, tv') = substTyVarBndr subst bndr
+ (subst_cv, cv') = substCoVarBndr subst bndr
+
+subst_opt_id_bndr :: SimpleOptEnv -> InId -> (SimpleOptEnv, OutId)
+-- Nuke all fragile IdInfo, unfolding, and RULES;
+-- it gets added back later by add_info
+-- Rather like SimplEnv.substIdBndr
+--
+-- It's important to zap fragile OccInfo (which CoreSubst.substIdBndr
+-- carefully does not do) because simplOptExpr invalidates it
+
+subst_opt_id_bndr (SOE { soe_subst = subst, soe_inl = inl }) old_id
+ = (SOE { soe_subst = new_subst, soe_inl = new_inl }, new_id)
+ where
+ Subst in_scope id_subst tv_subst cv_subst = subst
+
+ id1 = uniqAway in_scope old_id
+ id2 = setIdType id1 (substTy subst (idType old_id))
+ new_id = zapFragileIdInfo id2
+ -- Zaps rules, worker-info, unfolding, and fragile OccInfo
+ -- The unfolding and rules will get added back later, by add_info
+
+ new_in_scope = in_scope `extendInScopeSet` new_id
+
+ no_change = new_id == old_id
+
+ -- Extend the substitution if the unique has changed,
+ -- See the notes with substTyVarBndr for the delSubstEnv
+ new_id_subst
+ | no_change = delVarEnv id_subst old_id
+ | otherwise = extendVarEnv id_subst old_id (Var new_id)
+
+ new_subst = Subst new_in_scope new_id_subst tv_subst cv_subst
+ new_inl = delVarEnv inl old_id
+
+----------------------
+add_info :: SimpleOptEnv -> InVar -> OutVar -> OutVar
+add_info env old_bndr new_bndr
+ | isTyVar old_bndr = new_bndr
+ | otherwise = maybeModifyIdInfo mb_new_info new_bndr
+ where
+ subst = soe_subst env
+ mb_new_info = substIdInfo subst new_bndr (idInfo old_bndr)
+
+simpleUnfoldingFun :: IdUnfoldingFun
+simpleUnfoldingFun id
+ | isAlwaysActive (idInlineActivation id) = idUnfolding id
+ | otherwise = noUnfolding
+
+wrapLet :: Maybe (Id,CoreExpr) -> CoreExpr -> CoreExpr
+wrapLet Nothing body = body
+wrapLet (Just (b,r)) body = Let (NonRec b r) body
+
+------------------
+substVects :: Subst -> [CoreVect] -> [CoreVect]
+substVects subst = map (substVect subst)
+
+------------------
+substVect :: Subst -> CoreVect -> CoreVect
+substVect subst (Vect v rhs) = Vect v (simpleOptExprWith subst rhs)
+substVect _subst vd@(NoVect _) = vd
+substVect _subst vd@(VectType _ _ _) = vd
+substVect _subst vd@(VectClass _) = vd
+substVect _subst vd@(VectInst _) = vd
+
+{-
+Note [Inline prag in simplOpt]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If there's an INLINE/NOINLINE pragma that restricts the phase in
+which the binder can be inlined, we don't inline here; after all,
+we don't know what phase we're in. Here's an example
+
+ foo :: Int -> Int -> Int
+ {-# INLINE foo #-}
+ foo m n = inner m
+ where
+ {-# INLINE [1] inner #-}
+ inner m = m+n
+
+ bar :: Int -> Int
+ bar n = foo n 1
+
+When inlining 'foo' in 'bar' we want the let-binding for 'inner'
+to remain visible until Phase 1
+
+Note [Unfold compulsory unfoldings in LHSs]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When the user writes `RULES map coerce = coerce` as a rule, the rule
+will only ever match if simpleOptExpr replaces coerce by its unfolding
+on the LHS, because that is the core that the rule matching engine
+will find. So do that for everything that has a compulsory
+unfolding. Also see Note [Desugaring coerce as cast] in Desugar.
+
+However, we don't want to inline 'seq', which happens to also have a
+compulsory unfolding, so we only do this unfolding only for things
+that are always-active. See Note [User-defined RULES for seq] in MkId.
+
+Note [Getting the map/coerce RULE to work]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We wish to allow the "map/coerce" RULE to fire:
+
+ {-# RULES "map/coerce" map coerce = coerce #-}
+
+The naive core produced for this is
+
+ forall a b (dict :: Coercible * a b).
+ map @a @b (coerce @a @b @dict) = coerce @[a] @[b] @dict'
+
+ where dict' :: Coercible [a] [b]
+ dict' = ...
+
+This matches literal uses of `map coerce` in code, but that's not what we
+want. We want it to match, say, `map MkAge` (where newtype Age = MkAge Int)
+too. Some of this is addressed by compulsorily unfolding coerce on the LHS,
+yielding
+
+ forall a b (dict :: Coercible * a b).
+ map @a @b (\(x :: a) -> case dict of
+ MkCoercible (co :: a ~R# b) -> x |> co) = ...
+
+Getting better. But this isn't exactly what gets produced. This is because
+Coercible essentially has ~R# as a superclass, and superclasses get eagerly
+extracted during solving. So we get this:
+
+ forall a b (dict :: Coercible * a b).
+ case Coercible_SCSel @* @a @b dict of
+ _ [Dead] -> map @a @b (\(x :: a) -> case dict of
+ MkCoercible (co :: a ~R# b) -> x |> co) = ...
+
+Unfortunately, this still abstracts over a Coercible dictionary. We really
+want it to abstract over the ~R# evidence. So, we have Desugar.unfold_coerce,
+which transforms the above to (see also Note [Desugaring coerce as cast] in
+Desugar)
+
+ forall a b (co :: a ~R# b).
+ let dict = MkCoercible @* @a @b co in
+ case Coercible_SCSel @* @a @b dict of
+ _ [Dead] -> map @a @b (\(x :: a) -> case dict of
+ MkCoercible (co :: a ~R# b) -> x |> co) = let dict = ... in ...
+
+Now, we need simpleOptExpr to fix this up. It does so by taking three
+separate actions:
+ 1. Inline certain non-recursive bindings. The choice whether to inline
+ is made in simple_bind_pair. Note the rather specific check for
+ MkCoercible in there.
+
+ 2. Stripping case expressions like the Coercible_SCSel one.
+ See the `Case` case of simple_opt_expr's `go` function.
+
+ 3. Look for case expressions that unpack something that was
+ just packed and inline them. This is also done in simple_opt_expr's
+ `go` function.
+
+This is all a fair amount of special-purpose hackery, but it's for
+a good cause. And it won't hurt other RULES and such that it comes across.
+
+
+************************************************************************
+* *
+ Join points
+* *
+************************************************************************
+-}
+
+-- | Returns Just (bndr,rhs) if the binding is a join point:
+-- If it's a JoinId, just return it
+-- If it's not yet a JoinId but is always tail-called,
+-- make it into a JoinId and return it.
+-- In the latter case, eta-expand the RHS if necessary, to make the
+-- lambdas explicit, as is required for join points
+--
+-- Precondition: the InBndr has been occurrence-analysed,
+-- so its OccInfo is valid
+joinPointBinding_maybe :: InBndr -> InExpr -> Maybe (InBndr, InExpr)
+joinPointBinding_maybe bndr rhs
+ | not (isId bndr)
+ = Nothing
+
+ | isJoinId bndr
+ = Just (bndr, rhs)
+
+ | AlwaysTailCalled join_arity <- tailCallInfo (idOccInfo bndr)
+ , not (bad_unfolding join_arity (idUnfolding bndr))
+ , (bndrs, body) <- etaExpandToJoinPoint join_arity rhs
+ = Just (bndr `asJoinId` join_arity, mkLams bndrs body)
+
+ | otherwise
+ = Nothing
+
+ where
+ -- bad_unfolding returns True if we should /not/ convert a non-join-id
+ -- into a join-id, even though it is AlwaysTailCalled
+ -- See Note [Join points and INLINE pragmas]
+ bad_unfolding join_arity (CoreUnfolding { uf_src = src, uf_tmpl = rhs })
+ = isStableSource src && join_arity > joinRhsArity rhs
+ bad_unfolding _ (DFunUnfolding {})
+ = True
+ bad_unfolding _ _
+ = False
+
+joinPointBindings_maybe :: [(InBndr, InExpr)] -> Maybe [(InBndr, InExpr)]
+joinPointBindings_maybe bndrs
+ = mapM (uncurry joinPointBinding_maybe) bndrs
+
+
+{- Note [Join points and INLINE pragmas]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+ f x = let g = \x. not -- Arity 1
+ {-# INLINE g #-}
+ in case x of
+ A -> g True True
+ B -> g True False
+ C -> blah2
+
+Here 'g' is always tail-called applied to 2 args, but the stable
+unfolding captured by the INLINE pragma has arity 1. If we try to
+convert g to be a join point, its unfolding will still have arity 1
+(since it is stable, and we don't meddle with stable unfoldings), and
+Lint will complain (see Note [Invariants on join points], (2a), in
+CoreSyn. Trac #13413.
+
+Moreover, since g is going to be inlined anyway, there is no benefit
+from making it a join point.
+
+If it is recursive, and uselessly marked INLINE, this will stop us
+making it a join point, which is a annoying. But occasionally
+(notably in class methods; see Note [Instances and loop breakers] in
+TcInstDcls) we mark recurive things as INLINE but the recursion
+unravels; so ignoring INLINE pragmas on recursive things isn't good
+either.
+
+
+************************************************************************
+* *
+ exprIsConApp_maybe
+* *
+************************************************************************
+
+Note [exprIsConApp_maybe]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+exprIsConApp_maybe is a very important function. There are two principal
+uses:
+ * case e of { .... }
+ * cls_op e, where cls_op is a class operation
+
+In both cases you want to know if e is of form (C e1..en) where C is
+a data constructor.
+
+However e might not *look* as if
+
+
+Note [exprIsConApp_maybe on literal strings]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+See #9400 and #13317.
+
+Conceptually, a string literal "abc" is just ('a':'b':'c':[]), but in Core
+they are represented as unpackCString# "abc"# by MkCore.mkStringExprFS, or
+unpackCStringUtf8# when the literal contains multi-byte UTF8 characters.
+
+For optimizations we want to be able to treat it as a list, so they can be
+decomposed when used in a case-statement. exprIsConApp_maybe detects those
+calls to unpackCString# and returns:
+
+Just (':', [Char], ['a', unpackCString# "bc"]).
+
+We need to be careful about UTF8 strings here. ""# contains a ByteString, so
+we must parse it back into a FastString to split off the first character.
+That way we can treat unpackCString# and unpackCStringUtf8# in the same way.
+
+We must also be caeful about
+ lvl = "foo"#
+ ...(unpackCString# lvl)...
+to ensure that we see through the let-binding for 'lvl'. Hence the
+(exprIsLiteral_maybe .. arg) in the guard before the call to
+dealWithStringLiteral.
+
+Note [Push coercions in exprIsConApp_maybe]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In Trac #13025 I found a case where we had
+ op (df @t1 @t2) -- op is a ClassOp
+where
+ df = (/\a b. K e1 e2) |> g
+
+To get this to come out we need to simplify on the fly
+ ((/\a b. K e1 e2) |> g) @t1 @t2
+
+Hence the use of pushCoArgs.
+-}
+
+data ConCont = CC [CoreExpr] Coercion
+ -- Substitution already applied
+
+-- | Returns @Just (dc, [t1..tk], [x1..xn])@ if the argument expression is
+-- a *saturated* constructor application of the form @dc t1..tk x1 .. xn@,
+-- where t1..tk are the *universally-qantified* type args of 'dc'
+exprIsConApp_maybe :: InScopeEnv -> CoreExpr -> Maybe (DataCon, [Type], [CoreExpr])
+exprIsConApp_maybe (in_scope, id_unf) expr
+ = go (Left in_scope) expr (CC [] (mkRepReflCo (exprType expr)))
+ where
+ go :: Either InScopeSet Subst
+ -- Left in-scope means "empty substitution"
+ -- Right subst means "apply this substitution to the CoreExpr"
+ -> CoreExpr -> ConCont
+ -> Maybe (DataCon, [Type], [CoreExpr])
+ go subst (Tick t expr) cont
+ | not (tickishIsCode t) = go subst expr cont
+ go subst (Cast expr co1) (CC args co2)
+ | Just (args', co1') <- pushCoArgs (subst_co subst co1) args
+ -- See Note [Push coercions in exprIsConApp_maybe]
+ = go subst expr (CC args' (co1' `mkTransCo` co2))
+ go subst (App fun arg) (CC args co)
+ = go subst fun (CC (subst_arg subst arg : args) co)
+ go subst (Lam var body) (CC (arg:args) co)
+ | exprIsTrivial arg -- Don't duplicate stuff!
+ = go (extend subst var arg) body (CC args co)
+ go (Right sub) (Var v) cont
+ = go (Left (substInScope sub))
+ (lookupIdSubst (text "exprIsConApp" <+> ppr expr) sub v)
+ cont
+
+ go (Left in_scope) (Var fun) cont@(CC args co)
+
+ | Just con <- isDataConWorkId_maybe fun
+ , count isValArg args == idArity fun
+ = pushCoDataCon con args co
+
+ -- Look through dictionary functions; see Note [Unfolding DFuns]
+ | DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = dfun_args } <- unfolding
+ , bndrs `equalLength` args -- See Note [DFun arity check]
+ , let subst = mkOpenSubst in_scope (bndrs `zip` args)
+ = pushCoDataCon con (map (substExpr (text "exprIsConApp1") subst) dfun_args) co
+
+ -- Look through unfoldings, but only arity-zero one;
+ -- if arity > 0 we are effectively inlining a function call,
+ -- and that is the business of callSiteInline.
+ -- In practice, without this test, most of the "hits" were
+ -- CPR'd workers getting inlined back into their wrappers,
+ | idArity fun == 0
+ , Just rhs <- expandUnfolding_maybe unfolding
+ , let in_scope' = extendInScopeSetSet in_scope (exprFreeVars rhs)
+ = go (Left in_scope') rhs cont
+
+ -- See Note [exprIsConApp_maybe on literal strings]
+ | (fun `hasKey` unpackCStringIdKey) ||
+ (fun `hasKey` unpackCStringUtf8IdKey)
+ , [arg] <- args
+ , Just (MachStr str) <- exprIsLiteral_maybe (in_scope, id_unf) arg
+ = dealWithStringLiteral fun str co
+ where
+ unfolding = id_unf fun
+
+ go _ _ _ = Nothing
+
+ ----------------------------
+ -- Operations on the (Either InScopeSet CoreSubst)
+ -- The Left case is wildly dominant
+ subst_co (Left {}) co = co
+ subst_co (Right s) co = CoreSubst.substCo s co
+
+ subst_arg (Left {}) e = e
+ subst_arg (Right s) e = substExpr (text "exprIsConApp2") s e
+
+ extend (Left in_scope) v e = Right (extendSubst (mkEmptySubst in_scope) v e)
+ extend (Right s) v e = Right (extendSubst s v e)
+
+
+-- See Note [exprIsConApp_maybe on literal strings]
+dealWithStringLiteral :: Var -> BS.ByteString -> Coercion
+ -> Maybe (DataCon, [Type], [CoreExpr])
+
+-- This is not possible with user-supplied empty literals, MkCore.mkStringExprFS
+-- turns those into [] automatically, but just in case something else in GHC
+-- generates a string literal directly.
+dealWithStringLiteral _ str co
+ | BS.null str
+ = pushCoDataCon nilDataCon [Type charTy] co
+
+dealWithStringLiteral fun str co
+ = let strFS = mkFastStringByteString str
+
+ char = mkConApp charDataCon [mkCharLit (headFS strFS)]
+ charTail = fastStringToByteString (tailFS strFS)
+
+ -- In singleton strings, just add [] instead of unpackCstring# ""#.
+ rest = if BS.null charTail
+ then mkConApp nilDataCon [Type charTy]
+ else App (Var fun)
+ (Lit (MachStr charTail))
+
+ in pushCoDataCon consDataCon [Type charTy, char, rest] co
+
+{-
+Note [Unfolding DFuns]
+~~~~~~~~~~~~~~~~~~~~~~
+DFuns look like
+
+ df :: forall a b. (Eq a, Eq b) -> Eq (a,b)
+ df a b d_a d_b = MkEqD (a,b) ($c1 a b d_a d_b)
+ ($c2 a b d_a d_b)
+
+So to split it up we just need to apply the ops $c1, $c2 etc
+to the very same args as the dfun. It takes a little more work
+to compute the type arguments to the dictionary constructor.
+
+Note [DFun arity check]
+~~~~~~~~~~~~~~~~~~~~~~~
+Here we check that the total number of supplied arguments (inclding
+type args) matches what the dfun is expecting. This may be *less*
+than the ordinary arity of the dfun: see Note [DFun unfoldings] in CoreSyn
+-}
+
+exprIsLiteral_maybe :: InScopeEnv -> CoreExpr -> Maybe Literal
+-- Same deal as exprIsConApp_maybe, but much simpler
+-- Nevertheless we do need to look through unfoldings for
+-- Integer and string literals, which are vigorously hoisted to top level
+-- and not subsequently inlined
+exprIsLiteral_maybe env@(_, id_unf) e
+ = case e of
+ Lit l -> Just l
+ Tick _ e' -> exprIsLiteral_maybe env e' -- dubious?
+ Var v | Just rhs <- expandUnfolding_maybe (id_unf v)
+ -> exprIsLiteral_maybe env rhs
+ _ -> Nothing
+
+{-
+Note [exprIsLambda_maybe]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+exprIsLambda_maybe will, given an expression `e`, try to turn it into the form
+`Lam v e'` (returned as `Just (v,e')`). Besides using lambdas, it looks through
+casts (using the Push rule), and it unfolds function calls if the unfolding
+has a greater arity than arguments are present.
+
+Currently, it is used in Rules.match, and is required to make
+"map coerce = coerce" match.
+-}
+
+exprIsLambda_maybe :: InScopeEnv -> CoreExpr
+ -> Maybe (Var, CoreExpr,[Tickish Id])
+ -- See Note [exprIsLambda_maybe]
+
+-- The simple case: It is a lambda already
+exprIsLambda_maybe _ (Lam x e)
+ = Just (x, e, [])
+
+-- Still straightforward: Ticks that we can float out of the way
+exprIsLambda_maybe (in_scope_set, id_unf) (Tick t e)
+ | tickishFloatable t
+ , Just (x, e, ts) <- exprIsLambda_maybe (in_scope_set, id_unf) e
+ = Just (x, e, t:ts)
+
+-- Also possible: A casted lambda. Push the coercion inside
+exprIsLambda_maybe (in_scope_set, id_unf) (Cast casted_e co)
+ | Just (x, e,ts) <- exprIsLambda_maybe (in_scope_set, id_unf) casted_e
+ -- Only do value lambdas.
+ -- this implies that x is not in scope in gamma (makes this code simpler)
+ , not (isTyVar x) && not (isCoVar x)
+ , ASSERT( not $ x `elemVarSet` tyCoVarsOfCo co) True
+ , Just (x',e') <- pushCoercionIntoLambda in_scope_set x e co
+ , let res = Just (x',e',ts)
+ = --pprTrace "exprIsLambda_maybe:Cast" (vcat [ppr casted_e,ppr co,ppr res)])
+ res
+
+-- Another attempt: See if we find a partial unfolding
+exprIsLambda_maybe (in_scope_set, id_unf) e
+ | (Var f, as, ts) <- collectArgsTicks tickishFloatable e
+ , idArity f > count isValArg as
+ -- Make sure there is hope to get a lambda
+ , Just rhs <- expandUnfolding_maybe (id_unf f)
+ -- Optimize, for beta-reduction
+ , let e' = simpleOptExprWith (mkEmptySubst in_scope_set) (rhs `mkApps` as)
+ -- Recurse, because of possible casts
+ , Just (x', e'', ts') <- exprIsLambda_maybe (in_scope_set, id_unf) e'
+ , let res = Just (x', e'', ts++ts')
+ = -- pprTrace "exprIsLambda_maybe:Unfold" (vcat [ppr e, ppr (x',e'')])
+ res
+
+exprIsLambda_maybe _ _e
+ = -- pprTrace "exprIsLambda_maybe:Fail" (vcat [ppr _e])
+ Nothing
+
+
+{- *********************************************************************
+* *
+ The "push rules"
+* *
+************************************************************************
+
+Here we implement the "push rules" from FC papers:
+
+* The push-argument rules, where we can move a coercion past an argument.
+ We have
+ (fun |> co) arg
+ and we want to transform it to
+ (fun arg') |> co'
+ for some suitable co' and tranformed arg'.
+
+* The PushK rule for data constructors. We have
+ (K e1 .. en) |> co
+ and we want to tranform to
+ (K e1' .. en')
+ by pushing the coercion into the oarguments
+-}
+
+pushCoArgs :: Coercion -> [CoreArg] -> Maybe ([CoreArg], Coercion)
+pushCoArgs co [] = return ([], co)
+pushCoArgs co (arg:args) = do { (arg', co1) <- pushCoArg co arg
+ ; (args', co2) <- pushCoArgs co1 args
+ ; return (arg':args', co2) }
+
+pushCoArg :: Coercion -> CoreArg -> Maybe (CoreArg, Coercion)
+-- We have (fun |> co) arg, and we want to transform it to
+-- (fun arg) |> co
+-- This may fail, e.g. if (fun :: N) where N is a newtype
+-- C.f. simplCast in Simplify.hs
+-- 'co' is always Representational
+
+pushCoArg co (Type ty) = do { (ty', co') <- pushCoTyArg co ty
+ ; return (Type ty', co') }
+pushCoArg co val_arg = do { (arg_co, co') <- pushCoValArg co
+ ; return (mkCast val_arg arg_co, co') }
+
+pushCoTyArg :: Coercion -> Type -> Maybe (Type, Coercion)
+-- We have (fun |> co) @ty
+-- Push the coercion through to return
+-- (fun @ty') |> co'
+-- 'co' is always Representational
+pushCoTyArg co ty
+ | tyL `eqType` tyR
+ = Just (ty, mkRepReflCo (piResultTy tyR ty))
+
+ | isForAllTy tyL
+ = ASSERT2( isForAllTy tyR, ppr co $$ ppr ty )
+ Just (ty `mkCastTy` mkSymCo co1, co2)
+
+ | otherwise
+ = Nothing
+ where
+ Pair tyL tyR = coercionKind co
+ -- co :: tyL ~ tyR
+ -- tyL = forall (a1 :: k1). ty1
+ -- tyR = forall (a2 :: k2). ty2
+
+ co1 = mkNthCo 0 co
+ -- co1 :: k1 ~ k2
+ -- Note that NthCo can extract an equality between the kinds
+ -- of the types related by a coercion between forall-types.
+ -- See the NthCo case in CoreLint.
+
+ co2 = mkInstCo co (mkCoherenceLeftCo (mkNomReflCo ty) co1)
+ -- co2 :: ty1[ (ty|>co1)/a1 ] ~ ty2[ ty/a2 ]
+ -- Arg of mkInstCo is always nominal, hence mkNomReflCo
+
+pushCoValArg :: Coercion -> Maybe (Coercion, Coercion)
+-- We have (fun |> co) arg
+-- Push the coercion through to return
+-- (fun (arg |> co_arg)) |> co_res
+-- 'co' is always Representational
+pushCoValArg co
+ | tyL `eqType` tyR
+ = Just (mkRepReflCo arg, mkRepReflCo res)
+
+ | isFunTy tyL
+ , (co1, co2) <- decomposeFunCo co
+ -- If co :: (tyL1 -> tyL2) ~ (tyR1 -> tyR2)
+ -- then co1 :: tyL1 ~ tyR1
+ -- co2 :: tyL2 ~ tyR2
+ = ASSERT2( isFunTy tyR, ppr co $$ ppr arg )
+ Just (mkSymCo co1, co2)
+
+ | otherwise
+ = Nothing
+ where
+ (arg, res) = splitFunTy tyR
+ Pair tyL tyR = coercionKind co
+
+pushCoercionIntoLambda
+ :: InScopeSet -> Var -> CoreExpr -> Coercion -> Maybe (Var, CoreExpr)
+-- This implements the Push rule from the paper on coercions
+-- (\x. e) |> co
+-- ===>
+-- (\x'. e |> co')
+pushCoercionIntoLambda in_scope x e co
+ | ASSERT(not (isTyVar x) && not (isCoVar x)) True
+ , Pair s1s2 t1t2 <- coercionKind co
+ , Just (_s1,_s2) <- splitFunTy_maybe s1s2
+ , Just (t1,_t2) <- splitFunTy_maybe t1t2
+ = let (co1, co2) = decomposeFunCo co
+ -- Should we optimize the coercions here?
+ -- Otherwise they might not match too well
+ x' = x `setIdType` t1
+ in_scope' = in_scope `extendInScopeSet` x'
+ subst = extendIdSubst (mkEmptySubst in_scope')
+ x
+ (mkCast (Var x') co1)
+ in Just (x', substExpr (text "pushCoercionIntoLambda") subst e `mkCast` co2)
+ | otherwise
+ = pprTrace "exprIsLambda_maybe: Unexpected lambda in case" (ppr (Lam x e))
+ Nothing
+
+pushCoDataCon :: DataCon -> [CoreExpr] -> Coercion
+ -> Maybe (DataCon
+ , [Type] -- Universal type args
+ , [CoreExpr]) -- All other args incl existentials
+-- Implement the KPush reduction rule as described in "Down with kinds"
+-- The transformation applies iff we have
+-- (C e1 ... en) `cast` co
+-- where co :: (T t1 .. tn) ~ to_ty
+-- The left-hand one must be a T, because exprIsConApp returned True
+-- but the right-hand one might not be. (Though it usually will.)
+pushCoDataCon dc dc_args co
+ | isReflCo co || from_ty `eqType` to_ty -- try cheap test first
+ , let (univ_ty_args, rest_args) = splitAtList (dataConUnivTyVars dc) dc_args
+ = Just (dc, map exprToType univ_ty_args, rest_args)
+
+ | Just (to_tc, to_tc_arg_tys) <- splitTyConApp_maybe to_ty
+ , to_tc == dataConTyCon dc
+ -- These two tests can fail; we might see
+ -- (C x y) `cast` (g :: T a ~ S [a]),
+ -- where S is a type function. In fact, exprIsConApp
+ -- will probably not be called in such circumstances,
+ -- but there't nothing wrong with it
+
+ = let
+ tc_arity = tyConArity to_tc
+ dc_univ_tyvars = dataConUnivTyVars dc
+ dc_ex_tyvars = dataConExTyVars dc
+ arg_tys = dataConRepArgTys dc
+
+ non_univ_args = dropList dc_univ_tyvars dc_args
+ (ex_args, val_args) = splitAtList dc_ex_tyvars non_univ_args
+
+ -- Make the "Psi" from the paper
+ omegas = decomposeCo tc_arity co
+ (psi_subst, to_ex_arg_tys)
+ = liftCoSubstWithEx Representational
+ dc_univ_tyvars
+ omegas
+ dc_ex_tyvars
+ (map exprToType ex_args)
+
+ -- Cast the value arguments (which include dictionaries)
+ new_val_args = zipWith cast_arg arg_tys val_args
+ cast_arg arg_ty arg = mkCast arg (psi_subst arg_ty)
+
+ to_ex_args = map Type to_ex_arg_tys
+
+ dump_doc = vcat [ppr dc, ppr dc_univ_tyvars, ppr dc_ex_tyvars,
+ ppr arg_tys, ppr dc_args,
+ ppr ex_args, ppr val_args, ppr co, ppr from_ty, ppr to_ty, ppr to_tc ]
+ in
+ ASSERT2( eqType from_ty (mkTyConApp to_tc (map exprToType $ takeList dc_univ_tyvars dc_args)), dump_doc )
+ ASSERT2( equalLength val_args arg_tys, dump_doc )
+ Just (dc, to_tc_arg_tys, to_ex_args ++ new_val_args)
+
+ | otherwise
+ = Nothing
+
+ where
+ Pair from_ty to_ty = coercionKind co
+
+collectBindersPushingCo :: CoreExpr -> ([Var], CoreExpr)
+-- Collect lambda binders, pushing coercions inside if possible
+-- E.g. (\x.e) |> g g :: -> blah
+-- = (\x. e |> Nth 1 g)
+--
+-- That is,
+--
+-- collectBindersPushingCo ((\x.e) |> g) === ([x], e |> Nth 1 g)
+collectBindersPushingCo e
+ = go [] e
+ where
+ -- Peel off lambdas until we hit a cast.
+ go :: [Var] -> CoreExpr -> ([Var], CoreExpr)
+ -- The accumulator is in reverse order
+ go bs (Lam b e) = go (b:bs) e
+ go bs (Cast e co) = go_c bs e co
+ go bs e = (reverse bs, e)
+
+ -- We are in a cast; peel off casts until we hit a lambda.
+ go_c :: [Var] -> CoreExpr -> Coercion -> ([Var], CoreExpr)
+ -- (go_c bs e c) is same as (go bs e (e |> c))
+ go_c bs (Cast e co1) co2 = go_c bs e (co1 `mkTransCo` co2)
+ go_c bs (Lam b e) co = go_lam bs b e co
+ go_c bs e co = (reverse bs, mkCast e co)
+
+ -- We are in a lambda under a cast; peel off lambdas and build a
+ -- new coercion for the body.
+ go_lam :: [Var] -> Var -> CoreExpr -> Coercion -> ([Var], CoreExpr)
+ -- (go_lam bs b e c) is same as (go_c bs (\b.e) c)
+ go_lam bs b e co
+ | isTyVar b
+ , let Pair tyL tyR = coercionKind co
+ , ASSERT( isForAllTy tyL )
+ isForAllTy tyR
+ , isReflCo (mkNthCo 0 co) -- See Note [collectBindersPushingCo]
+ = go_c (b:bs) e (mkInstCo co (mkNomReflCo (mkTyVarTy b)))
+
+ | isId b
+ , let Pair tyL tyR = coercionKind co
+ , ASSERT( isFunTy tyL) isFunTy tyR
+ , (co_arg, co_res) <- decomposeFunCo co
+ , isReflCo co_arg -- See Note [collectBindersPushingCo]
+ = go_c (b:bs) e co_res
+
+ | otherwise = (reverse bs, mkCast (Lam b e) co)
+
+{- Note [collectBindersPushingCo]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We just look for coercions of form
+ -> blah
+(and similarly for foralls) to keep this function simple. We could do
+more elaborate stuff, but it'd involve substitution etc.
+-}
diff --git a/coreSyn/CorePrep.hs b/coreSyn/CorePrep.hs
new file mode 100644
--- /dev/null
+++ b/coreSyn/CorePrep.hs
@@ -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)
diff --git a/coreSyn/CoreSeq.hs b/coreSyn/CoreSeq.hs
new file mode 100644
--- /dev/null
+++ b/coreSyn/CoreSeq.hs
@@ -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 _ = ()
diff --git a/coreSyn/CoreStats.hs b/coreSyn/CoreStats.hs
new file mode 100644
--- /dev/null
+++ b/coreSyn/CoreStats.hs
@@ -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
diff --git a/coreSyn/CoreSubst.hs b/coreSyn/CoreSubst.hs
new file mode 100644
--- /dev/null
+++ b/coreSyn/CoreSubst.hs
@@ -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 " in_scope_doc
+ $$ text " IdSubst =" <+> ppr ids
+ $$ text " TvSubst =" <+> ppr tvs
+ $$ text " CvSubst =" <+> ppr cvs
+ <> char '>'
+ where
+ in_scope_doc = pprVarSet (getInScopeVars in_scope) (braces . fsep . map ppr)
+
+{-
+************************************************************************
+* *
+ Substituting expressions
+* *
+************************************************************************
+-}
+
+-- | Apply a substitution to an entire 'CoreExpr'. Remember, you may only
+-- apply the substitution /once/: see "CoreSubst#apply_once"
+--
+-- Do *not* attempt to short-cut in the case of an empty substitution!
+-- See Note [Extending the Subst]
+substExprSC :: SDoc -> Subst -> CoreExpr -> CoreExpr
+substExprSC doc subst orig_expr
+ | isEmptySubst subst = orig_expr
+ | otherwise = -- pprTrace "enter subst-expr" (doc $$ ppr orig_expr) $
+ subst_expr doc subst orig_expr
+
+substExpr :: SDoc -> Subst -> CoreExpr -> CoreExpr
+substExpr doc subst orig_expr = subst_expr doc subst orig_expr
+
+subst_expr :: SDoc -> Subst -> CoreExpr -> CoreExpr
+subst_expr doc subst expr
+ = go expr
+ where
+ go (Var v) = lookupIdSubst (doc $$ text "subst_expr") subst v
+ go (Type ty) = Type (substTy subst ty)
+ go (Coercion co) = Coercion (substCo subst co)
+ go (Lit lit) = Lit lit
+ go (App fun arg) = App (go fun) (go arg)
+ go (Tick tickish e) = mkTick (substTickish subst tickish) (go e)
+ go (Cast e co) = Cast (go e) (substCo subst co)
+ -- Do not optimise even identity coercions
+ -- Reason: substitution applies to the LHS of RULES, and
+ -- if you "optimise" an identity coercion, you may
+ -- lose a binder. We optimise the LHS of rules at
+ -- construction time
+
+ go (Lam bndr body) = Lam bndr' (subst_expr doc subst' body)
+ where
+ (subst', bndr') = substBndr subst bndr
+
+ go (Let bind body) = Let bind' (subst_expr doc subst' body)
+ where
+ (subst', bind') = substBind subst bind
+
+ go (Case scrut bndr ty alts) = Case (go scrut) bndr' (substTy subst ty) (map (go_alt subst') alts)
+ where
+ (subst', bndr') = substBndr subst bndr
+
+ go_alt subst (con, bndrs, rhs) = (con, bndrs', subst_expr doc subst' rhs)
+ where
+ (subst', bndrs') = substBndrs subst bndrs
+
+-- | Apply a substitution to an entire 'CoreBind', additionally returning an updated 'Subst'
+-- that should be used by subsequent substitutions.
+substBind, substBindSC :: Subst -> CoreBind -> (Subst, CoreBind)
+
+substBindSC subst bind -- Short-cut if the substitution is empty
+ | not (isEmptySubst subst)
+ = substBind subst bind
+ | otherwise
+ = case bind of
+ NonRec bndr rhs -> (subst', NonRec bndr' rhs)
+ where
+ (subst', bndr') = substBndr subst bndr
+ Rec pairs -> (subst', Rec (bndrs' `zip` rhss'))
+ where
+ (bndrs, rhss) = unzip pairs
+ (subst', bndrs') = substRecBndrs subst bndrs
+ rhss' | isEmptySubst subst'
+ = rhss
+ | otherwise
+ = map (subst_expr (text "substBindSC") subst') rhss
+
+substBind subst (NonRec bndr rhs)
+ = (subst', NonRec bndr' (subst_expr (text "substBind") subst rhs))
+ where
+ (subst', bndr') = substBndr subst bndr
+
+substBind subst (Rec pairs)
+ = (subst', Rec (bndrs' `zip` rhss'))
+ where
+ (bndrs, rhss) = unzip pairs
+ (subst', bndrs') = substRecBndrs subst bndrs
+ rhss' = map (subst_expr (text "substBind") subst') rhss
+
+-- | De-shadowing the program is sometimes a useful pre-pass. It can be done simply
+-- by running over the bindings with an empty substitution, because substitution
+-- returns a result that has no-shadowing guaranteed.
+--
+-- (Actually, within a single /type/ there might still be shadowing, because
+-- 'substTy' is a no-op for the empty substitution, but that's probably OK.)
+--
+-- [Aug 09] This function is not used in GHC at the moment, but seems so
+-- short and simple that I'm going to leave it here
+deShadowBinds :: CoreProgram -> CoreProgram
+deShadowBinds binds = snd (mapAccumL substBind emptySubst binds)
+
+{-
+************************************************************************
+* *
+ Substituting binders
+* *
+************************************************************************
+
+Remember that substBndr and friends are used when doing expression
+substitution only. Their only business is substitution, so they
+preserve all IdInfo (suitably substituted). For example, we *want* to
+preserve occ info in rules.
+-}
+
+-- | Substitutes a 'Var' for another one according to the 'Subst' given, returning
+-- the result and an updated 'Subst' that should be used by subsequent substitutions.
+-- 'IdInfo' is preserved by this process, although it is substituted into appropriately.
+substBndr :: Subst -> Var -> (Subst, Var)
+substBndr subst bndr
+ | isTyVar bndr = substTyVarBndr subst bndr
+ | isCoVar bndr = substCoVarBndr subst bndr
+ | otherwise = substIdBndr (text "var-bndr") subst subst bndr
+
+-- | Applies 'substBndr' to a number of 'Var's, accumulating a new 'Subst' left-to-right
+substBndrs :: Subst -> [Var] -> (Subst, [Var])
+substBndrs subst bndrs = mapAccumL substBndr subst bndrs
+
+-- | Substitute in a mutually recursive group of 'Id's
+substRecBndrs :: Subst -> [Id] -> (Subst, [Id])
+substRecBndrs subst bndrs
+ = (new_subst, new_bndrs)
+ where -- Here's the reason we need to pass rec_subst to subst_id
+ (new_subst, new_bndrs) = mapAccumL (substIdBndr (text "rec-bndr") new_subst) subst bndrs
+
+substIdBndr :: SDoc
+ -> Subst -- ^ Substitution to use for the IdInfo
+ -> Subst -> Id -- ^ Substitution and Id to transform
+ -> (Subst, Id) -- ^ Transformed pair
+ -- NB: unfolding may be zapped
+
+substIdBndr _doc rec_subst subst@(Subst in_scope env tvs cvs) old_id
+ = -- pprTrace "substIdBndr" (doc $$ ppr old_id $$ ppr in_scope) $
+ (Subst (in_scope `extendInScopeSet` new_id) new_env tvs cvs, new_id)
+ where
+ id1 = uniqAway in_scope old_id -- id1 is cloned if necessary
+ id2 | no_type_change = id1
+ | otherwise = setIdType id1 (substTy subst old_ty)
+
+ old_ty = idType old_id
+ no_type_change = (isEmptyVarEnv tvs && isEmptyVarEnv cvs) ||
+ noFreeVarsOfType old_ty
+
+ -- new_id has the right IdInfo
+ -- The lazy-set is because we're in a loop here, with
+ -- rec_subst, when dealing with a mutually-recursive group
+ new_id = maybeModifyIdInfo mb_new_info id2
+ mb_new_info = substIdInfo rec_subst id2 (idInfo id2)
+ -- NB: unfolding info may be zapped
+
+ -- Extend the substitution if the unique has changed
+ -- See the notes with substTyVarBndr for the delVarEnv
+ new_env | no_change = delVarEnv env old_id
+ | otherwise = extendVarEnv env old_id (Var new_id)
+
+ no_change = id1 == old_id
+ -- See Note [Extending the Subst]
+ -- it's /not/ necessary to check mb_new_info and no_type_change
+
+{-
+Now a variant that unconditionally allocates a new unique.
+It also unconditionally zaps the OccInfo.
+-}
+
+-- | Very similar to 'substBndr', but it always allocates a new 'Unique' for
+-- each variable in its output. It substitutes the IdInfo though.
+cloneIdBndr :: Subst -> UniqSupply -> Id -> (Subst, Id)
+cloneIdBndr subst us old_id
+ = clone_id subst subst (old_id, uniqFromSupply us)
+
+-- | Applies 'cloneIdBndr' to a number of 'Id's, accumulating a final
+-- substitution from left to right
+cloneIdBndrs :: Subst -> UniqSupply -> [Id] -> (Subst, [Id])
+cloneIdBndrs subst us ids
+ = mapAccumL (clone_id subst) subst (ids `zip` uniqsFromSupply us)
+
+cloneBndrs :: Subst -> UniqSupply -> [Var] -> (Subst, [Var])
+-- Works for all kinds of variables (typically case binders)
+-- not just Ids
+cloneBndrs subst us vs
+ = mapAccumL (\subst (v, u) -> cloneBndr subst u v) subst (vs `zip` uniqsFromSupply us)
+
+cloneBndr :: Subst -> Unique -> Var -> (Subst, Var)
+cloneBndr subst uniq v
+ | isTyVar v = cloneTyVarBndr subst v uniq
+ | otherwise = clone_id subst subst (v,uniq) -- Works for coercion variables too
+
+-- | Clone a mutually recursive group of 'Id's
+cloneRecIdBndrs :: Subst -> UniqSupply -> [Id] -> (Subst, [Id])
+cloneRecIdBndrs subst us ids
+ = (subst', ids')
+ where
+ (subst', ids') = mapAccumL (clone_id subst') subst
+ (ids `zip` uniqsFromSupply us)
+
+-- Just like substIdBndr, except that it always makes a new unique
+-- It is given the unique to use
+clone_id :: Subst -- Substitution for the IdInfo
+ -> Subst -> (Id, Unique) -- Substitution and Id to transform
+ -> (Subst, Id) -- Transformed pair
+
+clone_id rec_subst subst@(Subst in_scope idvs tvs cvs) (old_id, uniq)
+ = (Subst (in_scope `extendInScopeSet` new_id) new_idvs tvs new_cvs, new_id)
+ where
+ id1 = setVarUnique old_id uniq
+ id2 = substIdType subst id1
+ new_id = maybeModifyIdInfo (substIdInfo rec_subst id2 (idInfo old_id)) id2
+ (new_idvs, new_cvs) | isCoVar old_id = (idvs, extendVarEnv cvs old_id (mkCoVarCo new_id))
+ | otherwise = (extendVarEnv idvs old_id (Var new_id), cvs)
+
+{-
+************************************************************************
+* *
+ Types and Coercions
+* *
+************************************************************************
+
+For types and coercions we just call the corresponding functions in
+Type and Coercion, but we have to repackage the substitution, from a
+Subst to a TCvSubst.
+-}
+
+substTyVarBndr :: Subst -> TyVar -> (Subst, TyVar)
+substTyVarBndr (Subst in_scope id_env tv_env cv_env) tv
+ = case Type.substTyVarBndr (TCvSubst in_scope tv_env cv_env) tv of
+ (TCvSubst in_scope' tv_env' cv_env', tv')
+ -> (Subst in_scope' id_env tv_env' cv_env', tv')
+
+cloneTyVarBndr :: Subst -> TyVar -> Unique -> (Subst, TyVar)
+cloneTyVarBndr (Subst in_scope id_env tv_env cv_env) tv uniq
+ = case Type.cloneTyVarBndr (TCvSubst in_scope tv_env cv_env) tv uniq of
+ (TCvSubst in_scope' tv_env' cv_env', tv')
+ -> (Subst in_scope' id_env tv_env' cv_env', tv')
+
+substCoVarBndr :: Subst -> TyVar -> (Subst, TyVar)
+substCoVarBndr (Subst in_scope id_env tv_env cv_env) cv
+ = case Coercion.substCoVarBndr (TCvSubst in_scope tv_env cv_env) cv of
+ (TCvSubst in_scope' tv_env' cv_env', cv')
+ -> (Subst in_scope' id_env tv_env' cv_env', cv')
+
+-- | See 'Type.substTy'
+substTy :: Subst -> Type -> Type
+substTy subst ty = Type.substTyUnchecked (getTCvSubst subst) ty
+
+getTCvSubst :: Subst -> TCvSubst
+getTCvSubst (Subst in_scope _ tenv cenv) = TCvSubst in_scope tenv cenv
+
+-- | See 'Coercion.substCo'
+substCo :: Subst -> Coercion -> Coercion
+substCo subst co = Coercion.substCo (getTCvSubst subst) co
+
+{-
+************************************************************************
+* *
+\section{IdInfo substitution}
+* *
+************************************************************************
+-}
+
+substIdType :: Subst -> Id -> Id
+substIdType subst@(Subst _ _ tv_env cv_env) id
+ | (isEmptyVarEnv tv_env && isEmptyVarEnv cv_env) || noFreeVarsOfType old_ty = id
+ | otherwise = setIdType id (substTy subst old_ty)
+ -- The tyCoVarsOfType is cheaper than it looks
+ -- because we cache the free tyvars of the type
+ -- in a Note in the id's type itself
+ where
+ old_ty = idType id
+
+------------------
+-- | Substitute into some 'IdInfo' with regard to the supplied new 'Id'.
+substIdInfo :: Subst -> Id -> IdInfo -> Maybe IdInfo
+substIdInfo subst new_id info
+ | nothing_to_do = Nothing
+ | otherwise = Just (info `setRuleInfo` substSpec subst new_id old_rules
+ `setUnfoldingInfo` substUnfolding subst old_unf)
+ where
+ old_rules = ruleInfo info
+ old_unf = unfoldingInfo info
+ nothing_to_do = isEmptyRuleInfo old_rules && not (isFragileUnfolding old_unf)
+
+------------------
+-- | Substitutes for the 'Id's within an unfolding
+substUnfolding, substUnfoldingSC :: Subst -> Unfolding -> Unfolding
+ -- Seq'ing on the returned Unfolding is enough to cause
+ -- all the substitutions to happen completely
+
+substUnfoldingSC subst unf -- Short-cut version
+ | isEmptySubst subst = unf
+ | otherwise = substUnfolding subst unf
+
+substUnfolding subst df@(DFunUnfolding { df_bndrs = bndrs, df_args = args })
+ = df { df_bndrs = bndrs', df_args = args' }
+ where
+ (subst',bndrs') = substBndrs subst bndrs
+ args' = map (substExpr (text "subst-unf:dfun") subst') args
+
+substUnfolding subst unf@(CoreUnfolding { uf_tmpl = tmpl, uf_src = src })
+ -- Retain an InlineRule!
+ | not (isStableSource src) -- Zap an unstable unfolding, to save substitution work
+ = NoUnfolding
+ | otherwise -- But keep a stable one!
+ = seqExpr new_tmpl `seq`
+ unf { uf_tmpl = new_tmpl }
+ where
+ new_tmpl = substExpr (text "subst-unf") subst tmpl
+
+substUnfolding _ unf = unf -- NoUnfolding, OtherCon
+
+------------------
+substIdOcc :: Subst -> Id -> Id
+-- These Ids should not be substituted to non-Ids
+substIdOcc subst v = case lookupIdSubst (text "substIdOcc") subst v of
+ Var v' -> v'
+ other -> pprPanic "substIdOcc" (vcat [ppr v <+> ppr other, ppr subst])
+
+------------------
+-- | Substitutes for the 'Id's within the 'WorkerInfo' given the new function 'Id'
+substSpec :: Subst -> Id -> RuleInfo -> RuleInfo
+substSpec subst new_id (RuleInfo rules rhs_fvs)
+ = seqRuleInfo new_spec `seq` new_spec
+ where
+ subst_ru_fn = const (idName new_id)
+ new_spec = RuleInfo (map (substRule subst subst_ru_fn) rules)
+ (substDVarSet subst rhs_fvs)
+
+------------------
+substRulesForImportedIds :: Subst -> [CoreRule] -> [CoreRule]
+substRulesForImportedIds subst rules
+ = map (substRule subst not_needed) rules
+ where
+ not_needed name = pprPanic "substRulesForImportedIds" (ppr name)
+
+------------------
+substRule :: Subst -> (Name -> Name) -> CoreRule -> CoreRule
+
+-- The subst_ru_fn argument is applied to substitute the ru_fn field
+-- of the rule:
+-- - Rules for *imported* Ids never change ru_fn
+-- - Rules for *local* Ids are in the IdInfo for that Id,
+-- and the ru_fn field is simply replaced by the new name
+-- of the Id
+substRule _ _ rule@(BuiltinRule {}) = rule
+substRule subst subst_ru_fn rule@(Rule { ru_bndrs = bndrs, ru_args = args
+ , ru_fn = fn_name, ru_rhs = rhs
+ , ru_local = is_local })
+ = rule { ru_bndrs = bndrs'
+ , ru_fn = if is_local
+ then subst_ru_fn fn_name
+ else fn_name
+ , ru_args = map (substExpr doc subst') args
+ , ru_rhs = substExpr (text "foo") subst' rhs }
+ -- Do NOT optimise the RHS (previously we did simplOptExpr here)
+ -- See Note [Substitute lazily]
+ where
+ doc = text "subst-rule" <+> ppr fn_name
+ (subst', bndrs') = substBndrs subst bndrs
+
+------------------
+substDVarSet :: Subst -> DVarSet -> DVarSet
+substDVarSet subst fvs
+ = mkDVarSet $ fst $ foldr (subst_fv subst) ([], emptyVarSet) $ dVarSetElems fvs
+ where
+ subst_fv subst fv acc
+ | isId fv = expr_fvs (lookupIdSubst (text "substDVarSet") subst fv) isLocalVar emptyVarSet $! acc
+ | otherwise = tyCoFVsOfType (lookupTCvSubst subst fv) (const True) emptyVarSet $! acc
+
+------------------
+substTickish :: Subst -> Tickish Id -> Tickish Id
+substTickish subst (Breakpoint n ids)
+ = Breakpoint n (map do_one ids)
+ where
+ do_one = getIdFromTrivialExpr . lookupIdSubst (text "subst_tickish") subst
+substTickish _subst other = other
+
+{- Note [Substitute lazily]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The functions that substitute over IdInfo must be pretty lazy, because
+they are knot-tied by substRecBndrs.
+
+One case in point was Trac #10627 in which a rule for a function 'f'
+referred to 'f' (at a differnet type) on the RHS. But instead of just
+substituting in the rhs of the rule, we were calling simpleOptExpr, which
+looked at the idInfo for 'f'; result <>.
+
+In any case we don't need to optimise the RHS of rules, or unfoldings,
+because the simplifier will do that.
+
+
+Note [substTickish]
+~~~~~~~~~~~~~~~~~~~~~~
+A Breakpoint contains a list of Ids. What happens if we ever want to
+substitute an expression for one of these Ids?
+
+First, we ensure that we only ever substitute trivial expressions for
+these Ids, by marking them as NoOccInfo in the occurrence analyser.
+Then, when substituting for the Id, we unwrap any type applications
+and abstractions to get back to an Id, with getIdFromTrivialExpr.
+
+Second, we have to ensure that we never try to substitute a literal
+for an Id in a breakpoint. We ensure this by never storing an Id with
+an unlifted type in a Breakpoint - see Coverage.mkTickish.
+Breakpoints can't handle free variables with unlifted types anyway.
+-}
+
+{-
+Note [Worker inlining]
+~~~~~~~~~~~~~~~~~~~~~~
+A worker can get sustituted away entirely.
+ - it might be trivial
+ - it might simply be very small
+We do not treat an InlWrapper as an 'occurrence' in the occurrence
+analyser, so it's possible that the worker is not even in scope any more.
+
+In all all these cases we simply drop the special case, returning to
+InlVanilla. The WARN is just so I can see if it happens a lot.
+-}
+
diff --git a/coreSyn/CoreSyn.hs b/coreSyn/CoreSyn.hs
new file mode 100644
--- /dev/null
+++ b/coreSyn/CoreSyn.hs
@@ -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 for this purpose,
+-- which is closely related to the simpler and better known System F .
+--
+-- We get from Haskell source to this Core language in a number of stages:
+--
+-- 1. The source code is parsed into an abstract syntax tree, which is represented
+-- by the data type 'HsExpr.HsExpr' with the names being 'RdrName.RdrNames'
+--
+-- 2. This syntax tree is /renamed/, which attaches a 'Unique.Unique' to every 'RdrName.RdrName'
+-- (yielding a 'Name.Name') to disambiguate identifiers which are lexically identical.
+-- For example, this program:
+--
+-- @
+-- f x = let f x = x + 1
+-- in f (x - 2)
+-- @
+--
+-- Would be renamed by having 'Unique's attached so it looked something like this:
+--
+-- @
+-- f_1 x_2 = let f_3 x_4 = x_4 + 1
+-- in f_3 (x_2 - 2)
+-- @
+-- But see Note [Shadowing] below.
+--
+-- 3. The resulting syntax tree undergoes type checking (which also deals with instantiating
+-- type class arguments) to yield a 'HsExpr.HsExpr' type that has 'Id.Id' as it's names.
+--
+-- 4. Finally the syntax tree is /desugared/ from the expressive 'HsExpr.HsExpr' type into
+-- this 'Expr' type, which has far fewer constructors and hence is easier to perform
+-- optimization, analysis and code generation on.
+--
+-- The type parameter @b@ is for the type of binders in the expression tree.
+--
+-- The language consists of the following elements:
+--
+-- * Variables
+--
+-- * Primitive literals
+--
+-- * Applications: note that the argument may be a 'Type'.
+-- See Note [CoreSyn let/app invariant]
+-- See Note [Levity polymorphism invariants]
+--
+-- * Lambda abstraction
+-- See Note [Levity polymorphism invariants]
+--
+-- * Recursive and non recursive @let@s. Operationally
+-- this corresponds to allocating a thunk for the things
+-- bound and then executing the sub-expression.
+--
+-- #top_level_invariant#
+-- #letrec_invariant#
+--
+-- The right hand sides of all top-level and recursive @let@s
+-- /must/ be of lifted type (see "Type#type_classification" for
+-- the meaning of /lifted/ vs. /unlifted/). There is one exception
+-- to this rule, top-level @let@s are allowed to bind primitive
+-- string literals, see Note [CoreSyn top-level string literals].
+--
+-- See Note [CoreSyn let/app invariant]
+-- See Note [Levity polymorphism invariants]
+--
+-- #type_let#
+-- We allow a /non-recursive/ let to bind a type variable, thus:
+--
+-- > Let (NonRec tv (Type ty)) body
+--
+-- This can be very convenient for postponing type substitutions until
+-- the next run of the simplifier.
+--
+-- At the moment, the rest of the compiler only deals with type-let
+-- in a Let expression, rather than at top level. We may want to revist
+-- this choice.
+--
+-- * Case expression. Operationally this corresponds to evaluating
+-- the scrutinee (expression examined) to weak head normal form
+-- and then examining at most one level of resulting constructor (i.e. you
+-- cannot do nested pattern matching directly with this).
+--
+-- The binder gets bound to the value of the scrutinee,
+-- and the 'Type' must be that of all the case alternatives
+--
+-- #case_invariants#
+-- This is one of the more complicated elements of the Core language,
+-- and comes with a number of restrictions:
+--
+-- 1. The list of alternatives may be empty;
+-- See Note [Empty case alternatives]
+--
+-- 2. The 'DEFAULT' case alternative must be first in the list,
+-- if it occurs at all.
+--
+-- 3. The remaining cases are in order of increasing
+-- tag (for 'DataAlts') or
+-- lit (for 'LitAlts').
+-- This makes finding the relevant constructor easy,
+-- and makes comparison easier too.
+--
+-- 4. The list of alternatives must be exhaustive. An /exhaustive/ case
+-- does not necessarily mention all constructors:
+--
+-- @
+-- data Foo = Red | Green | Blue
+-- ... case x of
+-- Red -> True
+-- other -> f (case x of
+-- Green -> ...
+-- Blue -> ... ) ...
+-- @
+--
+-- The inner case does not need a @Red@ alternative, because @x@
+-- can't be @Red@ at that program point.
+--
+-- 5. Floating-point values must not be scrutinised against literals.
+-- See Trac #9238 and Note [Rules for floating-point comparisons]
+-- in PrelRules for rationale.
+--
+-- * Cast an expression to a particular type.
+-- This is used to implement @newtype@s (a @newtype@ constructor or
+-- destructor just becomes a 'Cast' in Core) and GADTs.
+--
+-- * Notes. These allow general information to be added to expressions
+-- in the syntax tree
+--
+-- * A type: this should only show up at the top level of an Arg
+--
+-- * A coercion
+
+-- If you edit this type, you may need to update the GHC formalism
+-- See Note [GHC Formalism] in coreSyn/CoreLint.hs
+data Expr b
+ = Var Id
+ | Lit Literal
+ | App (Expr b) (Arg b)
+ | Lam b (Expr b)
+ | Let (Bind b) (Expr b)
+ | Case (Expr b) b Type [Alt b] -- See #case_invariants#
+ | Cast (Expr b) Coercion
+ | Tick (Tickish Id) (Expr b)
+ | Type Type
+ | Coercion Coercion
+ deriving Data
+
+-- | Type synonym for expressions that occur in function argument positions.
+-- Only 'Arg' should contain a 'Type' at top level, general 'Expr' should not
+type Arg b = Expr b
+
+-- | A case split alternative. Consists of the constructor leading to the alternative,
+-- the variables bound from the constructor, and the expression to be executed given that binding.
+-- The default alternative is @(DEFAULT, [], rhs)@
+
+-- If you edit this type, you may need to update the GHC formalism
+-- See Note [GHC Formalism] in coreSyn/CoreLint.hs
+type Alt b = (AltCon, [b], Expr b)
+
+-- | A case alternative constructor (i.e. pattern match)
+
+-- If you edit this type, you may need to update the GHC formalism
+-- See Note [GHC Formalism] in coreSyn/CoreLint.hs
+data AltCon
+ = DataAlt DataCon -- ^ A plain data constructor: @case e of { Foo x -> ... }@.
+ -- Invariant: the 'DataCon' is always from a @data@ type, and never from a @newtype@
+
+ | LitAlt Literal -- ^ A literal: @case e of { 1 -> ... }@
+ -- Invariant: always an *unlifted* literal
+ -- See Note [Literal alternatives]
+
+ | DEFAULT -- ^ Trivial alternative: @case e of { _ -> ... }@
+ deriving (Eq, Data)
+
+-- | Binding, used for top level bindings in a module and local bindings in a @let@.
+
+-- If you edit this type, you may need to update the GHC formalism
+-- See Note [GHC Formalism] in coreSyn/CoreLint.hs
+data Bind b = NonRec b (Expr b)
+ | Rec [(b, (Expr b))]
+ deriving Data
+
+{-
+Note [Shadowing]
+~~~~~~~~~~~~~~~~
+While various passes attempt to rename on-the-fly in a manner that
+avoids "shadowing" (thereby simplifying downstream optimizations),
+neither the simplifier nor any other pass GUARANTEES that shadowing is
+avoided. Thus, all passes SHOULD work fine even in the presence of
+arbitrary shadowing in their inputs.
+
+In particular, scrutinee variables `x` in expressions of the form
+`Case e x t` are often renamed to variables with a prefix
+"wild_". These "wild" variables may appear in the body of the
+case-expression, and further, may be shadowed within the body.
+
+So the Unique in an Var is not really unique at all. Still, it's very
+useful to give a constant-time equality/ordering for Vars, and to give
+a key that can be used to make sets of Vars (VarSet), or mappings from
+Vars to other things (VarEnv). Moreover, if you do want to eliminate
+shadowing, you can give a new Unique to an Id without changing its
+printable name, which makes debugging easier.
+
+Note [Literal alternatives]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Literal alternatives (LitAlt lit) are always for *un-lifted* literals.
+We have one literal, a literal Integer, that is lifted, and we don't
+allow in a LitAlt, because LitAlt cases don't do any evaluation. Also
+(see Trac #5603) if you say
+ case 3 of
+ S# x -> ...
+ J# _ _ -> ...
+(where S#, J# are the constructors for Integer) we don't want the
+simplifier calling findAlt with argument (LitAlt 3). No no. Integer
+literals are an opaque encoding of an algebraic data type, not of
+an unlifted literal, like all the others.
+
+Also, we do not permit case analysis with literal patterns on floating-point
+types. See Trac #9238 and Note [Rules for floating-point comparisons] in
+PrelRules for the rationale for this restriction.
+
+-------------------------- CoreSyn INVARIANTS ---------------------------
+
+Note [CoreSyn top-level invariant]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+See #toplevel_invariant#
+
+Note [CoreSyn letrec invariant]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+See #letrec_invariant#
+
+Note [CoreSyn top-level string literals]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+As an exception to the usual rule that top-level binders must be lifted,
+we allow binding primitive string literals (of type Addr#) of type Addr# at the
+top level. This allows us to share string literals earlier in the pipeline and
+crucially allows other optimizations in the Core2Core pipeline to fire.
+Consider,
+
+ f n = let a::Addr# = "foo"#
+ in \x -> blah
+
+In order to be able to inline `f`, we would like to float `a` to the top.
+Another option would be to inline `a`, but that would lead to duplicating string
+literals, which we want to avoid. See Trac #8472.
+
+The solution is simply to allow top-level unlifted binders. We can't allow
+arbitrary unlifted expression at the top-level though, unlifted binders cannot
+be thunks, so we just allow string literals.
+
+It is important to note that top-level primitive string literals cannot be
+wrapped in Ticks, as is otherwise done with lifted bindings. CoreToStg expects
+to see just a plain (Lit (MachStr ...)) expression on the RHS of primitive
+string bindings; anything else and things break. CoreLint checks this invariant.
+To ensure that ticks don't sneak in CoreUtils.mkTick refuses to wrap any
+primitve string expression with a tick.
+
+Also see Note [Compilation plan for top-level string literals].
+
+Note [Compilation plan for top-level string literals]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Here is a summary on how top-level string literals are handled by various
+parts of the compilation pipeline.
+
+* In the source language, there is no way to bind a primitive string literal
+ at the top leve.
+
+* In Core, we have a special rule that permits top-level Addr# bindings. See
+ Note [CoreSyn top-level string literals]. Core-to-core passes may introduce
+ new top-level string literals.
+
+* In STG, top-level string literals are explicitly represented in the syntax
+ tree.
+
+* A top-level string literal may end up exported from a module. In this case,
+ in the object file, the content of the exported literal is given a label with
+ the _bytes suffix.
+
+Note [CoreSyn let/app invariant]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The let/app invariant
+ the right hand side of a non-recursive 'Let', and
+ the argument of an 'App',
+ /may/ be of unlifted type, but only if
+ the expression is ok-for-speculation
+ or the 'Let' is for a join point.
+
+This means that the let can be floated around
+without difficulty. For example, this is OK:
+
+ y::Int# = x +# 1#
+
+But this is not, as it may affect termination if the
+expression is floated out:
+
+ y::Int# = fac 4#
+
+In this situation you should use @case@ rather than a @let@. The function
+'CoreUtils.needsCaseBinding' can help you determine which to generate, or
+alternatively use 'MkCore.mkCoreLet' rather than this constructor directly,
+which will generate a @case@ if necessary
+
+The let/app invariant is initially enforced by mkCoreLet and mkCoreApp in
+coreSyn/MkCore.
+
+Note [CoreSyn case invariants]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+See #case_invariants#
+
+Note [Levity polymorphism invariants]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The levity-polymorphism invariants are these:
+
+* The type of a term-binder must not be levity-polymorphic,
+ unless it is a let(rec)-bound join point
+ (see Note [Invariants on join points])
+
+* The type of the argument of an App must not be levity-polymorphic.
+
+A type (t::TYPE r) is "levity polymorphic" if 'r' has any free variables.
+
+For example
+ \(r::RuntimeRep). \(a::TYPE r). \(x::a). e
+is illegal because x's type has kind (TYPE r), which has 'r' free.
+
+See Note [Levity polymorphism checking] in DsMonad to see where these
+invariants are established for user-written code.
+
+Note [CoreSyn let goal]
+~~~~~~~~~~~~~~~~~~~~~~~
+* The simplifier tries to ensure that if the RHS of a let is a constructor
+ application, its arguments are trivial, so that the constructor can be
+ inlined vigorously.
+
+Note [Type let]
+~~~~~~~~~~~~~~~
+See #type_let#
+
+Note [Empty case alternatives]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The alternatives of a case expression should be exhaustive. But
+this exhaustive list can be empty!
+
+* A case expression can have empty alternatives if (and only if) the
+ scrutinee is bound to raise an exception or diverge. When do we know
+ this? See Note [Bottoming expressions] in CoreUtils.
+
+* The possiblity of empty alternatives is one reason we need a type on
+ the case expression: if the alternatives are empty we can't get the
+ type from the alternatives!
+
+* In the case of empty types (see Note [Bottoming expressions]), say
+ data T
+ we do NOT want to replace
+ case (x::T) of Bool {} --> error Bool "Inaccessible case"
+ because x might raise an exception, and *that*'s what we want to see!
+ (Trac #6067 is an example.) To preserve semantics we'd have to say
+ x `seq` error Bool "Inaccessible case"
+ but the 'seq' is just a case, so we are back to square 1. Or I suppose
+ we could say
+ x |> UnsafeCoerce T Bool
+ but that loses all trace of the fact that this originated with an empty
+ set of alternatives.
+
+* We can use the empty-alternative construct to coerce error values from
+ one type to another. For example
+
+ f :: Int -> Int
+ f n = error "urk"
+
+ g :: Int -> (# Char, Bool #)
+ g x = case f x of { 0 -> ..., n -> ... }
+
+ Then if we inline f in g's RHS we get
+ case (error Int "urk") of (# Char, Bool #) { ... }
+ and we can discard the alternatives since the scrutinee is bottom to give
+ case (error Int "urk") of (# Char, Bool #) {}
+
+ This is nicer than using an unsafe coerce between Int ~ (# Char,Bool #),
+ if for no other reason that we don't need to instantiate the (~) at an
+ unboxed type.
+
+* We treat a case expression with empty alternatives as trivial iff
+ its scrutinee is (see CoreUtils.exprIsTrivial). This is actually
+ important; see Note [Empty case is trivial] in CoreUtils
+
+* An empty case is replaced by its scrutinee during the CoreToStg
+ conversion; remember STG is un-typed, so there is no need for
+ the empty case to do the type conversion.
+
+Note [Join points]
+~~~~~~~~~~~~~~~~~~
+In Core, a *join point* is a specially tagged function whose only occurrences
+are saturated tail calls. A tail call can appear in these places:
+
+ 1. In the branches (not the scrutinee) of a case
+ 2. Underneath a let (value or join point)
+ 3. Inside another join point
+
+We write a join-point declaration as
+ join j @a @b x y = e1 in e2,
+like a let binding but with "join" instead (or "join rec" for "let rec"). Note
+that we put the parameters before the = rather than using lambdas; this is
+because it's relevant how many parameters the join point takes *as a join
+point.* This number is called the *join arity,* distinct from arity because it
+counts types as well as values. Note that a join point may return a lambda! So
+ join j x = x + 1
+is different from
+ join j = \x -> x + 1
+The former has join arity 1, while the latter has join arity 0.
+
+The identifier for a join point is called a join id or a *label.* An invocation
+is called a *jump.* We write a jump using the jump keyword:
+
+ jump j 3
+
+The words *label* and *jump* are evocative of assembly code (or Cmm) for a
+reason: join points are indeed compiled as labeled blocks, and jumps become
+actual jumps (plus argument passing and stack adjustment). There is no closure
+allocated and only a fraction of the function-call overhead. Hence we would
+like as many functions as possible to become join points (see OccurAnal) and
+the type rules for join points ensure we preserve the properties that make them
+efficient.
+
+In the actual AST, a join point is indicated by the IdDetails of the binder: a
+local value binding gets 'VanillaId' but a join point gets a 'JoinId' with its
+join arity.
+
+For more details, see the paper:
+
+ Luke Maurer, Paul Downen, Zena Ariola, and Simon Peyton Jones. "Compiling
+ without continuations." Submitted to PLDI'17.
+
+ https://www.microsoft.com/en-us/research/publication/compiling-without-continuations/
+
+Note [Invariants on join points]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Join points must follow these invariants:
+
+ 1. All occurrences must be tail calls. Each of these tail calls must pass the
+ same number of arguments, counting both types and values; we call this the
+ "join arity" (to distinguish from regular arity, which only counts values).
+
+ 2. For join arity n, the right-hand side must begin with at least n lambdas.
+ No ticks, no casts, just lambdas! C.f. CoreUtils.joinRhsArity.
+
+ 2a. Moreover, this same constraint applies to any unfolding of the binder.
+ Reason: if we want to push a continuation into the RHS we must push it
+ into the unfolding as well.
+
+ 3. If the binding is recursive, then all other bindings in the recursive group
+ must also be join points.
+
+ 4. The binding's type must not be polymorphic in its return type (as defined
+ in Note [The polymorphism rule of join points]).
+
+However, join points have simpler invariants in other ways
+
+ 5. A join point can have an unboxed type without the RHS being
+ ok-for-speculation (i.e. drop the let/app invariant)
+ e.g. let j :: Int# = factorial x in ...
+
+ 6. A join point can have a levity-polymorphic RHS
+ e.g. let j :: r :: TYPE l = fail void# in ...
+ This happened in an intermediate program Trac #13394
+
+Examples:
+
+ join j1 x = 1 + x in jump j (jump j x) -- Fails 1: non-tail call
+ join j1' x = 1 + x in if even a
+ then jump j1 a
+ else jump j1 a b -- Fails 1: inconsistent calls
+ join j2 x = flip (+) x in j2 1 2 -- Fails 2: not enough lambdas
+ join j2' x = \y -> x + y in j3 1 -- Passes: extra lams ok
+ join j @a (x :: a) = x -- Fails 4: polymorphic in ret type
+
+Invariant 1 applies to left-hand sides of rewrite rules, so a rule for a join
+point must have an exact call as its LHS.
+
+Strictly speaking, invariant 3 is redundant, since a call from inside a lazy
+binding isn't a tail call. Since a let-bound value can't invoke a free join
+point, then, they can't be mutually recursive. (A Core binding group *can*
+include spurious extra bindings if the occurrence analyser hasn't run, so
+invariant 3 does still need to be checked.) For the rigorous definition of
+"tail call", see Section 3 of the paper (Note [Join points]).
+
+Invariant 4 is subtle; see Note [The polymorphism rule of join points].
+
+Core Lint will check these invariants, anticipating that any binder whose
+OccInfo is marked AlwaysTailCalled will become a join point as soon as the
+simplifier (or simpleOptPgm) runs.
+
+Note [The type of a join point]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+A join point has the same type it would have as a function. That is, if it takes
+an Int and a Bool and its body produces a String, its type is `Int -> Bool ->
+String`. Natural as this may seem, it can be awkward. A join point shouldn't be
+thought to "return" in the same sense a function does---a jump is one-way. This
+is crucial for understanding how case-of-case interacts with join points:
+
+ case (join
+ j :: Int -> Bool -> String
+ j x y = ...
+ in
+ jump j z w) of
+ "" -> True
+ _ -> False
+
+The simplifier will pull the case into the join point (see Note [Case-of-case
+and join points] in Simplify):
+
+ join
+ j :: Int -> Bool -> Bool -- changed!
+ j x y = case ... of "" -> True
+ _ -> False
+ in
+ jump j z w
+
+The body of the join point now returns a Bool, so the label `j` has to have its
+type updated accordingly. Inconvenient though this may be, it has the advantage
+that 'CoreUtils.exprType' can still return a type for any expression, including
+a jump.
+
+This differs from the paper (see Note [Invariants on join points]). In the
+paper, we instead give j the type `Int -> Bool -> forall a. a`. Then each jump
+carries the "return type" as a parameter, exactly the way other non-returning
+functions like `error` work:
+
+ case (join
+ j :: Int -> Bool -> forall a. a
+ j x y = ...
+ in
+ jump j z w @String) of
+ "" -> True
+ _ -> False
+
+Now we can move the case inward and we only have to change the jump:
+
+ join
+ j :: Int -> Bool -> forall a. a
+ j x y = case ... of "" -> True
+ _ -> False
+ in
+ jump j z w @Bool
+
+(Core Lint would still check that the body of the join point has the right type;
+that type would simply not be reflected in the join id.)
+
+Note [The polymorphism rule of join points]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Invariant 4 of Note [Invariants on join points] forbids a join point to be
+polymorphic in its return type. That is, if its type is
+
+ forall a1 ... ak. t1 -> ... -> tn -> r
+
+where its join arity is k+n, none of the type parameters ai may occur free in r.
+The most direct explanation is that given
+
+ join j @a1 ... @ak x1 ... xn = e1 in e2
+
+our typing rules require `e1` and `e2` to have the same type. Therefore the type
+of `e1`---the return type of the join point---must be the same as the type of
+e2. Since the type variables aren't bound in `e2`, its type can't include them,
+and thus neither can the type of `e1`.
+
+There's a deeper explanation in terms of the sequent calculus in Section 5.3 of
+a previous paper:
+
+ Paul Downen, Luke Maurer, Zena Ariola, and Simon Peyton Jones. "Sequent
+ calculus as a compiler intermediate language." ICFP'16.
+
+ https://www.microsoft.com/en-us/research/wp-content/uploads/2016/04/sequent-calculus-icfp16.pdf
+
+The quick version: Consider the CPS term (the paper uses the sequent calculus,
+but we can translate readily):
+
+ \k -> join j @a1 ... @ak x1 ... xn = e1 k in e2 k
+
+Since `j` is a join point, it doesn't bind a continuation variable but reuses
+the variable `k` from the context. But the parameters `ai` are not in `k`'s
+scope, and `k`'s type determines the return type of `j`; thus the `ai`s don't
+appear in the return type of `j`. (Also, since `e1` and `e2` are passed the same
+continuation, they must have the same type; hence the direct explanation above.)
+
+************************************************************************
+* *
+ In/Out type synonyms
+* *
+********************************************************************* -}
+
+{- Many passes apply a substitution, and it's very handy to have type
+ synonyms to remind us whether or not the substitution has been applied -}
+
+-- Pre-cloning or substitution
+type InBndr = CoreBndr
+type InType = Type
+type InKind = Kind
+type InBind = CoreBind
+type InExpr = CoreExpr
+type InAlt = CoreAlt
+type InArg = CoreArg
+type InCoercion = Coercion
+
+-- Post-cloning or substitution
+type OutBndr = CoreBndr
+type OutType = Type
+type OutKind = Kind
+type OutCoercion = Coercion
+type OutBind = CoreBind
+type OutExpr = CoreExpr
+type OutAlt = CoreAlt
+type OutArg = CoreArg
+
+
+{- *********************************************************************
+* *
+ Ticks
+* *
+************************************************************************
+-}
+
+-- | Allows attaching extra information to points in expressions
+
+-- If you edit this type, you may need to update the GHC formalism
+-- See Note [GHC Formalism] in coreSyn/CoreLint.hs
+data Tickish id =
+ -- | An @{-# SCC #-}@ profiling annotation, either automatically
+ -- added by the desugarer as a result of -auto-all, or added by
+ -- the user.
+ ProfNote {
+ profNoteCC :: CostCentre, -- ^ the cost centre
+ profNoteCount :: !Bool, -- ^ bump the entry count?
+ profNoteScope :: !Bool -- ^ scopes over the enclosed expression
+ -- (i.e. not just a tick)
+ }
+
+ -- | A "tick" used by HPC to track the execution of each
+ -- subexpression in the original source code.
+ | HpcTick {
+ tickModule :: Module,
+ tickId :: !Int
+ }
+
+ -- | A breakpoint for the GHCi debugger. This behaves like an HPC
+ -- tick, but has a list of free variables which will be available
+ -- for inspection in GHCi when the program stops at the breakpoint.
+ --
+ -- NB. we must take account of these Ids when (a) counting free variables,
+ -- and (b) substituting (don't substitute for them)
+ | Breakpoint
+ { breakpointId :: !Int
+ , breakpointFVs :: [id] -- ^ the order of this list is important:
+ -- it matches the order of the lists in the
+ -- appropriate entry in HscTypes.ModBreaks.
+ --
+ -- Careful about substitution! See
+ -- Note [substTickish] in CoreSubst.
+ }
+
+ -- | A source note.
+ --
+ -- Source notes are pure annotations: Their presence should neither
+ -- influence compilation nor execution. The semantics are given by
+ -- causality: The presence of a source note means that a local
+ -- change in the referenced source code span will possibly provoke
+ -- the generated code to change. On the flip-side, the functionality
+ -- of annotated code *must* be invariant against changes to all
+ -- source code *except* the spans referenced in the source notes
+ -- (see "Causality of optimized Haskell" paper for details).
+ --
+ -- Therefore extending the scope of any given source note is always
+ -- valid. Note that it is still undesirable though, as this reduces
+ -- their usefulness for debugging and profiling. Therefore we will
+ -- generally try only to make use of this property where it is
+ -- necessary to enable optimizations.
+ | SourceNote
+ { sourceSpan :: RealSrcSpan -- ^ Source covered
+ , sourceName :: String -- ^ Name for source location
+ -- (uses same names as CCs)
+ }
+
+ deriving (Eq, Ord, Data)
+
+-- | A "counting tick" (where tickishCounts is True) is one that
+-- counts evaluations in some way. We cannot discard a counting tick,
+-- and the compiler should preserve the number of counting ticks as
+-- far as possible.
+--
+-- However, we still allow the simplifier to increase or decrease
+-- sharing, so in practice the actual number of ticks may vary, except
+-- that we never change the value from zero to non-zero or vice versa.
+tickishCounts :: Tickish id -> Bool
+tickishCounts n@ProfNote{} = profNoteCount n
+tickishCounts HpcTick{} = True
+tickishCounts Breakpoint{} = True
+tickishCounts _ = False
+
+
+-- | Specifies the scoping behaviour of ticks. This governs the
+-- behaviour of ticks that care about the covered code and the cost
+-- associated with it. Important for ticks relating to profiling.
+data TickishScoping =
+ -- | No scoping: The tick does not care about what code it
+ -- covers. Transformations can freely move code inside as well as
+ -- outside without any additional annotation obligations
+ NoScope
+
+ -- | Soft scoping: We want all code that is covered to stay
+ -- covered. Note that this scope type does not forbid
+ -- transformations from happening, as as long as all results of
+ -- the transformations are still covered by this tick or a copy of
+ -- it. For example
+ --
+ -- let x = tick<...> (let y = foo in bar) in baz
+ -- ===>
+ -- let x = tick<...> bar; y = tick<...> foo in baz
+ --
+ -- Is a valid transformation as far as "bar" and "foo" is
+ -- concerned, because both still are scoped over by the tick.
+ --
+ -- Note though that one might object to the "let" not being
+ -- covered by the tick any more. However, we are generally lax
+ -- with this - constant costs don't matter too much, and given
+ -- that the "let" was effectively merged we can view it as having
+ -- lost its identity anyway.
+ --
+ -- Also note that this scoping behaviour allows floating a tick
+ -- "upwards" in pretty much any situation. For example:
+ --
+ -- case foo of x -> tick<...> bar
+ -- ==>
+ -- tick<...> case foo of x -> bar
+ --
+ -- While this is always leagl, we want to make a best effort to
+ -- only make us of this where it exposes transformation
+ -- opportunities.
+ | SoftScope
+
+ -- | Cost centre scoping: We don't want any costs to move to other
+ -- cost-centre stacks. This means we not only want no code or cost
+ -- to get moved out of their cost centres, but we also object to
+ -- code getting associated with new cost-centre ticks - or
+ -- changing the order in which they get applied.
+ --
+ -- A rule of thumb is that we don't want any code to gain new
+ -- annotations. However, there are notable exceptions, for
+ -- example:
+ --
+ -- let f = \y -> foo in tick<...> ... (f x) ...
+ -- ==>
+ -- tick<...> ... foo[x/y] ...
+ --
+ -- In-lining lambdas like this is always legal, because inlining a
+ -- function does not change the cost-centre stack when the
+ -- function is called.
+ | CostCentreScope
+
+ deriving (Eq)
+
+-- | Returns the intended scoping rule for a Tickish
+tickishScoped :: Tickish id -> TickishScoping
+tickishScoped n@ProfNote{}
+ | profNoteScope n = CostCentreScope
+ | otherwise = NoScope
+tickishScoped HpcTick{} = NoScope
+tickishScoped Breakpoint{} = CostCentreScope
+ -- Breakpoints are scoped: eventually we're going to do call
+ -- stacks, but also this helps prevent the simplifier from moving
+ -- breakpoints around and changing their result type (see #1531).
+tickishScoped SourceNote{} = SoftScope
+
+-- | Returns whether the tick scoping rule is at least as permissive
+-- as the given scoping rule.
+tickishScopesLike :: Tickish id -> TickishScoping -> Bool
+tickishScopesLike t scope = tickishScoped t `like` scope
+ where NoScope `like` _ = True
+ _ `like` NoScope = False
+ SoftScope `like` _ = True
+ _ `like` SoftScope = False
+ CostCentreScope `like` _ = True
+
+-- | Returns @True@ for ticks that can be floated upwards easily even
+-- where it might change execution counts, such as:
+--
+-- Just (tick<...> foo)
+-- ==>
+-- tick<...> (Just foo)
+--
+-- This is a combination of @tickishSoftScope@ and
+-- @tickishCounts@. Note that in principle splittable ticks can become
+-- floatable using @mkNoTick@ -- even though there's currently no
+-- tickish for which that is the case.
+tickishFloatable :: Tickish id -> Bool
+tickishFloatable t = t `tickishScopesLike` SoftScope && not (tickishCounts t)
+
+-- | Returns @True@ for a tick that is both counting /and/ scoping and
+-- can be split into its (tick, scope) parts using 'mkNoScope' and
+-- 'mkNoTick' respectively.
+tickishCanSplit :: Tickish id -> Bool
+tickishCanSplit ProfNote{profNoteScope = True, profNoteCount = True}
+ = True
+tickishCanSplit _ = False
+
+mkNoCount :: Tickish id -> Tickish id
+mkNoCount n | not (tickishCounts n) = n
+ | not (tickishCanSplit n) = panic "mkNoCount: Cannot split!"
+mkNoCount n@ProfNote{} = n {profNoteCount = False}
+mkNoCount _ = panic "mkNoCount: Undefined split!"
+
+mkNoScope :: Tickish id -> Tickish id
+mkNoScope n | tickishScoped n == NoScope = n
+ | not (tickishCanSplit n) = panic "mkNoScope: Cannot split!"
+mkNoScope n@ProfNote{} = n {profNoteScope = False}
+mkNoScope _ = panic "mkNoScope: Undefined split!"
+
+-- | Return @True@ if this source annotation compiles to some backend
+-- code. Without this flag, the tickish is seen as a simple annotation
+-- that does not have any associated evaluation code.
+--
+-- What this means that we are allowed to disregard the tick if doing
+-- so means that we can skip generating any code in the first place. A
+-- typical example is top-level bindings:
+--
+-- foo = tick<...> \y -> ...
+-- ==>
+-- foo = \y -> tick<...> ...
+--
+-- Here there is just no operational difference between the first and
+-- the second version. Therefore code generation should simply
+-- translate the code as if it found the latter.
+tickishIsCode :: Tickish id -> Bool
+tickishIsCode SourceNote{} = False
+tickishIsCode _tickish = True -- all the rest for now
+
+
+-- | Governs the kind of expression that the tick gets placed on when
+-- annotating for example using @mkTick@. If we find that we want to
+-- put a tickish on an expression ruled out here, we try to float it
+-- inwards until we find a suitable expression.
+data TickishPlacement =
+
+ -- | Place ticks exactly on run-time expressions. We can still
+ -- move the tick through pure compile-time constructs such as
+ -- other ticks, casts or type lambdas. This is the most
+ -- restrictive placement rule for ticks, as all tickishs have in
+ -- common that they want to track runtime processes. The only
+ -- legal placement rule for counting ticks.
+ PlaceRuntime
+
+ -- | As @PlaceRuntime@, but we float the tick through all
+ -- lambdas. This makes sense where there is little difference
+ -- between annotating the lambda and annotating the lambda's code.
+ | PlaceNonLam
+
+ -- | In addition to floating through lambdas, cost-centre style
+ -- tickishs can also be moved from constructors, non-function
+ -- variables and literals. For example:
+ --
+ -- let x = scc<...> C (scc<...> y) (scc<...> 3) in ...
+ --
+ -- Neither the constructor application, the variable or the
+ -- literal are likely to have any cost worth mentioning. And even
+ -- if y names a thunk, the call would not care about the
+ -- evaluation context. Therefore removing all annotations in the
+ -- above example is safe.
+ | PlaceCostCentre
+
+ deriving (Eq)
+
+-- | Placement behaviour we want for the ticks
+tickishPlace :: Tickish id -> TickishPlacement
+tickishPlace n@ProfNote{}
+ | profNoteCount n = PlaceRuntime
+ | otherwise = PlaceCostCentre
+tickishPlace HpcTick{} = PlaceRuntime
+tickishPlace Breakpoint{} = PlaceRuntime
+tickishPlace SourceNote{} = PlaceNonLam
+
+-- | Returns whether one tick "contains" the other one, therefore
+-- making the second tick redundant.
+tickishContains :: Eq b => Tickish b -> Tickish b -> Bool
+tickishContains (SourceNote sp1 n1) (SourceNote sp2 n2)
+ = containsSpan sp1 sp2 && n1 == n2
+ -- compare the String last
+tickishContains t1 t2
+ = t1 == t2
+
+{-
+************************************************************************
+* *
+ Orphans
+* *
+************************************************************************
+-}
+
+-- | Is this instance an orphan? If it is not an orphan, contains an 'OccName'
+-- witnessing the instance's non-orphanhood.
+-- See Note [Orphans]
+data IsOrphan
+ = IsOrphan
+ | NotOrphan OccName -- The OccName 'n' witnesses the instance's non-orphanhood
+ -- In that case, the instance is fingerprinted as part
+ -- of the definition of 'n's definition
+ deriving Data
+
+-- | Returns true if 'IsOrphan' is orphan.
+isOrphan :: IsOrphan -> Bool
+isOrphan IsOrphan = True
+isOrphan _ = False
+
+-- | Returns true if 'IsOrphan' is not an orphan.
+notOrphan :: IsOrphan -> Bool
+notOrphan NotOrphan{} = True
+notOrphan _ = False
+
+chooseOrphanAnchor :: NameSet -> IsOrphan
+-- Something (rule, instance) is relate to all the Names in this
+-- list. Choose one of them to be an "anchor" for the orphan. We make
+-- the choice deterministic to avoid gratuitious changes in the ABI
+-- hash (Trac #4012). Specifically, use lexicographic comparison of
+-- OccName rather than comparing Uniques
+--
+-- NB: 'minimum' use Ord, and (Ord OccName) works lexicographically
+--
+chooseOrphanAnchor local_names
+ | isEmptyNameSet local_names = IsOrphan
+ | otherwise = NotOrphan (minimum occs)
+ where
+ occs = map nameOccName $ nonDetEltsUniqSet local_names
+ -- It's OK to use nonDetEltsUFM here, see comments above
+
+instance Binary IsOrphan where
+ put_ bh IsOrphan = putByte bh 0
+ put_ bh (NotOrphan n) = do
+ putByte bh 1
+ put_ bh n
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> return IsOrphan
+ _ -> do
+ n <- get bh
+ return $ NotOrphan n
+
+{-
+Note [Orphans]
+~~~~~~~~~~~~~~
+Class instances, rules, and family instances are divided into orphans
+and non-orphans. Roughly speaking, an instance/rule is an orphan if
+its left hand side mentions nothing defined in this module. Orphan-hood
+has two major consequences
+
+ * A module that contains orphans is called an "orphan module". If
+ the module being compiled depends (transitively) on an oprhan
+ module M, then M.hi is read in regardless of whether M is oherwise
+ needed. This is to ensure that we don't miss any instance decls in
+ M. But it's painful, because it means we need to keep track of all
+ the orphan modules below us.
+
+ * A non-orphan is not finger-printed separately. Instead, for
+ fingerprinting purposes it is treated as part of the entity it
+ mentions on the LHS. For example
+ data T = T1 | T2
+ instance Eq T where ....
+ The instance (Eq T) is incorprated as part of T's fingerprint.
+
+ In contrast, orphans are all fingerprinted together in the
+ mi_orph_hash field of the ModIface.
+
+ See MkIface.addFingerprints.
+
+Orphan-hood is computed
+ * For class instances:
+ when we make a ClsInst
+ (because it is needed during instance lookup)
+
+ * For rules and family instances:
+ when we generate an IfaceRule (MkIface.coreRuleToIfaceRule)
+ or IfaceFamInst (MkIface.instanceToIfaceInst)
+-}
+
+{-
+************************************************************************
+* *
+\subsection{Transformation rules}
+* *
+************************************************************************
+
+The CoreRule type and its friends are dealt with mainly in CoreRules,
+but CoreFVs, Subst, PprCore, CoreTidy also inspect the representation.
+-}
+
+-- | Gathers a collection of 'CoreRule's. Maps (the name of) an 'Id' to its rules
+type RuleBase = NameEnv [CoreRule]
+ -- The rules are unordered;
+ -- we sort out any overlaps on lookup
+
+-- | A full rule environment which we can apply rules from. Like a 'RuleBase',
+-- but it also includes the set of visible orphans we use to filter out orphan
+-- rules which are not visible (even though we can see them...)
+data RuleEnv
+ = RuleEnv { re_base :: RuleBase
+ , re_visible_orphs :: ModuleSet
+ }
+
+mkRuleEnv :: RuleBase -> [Module] -> RuleEnv
+mkRuleEnv rules vis_orphs = RuleEnv rules (mkModuleSet vis_orphs)
+
+emptyRuleEnv :: RuleEnv
+emptyRuleEnv = RuleEnv emptyNameEnv emptyModuleSet
+
+-- | A 'CoreRule' is:
+--
+-- * \"Local\" if the function it is a rule for is defined in the
+-- same module as the rule itself.
+--
+-- * \"Orphan\" if nothing on the LHS is defined in the same module
+-- as the rule itself
+data CoreRule
+ = Rule {
+ ru_name :: RuleName, -- ^ Name of the rule, for communication with the user
+ ru_act :: Activation, -- ^ When the rule is active
+
+ -- Rough-matching stuff
+ -- see comments with InstEnv.ClsInst( is_cls, is_rough )
+ ru_fn :: Name, -- ^ Name of the 'Id.Id' at the head of this rule
+ ru_rough :: [Maybe Name], -- ^ Name at the head of each argument to the left hand side
+
+ -- Proper-matching stuff
+ -- see comments with InstEnv.ClsInst( is_tvs, is_tys )
+ ru_bndrs :: [CoreBndr], -- ^ Variables quantified over
+ ru_args :: [CoreExpr], -- ^ Left hand side arguments
+
+ -- And the right-hand side
+ ru_rhs :: CoreExpr, -- ^ Right hand side of the rule
+ -- Occurrence info is guaranteed correct
+ -- See Note [OccInfo in unfoldings and rules]
+
+ -- Locality
+ ru_auto :: Bool, -- ^ @True@ <=> this rule is auto-generated
+ -- (notably by Specialise or SpecConstr)
+ -- @False@ <=> generated at the user's behest
+ -- See Note [Trimming auto-rules] in TidyPgm
+ -- for the sole purpose of this field.
+
+ ru_origin :: !Module, -- ^ 'Module' the rule was defined in, used
+ -- to test if we should see an orphan rule.
+
+ ru_orphan :: !IsOrphan, -- ^ Whether or not the rule is an orphan.
+
+ ru_local :: Bool -- ^ @True@ iff the fn at the head of the rule is
+ -- defined in the same module as the rule
+ -- and is not an implicit 'Id' (like a record selector,
+ -- class operation, or data constructor). This
+ -- is different from 'ru_orphan', where a rule
+ -- can avoid being an orphan if *any* Name in
+ -- LHS of the rule was defined in the same
+ -- module as the rule.
+ }
+
+ -- | Built-in rules are used for constant folding
+ -- and suchlike. They have no free variables.
+ -- A built-in rule is always visible (there is no such thing as
+ -- an orphan built-in rule.)
+ | BuiltinRule {
+ ru_name :: RuleName, -- ^ As above
+ ru_fn :: Name, -- ^ As above
+ ru_nargs :: Int, -- ^ Number of arguments that 'ru_try' consumes,
+ -- if it fires, including type arguments
+ ru_try :: RuleFun
+ -- ^ This function does the rewrite. It given too many
+ -- arguments, it simply discards them; the returned 'CoreExpr'
+ -- is just the rewrite of 'ru_fn' applied to the first 'ru_nargs' args
+ }
+ -- See Note [Extra args in rule matching] in Rules.hs
+
+type RuleFun = DynFlags -> InScopeEnv -> Id -> [CoreExpr] -> Maybe CoreExpr
+type InScopeEnv = (InScopeSet, IdUnfoldingFun)
+
+type IdUnfoldingFun = Id -> Unfolding
+-- A function that embodies how to unfold an Id if you need
+-- to do that in the Rule. The reason we need to pass this info in
+-- is that whether an Id is unfoldable depends on the simplifier phase
+
+isBuiltinRule :: CoreRule -> Bool
+isBuiltinRule (BuiltinRule {}) = True
+isBuiltinRule _ = False
+
+isAutoRule :: CoreRule -> Bool
+isAutoRule (BuiltinRule {}) = False
+isAutoRule (Rule { ru_auto = is_auto }) = is_auto
+
+-- | The number of arguments the 'ru_fn' must be applied
+-- to before the rule can match on it
+ruleArity :: CoreRule -> Int
+ruleArity (BuiltinRule {ru_nargs = n}) = n
+ruleArity (Rule {ru_args = args}) = length args
+
+ruleName :: CoreRule -> RuleName
+ruleName = ru_name
+
+ruleModule :: CoreRule -> Maybe Module
+ruleModule Rule { ru_origin } = Just ru_origin
+ruleModule BuiltinRule {} = Nothing
+
+ruleActivation :: CoreRule -> Activation
+ruleActivation (BuiltinRule { }) = AlwaysActive
+ruleActivation (Rule { ru_act = act }) = act
+
+-- | The 'Name' of the 'Id.Id' at the head of the rule left hand side
+ruleIdName :: CoreRule -> Name
+ruleIdName = ru_fn
+
+isLocalRule :: CoreRule -> Bool
+isLocalRule = ru_local
+
+-- | Set the 'Name' of the 'Id.Id' at the head of the rule left hand side
+setRuleIdName :: Name -> CoreRule -> CoreRule
+setRuleIdName nm ru = ru { ru_fn = nm }
+
+{-
+************************************************************************
+* *
+\subsection{Vectorisation declarations}
+* *
+************************************************************************
+
+Representation of desugared vectorisation declarations that are fed to the vectoriser (via
+'ModGuts').
+-}
+
+data CoreVect = Vect Id CoreExpr
+ | NoVect Id
+ | VectType Bool TyCon (Maybe TyCon)
+ | VectClass TyCon -- class tycon
+ | VectInst Id -- instance dfun (always SCALAR) !!!FIXME: should be superfluous now
+
+{-
+************************************************************************
+* *
+ Unfoldings
+* *
+************************************************************************
+
+The @Unfolding@ type is declared here to avoid numerous loops
+-}
+
+-- | Records the /unfolding/ of an identifier, which is approximately the form the
+-- identifier would have if we substituted its definition in for the identifier.
+-- This type should be treated as abstract everywhere except in "CoreUnfold"
+data Unfolding
+ = NoUnfolding -- ^ We have no information about the unfolding.
+
+ | BootUnfolding -- ^ We have no information about the unfolding, because
+ -- this 'Id' came from an @hi-boot@ file.
+ -- See Note [Inlining and hs-boot files] in ToIface
+ -- for what this is used for.
+
+ | OtherCon [AltCon] -- ^ It ain't one of these constructors.
+ -- @OtherCon xs@ also indicates that something has been evaluated
+ -- and hence there's no point in re-evaluating it.
+ -- @OtherCon []@ is used even for non-data-type values
+ -- to indicated evaluated-ness. Notably:
+ --
+ -- > data C = C !(Int -> Int)
+ -- > case x of { C f -> ... }
+ --
+ -- Here, @f@ gets an @OtherCon []@ unfolding.
+
+ | DFunUnfolding { -- The Unfolding of a DFunId
+ -- See Note [DFun unfoldings]
+ -- df = /\a1..am. \d1..dn. MkD t1 .. tk
+ -- (op1 a1..am d1..dn)
+ -- (op2 a1..am d1..dn)
+ df_bndrs :: [Var], -- The bound variables [a1..m],[d1..dn]
+ df_con :: DataCon, -- The dictionary data constructor (never a newtype datacon)
+ df_args :: [CoreExpr] -- Args of the data con: types, superclasses and methods,
+ } -- in positional order
+
+ | CoreUnfolding { -- An unfolding for an Id with no pragma,
+ -- or perhaps a NOINLINE pragma
+ -- (For NOINLINE, the phase, if any, is in the
+ -- InlinePragInfo for this Id.)
+ uf_tmpl :: CoreExpr, -- Template; occurrence info is correct
+ uf_src :: UnfoldingSource, -- Where the unfolding came from
+ uf_is_top :: Bool, -- True <=> top level binding
+ uf_is_value :: Bool, -- exprIsHNF template (cached); it is ok to discard
+ -- a `seq` on this variable
+ uf_is_conlike :: Bool, -- True <=> applicn of constructor or CONLIKE function
+ -- Cached version of exprIsConLike
+ uf_is_work_free :: Bool, -- True <=> doesn't waste (much) work to expand
+ -- inside an inlining
+ -- Cached version of exprIsCheap
+ uf_expandable :: Bool, -- True <=> can expand in RULE matching
+ -- Cached version of exprIsExpandable
+ uf_guidance :: UnfoldingGuidance -- Tells about the *size* of the template.
+ }
+ -- ^ An unfolding with redundant cached information. Parameters:
+ --
+ -- uf_tmpl: Template used to perform unfolding;
+ -- NB: Occurrence info is guaranteed correct:
+ -- see Note [OccInfo in unfoldings and rules]
+ --
+ -- uf_is_top: Is this a top level binding?
+ --
+ -- uf_is_value: 'exprIsHNF' template (cached); it is ok to discard a 'seq' on
+ -- this variable
+ --
+ -- uf_is_work_free: Does this waste only a little work if we expand it inside an inlining?
+ -- Basically this is a cached version of 'exprIsWorkFree'
+ --
+ -- uf_guidance: Tells us about the /size/ of the unfolding template
+
+
+------------------------------------------------
+data UnfoldingSource
+ = -- See also Note [Historical note: unfoldings for wrappers]
+
+ InlineRhs -- The current rhs of the function
+ -- Replace uf_tmpl each time around
+
+ | InlineStable -- From an INLINE or INLINABLE pragma
+ -- INLINE if guidance is UnfWhen
+ -- INLINABLE if guidance is UnfIfGoodArgs/UnfoldNever
+ -- (well, technically an INLINABLE might be made
+ -- UnfWhen if it was small enough, and then
+ -- it will behave like INLINE outside the current
+ -- module, but that is the way automatic unfoldings
+ -- work so it is consistent with the intended
+ -- meaning of INLINABLE).
+ --
+ -- uf_tmpl may change, but only as a result of
+ -- gentle simplification, it doesn't get updated
+ -- to the current RHS during compilation as with
+ -- InlineRhs.
+ --
+ -- See Note [InlineStable]
+
+ | InlineCompulsory -- Something that *has* no binding, so you *must* inline it
+ -- Only a few primop-like things have this property
+ -- (see MkId.hs, calls to mkCompulsoryUnfolding).
+ -- Inline absolutely always, however boring the context.
+
+
+
+-- | 'UnfoldingGuidance' says when unfolding should take place
+data UnfoldingGuidance
+ = UnfWhen { -- Inline without thinking about the *size* of the uf_tmpl
+ -- Used (a) for small *and* cheap unfoldings
+ -- (b) for INLINE functions
+ -- See Note [INLINE for small functions] in CoreUnfold
+ ug_arity :: Arity, -- Number of value arguments expected
+
+ ug_unsat_ok :: Bool, -- True <=> ok to inline even if unsaturated
+ ug_boring_ok :: Bool -- True <=> ok to inline even if the context is boring
+ -- So True,True means "always"
+ }
+
+ | UnfIfGoodArgs { -- Arose from a normal Id; the info here is the
+ -- result of a simple analysis of the RHS
+
+ ug_args :: [Int], -- Discount if the argument is evaluated.
+ -- (i.e., a simplification will definitely
+ -- be possible). One elt of the list per *value* arg.
+
+ ug_size :: Int, -- The "size" of the unfolding.
+
+ ug_res :: Int -- Scrutinee discount: the discount to substract if the thing is in
+ } -- a context (case (thing args) of ...),
+ -- (where there are the right number of arguments.)
+
+ | UnfNever -- The RHS is big, so don't inline it
+ deriving (Eq)
+
+{-
+Note [Historical note: unfoldings for wrappers]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We used to have a nice clever scheme in interface files for
+wrappers. A wrapper's unfolding can be reconstructed from its worker's
+id and its strictness. This decreased .hi file size (sometimes
+significantly, for modules like GHC.Classes with many high-arity w/w
+splits) and had a slight corresponding effect on compile times.
+
+However, when we added the second demand analysis, this scheme lead to
+some Core lint errors. The second analysis could change the strictness
+signatures, which sometimes resulted in a wrapper's regenerated
+unfolding applying the wrapper to too many arguments.
+
+Instead of repairing the clever .hi scheme, we abandoned it in favor
+of simplicity. The .hi sizes are usually insignificant (excluding the
++1M for base libraries), and compile time barely increases (~+1% for
+nofib). The nicer upshot is that the UnfoldingSource no longer mentions
+an Id, so, eg, substitutions need not traverse them.
+
+
+Note [DFun unfoldings]
+~~~~~~~~~~~~~~~~~~~~~~
+The Arity in a DFunUnfolding is total number of args (type and value)
+that the DFun needs to produce a dictionary. That's not necessarily
+related to the ordinary arity of the dfun Id, esp if the class has
+one method, so the dictionary is represented by a newtype. Example
+
+ class C a where { op :: a -> Int }
+ instance C a -> C [a] where op xs = op (head xs)
+
+The instance translates to
+
+ $dfCList :: forall a. C a => C [a] -- Arity 2!
+ $dfCList = /\a.\d. $copList {a} d |> co
+
+ $copList :: forall a. C a => [a] -> Int -- Arity 2!
+ $copList = /\a.\d.\xs. op {a} d (head xs)
+
+Now we might encounter (op (dfCList {ty} d) a1 a2)
+and we want the (op (dfList {ty} d)) rule to fire, because $dfCList
+has all its arguments, even though its (value) arity is 2. That's
+why we record the number of expected arguments in the DFunUnfolding.
+
+Note that although it's an Arity, it's most convenient for it to give
+the *total* number of arguments, both type and value. See the use
+site in exprIsConApp_maybe.
+-}
+
+-- Constants for the UnfWhen constructor
+needSaturated, unSaturatedOk :: Bool
+needSaturated = False
+unSaturatedOk = True
+
+boringCxtNotOk, boringCxtOk :: Bool
+boringCxtOk = True
+boringCxtNotOk = False
+
+------------------------------------------------
+noUnfolding :: Unfolding
+-- ^ There is no known 'Unfolding'
+evaldUnfolding :: Unfolding
+-- ^ This unfolding marks the associated thing as being evaluated
+
+noUnfolding = NoUnfolding
+evaldUnfolding = OtherCon []
+
+-- | There is no known 'Unfolding', because this came from an
+-- hi-boot file.
+bootUnfolding :: Unfolding
+bootUnfolding = BootUnfolding
+
+mkOtherCon :: [AltCon] -> Unfolding
+mkOtherCon = OtherCon
+
+isStableSource :: UnfoldingSource -> Bool
+-- Keep the unfolding template
+isStableSource InlineCompulsory = True
+isStableSource InlineStable = True
+isStableSource InlineRhs = False
+
+-- | Retrieves the template of an unfolding: panics if none is known
+unfoldingTemplate :: Unfolding -> CoreExpr
+unfoldingTemplate = uf_tmpl
+
+-- | Retrieves the template of an unfolding if possible
+-- maybeUnfoldingTemplate is used mainly wnen specialising, and we do
+-- want to specialise DFuns, so it's important to return a template
+-- for DFunUnfoldings
+maybeUnfoldingTemplate :: Unfolding -> Maybe CoreExpr
+maybeUnfoldingTemplate (CoreUnfolding { uf_tmpl = expr })
+ = Just expr
+maybeUnfoldingTemplate (DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = args })
+ = Just (mkLams bndrs (mkApps (Var (dataConWorkId con)) args))
+maybeUnfoldingTemplate _
+ = Nothing
+
+-- | The constructors that the unfolding could never be:
+-- returns @[]@ if no information is available
+otherCons :: Unfolding -> [AltCon]
+otherCons (OtherCon cons) = cons
+otherCons _ = []
+
+-- | Determines if it is certainly the case that the unfolding will
+-- yield a value (something in HNF): returns @False@ if unsure
+isValueUnfolding :: Unfolding -> Bool
+ -- Returns False for OtherCon
+isValueUnfolding (CoreUnfolding { uf_is_value = is_evald }) = is_evald
+isValueUnfolding _ = False
+
+-- | Determines if it possibly the case that the unfolding will
+-- yield a value. Unlike 'isValueUnfolding' it returns @True@
+-- for 'OtherCon'
+isEvaldUnfolding :: Unfolding -> Bool
+ -- Returns True for OtherCon
+isEvaldUnfolding (OtherCon _) = True
+isEvaldUnfolding (CoreUnfolding { uf_is_value = is_evald }) = is_evald
+isEvaldUnfolding _ = False
+
+-- | @True@ if the unfolding is a constructor application, the application
+-- of a CONLIKE function or 'OtherCon'
+isConLikeUnfolding :: Unfolding -> Bool
+isConLikeUnfolding (OtherCon _) = True
+isConLikeUnfolding (CoreUnfolding { uf_is_conlike = con }) = con
+isConLikeUnfolding _ = False
+
+-- | Is the thing we will unfold into certainly cheap?
+isCheapUnfolding :: Unfolding -> Bool
+isCheapUnfolding (CoreUnfolding { uf_is_work_free = is_wf }) = is_wf
+isCheapUnfolding _ = False
+
+isExpandableUnfolding :: Unfolding -> Bool
+isExpandableUnfolding (CoreUnfolding { uf_expandable = is_expable }) = is_expable
+isExpandableUnfolding _ = False
+
+expandUnfolding_maybe :: Unfolding -> Maybe CoreExpr
+-- Expand an expandable unfolding; this is used in rule matching
+-- See Note [Expanding variables] in Rules.hs
+-- The key point here is that CONLIKE things can be expanded
+expandUnfolding_maybe (CoreUnfolding { uf_expandable = True, uf_tmpl = rhs }) = Just rhs
+expandUnfolding_maybe _ = Nothing
+
+isCompulsoryUnfolding :: Unfolding -> Bool
+isCompulsoryUnfolding (CoreUnfolding { uf_src = InlineCompulsory }) = True
+isCompulsoryUnfolding _ = False
+
+isStableUnfolding :: Unfolding -> Bool
+-- True of unfoldings that should not be overwritten
+-- by a CoreUnfolding for the RHS of a let-binding
+isStableUnfolding (CoreUnfolding { uf_src = src }) = isStableSource src
+isStableUnfolding (DFunUnfolding {}) = True
+isStableUnfolding _ = False
+
+-- | Only returns False if there is no unfolding information available at all
+hasSomeUnfolding :: Unfolding -> Bool
+hasSomeUnfolding NoUnfolding = False
+hasSomeUnfolding BootUnfolding = False
+hasSomeUnfolding _ = True
+
+isBootUnfolding :: Unfolding -> Bool
+isBootUnfolding BootUnfolding = True
+isBootUnfolding _ = False
+
+neverUnfoldGuidance :: UnfoldingGuidance -> Bool
+neverUnfoldGuidance UnfNever = True
+neverUnfoldGuidance _ = False
+
+isFragileUnfolding :: Unfolding -> Bool
+-- An unfolding is fragile if it mentions free variables or
+-- is otherwise subject to change. A robust one can be kept.
+-- See Note [Fragile unfoldings]
+isFragileUnfolding (CoreUnfolding {}) = True
+isFragileUnfolding (DFunUnfolding {}) = True
+isFragileUnfolding _ = False
+ -- NoUnfolding, BootUnfolding, OtherCon are all non-fragile
+
+canUnfold :: Unfolding -> Bool
+canUnfold (CoreUnfolding { uf_guidance = g }) = not (neverUnfoldGuidance g)
+canUnfold _ = False
+
+{- Note [Fragile unfoldings]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+An unfolding is "fragile" if it mentions free variables (and hence would
+need substitution) or might be affected by optimisation. The non-fragile
+ones are
+
+ NoUnfolding, BootUnfolding
+
+ OtherCon {} If we know this binder (say a lambda binder) will be
+ bound to an evaluated thing, we want to retain that
+ info in simpleOptExpr; see Trac #13077.
+
+We consider even a StableUnfolding as fragile, because it needs substitution.
+
+Note [InlineStable]
+~~~~~~~~~~~~~~~~~
+When you say
+ {-# INLINE f #-}
+ f x =
+you intend that calls (f e) are replaced by [e/x] So we
+should capture (\x.) in the Unfolding of 'f', and never meddle
+with it. Meanwhile, we can optimise to our heart's content,
+leaving the original unfolding intact in Unfolding of 'f'. For example
+ all xs = foldr (&&) True xs
+ any p = all . map p {-# INLINE any #-}
+We optimise any's RHS fully, but leave the InlineRule saying "all . map p",
+which deforests well at the call site.
+
+So INLINE pragma gives rise to an InlineRule, which captures the original RHS.
+
+Moreover, it's only used when 'f' is applied to the
+specified number of arguments; that is, the number of argument on
+the LHS of the '=' sign in the original source definition.
+For example, (.) is now defined in the libraries like this
+ {-# INLINE (.) #-}
+ (.) f g = \x -> f (g x)
+so that it'll inline when applied to two arguments. If 'x' appeared
+on the left, thus
+ (.) f g x = f (g x)
+it'd only inline when applied to three arguments. This slightly-experimental
+change was requested by Roman, but it seems to make sense.
+
+See also Note [Inlining an InlineRule] in CoreUnfold.
+
+
+Note [OccInfo in unfoldings and rules]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In unfoldings and rules, we guarantee that the template is occ-analysed,
+so that the occurrence info on the binders is correct. This is important,
+because the Simplifier does not re-analyse the template when using it. If
+the occurrence info is wrong
+ - We may get more simpifier iterations than necessary, because
+ once-occ info isn't there
+ - More seriously, we may get an infinite loop if there's a Rec
+ without a loop breaker marked
+
+
+************************************************************************
+* *
+ AltCon
+* *
+************************************************************************
+-}
+
+-- The Ord is needed for the FiniteMap used in the lookForConstructor
+-- in SimplEnv. If you declared that lookForConstructor *ignores*
+-- constructor-applications with LitArg args, then you could get
+-- rid of this Ord.
+
+instance Outputable AltCon where
+ ppr (DataAlt dc) = ppr dc
+ ppr (LitAlt lit) = ppr lit
+ ppr DEFAULT = text "__DEFAULT"
+
+cmpAlt :: (AltCon, a, b) -> (AltCon, a, b) -> Ordering
+cmpAlt (con1, _, _) (con2, _, _) = con1 `cmpAltCon` con2
+
+ltAlt :: (AltCon, a, b) -> (AltCon, a, b) -> Bool
+ltAlt a1 a2 = (a1 `cmpAlt` a2) == LT
+
+cmpAltCon :: AltCon -> AltCon -> Ordering
+-- ^ Compares 'AltCon's within a single list of alternatives
+cmpAltCon DEFAULT DEFAULT = EQ
+cmpAltCon DEFAULT _ = LT
+
+cmpAltCon (DataAlt d1) (DataAlt d2) = dataConTag d1 `compare` dataConTag d2
+cmpAltCon (DataAlt _) DEFAULT = GT
+cmpAltCon (LitAlt l1) (LitAlt l2) = l1 `compare` l2
+cmpAltCon (LitAlt _) DEFAULT = GT
+
+cmpAltCon con1 con2 = WARN( True, text "Comparing incomparable AltCons" <+>
+ ppr con1 <+> ppr con2 )
+ LT
+
+{-
+************************************************************************
+* *
+\subsection{Useful synonyms}
+* *
+************************************************************************
+
+Note [CoreProgram]
+~~~~~~~~~~~~~~~~~~
+The top level bindings of a program, a CoreProgram, are represented as
+a list of CoreBind
+
+ * Later bindings in the list can refer to earlier ones, but not vice
+ versa. So this is OK
+ NonRec { x = 4 }
+ Rec { p = ...q...x...
+ ; q = ...p...x }
+ Rec { f = ...p..x..f.. }
+ NonRec { g = ..f..q...x.. }
+ But it would NOT be ok for 'f' to refer to 'g'.
+
+ * The occurrence analyser does strongly-connected component analysis
+ on each Rec binding, and splits it into a sequence of smaller
+ bindings where possible. So the program typically starts life as a
+ single giant Rec, which is then dependency-analysed into smaller
+ chunks.
+-}
+
+-- If you edit this type, you may need to update the GHC formalism
+-- See Note [GHC Formalism] in coreSyn/CoreLint.hs
+type CoreProgram = [CoreBind] -- See Note [CoreProgram]
+
+-- | The common case for the type of binders and variables when
+-- we are manipulating the Core language within GHC
+type CoreBndr = Var
+-- | Expressions where binders are 'CoreBndr's
+type CoreExpr = Expr CoreBndr
+-- | Argument expressions where binders are 'CoreBndr's
+type CoreArg = Arg CoreBndr
+-- | Binding groups where binders are 'CoreBndr's
+type CoreBind = Bind CoreBndr
+-- | Case alternatives where binders are 'CoreBndr's
+type CoreAlt = Alt CoreBndr
+
+{-
+************************************************************************
+* *
+\subsection{Tagging}
+* *
+************************************************************************
+-}
+
+-- | Binders are /tagged/ with a t
+data TaggedBndr t = TB CoreBndr t -- TB for "tagged binder"
+
+type TaggedBind t = Bind (TaggedBndr t)
+type TaggedExpr t = Expr (TaggedBndr t)
+type TaggedArg t = Arg (TaggedBndr t)
+type TaggedAlt t = Alt (TaggedBndr t)
+
+instance Outputable b => Outputable (TaggedBndr b) where
+ ppr (TB b l) = char '<' <> ppr b <> comma <> ppr l <> char '>'
+
+deTagExpr :: TaggedExpr t -> CoreExpr
+deTagExpr (Var v) = Var v
+deTagExpr (Lit l) = Lit l
+deTagExpr (Type ty) = Type ty
+deTagExpr (Coercion co) = Coercion co
+deTagExpr (App e1 e2) = App (deTagExpr e1) (deTagExpr e2)
+deTagExpr (Lam (TB b _) e) = Lam b (deTagExpr e)
+deTagExpr (Let bind body) = Let (deTagBind bind) (deTagExpr body)
+deTagExpr (Case e (TB b _) ty alts) = Case (deTagExpr e) b ty (map deTagAlt alts)
+deTagExpr (Tick t e) = Tick t (deTagExpr e)
+deTagExpr (Cast e co) = Cast (deTagExpr e) co
+
+deTagBind :: TaggedBind t -> CoreBind
+deTagBind (NonRec (TB b _) rhs) = NonRec b (deTagExpr rhs)
+deTagBind (Rec prs) = Rec [(b, deTagExpr rhs) | (TB b _, rhs) <- prs]
+
+deTagAlt :: TaggedAlt t -> CoreAlt
+deTagAlt (con, bndrs, rhs) = (con, [b | TB b _ <- bndrs], deTagExpr rhs)
+
+{-
+************************************************************************
+* *
+\subsection{Core-constructing functions with checking}
+* *
+************************************************************************
+-}
+
+-- | Apply a list of argument expressions to a function expression in a nested fashion. Prefer to
+-- use 'MkCore.mkCoreApps' if possible
+mkApps :: Expr b -> [Arg b] -> Expr b
+-- | Apply a list of type argument expressions to a function expression in a nested fashion
+mkTyApps :: Expr b -> [Type] -> Expr b
+-- | Apply a list of coercion argument expressions to a function expression in a nested fashion
+mkCoApps :: Expr b -> [Coercion] -> Expr b
+-- | Apply a list of type or value variables to a function expression in a nested fashion
+mkVarApps :: Expr b -> [Var] -> Expr b
+-- | Apply a list of argument expressions to a data constructor in a nested fashion. Prefer to
+-- use 'MkCore.mkCoreConApps' if possible
+mkConApp :: DataCon -> [Arg b] -> Expr b
+
+mkApps f args = foldl App f args
+mkCoApps f args = foldl (\ e a -> App e (Coercion a)) f args
+mkVarApps f vars = foldl (\ e a -> App e (varToCoreExpr a)) f vars
+mkConApp con args = mkApps (Var (dataConWorkId con)) args
+
+mkTyApps f args = foldl (\ e a -> App e (mkTyArg a)) f args
+
+mkConApp2 :: DataCon -> [Type] -> [Var] -> Expr b
+mkConApp2 con tys arg_ids = Var (dataConWorkId con)
+ `mkApps` map Type tys
+ `mkApps` map varToCoreExpr arg_ids
+
+mkTyArg :: Type -> Expr b
+mkTyArg ty
+ | Just co <- isCoercionTy_maybe ty = Coercion co
+ | otherwise = Type ty
+
+-- | Create a machine integer literal expression of type @Int#@ from an @Integer@.
+-- If you want an expression of type @Int@ use 'MkCore.mkIntExpr'
+mkIntLit :: DynFlags -> Integer -> Expr b
+-- | Create a machine integer literal expression of type @Int#@ from an @Int@.
+-- If you want an expression of type @Int@ use 'MkCore.mkIntExpr'
+mkIntLitInt :: DynFlags -> Int -> Expr b
+
+mkIntLit dflags n = Lit (mkMachInt dflags n)
+mkIntLitInt dflags n = Lit (mkMachInt dflags (toInteger n))
+
+-- | Create a machine word literal expression of type @Word#@ from an @Integer@.
+-- If you want an expression of type @Word@ use 'MkCore.mkWordExpr'
+mkWordLit :: DynFlags -> Integer -> Expr b
+-- | Create a machine word literal expression of type @Word#@ from a @Word@.
+-- If you want an expression of type @Word@ use 'MkCore.mkWordExpr'
+mkWordLitWord :: DynFlags -> Word -> Expr b
+
+mkWordLit dflags w = Lit (mkMachWord dflags w)
+mkWordLitWord dflags w = Lit (mkMachWord dflags (toInteger w))
+
+mkWord64LitWord64 :: Word64 -> Expr b
+mkWord64LitWord64 w = Lit (mkMachWord64 (toInteger w))
+
+mkInt64LitInt64 :: Int64 -> Expr b
+mkInt64LitInt64 w = Lit (mkMachInt64 (toInteger w))
+
+-- | Create a machine character literal expression of type @Char#@.
+-- If you want an expression of type @Char@ use 'MkCore.mkCharExpr'
+mkCharLit :: Char -> Expr b
+-- | Create a machine string literal expression of type @Addr#@.
+-- If you want an expression of type @String@ use 'MkCore.mkStringExpr'
+mkStringLit :: String -> Expr b
+
+mkCharLit c = Lit (mkMachChar c)
+mkStringLit s = Lit (mkMachString s)
+
+-- | Create a machine single precision literal expression of type @Float#@ from a @Rational@.
+-- If you want an expression of type @Float@ use 'MkCore.mkFloatExpr'
+mkFloatLit :: Rational -> Expr b
+-- | Create a machine single precision literal expression of type @Float#@ from a @Float@.
+-- If you want an expression of type @Float@ use 'MkCore.mkFloatExpr'
+mkFloatLitFloat :: Float -> Expr b
+
+mkFloatLit f = Lit (mkMachFloat f)
+mkFloatLitFloat f = Lit (mkMachFloat (toRational f))
+
+-- | Create a machine double precision literal expression of type @Double#@ from a @Rational@.
+-- If you want an expression of type @Double@ use 'MkCore.mkDoubleExpr'
+mkDoubleLit :: Rational -> Expr b
+-- | Create a machine double precision literal expression of type @Double#@ from a @Double@.
+-- If you want an expression of type @Double@ use 'MkCore.mkDoubleExpr'
+mkDoubleLitDouble :: Double -> Expr b
+
+mkDoubleLit d = Lit (mkMachDouble d)
+mkDoubleLitDouble d = Lit (mkMachDouble (toRational d))
+
+-- | Bind all supplied binding groups over an expression in a nested let expression. Assumes
+-- that the rhs satisfies the let/app invariant. Prefer to use 'MkCore.mkCoreLets' if
+-- possible, which does guarantee the invariant
+mkLets :: [Bind b] -> Expr b -> Expr b
+-- | Bind all supplied binders over an expression in a nested lambda expression. Prefer to
+-- use 'MkCore.mkCoreLams' if possible
+mkLams :: [b] -> Expr b -> Expr b
+
+mkLams binders body = foldr Lam body binders
+mkLets binds body = foldr mkLet body binds
+
+mkLet :: Bind b -> Expr b -> Expr b
+-- The desugarer sometimes generates an empty Rec group
+-- which Lint rejects, so we kill it off right away
+mkLet (Rec []) body = body
+mkLet bind body = Let bind body
+
+-- | Create a binding group where a type variable is bound to a type. Per "CoreSyn#type_let",
+-- this can only be used to bind something in a non-recursive @let@ expression
+mkTyBind :: TyVar -> Type -> CoreBind
+mkTyBind tv ty = NonRec tv (Type ty)
+
+-- | Create a binding group where a type variable is bound to a type. Per "CoreSyn#type_let",
+-- this can only be used to bind something in a non-recursive @let@ expression
+mkCoBind :: CoVar -> Coercion -> CoreBind
+mkCoBind cv co = NonRec cv (Coercion co)
+
+-- | Convert a binder into either a 'Var' or 'Type' 'Expr' appropriately
+varToCoreExpr :: CoreBndr -> Expr b
+varToCoreExpr v | isTyVar v = Type (mkTyVarTy v)
+ | isCoVar v = Coercion (mkCoVarCo v)
+ | otherwise = ASSERT( isId v ) Var v
+
+varsToCoreExprs :: [CoreBndr] -> [Expr b]
+varsToCoreExprs vs = map varToCoreExpr vs
+
+{-
+************************************************************************
+* *
+ Getting a result type
+* *
+************************************************************************
+
+These are defined here to avoid a module loop between CoreUtils and CoreFVs
+
+-}
+
+applyTypeToArg :: Type -> CoreExpr -> Type
+-- ^ Determines the type resulting from applying an expression with given type
+-- to a given argument expression
+applyTypeToArg fun_ty arg = piResultTy fun_ty (exprToType arg)
+
+-- | If the expression is a 'Type', converts. Otherwise,
+-- panics. NB: This does /not/ convert 'Coercion' to 'CoercionTy'.
+exprToType :: CoreExpr -> Type
+exprToType (Type ty) = ty
+exprToType _bad = pprPanic "exprToType" empty
+
+-- | If the expression is a 'Coercion', converts.
+exprToCoercion_maybe :: CoreExpr -> Maybe Coercion
+exprToCoercion_maybe (Coercion co) = Just co
+exprToCoercion_maybe _ = Nothing
+
+{-
+************************************************************************
+* *
+\subsection{Simple access functions}
+* *
+************************************************************************
+-}
+
+-- | Extract every variable by this group
+bindersOf :: Bind b -> [b]
+-- If you edit this function, you may need to update the GHC formalism
+-- See Note [GHC Formalism] in coreSyn/CoreLint.hs
+bindersOf (NonRec binder _) = [binder]
+bindersOf (Rec pairs) = [binder | (binder, _) <- pairs]
+
+-- | 'bindersOf' applied to a list of binding groups
+bindersOfBinds :: [Bind b] -> [b]
+bindersOfBinds binds = foldr ((++) . bindersOf) [] binds
+
+rhssOfBind :: Bind b -> [Expr b]
+rhssOfBind (NonRec _ rhs) = [rhs]
+rhssOfBind (Rec pairs) = [rhs | (_,rhs) <- pairs]
+
+rhssOfAlts :: [Alt b] -> [Expr b]
+rhssOfAlts alts = [e | (_,_,e) <- alts]
+
+-- | Collapse all the bindings in the supplied groups into a single
+-- list of lhs\/rhs pairs suitable for binding in a 'Rec' binding group
+flattenBinds :: [Bind b] -> [(b, Expr b)]
+flattenBinds (NonRec b r : binds) = (b,r) : flattenBinds binds
+flattenBinds (Rec prs1 : binds) = prs1 ++ flattenBinds binds
+flattenBinds [] = []
+
+-- | We often want to strip off leading lambdas before getting down to
+-- business. Variants are 'collectTyBinders', 'collectValBinders',
+-- and 'collectTyAndValBinders'
+collectBinders :: Expr b -> ([b], Expr b)
+collectTyBinders :: CoreExpr -> ([TyVar], CoreExpr)
+collectValBinders :: CoreExpr -> ([Id], CoreExpr)
+collectTyAndValBinders :: CoreExpr -> ([TyVar], [Id], CoreExpr)
+-- | Strip off exactly N leading lambdas (type or value). Good for use with
+-- join points.
+collectNBinders :: Int -> Expr b -> ([b], Expr b)
+
+collectBinders expr
+ = go [] expr
+ where
+ go bs (Lam b e) = go (b:bs) e
+ go bs e = (reverse bs, e)
+
+collectTyBinders expr
+ = go [] expr
+ where
+ go tvs (Lam b e) | isTyVar b = go (b:tvs) e
+ go tvs e = (reverse tvs, e)
+
+collectValBinders expr
+ = go [] expr
+ where
+ go ids (Lam b e) | isId b = go (b:ids) e
+ go ids body = (reverse ids, body)
+
+collectTyAndValBinders expr
+ = (tvs, ids, body)
+ where
+ (tvs, body1) = collectTyBinders expr
+ (ids, body) = collectValBinders body1
+
+collectNBinders orig_n orig_expr
+ = go orig_n [] orig_expr
+ where
+ go 0 bs expr = (reverse bs, expr)
+ go n bs (Lam b e) = go (n-1) (b:bs) e
+ go _ _ _ = pprPanic "collectNBinders" $ int orig_n
+
+-- | Takes a nested application expression and returns the the function
+-- being applied and the arguments to which it is applied
+collectArgs :: Expr b -> (Expr b, [Arg b])
+collectArgs expr
+ = go expr []
+ where
+ go (App f a) as = go f (a:as)
+ go e as = (e, as)
+
+-- | Like @collectArgs@, but also collects looks through floatable
+-- ticks if it means that we can find more arguments.
+collectArgsTicks :: (Tickish Id -> Bool) -> Expr b
+ -> (Expr b, [Arg b], [Tickish Id])
+collectArgsTicks skipTick expr
+ = go expr [] []
+ where
+ go (App f a) as ts = go f (a:as) ts
+ go (Tick t e) as ts
+ | skipTick t = go e as (t:ts)
+ go e as ts = (e, as, reverse ts)
+
+
+{-
+************************************************************************
+* *
+\subsection{Predicates}
+* *
+************************************************************************
+
+At one time we optionally carried type arguments through to runtime.
+@isRuntimeVar v@ returns if (Lam v _) really becomes a lambda at runtime,
+i.e. if type applications are actual lambdas because types are kept around
+at runtime. Similarly isRuntimeArg.
+-}
+
+-- | Will this variable exist at runtime?
+isRuntimeVar :: Var -> Bool
+isRuntimeVar = isId
+
+-- | Will this argument expression exist at runtime?
+isRuntimeArg :: CoreExpr -> Bool
+isRuntimeArg = isValArg
+
+-- | Returns @True@ for value arguments, false for type args
+-- NB: coercions are value arguments (zero width, to be sure,
+-- like State#, but still value args).
+isValArg :: Expr b -> Bool
+isValArg e = not (isTypeArg e)
+
+-- | Returns @True@ iff the expression is a 'Type' or 'Coercion'
+-- expression at its top level
+isTyCoArg :: Expr b -> Bool
+isTyCoArg (Type {}) = True
+isTyCoArg (Coercion {}) = True
+isTyCoArg _ = False
+
+-- | Returns @True@ iff the expression is a 'Type' expression at its
+-- top level. Note this does NOT include 'Coercion's.
+isTypeArg :: Expr b -> Bool
+isTypeArg (Type {}) = True
+isTypeArg _ = False
+
+-- | The number of binders that bind values rather than types
+valBndrCount :: [CoreBndr] -> Int
+valBndrCount = count isId
+
+-- | The number of argument expressions that are values rather than types at their top level
+valArgCount :: [Arg b] -> Int
+valArgCount = count isValArg
+
+{-
+************************************************************************
+* *
+\subsection{Annotated core}
+* *
+************************************************************************
+-}
+
+-- | Annotated core: allows annotation at every node in the tree
+type AnnExpr bndr annot = (annot, AnnExpr' bndr annot)
+
+-- | A clone of the 'Expr' type but allowing annotation at every tree node
+data AnnExpr' bndr annot
+ = AnnVar Id
+ | AnnLit Literal
+ | AnnLam bndr (AnnExpr bndr annot)
+ | AnnApp (AnnExpr bndr annot) (AnnExpr bndr annot)
+ | AnnCase (AnnExpr bndr annot) bndr Type [AnnAlt bndr annot]
+ | AnnLet (AnnBind bndr annot) (AnnExpr bndr annot)
+ | AnnCast (AnnExpr bndr annot) (annot, Coercion)
+ -- Put an annotation on the (root of) the coercion
+ | AnnTick (Tickish Id) (AnnExpr bndr annot)
+ | AnnType Type
+ | AnnCoercion Coercion
+
+-- | A clone of the 'Alt' type but allowing annotation at every tree node
+type AnnAlt bndr annot = (AltCon, [bndr], AnnExpr bndr annot)
+
+-- | A clone of the 'Bind' type but allowing annotation at every tree node
+data AnnBind bndr annot
+ = AnnNonRec bndr (AnnExpr bndr annot)
+ | AnnRec [(bndr, AnnExpr bndr annot)]
+
+-- | Takes a nested application expression and returns the the function
+-- being applied and the arguments to which it is applied
+collectAnnArgs :: AnnExpr b a -> (AnnExpr b a, [AnnExpr b a])
+collectAnnArgs expr
+ = go expr []
+ where
+ go (_, AnnApp f a) as = go f (a:as)
+ go e as = (e, as)
+
+collectAnnArgsTicks :: (Tickish Var -> Bool) -> AnnExpr b a
+ -> (AnnExpr b a, [AnnExpr b a], [Tickish Var])
+collectAnnArgsTicks tickishOk expr
+ = go expr [] []
+ where
+ go (_, AnnApp f a) as ts = go f (a:as) ts
+ go (_, AnnTick t e) as ts | tickishOk t
+ = go e as (t:ts)
+ go e as ts = (e, as, reverse ts)
+
+deAnnotate :: AnnExpr bndr annot -> Expr bndr
+deAnnotate (_, e) = deAnnotate' e
+
+deAnnotate' :: AnnExpr' bndr annot -> Expr bndr
+deAnnotate' (AnnType t) = Type t
+deAnnotate' (AnnCoercion co) = Coercion co
+deAnnotate' (AnnVar v) = Var v
+deAnnotate' (AnnLit lit) = Lit lit
+deAnnotate' (AnnLam binder body) = Lam binder (deAnnotate body)
+deAnnotate' (AnnApp fun arg) = App (deAnnotate fun) (deAnnotate arg)
+deAnnotate' (AnnCast e (_,co)) = Cast (deAnnotate e) co
+deAnnotate' (AnnTick tick body) = Tick tick (deAnnotate body)
+
+deAnnotate' (AnnLet bind body)
+ = Let (deAnnBind bind) (deAnnotate body)
+ where
+ deAnnBind (AnnNonRec var rhs) = NonRec var (deAnnotate rhs)
+ deAnnBind (AnnRec pairs) = Rec [(v,deAnnotate rhs) | (v,rhs) <- pairs]
+
+deAnnotate' (AnnCase scrut v t alts)
+ = Case (deAnnotate scrut) v t (map deAnnAlt alts)
+
+deAnnAlt :: AnnAlt bndr annot -> Alt bndr
+deAnnAlt (con,args,rhs) = (con,args,deAnnotate rhs)
+
+-- | As 'collectBinders' but for 'AnnExpr' rather than 'Expr'
+collectAnnBndrs :: AnnExpr bndr annot -> ([bndr], AnnExpr bndr annot)
+collectAnnBndrs e
+ = collect [] e
+ where
+ collect bs (_, AnnLam b body) = collect (b:bs) body
+ collect bs body = (reverse bs, body)
+
+-- | As 'collectNBinders' but for 'AnnExpr' rather than 'Expr'
+collectNAnnBndrs :: Int -> AnnExpr bndr annot -> ([bndr], AnnExpr bndr annot)
+collectNAnnBndrs orig_n e
+ = collect orig_n [] e
+ where
+ collect 0 bs body = (reverse bs, body)
+ collect n bs (_, AnnLam b body) = collect (n-1) (b:bs) body
+ collect _ _ _ = pprPanic "collectNBinders" $ int orig_n
diff --git a/coreSyn/CoreTidy.hs b/coreSyn/CoreTidy.hs
new file mode 100644
--- /dev/null
+++ b/coreSyn/CoreTidy.hs
@@ -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
diff --git a/coreSyn/CoreUnfold.hs b/coreSyn/CoreUnfold.hs
new file mode 100644
--- /dev/null
+++ b/coreSyn/CoreUnfold.hs
@@ -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 ...
+ -- to
+ -- \new_bndrs. MkD (spec_app(\old_bndrs. )) ... ditto
+ -- The ASSERT checks the value part of that
+ where
+ spec_arg arg = simpleOptExpr (spec_app (mkLams old_bndrs arg))
+ -- The beta-redexes created by spec_app will be
+ -- simplified away by simplOptExpr
+
+specUnfolding spec_bndrs spec_app arity_decrease
+ (CoreUnfolding { uf_src = src, uf_tmpl = tmpl
+ , uf_is_top = top_lvl
+ , uf_guidance = old_guidance })
+ | isStableSource src -- See Note [Specialising unfoldings]
+ , UnfWhen { ug_arity = old_arity
+ , ug_unsat_ok = unsat_ok
+ , ug_boring_ok = boring_ok } <- old_guidance
+ = let guidance = UnfWhen { ug_arity = old_arity - arity_decrease
+ , ug_unsat_ok = unsat_ok
+ , ug_boring_ok = boring_ok }
+ new_tmpl = simpleOptExpr (mkLams spec_bndrs (spec_app tmpl))
+ -- The beta-redexes created by spec_app will be
+ -- simplified away by simplOptExpr
+
+ in mkCoreUnfolding src top_lvl new_tmpl guidance
+
+specUnfolding _ _ _ _ = noUnfolding
+
+{- Note [Specialising unfoldings]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we specialise a function for some given type-class arguments, we use
+specUnfolding to specialise its unfolding. Some important points:
+
+* If the original function has a DFunUnfolding, the specialised one
+ must do so too! Otherwise we lose the magic rules that make it
+ interact with ClassOps
+
+* There is a bit of hack for INLINABLE functions:
+ f :: Ord a => ....
+ f =
+ {- INLINABLE f #-}
+ Now if we specialise f, should the specialised version still have
+ an INLINABLE pragma? If it does, we'll capture a specialised copy
+ of as its unfolding, and that probaby won't inline. But
+ if we don't, the specialised version of might be small
+ enough to inline at a call site. This happens with Control.Monad.liftM3,
+ and can cause a lot more allocation as a result (nofib n-body shows this).
+
+ Moreover, keeping the INLINABLE thing isn't much help, because
+ the specialised function (probaby) isn't overloaded any more.
+
+ Conclusion: drop the INLINEALE pragma. In practice what this means is:
+ if a stable unfolding has UnfoldingGuidance of UnfWhen,
+ we keep it (so the specialised thing too will always inline)
+ if a stable unfolding has UnfoldingGuidance of UnfIfGoodArgs
+ (which arises from INLINABLE), we discard it
+-}
+
+mkCoreUnfolding :: UnfoldingSource -> Bool -> CoreExpr
+ -> UnfoldingGuidance -> Unfolding
+-- Occurrence-analyses the expression before capturing it
+mkCoreUnfolding src top_lvl expr guidance
+ = CoreUnfolding { uf_tmpl = occurAnalyseExpr expr,
+ -- See Note [Occurrence analysis of unfoldings]
+ uf_src = src,
+ uf_is_top = top_lvl,
+ uf_is_value = exprIsHNF expr,
+ uf_is_conlike = exprIsConLike expr,
+ uf_is_work_free = exprIsWorkFree expr,
+ uf_expandable = exprIsExpandable expr,
+ uf_guidance = guidance }
+
+mkUnfolding :: DynFlags -> UnfoldingSource
+ -> Bool -- Is top-level
+ -> Bool -- Definitely a bottoming binding
+ -- (only relevant for top-level bindings)
+ -> CoreExpr
+ -> Unfolding
+-- Calculates unfolding guidance
+-- Occurrence-analyses the expression before capturing it
+mkUnfolding dflags src is_top_lvl is_bottoming expr
+ = CoreUnfolding { uf_tmpl = occurAnalyseExpr expr,
+ -- See Note [Occurrence analysis of unfoldings]
+ uf_src = src,
+ uf_is_top = is_top_lvl,
+ uf_is_value = exprIsHNF expr,
+ uf_is_conlike = exprIsConLike expr,
+ uf_expandable = exprIsExpandable expr,
+ uf_is_work_free = exprIsWorkFree expr,
+ uf_guidance = guidance }
+ where
+ is_top_bottoming = is_top_lvl && is_bottoming
+ guidance = calcUnfoldingGuidance dflags is_top_bottoming expr
+ -- NB: *not* (calcUnfoldingGuidance (occurAnalyseExpr expr))!
+ -- See Note [Calculate unfolding guidance on the non-occ-anal'd expression]
+
+{-
+Note [Occurrence analysis of unfoldings]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We do occurrence-analysis of unfoldings once and for all, when the
+unfolding is built, rather than each time we inline them.
+
+But given this decision it's vital that we do
+*always* do it. Consider this unfolding
+ \x -> letrec { f = ...g...; g* = f } in body
+where g* is (for some strange reason) the loop breaker. If we don't
+occ-anal it when reading it in, we won't mark g as a loop breaker, and
+we may inline g entirely in body, dropping its binding, and leaving
+the occurrence in f out of scope. This happened in Trac #8892, where
+the unfolding in question was a DFun unfolding.
+
+But more generally, the simplifier is designed on the
+basis that it is looking at occurrence-analysed expressions, so better
+ensure that they acutally are.
+
+Note [Calculate unfolding guidance on the non-occ-anal'd expression]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Notice that we give the non-occur-analysed expression to
+calcUnfoldingGuidance. In some ways it'd be better to occur-analyse
+first; for example, sometimes during simplification, there's a large
+let-bound thing which has been substituted, and so is now dead; so
+'expr' contains two copies of the thing while the occurrence-analysed
+expression doesn't.
+
+Nevertheless, we *don't* and *must not* occ-analyse before computing
+the size because
+
+a) The size computation bales out after a while, whereas occurrence
+ analysis does not.
+
+b) Residency increases sharply if you occ-anal first. I'm not
+ 100% sure why, but it's a large effect. Compiling Cabal went
+ from residency of 534M to over 800M with this one change.
+
+This can occasionally mean that the guidance is very pessimistic;
+it gets fixed up next round. And it should be rare, because large
+let-bound things that are dead are usually caught by preInlineUnconditionally
+
+
+************************************************************************
+* *
+\subsection{The UnfoldingGuidance type}
+* *
+************************************************************************
+-}
+
+inlineBoringOk :: CoreExpr -> Bool
+-- See Note [INLINE for small functions]
+-- True => the result of inlining the expression is
+-- no bigger than the expression itself
+-- eg (\x y -> f y x)
+-- This is a quick and dirty version. It doesn't attempt
+-- to deal with (\x y z -> x (y z))
+-- The really important one is (x `cast` c)
+inlineBoringOk e
+ = go 0 e
+ where
+ go :: Int -> CoreExpr -> Bool
+ go credit (Lam x e) | isId x = go (credit+1) e
+ | otherwise = go credit e
+ go credit (App f (Type {})) = go credit f
+ go credit (App f a) | credit > 0
+ , exprIsTrivial a = go (credit-1) f
+ go credit (Tick _ e) = go credit e -- dubious
+ go credit (Cast e _) = go credit e
+ go _ (Var {}) = boringCxtOk
+ go _ _ = boringCxtNotOk
+
+calcUnfoldingGuidance
+ :: DynFlags
+ -> Bool -- Definitely a top-level, bottoming binding
+ -> CoreExpr -- Expression to look at
+ -> UnfoldingGuidance
+calcUnfoldingGuidance dflags is_top_bottoming (Tick t expr)
+ | not (tickishIsCode t) -- non-code ticks don't matter for unfolding
+ = calcUnfoldingGuidance dflags is_top_bottoming expr
+calcUnfoldingGuidance dflags is_top_bottoming expr
+ = case sizeExpr dflags bOMB_OUT_SIZE val_bndrs body of
+ TooBig -> UnfNever
+ SizeIs size cased_bndrs scrut_discount
+ | uncondInline expr n_val_bndrs size
+ -> UnfWhen { ug_unsat_ok = unSaturatedOk
+ , ug_boring_ok = boringCxtOk
+ , ug_arity = n_val_bndrs } -- Note [INLINE for small functions]
+
+ | is_top_bottoming
+ -> UnfNever -- See Note [Do not inline top-level bottoming functions]
+
+ | otherwise
+ -> UnfIfGoodArgs { ug_args = map (mk_discount cased_bndrs) val_bndrs
+ , ug_size = size
+ , ug_res = scrut_discount }
+
+ where
+ (bndrs, body) = collectBinders expr
+ bOMB_OUT_SIZE = ufCreationThreshold dflags
+ -- Bomb out if size gets bigger than this
+ val_bndrs = filter isId bndrs
+ n_val_bndrs = length val_bndrs
+
+ mk_discount :: Bag (Id,Int) -> Id -> Int
+ mk_discount cbs bndr = foldlBag combine 0 cbs
+ where
+ combine acc (bndr', disc)
+ | bndr == bndr' = acc `plus_disc` disc
+ | otherwise = acc
+
+ plus_disc :: Int -> Int -> Int
+ plus_disc | isFunTy (idType bndr) = max
+ | otherwise = (+)
+ -- See Note [Function and non-function discounts]
+
+{-
+Note [Computing the size of an expression]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The basic idea of sizeExpr is obvious enough: count nodes. But getting the
+heuristics right has taken a long time. Here's the basic strategy:
+
+ * Variables, literals: 0
+ (Exception for string literals, see litSize.)
+
+ * Function applications (f e1 .. en): 1 + #value args
+
+ * Constructor applications: 1, regardless of #args
+
+ * Let(rec): 1 + size of components
+
+ * Note, cast: 0
+
+Examples
+
+ Size Term
+ --------------
+ 0 42#
+ 0 x
+ 0 True
+ 2 f x
+ 1 Just x
+ 4 f (g x)
+
+Notice that 'x' counts 0, while (f x) counts 2. That's deliberate: there's
+a function call to account for. Notice also that constructor applications
+are very cheap, because exposing them to a caller is so valuable.
+
+[25/5/11] All sizes are now multiplied by 10, except for primops
+(which have sizes like 1 or 4. This makes primops look fantastically
+cheap, and seems to be almost unversally beneficial. Done partly as a
+result of #4978.
+
+Note [Do not inline top-level bottoming functions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The FloatOut pass has gone to some trouble to float out calls to 'error'
+and similar friends. See Note [Bottoming floats] in SetLevels.
+Do not re-inline them! But we *do* still inline if they are very small
+(the uncondInline stuff).
+
+Note [INLINE for small functions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider {-# INLINE f #-}
+ f x = Just x
+ g y = f y
+Then f's RHS is no larger than its LHS, so we should inline it into
+even the most boring context. In general, f the function is
+sufficiently small that its body is as small as the call itself, the
+inline unconditionally, regardless of how boring the context is.
+
+Things to note:
+
+(1) We inline *unconditionally* if inlined thing is smaller (using sizeExpr)
+ than the thing it's replacing. Notice that
+ (f x) --> (g 3) -- YES, unconditionally
+ (f x) --> x : [] -- YES, *even though* there are two
+ -- arguments to the cons
+ x --> g 3 -- NO
+ x --> Just v -- NO
+
+ It's very important not to unconditionally replace a variable by
+ a non-atomic term.
+
+(2) We do this even if the thing isn't saturated, else we end up with the
+ silly situation that
+ f x y = x
+ ...map (f 3)...
+ doesn't inline. Even in a boring context, inlining without being
+ saturated will give a lambda instead of a PAP, and will be more
+ efficient at runtime.
+
+(3) However, when the function's arity > 0, we do insist that it
+ has at least one value argument at the call site. (This check is
+ made in the UnfWhen case of callSiteInline.) Otherwise we find this:
+ f = /\a \x:a. x
+ d = /\b. MkD (f b)
+ If we inline f here we get
+ d = /\b. MkD (\x:b. x)
+ and then prepareRhs floats out the argument, abstracting the type
+ variables, so we end up with the original again!
+
+(4) We must be much more cautious about arity-zero things. Consider
+ let x = y +# z in ...
+ In *size* terms primops look very small, because the generate a
+ single instruction, but we do not want to unconditionally replace
+ every occurrence of x with (y +# z). So we only do the
+ unconditional-inline thing for *trivial* expressions.
+
+ NB: you might think that PostInlineUnconditionally would do this
+ but it doesn't fire for top-level things; see SimplUtils
+ Note [Top level and postInlineUnconditionally]
+-}
+
+uncondInline :: CoreExpr -> Arity -> Int -> Bool
+-- Inline unconditionally if there no size increase
+-- Size of call is arity (+1 for the function)
+-- See Note [INLINE for small functions]
+uncondInline rhs arity size
+ | arity > 0 = size <= 10 * (arity + 1) -- See Note [INLINE for small functions] (1)
+ | otherwise = exprIsTrivial rhs -- See Note [INLINE for small functions] (4)
+
+sizeExpr :: DynFlags
+ -> Int -- Bomb out if it gets bigger than this
+ -> [Id] -- Arguments; we're interested in which of these
+ -- get case'd
+ -> CoreExpr
+ -> ExprSize
+
+-- Note [Computing the size of an expression]
+
+sizeExpr dflags bOMB_OUT_SIZE top_args expr
+ = size_up expr
+ where
+ size_up (Cast e _) = size_up e
+ size_up (Tick _ e) = size_up e
+ size_up (Type _) = sizeZero -- Types cost nothing
+ size_up (Coercion _) = sizeZero
+ size_up (Lit lit) = sizeN (litSize lit)
+ size_up (Var f) | isRealWorldId f = sizeZero
+ -- Make sure we get constructor discounts even
+ -- on nullary constructors
+ | otherwise = size_up_call f [] 0
+
+ size_up (App fun arg)
+ | isTyCoArg arg = size_up fun
+ | otherwise = size_up arg `addSizeNSD`
+ size_up_app fun [arg] (if isRealWorldExpr arg then 1 else 0)
+
+ size_up (Lam b e)
+ | isId b && not (isRealWorldId b) = lamScrutDiscount dflags (size_up e `addSizeN` 10)
+ | otherwise = size_up e
+
+ size_up (Let (NonRec binder rhs) body)
+ = size_up_rhs (binder, rhs) `addSizeNSD`
+ size_up body `addSizeN`
+ size_up_alloc binder
+
+ size_up (Let (Rec pairs) body)
+ = foldr (addSizeNSD . size_up_rhs)
+ (size_up body `addSizeN` sum (map (size_up_alloc . fst) pairs))
+ pairs
+
+ size_up (Case e _ _ alts)
+ | null alts
+ = size_up e -- case e of {} never returns, so take size of scrutinee
+
+ size_up (Case e _ _ alts)
+ -- Now alts is non-empty
+ | Just v <- is_top_arg e -- We are scrutinising an argument variable
+ = let
+ alt_sizes = map size_up_alt alts
+
+ -- alts_size tries to compute a good discount for
+ -- the case when we are scrutinising an argument variable
+ alts_size (SizeIs tot tot_disc tot_scrut)
+ -- Size of all alternatives
+ (SizeIs max _ _)
+ -- Size of biggest alternative
+ = SizeIs tot (unitBag (v, 20 + tot - max)
+ `unionBags` tot_disc) tot_scrut
+ -- If the variable is known, we produce a
+ -- discount that will take us back to 'max',
+ -- the size of the largest alternative The
+ -- 1+ is a little discount for reduced
+ -- allocation in the caller
+ --
+ -- Notice though, that we return tot_disc,
+ -- the total discount from all branches. I
+ -- think that's right.
+
+ alts_size tot_size _ = tot_size
+ in
+ alts_size (foldr1 addAltSize alt_sizes) -- alts is non-empty
+ (foldr1 maxSize alt_sizes)
+ -- Good to inline if an arg is scrutinised, because
+ -- that may eliminate allocation in the caller
+ -- And it eliminates the case itself
+ where
+ is_top_arg (Var v) | v `elem` top_args = Just v
+ is_top_arg (Cast e _) = is_top_arg e
+ is_top_arg _ = Nothing
+
+
+ size_up (Case e _ _ alts) = size_up e `addSizeNSD`
+ foldr (addAltSize . size_up_alt) case_size alts
+ where
+ case_size
+ | is_inline_scrut e, not (lengthExceeds alts 1) = sizeN (-10)
+ | otherwise = sizeZero
+ -- Normally we don't charge for the case itself, but
+ -- we charge one per alternative (see size_up_alt,
+ -- below) to account for the cost of the info table
+ -- and comparisons.
+ --
+ -- However, in certain cases (see is_inline_scrut
+ -- below), no code is generated for the case unless
+ -- there are multiple alts. In these cases we
+ -- subtract one, making the first alt free.
+ -- e.g. case x# +# y# of _ -> ... should cost 1
+ -- case touch# x# of _ -> ... should cost 0
+ -- (see #4978)
+ --
+ -- I would like to not have the "not (lengthExceeds alts 1)"
+ -- condition above, but without that some programs got worse
+ -- (spectral/hartel/event and spectral/para). I don't fully
+ -- understand why. (SDM 24/5/11)
+
+ -- unboxed variables, inline primops and unsafe foreign calls
+ -- are all "inline" things:
+ is_inline_scrut (Var v) = isUnliftedType (idType v)
+ is_inline_scrut scrut
+ | (Var f, _) <- collectArgs scrut
+ = case idDetails f of
+ FCallId fc -> not (isSafeForeignCall fc)
+ PrimOpId op -> not (primOpOutOfLine op)
+ _other -> False
+ | otherwise
+ = False
+
+ size_up_rhs (bndr, rhs)
+ | Just join_arity <- isJoinId_maybe bndr
+ -- Skip arguments to join point
+ , (_bndrs, body) <- collectNBinders join_arity rhs
+ = size_up body
+ | otherwise
+ = size_up rhs
+
+ ------------
+ -- size_up_app is used when there's ONE OR MORE value args
+ size_up_app (App fun arg) args voids
+ | isTyCoArg arg = size_up_app fun args voids
+ | isRealWorldExpr arg = size_up_app fun (arg:args) (voids + 1)
+ | otherwise = size_up arg `addSizeNSD`
+ size_up_app fun (arg:args) voids
+ size_up_app (Var fun) args voids = size_up_call fun args voids
+ size_up_app (Tick _ expr) args voids = size_up_app expr args voids
+ size_up_app (Cast expr _) args voids = size_up_app expr args voids
+ size_up_app other args voids = size_up other `addSizeN`
+ callSize (length args) voids
+ -- if the lhs is not an App or a Var, or an invisible thing like a
+ -- Tick or Cast, then we should charge for a complete call plus the
+ -- size of the lhs itself.
+
+ ------------
+ size_up_call :: Id -> [CoreExpr] -> Int -> ExprSize
+ size_up_call fun val_args voids
+ = case idDetails fun of
+ FCallId _ -> sizeN (callSize (length val_args) voids)
+ DataConWorkId dc -> conSize dc (length val_args)
+ PrimOpId op -> primOpSize op (length val_args)
+ ClassOpId _ -> classOpSize dflags top_args val_args
+ _ -> funSize dflags top_args fun (length val_args) voids
+
+ ------------
+ size_up_alt (_con, _bndrs, rhs) = size_up rhs `addSizeN` 10
+ -- Don't charge for args, so that wrappers look cheap
+ -- (See comments about wrappers with Case)
+ --
+ -- IMPORATANT: *do* charge 1 for the alternative, else we
+ -- find that giant case nests are treated as practically free
+ -- A good example is Foreign.C.Error.errnoToIOError
+
+ ------------
+ -- Cost to allocate binding with given binder
+ size_up_alloc bndr
+ | isTyVar bndr -- Doesn't exist at runtime
+ || isJoinId bndr -- Not allocated at all
+ || isUnliftedType (idType bndr) -- Doesn't live in heap
+ = 0
+ | otherwise
+ = 10
+
+ ------------
+ -- These addSize things have to be here because
+ -- I don't want to give them bOMB_OUT_SIZE as an argument
+ addSizeN TooBig _ = TooBig
+ addSizeN (SizeIs n xs d) m = mkSizeIs bOMB_OUT_SIZE (n + m) xs d
+
+ -- addAltSize is used to add the sizes of case alternatives
+ addAltSize TooBig _ = TooBig
+ addAltSize _ TooBig = TooBig
+ addAltSize (SizeIs n1 xs d1) (SizeIs n2 ys d2)
+ = mkSizeIs bOMB_OUT_SIZE (n1 + n2)
+ (xs `unionBags` ys)
+ (d1 + d2) -- Note [addAltSize result discounts]
+
+ -- This variant ignores the result discount from its LEFT argument
+ -- It's used when the second argument isn't part of the result
+ addSizeNSD TooBig _ = TooBig
+ addSizeNSD _ TooBig = TooBig
+ addSizeNSD (SizeIs n1 xs _) (SizeIs n2 ys d2)
+ = mkSizeIs bOMB_OUT_SIZE (n1 + n2)
+ (xs `unionBags` ys)
+ d2 -- Ignore d1
+
+ isRealWorldId id = idType id `eqType` realWorldStatePrimTy
+
+ -- an expression of type State# RealWorld must be a variable
+ isRealWorldExpr (Var id) = isRealWorldId id
+ isRealWorldExpr (Tick _ e) = isRealWorldExpr e
+ isRealWorldExpr _ = False
+
+-- | Finds a nominal size of a string literal.
+litSize :: Literal -> Int
+-- Used by CoreUnfold.sizeExpr
+litSize (LitInteger {}) = 100 -- Note [Size of literal integers]
+litSize (MachStr str) = 10 + 10 * ((BS.length str + 3) `div` 4)
+ -- If size could be 0 then @f "x"@ might be too small
+ -- [Sept03: make literal strings a bit bigger to avoid fruitless
+ -- duplication of little strings]
+litSize _other = 0 -- Must match size of nullary constructors
+ -- Key point: if x |-> 4, then x must inline unconditionally
+ -- (eg via case binding)
+
+classOpSize :: DynFlags -> [Id] -> [CoreExpr] -> ExprSize
+-- See Note [Conlike is interesting]
+classOpSize _ _ []
+ = sizeZero
+classOpSize dflags top_args (arg1 : other_args)
+ = SizeIs size arg_discount 0
+ where
+ size = 20 + (10 * length other_args)
+ -- If the class op is scrutinising a lambda bound dictionary then
+ -- give it a discount, to encourage the inlining of this function
+ -- The actual discount is rather arbitrarily chosen
+ arg_discount = case arg1 of
+ Var dict | dict `elem` top_args
+ -> unitBag (dict, ufDictDiscount dflags)
+ _other -> emptyBag
+
+-- | The size of a function call
+callSize
+ :: Int -- ^ number of value args
+ -> Int -- ^ number of value args that are void
+ -> Int
+callSize n_val_args voids = 10 * (1 + n_val_args - voids)
+ -- The 1+ is for the function itself
+ -- Add 1 for each non-trivial arg;
+ -- the allocation cost, as in let(rec)
+
+-- | The size of a jump to a join point
+jumpSize
+ :: Int -- ^ number of value args
+ -> Int -- ^ number of value args that are void
+ -> Int
+jumpSize n_val_args voids = 2 * (1 + n_val_args - voids)
+ -- A jump is 20% the size of a function call. Making jumps free reopens
+ -- bug #6048, but making them any more expensive loses a 21% improvement in
+ -- spectral/puzzle. TODO Perhaps adjusting the default threshold would be a
+ -- better solution?
+
+funSize :: DynFlags -> [Id] -> Id -> Int -> Int -> ExprSize
+-- Size for functions that are not constructors or primops
+-- Note [Function applications]
+funSize dflags top_args fun n_val_args voids
+ | fun `hasKey` buildIdKey = buildSize
+ | fun `hasKey` augmentIdKey = augmentSize
+ | otherwise = SizeIs size arg_discount res_discount
+ where
+ some_val_args = n_val_args > 0
+ is_join = isJoinId fun
+
+ size | is_join = jumpSize n_val_args voids
+ | not some_val_args = 0
+ | otherwise = callSize n_val_args voids
+
+ -- DISCOUNTS
+ -- See Note [Function and non-function discounts]
+ arg_discount | some_val_args && fun `elem` top_args
+ = unitBag (fun, ufFunAppDiscount dflags)
+ | otherwise = emptyBag
+ -- If the function is an argument and is applied
+ -- to some values, give it an arg-discount
+
+ res_discount | idArity fun > n_val_args = ufFunAppDiscount dflags
+ | otherwise = 0
+ -- If the function is partially applied, show a result discount
+-- XXX maybe behave like ConSize for eval'd variable
+
+conSize :: DataCon -> Int -> ExprSize
+conSize dc n_val_args
+ | n_val_args == 0 = SizeIs 0 emptyBag 10 -- Like variables
+
+-- See Note [Unboxed tuple size and result discount]
+ | isUnboxedTupleCon dc = SizeIs 0 emptyBag (10 * (1 + n_val_args))
+
+-- See Note [Constructor size and result discount]
+ | otherwise = SizeIs 10 emptyBag (10 * (1 + n_val_args))
+
+-- XXX still looks to large to me
+
+{-
+Note [Constructor size and result discount]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Treat a constructors application as size 10, regardless of how many
+arguments it has; we are keen to expose them (and we charge separately
+for their args). We can't treat them as size zero, else we find that
+(Just x) has size 0, which is the same as a lone variable; and hence
+'v' will always be replaced by (Just x), where v is bound to Just x.
+
+The "result discount" is applied if the result of the call is
+scrutinised (say by a case). For a constructor application that will
+mean the constructor application will disappear, so we don't need to
+charge it to the function. So the discount should at least match the
+cost of the constructor application, namely 10. But to give a bit
+of extra incentive we give a discount of 10*(1 + n_val_args).
+
+Simon M tried a MUCH bigger discount: (10 * (10 + n_val_args)),
+and said it was an "unambiguous win", but its terribly dangerous
+because a function with many many case branches, each finishing with
+a constructor, can have an arbitrarily large discount. This led to
+terrible code bloat: see Trac #6099.
+
+Note [Unboxed tuple size and result discount]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+However, unboxed tuples count as size zero. I found occasions where we had
+ f x y z = case op# x y z of { s -> (# s, () #) }
+and f wasn't getting inlined.
+
+I tried giving unboxed tuples a *result discount* of zero (see the
+commented-out line). Why? When returned as a result they do not
+allocate, so maybe we don't want to charge so much for them If you
+have a non-zero discount here, we find that workers often get inlined
+back into wrappers, because it look like
+ f x = case $wf x of (# a,b #) -> (a,b)
+and we are keener because of the case. However while this change
+shrank binary sizes by 0.5% it also made spectral/boyer allocate 5%
+more. All other changes were very small. So it's not a big deal but I
+didn't adopt the idea.
+
+Note [Function and non-function discounts]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We want a discount if the function is applied. A good example is
+monadic combinators with continuation arguments, where inlining is
+quite important.
+
+But we don't want a big discount when a function is called many times
+(see the detailed comments with Trac #6048) because if the function is
+big it won't be inlined at its many call sites and no benefit results.
+Indeed, we can get exponentially big inlinings this way; that is what
+Trac #6048 is about.
+
+On the other hand, for data-valued arguments, if there are lots of
+case expressions in the body, each one will get smaller if we apply
+the function to a constructor application, so we *want* a big discount
+if the argument is scrutinised by many case expressions.
+
+Conclusion:
+ - For functions, take the max of the discounts
+ - For data values, take the sum of the discounts
+
+
+Note [Literal integer size]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Literal integers *can* be big (mkInteger [...coefficients...]), but
+need not be (S# n). We just use an arbitrary big-ish constant here
+so that, in particular, we don't inline top-level defns like
+ n = S# 5
+There's no point in doing so -- any optimisations will see the S#
+through n's unfolding. Nor will a big size inhibit unfoldings functions
+that mention a literal Integer, because the float-out pass will float
+all those constants to top level.
+-}
+
+primOpSize :: PrimOp -> Int -> ExprSize
+primOpSize op n_val_args
+ = if primOpOutOfLine op
+ then sizeN (op_size + n_val_args)
+ else sizeN op_size
+ where
+ op_size = primOpCodeSize op
+
+
+buildSize :: ExprSize
+buildSize = SizeIs 0 emptyBag 40
+ -- We really want to inline applications of build
+ -- build t (\cn -> e) should cost only the cost of e (because build will be inlined later)
+ -- Indeed, we should add a result_discount because build is
+ -- very like a constructor. We don't bother to check that the
+ -- build is saturated (it usually is). The "-2" discounts for the \c n,
+ -- The "4" is rather arbitrary.
+
+augmentSize :: ExprSize
+augmentSize = SizeIs 0 emptyBag 40
+ -- Ditto (augment t (\cn -> e) ys) should cost only the cost of
+ -- e plus ys. The -2 accounts for the \cn
+
+-- When we return a lambda, give a discount if it's used (applied)
+lamScrutDiscount :: DynFlags -> ExprSize -> ExprSize
+lamScrutDiscount dflags (SizeIs n vs _) = SizeIs n vs (ufFunAppDiscount dflags)
+lamScrutDiscount _ TooBig = TooBig
+
+{-
+Note [addAltSize result discounts]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When adding the size of alternatives, we *add* the result discounts
+too, rather than take the *maximum*. For a multi-branch case, this
+gives a discount for each branch that returns a constructor, making us
+keener to inline. I did try using 'max' instead, but it makes nofib
+'rewrite' and 'puzzle' allocate significantly more, and didn't make
+binary sizes shrink significantly either.
+
+Note [Discounts and thresholds]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Constants for discounts and thesholds are defined in main/DynFlags,
+all of form ufXxxx. They are:
+
+ufCreationThreshold
+ At a definition site, if the unfolding is bigger than this, we
+ may discard it altogether
+
+ufUseThreshold
+ At a call site, if the unfolding, less discounts, is smaller than
+ this, then it's small enough inline
+
+ufKeenessFactor
+ Factor by which the discounts are multiplied before
+ subtracting from size
+
+ufDictDiscount
+ The discount for each occurrence of a dictionary argument
+ as an argument of a class method. Should be pretty small
+ else big functions may get inlined
+
+ufFunAppDiscount
+ Discount for a function argument that is applied. Quite
+ large, because if we inline we avoid the higher-order call.
+
+ufDearOp
+ The size of a foreign call or not-dupable PrimOp
+
+ufVeryAggressive
+ If True, the compiler ignores all the thresholds and inlines very
+ aggressively. It still adheres to arity, simplifier phase control and
+ loop breakers.
+
+
+Note [Function applications]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In a function application (f a b)
+
+ - If 'f' is an argument to the function being analysed,
+ and there's at least one value arg, record a FunAppDiscount for f
+
+ - If the application if a PAP (arity > 2 in this example)
+ record a *result* discount (because inlining
+ with "extra" args in the call may mean that we now
+ get a saturated application)
+
+Code for manipulating sizes
+-}
+
+-- | The size of an candidate expression for unfolding
+data ExprSize
+ = TooBig
+ | SizeIs { _es_size_is :: {-# UNPACK #-} !Int -- ^ Size found
+ , _es_args :: !(Bag (Id,Int))
+ -- ^ Arguments cased herein, and discount for each such
+ , _es_discount :: {-# UNPACK #-} !Int
+ -- ^ Size to subtract if result is scrutinised by a case
+ -- expression
+ }
+
+instance Outputable ExprSize where
+ ppr TooBig = text "TooBig"
+ ppr (SizeIs a _ c) = brackets (int a <+> int c)
+
+-- subtract the discount before deciding whether to bale out. eg. we
+-- want to inline a large constructor application into a selector:
+-- tup = (a_1, ..., a_99)
+-- x = case tup of ...
+--
+mkSizeIs :: Int -> Int -> Bag (Id, Int) -> Int -> ExprSize
+mkSizeIs max n xs d | (n - d) > max = TooBig
+ | otherwise = SizeIs n xs d
+
+maxSize :: ExprSize -> ExprSize -> ExprSize
+maxSize TooBig _ = TooBig
+maxSize _ TooBig = TooBig
+maxSize s1@(SizeIs n1 _ _) s2@(SizeIs n2 _ _) | n1 > n2 = s1
+ | otherwise = s2
+
+sizeZero :: ExprSize
+sizeN :: Int -> ExprSize
+
+sizeZero = SizeIs 0 emptyBag 0
+sizeN n = SizeIs n emptyBag 0
+
+{-
+************************************************************************
+* *
+\subsection[considerUnfolding]{Given all the info, do (not) do the unfolding}
+* *
+************************************************************************
+
+We use 'couldBeSmallEnoughToInline' to avoid exporting inlinings that
+we ``couldn't possibly use'' on the other side. Can be overridden w/
+flaggery. Just the same as smallEnoughToInline, except that it has no
+actual arguments.
+-}
+
+couldBeSmallEnoughToInline :: DynFlags -> Int -> CoreExpr -> Bool
+couldBeSmallEnoughToInline dflags threshold rhs
+ = case sizeExpr dflags threshold [] body of
+ TooBig -> False
+ _ -> True
+ where
+ (_, body) = collectBinders rhs
+
+----------------
+smallEnoughToInline :: DynFlags -> Unfolding -> Bool
+smallEnoughToInline dflags (CoreUnfolding {uf_guidance = UnfIfGoodArgs {ug_size = size}})
+ = size <= ufUseThreshold dflags
+smallEnoughToInline _ _
+ = False
+
+----------------
+
+certainlyWillInline :: DynFlags -> IdInfo -> Maybe Unfolding
+-- Sees if the unfolding is pretty certain to inline
+-- If so, return a *stable* unfolding for it, that will always inline
+certainlyWillInline dflags fn_info
+ = case unfoldingInfo fn_info of
+ CoreUnfolding { uf_tmpl = e, uf_guidance = g }
+ | loop_breaker -> Nothing -- Won't inline, so try w/w
+ | otherwise -> do_cunf e g -- Depends on size, so look at that
+
+ DFunUnfolding {} -> Just fn_unf -- Don't w/w DFuns; it never makes sense
+ -- to do so, and even if it is currently a
+ -- loop breaker, it may not be later
+
+ _other_unf -> Nothing
+
+ where
+ loop_breaker = isStrongLoopBreaker (occInfo fn_info)
+ fn_unf = unfoldingInfo fn_info
+
+ do_cunf :: CoreExpr -> UnfoldingGuidance -> Maybe Unfolding
+ do_cunf _ UnfNever = Nothing
+ do_cunf _ (UnfWhen {}) = Just (fn_unf { uf_src = InlineStable })
+ -- INLINE functions have UnfWhen
+
+ -- The UnfIfGoodArgs case seems important. If we w/w small functions
+ -- binary sizes go up by 10%! (This is with SplitObjs.)
+ -- I'm not totally sure why.
+ -- INLINABLE functions come via this path
+ -- See Note [certainlyWillInline: INLINABLE]
+ do_cunf expr (UnfIfGoodArgs { ug_size = size, ug_args = args })
+ | not (null args) -- See Note [certainlyWillInline: be careful of thunks]
+ , case inlinePragmaSpec (inlinePragInfo fn_info) of
+ NoInline -> False -- NOINLINE; do not say certainlyWillInline!
+ _ -> True -- INLINE, INLINABLE, or nothing
+ , not (isBottomingSig (strictnessInfo fn_info))
+ -- Do not unconditionally inline a bottoming functions even if
+ -- it seems smallish. We've carefully lifted it out to top level,
+ -- so we don't want to re-inline it.
+ , let arity = length args
+ , size - (10 * (arity + 1)) <= ufUseThreshold dflags
+ = Just (fn_unf { uf_src = InlineStable
+ , uf_guidance = UnfWhen { ug_arity = arity
+ , ug_unsat_ok = unSaturatedOk
+ , ug_boring_ok = inlineBoringOk expr } })
+ -- Note the "unsaturatedOk". A function like f = \ab. a
+ -- will certainly inline, even if partially applied (f e), so we'd
+ -- better make sure that the transformed inlining has the same property
+ | otherwise
+ = Nothing
+
+{- Note [certainlyWillInline: be careful of thunks]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Don't claim that thunks will certainly inline, because that risks work
+duplication. Even if the work duplication is not great (eg is_cheap
+holds), it can make a big difference in an inner loop In Trac #5623 we
+found that the WorkWrap phase thought that
+ y = case x of F# v -> F# (v +# v)
+was certainlyWillInline, so the addition got duplicated.
+
+Note [certainlyWillInline: INLINABLE]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+certainlyWillInline /must/ return Nothing for a large INLINABLE thing,
+even though we have a stable inlining, so that strictness w/w takes
+place. It makes a big difference to efficiency, and the w/w pass knows
+how to transfer the INLINABLE info to the worker; see WorkWrap
+Note [Worker-wrapper for INLINABLE functions]
+
+************************************************************************
+* *
+\subsection{callSiteInline}
+* *
+************************************************************************
+
+This is the key function. It decides whether to inline a variable at a call site
+
+callSiteInline is used at call sites, so it is a bit more generous.
+It's a very important function that embodies lots of heuristics.
+A non-WHNF can be inlined if it doesn't occur inside a lambda,
+and occurs exactly once or
+ occurs once in each branch of a case and is small
+
+If the thing is in WHNF, there's no danger of duplicating work,
+so we can inline if it occurs once, or is small
+
+NOTE: we don't want to inline top-level functions that always diverge.
+It just makes the code bigger. Tt turns out that the convenient way to prevent
+them inlining is to give them a NOINLINE pragma, which we do in
+StrictAnal.addStrictnessInfoToTopId
+-}
+
+callSiteInline :: DynFlags
+ -> Id -- The Id
+ -> Bool -- True <=> unfolding is active
+ -> Bool -- True if there are no arguments at all (incl type args)
+ -> [ArgSummary] -- One for each value arg; True if it is interesting
+ -> CallCtxt -- True <=> continuation is interesting
+ -> Maybe CoreExpr -- Unfolding, if any
+
+data ArgSummary = TrivArg -- Nothing interesting
+ | NonTrivArg -- Arg has structure
+ | ValueArg -- Arg is a con-app or PAP
+ -- ..or con-like. Note [Conlike is interesting]
+
+instance Outputable ArgSummary where
+ ppr TrivArg = text "TrivArg"
+ ppr NonTrivArg = text "NonTrivArg"
+ ppr ValueArg = text "ValueArg"
+
+nonTriv :: ArgSummary -> Bool
+nonTriv TrivArg = False
+nonTriv _ = True
+
+data CallCtxt
+ = BoringCtxt
+ | RhsCtxt -- Rhs of a let-binding; see Note [RHS of lets]
+ | DiscArgCtxt -- Argument of a function with non-zero arg discount
+ | RuleArgCtxt -- We are somewhere in the argument of a function with rules
+
+ | ValAppCtxt -- We're applied to at least one value arg
+ -- This arises when we have ((f x |> co) y)
+ -- Then the (f x) has argument 'x' but in a ValAppCtxt
+
+ | CaseCtxt -- We're the scrutinee of a case
+ -- that decomposes its scrutinee
+
+instance Outputable CallCtxt where
+ ppr CaseCtxt = text "CaseCtxt"
+ ppr ValAppCtxt = text "ValAppCtxt"
+ ppr BoringCtxt = text "BoringCtxt"
+ ppr RhsCtxt = text "RhsCtxt"
+ ppr DiscArgCtxt = text "DiscArgCtxt"
+ ppr RuleArgCtxt = text "RuleArgCtxt"
+
+callSiteInline dflags id active_unfolding lone_variable arg_infos cont_info
+ = case idUnfolding id of
+ -- idUnfolding checks for loop-breakers, returning NoUnfolding
+ -- Things with an INLINE pragma may have an unfolding *and*
+ -- be a loop breaker (maybe the knot is not yet untied)
+ CoreUnfolding { uf_tmpl = unf_template, uf_is_top = is_top
+ , uf_is_work_free = is_wf
+ , uf_guidance = guidance, uf_expandable = is_exp }
+ | active_unfolding -> tryUnfolding dflags id lone_variable
+ arg_infos cont_info unf_template is_top
+ is_wf is_exp guidance
+ | otherwise -> traceInline dflags "Inactive unfolding:" (ppr id) Nothing
+ NoUnfolding -> Nothing
+ BootUnfolding -> Nothing
+ OtherCon {} -> Nothing
+ DFunUnfolding {} -> Nothing -- Never unfold a DFun
+
+traceInline :: DynFlags -> String -> SDoc -> a -> a
+traceInline dflags str doc result
+ | dopt Opt_D_dump_inlinings dflags && dopt Opt_D_verbose_core2core dflags
+ = pprTrace str doc result
+ | otherwise
+ = result
+
+tryUnfolding :: DynFlags -> Id -> Bool -> [ArgSummary] -> CallCtxt
+ -> CoreExpr -> Bool -> Bool -> Bool -> UnfoldingGuidance
+ -> Maybe CoreExpr
+tryUnfolding dflags id lone_variable
+ arg_infos cont_info unf_template is_top
+ is_wf is_exp guidance
+ = case guidance of
+ UnfNever -> traceInline dflags str (text "UnfNever") Nothing
+
+ UnfWhen { ug_arity = uf_arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok }
+ | enough_args && (boring_ok || some_benefit || ufVeryAggressive dflags)
+ -- See Note [INLINE for small functions (3)]
+ -> traceInline dflags str (mk_doc some_benefit empty True) (Just unf_template)
+ | otherwise
+ -> traceInline dflags str (mk_doc some_benefit empty False) Nothing
+ where
+ some_benefit = calc_some_benefit uf_arity
+ enough_args = (n_val_args >= uf_arity) || (unsat_ok && n_val_args > 0)
+
+ UnfIfGoodArgs { ug_args = arg_discounts, ug_res = res_discount, ug_size = size }
+ | ufVeryAggressive dflags
+ -> traceInline dflags str (mk_doc some_benefit extra_doc True) (Just unf_template)
+ | is_wf && some_benefit && small_enough
+ -> traceInline dflags str (mk_doc some_benefit extra_doc True) (Just unf_template)
+ | otherwise
+ -> traceInline dflags str (mk_doc some_benefit extra_doc False) Nothing
+ where
+ some_benefit = calc_some_benefit (length arg_discounts)
+ extra_doc = text "discounted size =" <+> int discounted_size
+ discounted_size = size - discount
+ small_enough = discounted_size <= ufUseThreshold dflags
+ discount = computeDiscount dflags arg_discounts
+ res_discount arg_infos cont_info
+
+ where
+ mk_doc some_benefit extra_doc yes_or_no
+ = vcat [ text "arg infos" <+> ppr arg_infos
+ , text "interesting continuation" <+> ppr cont_info
+ , text "some_benefit" <+> ppr some_benefit
+ , text "is exp:" <+> ppr is_exp
+ , text "is work-free:" <+> ppr is_wf
+ , text "guidance" <+> ppr guidance
+ , extra_doc
+ , text "ANSWER =" <+> if yes_or_no then text "YES" else text "NO"]
+
+ str = "Considering inlining: " ++ showSDocDump dflags (ppr id)
+ n_val_args = length arg_infos
+
+ -- some_benefit is used when the RHS is small enough
+ -- and the call has enough (or too many) value
+ -- arguments (ie n_val_args >= arity). But there must
+ -- be *something* interesting about some argument, or the
+ -- result context, to make it worth inlining
+ calc_some_benefit :: Arity -> Bool -- The Arity is the number of args
+ -- expected by the unfolding
+ calc_some_benefit uf_arity
+ | not saturated = interesting_args -- Under-saturated
+ -- Note [Unsaturated applications]
+ | otherwise = interesting_args -- Saturated or over-saturated
+ || interesting_call
+ where
+ saturated = n_val_args >= uf_arity
+ over_saturated = n_val_args > uf_arity
+ interesting_args = any nonTriv arg_infos
+ -- NB: (any nonTriv arg_infos) looks at the
+ -- over-saturated args too which is "wrong";
+ -- but if over-saturated we inline anyway.
+
+ interesting_call
+ | over_saturated
+ = True
+ | otherwise
+ = case cont_info of
+ CaseCtxt -> not (lone_variable && is_wf) -- Note [Lone variables]
+ ValAppCtxt -> True -- Note [Cast then apply]
+ RuleArgCtxt -> uf_arity > 0 -- See Note [Unfold info lazy contexts]
+ DiscArgCtxt -> uf_arity > 0 --
+ RhsCtxt -> uf_arity > 0 --
+ _ -> not is_top && uf_arity > 0 -- Note [Nested functions]
+ -- Note [Inlining in ArgCtxt]
+
+{-
+Note [Unfold into lazy contexts], Note [RHS of lets]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When the call is the argument of a function with a RULE, or the RHS of a let,
+we are a little bit keener to inline. For example
+ f y = (y,y,y)
+ g y = let x = f y in ...(case x of (a,b,c) -> ...) ...
+We'd inline 'f' if the call was in a case context, and it kind-of-is,
+only we can't see it. Also
+ x = f v
+could be expensive whereas
+ x = case v of (a,b) -> a
+is patently cheap and may allow more eta expansion.
+So we treat the RHS of a let as not-totally-boring.
+
+Note [Unsaturated applications]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When a call is not saturated, we *still* inline if one of the
+arguments has interesting structure. That's sometimes very important.
+A good example is the Ord instance for Bool in Base:
+
+ Rec {
+ $fOrdBool =GHC.Classes.D:Ord
+ @ Bool
+ ...
+ $cmin_ajX
+
+ $cmin_ajX [Occ=LoopBreaker] :: Bool -> Bool -> Bool
+ $cmin_ajX = GHC.Classes.$dmmin @ Bool $fOrdBool
+ }
+
+But the defn of GHC.Classes.$dmmin is:
+
+ $dmmin :: forall a. GHC.Classes.Ord a => a -> a -> a
+ {- Arity: 3, HasNoCafRefs, Strictness: SLL,
+ Unfolding: (\ @ a $dOrd :: GHC.Classes.Ord a x :: a y :: a ->
+ case @ a GHC.Classes.<= @ a $dOrd x y of wild {
+ GHC.Types.False -> y GHC.Types.True -> x }) -}
+
+We *really* want to inline $dmmin, even though it has arity 3, in
+order to unravel the recursion.
+
+
+Note [Things to watch]
+~~~~~~~~~~~~~~~~~~~~~~
+* { y = I# 3; x = y `cast` co; ...case (x `cast` co) of ... }
+ Assume x is exported, so not inlined unconditionally.
+ Then we want x to inline unconditionally; no reason for it
+ not to, and doing so avoids an indirection.
+
+* { x = I# 3; ....f x.... }
+ Make sure that x does not inline unconditionally!
+ Lest we get extra allocation.
+
+Note [Inlining an InlineRule]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+An InlineRules is used for
+ (a) programmer INLINE pragmas
+ (b) inlinings from worker/wrapper
+
+For (a) the RHS may be large, and our contract is that we *only* inline
+when the function is applied to all the arguments on the LHS of the
+source-code defn. (The uf_arity in the rule.)
+
+However for worker/wrapper it may be worth inlining even if the
+arity is not satisfied (as we do in the CoreUnfolding case) so we don't
+require saturation.
+
+
+Note [Nested functions]
+~~~~~~~~~~~~~~~~~~~~~~~
+If a function has a nested defn we also record some-benefit, on the
+grounds that we are often able to eliminate the binding, and hence the
+allocation, for the function altogether; this is good for join points.
+But this only makes sense for *functions*; inlining a constructor
+doesn't help allocation unless the result is scrutinised. UNLESS the
+constructor occurs just once, albeit possibly in multiple case
+branches. Then inlining it doesn't increase allocation, but it does
+increase the chance that the constructor won't be allocated at all in
+the branches that don't use it.
+
+Note [Cast then apply]
+~~~~~~~~~~~~~~~~~~~~~~
+Consider
+ myIndex = __inline_me ( (/\a. ) |> co )
+ co :: (forall a. a -> a) ~ (forall a. T a)
+ ... /\a.\x. case ((myIndex a) |> sym co) x of { ... } ...
+
+We need to inline myIndex to unravel this; but the actual call (myIndex a) has
+no value arguments. The ValAppCtxt gives it enough incentive to inline.
+
+Note [Inlining in ArgCtxt]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+The condition (arity > 0) here is very important, because otherwise
+we end up inlining top-level stuff into useless places; eg
+ x = I# 3#
+ f = \y. g x
+This can make a very big difference: it adds 16% to nofib 'integer' allocs,
+and 20% to 'power'.
+
+At one stage I replaced this condition by 'True' (leading to the above
+slow-down). The motivation was test eyeball/inline1.hs; but that seems
+to work ok now.
+
+NOTE: arguably, we should inline in ArgCtxt only if the result of the
+call is at least CONLIKE. At least for the cases where we use ArgCtxt
+for the RHS of a 'let', we only profit from the inlining if we get a
+CONLIKE thing (modulo lets).
+
+Note [Lone variables] See also Note [Interaction of exprIsWorkFree and lone variables]
+~~~~~~~~~~~~~~~~~~~~~ which appears below
+The "lone-variable" case is important. I spent ages messing about
+with unsatisfactory variants, but this is nice. The idea is that if a
+variable appears all alone
+
+ as an arg of lazy fn, or rhs BoringCtxt
+ as scrutinee of a case CaseCtxt
+ as arg of a fn ArgCtxt
+AND
+ it is bound to a cheap expression
+
+then we should not inline it (unless there is some other reason,
+e.g. it is the sole occurrence). That is what is happening at
+the use of 'lone_variable' in 'interesting_call'.
+
+Why? At least in the case-scrutinee situation, turning
+ let x = (a,b) in case x of y -> ...
+into
+ let x = (a,b) in case (a,b) of y -> ...
+and thence to
+ let x = (a,b) in let y = (a,b) in ...
+is bad if the binding for x will remain.
+
+Another example: I discovered that strings
+were getting inlined straight back into applications of 'error'
+because the latter is strict.
+ s = "foo"
+ f = \x -> ...(error s)...
+
+Fundamentally such contexts should not encourage inlining because the
+context can ``see'' the unfolding of the variable (e.g. case or a
+RULE) so there's no gain. If the thing is bound to a value.
+
+However, watch out:
+
+ * Consider this:
+ foo = _inline_ (\n. [n])
+ bar = _inline_ (foo 20)
+ baz = \n. case bar of { (m:_) -> m + n }
+ Here we really want to inline 'bar' so that we can inline 'foo'
+ and the whole thing unravels as it should obviously do. This is
+ important: in the NDP project, 'bar' generates a closure data
+ structure rather than a list.
+
+ So the non-inlining of lone_variables should only apply if the
+ unfolding is regarded as cheap; because that is when exprIsConApp_maybe
+ looks through the unfolding. Hence the "&& is_wf" in the
+ InlineRule branch.
+
+ * Even a type application or coercion isn't a lone variable.
+ Consider
+ case $fMonadST @ RealWorld of { :DMonad a b c -> c }
+ We had better inline that sucker! The case won't see through it.
+
+ For now, I'm treating treating a variable applied to types
+ in a *lazy* context "lone". The motivating example was
+ f = /\a. \x. BIG
+ g = /\a. \y. h (f a)
+ There's no advantage in inlining f here, and perhaps
+ a significant disadvantage. Hence some_val_args in the Stop case
+
+Note [Interaction of exprIsWorkFree and lone variables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The lone-variable test says "don't inline if a case expression
+scrutinises a lone variable whose unfolding is cheap". It's very
+important that, under these circumstances, exprIsConApp_maybe
+can spot a constructor application. So, for example, we don't
+consider
+ let x = e in (x,x)
+to be cheap, and that's good because exprIsConApp_maybe doesn't
+think that expression is a constructor application.
+
+In the 'not (lone_variable && is_wf)' test, I used to test is_value
+rather than is_wf, which was utterly wrong, because the above
+expression responds True to exprIsHNF, which is what sets is_value.
+
+This kind of thing can occur if you have
+
+ {-# INLINE foo #-}
+ foo = let x = e in (x,x)
+
+which Roman did.
+-}
+
+computeDiscount :: DynFlags -> [Int] -> Int -> [ArgSummary] -> CallCtxt
+ -> Int
+computeDiscount dflags arg_discounts res_discount arg_infos cont_info
+ -- We multiple the raw discounts (args_discount and result_discount)
+ -- ty opt_UnfoldingKeenessFactor because the former have to do with
+ -- *size* whereas the discounts imply that there's some extra
+ -- *efficiency* to be gained (e.g. beta reductions, case reductions)
+ -- by inlining.
+
+ = 10 -- Discount of 10 because the result replaces the call
+ -- so we count 10 for the function itself
+
+ + 10 * length actual_arg_discounts
+ -- Discount of 10 for each arg supplied,
+ -- because the result replaces the call
+
+ + round (ufKeenessFactor dflags *
+ fromIntegral (total_arg_discount + res_discount'))
+ where
+ actual_arg_discounts = zipWith mk_arg_discount arg_discounts arg_infos
+ total_arg_discount = sum actual_arg_discounts
+
+ mk_arg_discount _ TrivArg = 0
+ mk_arg_discount _ NonTrivArg = 10
+ mk_arg_discount discount ValueArg = discount
+
+ res_discount'
+ | LT <- arg_discounts `compareLength` arg_infos
+ = res_discount -- Over-saturated
+ | otherwise
+ = case cont_info of
+ BoringCtxt -> 0
+ CaseCtxt -> res_discount -- Presumably a constructor
+ ValAppCtxt -> res_discount -- Presumably a function
+ _ -> 40 `min` res_discount
+ -- ToDo: this 40 `min` res_discount doesn't seem right
+ -- for DiscArgCtxt it shouldn't matter because the function will
+ -- get the arg discount for any non-triv arg
+ -- for RuleArgCtxt we do want to be keener to inline; but not only
+ -- constructor results
+ -- for RhsCtxt I suppose that exposing a data con is good in general
+ -- And 40 seems very arbitrary
+ --
+ -- res_discount can be very large when a function returns
+ -- constructors; but we only want to invoke that large discount
+ -- when there's a case continuation.
+ -- Otherwise we, rather arbitrarily, threshold it. Yuk.
+ -- But we want to aovid inlining large functions that return
+ -- constructors into contexts that are simply "interesting"
diff --git a/coreSyn/CoreUtils.hs b/coreSyn/CoreUtils.hs
new file mode 100644
--- /dev/null
+++ b/coreSyn/CoreUtils.hs
@@ -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 x" as trivial, it will be inlined inside lambdas and the
+entry count will be skewed, for example. Furthermore "scc x" will
+turn into just "x" in mkTick.
+
+Note [Empty case is trivial]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The expression (case (x::Int) Bool of {}) is just a type-changing
+case used when we are sure that 'x' will not return. See
+Note [Empty case alternatives] in CoreSyn.
+
+If the scrutinee is trivial, then so is the whole expression; and the
+CoreToSTG pass in fact drops the case expression leaving only the
+scrutinee.
+
+Having more trivial expressions is good. Moreover, if we don't treat
+it as trivial we may land up with let-bindings like
+ let v = case x of {} in ...
+and after CoreToSTG that gives
+ let v = x in ...
+and that confuses the code generator (Trac #11155). So best to kill
+it off at source.
+-}
+
+exprIsTrivial :: CoreExpr -> Bool
+exprIsTrivial (Var _) = True -- See Note [Variables are trivial]
+exprIsTrivial (Type _) = True
+exprIsTrivial (Coercion _) = True
+exprIsTrivial (Lit lit) = litIsTrivial lit
+exprIsTrivial (App e arg) = not (isRuntimeArg arg) && exprIsTrivial e
+exprIsTrivial (Lam b e) = not (isRuntimeVar b) && exprIsTrivial e
+exprIsTrivial (Tick t e) = not (tickishIsCode t) && exprIsTrivial e
+ -- See Note [Tick trivial]
+exprIsTrivial (Cast e _) = exprIsTrivial e
+exprIsTrivial (Case e _ _ []) = exprIsTrivial e -- See Note [Empty case is trivial]
+exprIsTrivial _ = False
+
+{-
+Note [getIdFromTrivialExpr]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When substituting in a breakpoint we need to strip away the type cruft
+from a trivial expression and get back to the Id. The invariant is
+that the expression we're substituting was originally trivial
+according to exprIsTrivial, AND the expression is not a literal.
+See Note [substTickish] for how breakpoint substitution preserves
+this extra invariant.
+
+We also need this functionality in CorePrep to extract out Id of a
+function which we are saturating. However, in this case we don't know
+if the variable actually refers to a literal; thus we use
+'getIdFromTrivialExpr_maybe' to handle this case. See test
+T12076lit for an example where this matters.
+-}
+
+getIdFromTrivialExpr :: CoreExpr -> Id
+getIdFromTrivialExpr e
+ = fromMaybe (pprPanic "getIdFromTrivialExpr" (ppr e))
+ (getIdFromTrivialExpr_maybe e)
+
+getIdFromTrivialExpr_maybe :: CoreExpr -> Maybe Id
+-- See Note [getIdFromTrivialExpr]
+getIdFromTrivialExpr_maybe e = go e
+ where go (Var v) = Just v
+ go (App f t) | not (isRuntimeArg t) = go f
+ go (Tick t e) | not (tickishIsCode t) = go e
+ go (Cast e _) = go e
+ go (Lam b e) | not (isRuntimeVar b) = go e
+ go _ = Nothing
+
+{-
+exprIsBottom is a very cheap and cheerful function; it may return
+False for bottoming expressions, but it never costs much to ask. See
+also CoreArity.exprBotStrictness_maybe, but that's a bit more
+expensive.
+-}
+
+exprIsBottom :: CoreExpr -> Bool
+-- See Note [Bottoming expressions]
+exprIsBottom e
+ | isEmptyTy (exprType e)
+ = True
+ | otherwise
+ = go 0 e
+ where
+ go n (Var v) = isBottomingId v && n >= idArity v
+ go n (App e a) | isTypeArg a = go n e
+ | otherwise = go (n+1) e
+ go n (Tick _ e) = go n e
+ go n (Cast e _) = go n e
+ go n (Let _ e) = go n e
+ go n (Lam v e) | isTyVar v = go n e
+ go _ (Case _ _ _ alts) = null alts
+ -- See Note [Empty case alternatives] in CoreSyn
+ go _ _ = False
+
+{- Note [Bottoming expressions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+A bottoming expression is guaranteed to diverge, or raise an
+exception. We can test for it in two different ways, and exprIsBottom
+checks for both of these situations:
+
+* Visibly-bottom computations. For example
+ (error Int "Hello")
+ is visibly bottom. The strictness analyser also finds out if
+ a function diverges or raises an exception, and puts that info
+ in its strictness signature.
+
+* Empty types. If a type is empty, its only inhabitant is bottom.
+ For example:
+ data T
+ f :: T -> Bool
+ f = \(x:t). case x of Bool {}
+ Since T has no data constructors, the case alternatives are of course
+ empty. However note that 'x' is not bound to a visibly-bottom value;
+ it's the *type* that tells us it's going to diverge.
+
+A GADT may also be empty even though it has constructors:
+ data T a where
+ T1 :: a -> T Bool
+ T2 :: T Int
+ ...(case (x::T Char) of {})...
+Here (T Char) is uninhabited. A more realistic case is (Int ~ Bool),
+which is likewise uninhabited.
+
+
+************************************************************************
+* *
+ exprIsDupable
+* *
+************************************************************************
+
+Note [exprIsDupable]
+~~~~~~~~~~~~~~~~~~~~
+@exprIsDupable@ is true of expressions that can be duplicated at a modest
+ cost in code size. This will only happen in different case
+ branches, so there's no issue about duplicating work.
+
+ That is, exprIsDupable returns True of (f x) even if
+ f is very very expensive to call.
+
+ Its only purpose is to avoid fruitless let-binding
+ and then inlining of case join points
+-}
+
+exprIsDupable :: DynFlags -> CoreExpr -> Bool
+exprIsDupable dflags e
+ = isJust (go dupAppSize e)
+ where
+ go :: Int -> CoreExpr -> Maybe Int
+ go n (Type {}) = Just n
+ go n (Coercion {}) = Just n
+ go n (Var {}) = decrement n
+ go n (Tick _ e) = go n e
+ go n (Cast e _) = go n e
+ go n (App f a) | Just n' <- go n a = go n' f
+ go n (Lit lit) | litIsDupable dflags lit = decrement n
+ go _ _ = Nothing
+
+ decrement :: Int -> Maybe Int
+ decrement 0 = Nothing
+ decrement n = Just (n-1)
+
+dupAppSize :: Int
+dupAppSize = 8 -- Size of term we are prepared to duplicate
+ -- This is *just* big enough to make test MethSharing
+ -- inline enough join points. Really it should be
+ -- smaller, and could be if we fixed Trac #4960.
+
+{-
+************************************************************************
+* *
+ exprIsCheap, exprIsExpandable
+* *
+************************************************************************
+
+Note [exprIsWorkFree]
+~~~~~~~~~~~~~~~~~~~~~
+exprIsWorkFree is used when deciding whether to inline something; we
+don't inline it if doing so might duplicate work, by peeling off a
+complete copy of the expression. Here we do not want even to
+duplicate a primop (Trac #5623):
+ eg let x = a #+ b in x +# x
+ we do not want to inline/duplicate x
+
+Previously we were a bit more liberal, which led to the primop-duplicating
+problem. However, being more conservative did lead to a big regression in
+one nofib benchmark, wheel-sieve1. The situation looks like this:
+
+ let noFactor_sZ3 :: GHC.Types.Int -> GHC.Types.Bool
+ noFactor_sZ3 = case s_adJ of _ { GHC.Types.I# x_aRs ->
+ case GHC.Prim.<=# x_aRs 2 of _ {
+ GHC.Types.False -> notDivBy ps_adM qs_adN;
+ GHC.Types.True -> lvl_r2Eb }}
+ go = \x. ...(noFactor (I# y))....(go x')...
+
+The function 'noFactor' is heap-allocated and then called. Turns out
+that 'notDivBy' is strict in its THIRD arg, but that is invisible to
+the caller of noFactor, which therefore cannot do w/w and
+heap-allocates noFactor's argument. At the moment (May 12) we are just
+going to put up with this, because the previous more aggressive inlining
+(which treated 'noFactor' as work-free) was duplicating primops, which
+in turn was making inner loops of array calculations runs slow (#5623)
+
+Note [Case expressions are work-free]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Are case-expressions work-free? Consider
+ let v = case x of (p,q) -> p
+ go = \y -> ...case v of ...
+Should we inline 'v' at its use site inside the loop? At the moment
+we do. I experimented with saying that case are *not* work-free, but
+that increased allocation slightly. It's a fairly small effect, and at
+the moment we go for the slightly more aggressive version which treats
+(case x of ....) as work-free if the alternatives are.
+
+Moreover it improves arities of overloaded functions where
+there is only dictionary selection (no construction) involved
+
+Note [exprIsCheap] See also Note [Interaction of exprIsCheap and lone variables]
+~~~~~~~~~~~~~~~~~~ in CoreUnfold.hs
+@exprIsCheap@ looks at a Core expression and returns \tr{True} if
+it is obviously in weak head normal form, or is cheap to get to WHNF.
+[Note that that's not the same as exprIsDupable; an expression might be
+big, and hence not dupable, but still cheap.]
+
+By ``cheap'' we mean a computation we're willing to:
+ push inside a lambda, or
+ inline at more than one place
+That might mean it gets evaluated more than once, instead of being
+shared. The main examples of things which aren't WHNF but are
+``cheap'' are:
+
+ * case e of
+ pi -> ei
+ (where e, and all the ei are cheap)
+
+ * let x = e in b
+ (where e and b are cheap)
+
+ * op x1 ... xn
+ (where op is a cheap primitive operator)
+
+ * error "foo"
+ (because we are happy to substitute it inside a lambda)
+
+Notice that a variable is considered 'cheap': we can push it inside a lambda,
+because sharing will make sure it is only evaluated once.
+
+Note [exprIsCheap and exprIsHNF]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Note that exprIsHNF does not imply exprIsCheap. Eg
+ let x = fac 20 in Just x
+This responds True to exprIsHNF (you can discard a seq), but
+False to exprIsCheap.
+
+Note [exprIsExpandable]
+~~~~~~~~~~~~~~~~~~~~~~~
+An expression is "expandable" if we are willing to dupicate it, if doing
+so might make a RULE or case-of-constructor fire. Mainly this means
+data-constructor applications, but it's a bit more generous than exprIsCheap
+because it is true of "CONLIKE" Ids: see Note [CONLIKE pragma] in BasicTypes.
+
+It is used to set the uf_expandable field of an Unfolding, and that
+in turn is used
+ * In RULE matching
+ * In exprIsConApp_maybe, exprIsLiteral_maybe, exprIsLambda_maybe
+
+But take care: exprIsExpandable should /not/ be true of primops. I
+found this in test T5623a:
+ let q = /\a. Ptr a (a +# b)
+ in case q @ Float of Ptr v -> ...q...
+
+q's inlining should not be expandable, else exprIsConApp_maybe will
+say that (q @ Float) expands to (Ptr a (a +# b)), and that will
+duplicate the (a +# b) primop, which we should not do lightly.
+(It's quite hard to trigger this bug, but T13155 does so for GHC 8.0.)
+
+
+Note [Arguments in exprIsOk]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+What predicate should we apply to the argument of an application? We
+used to say "exprIsTrivial arg" due to concerns about duplicating
+nested constructor applications, but see #4978. The principle here is
+that
+ let x = a +# b in c *# x
+should behave equivalently to
+ c *# (a +# b)
+Since lets with cheap RHSs are accepted, so should paps with cheap arguments
+-}
+
+--------------------
+exprIsCheap :: CoreExpr -> Bool
+exprIsCheap = exprIsOk isCheapApp
+
+exprIsExpandable :: CoreExpr -> Bool -- See Note [exprIsExpandable]
+exprIsExpandable = exprIsOk isExpandableApp
+
+exprIsWorkFree :: CoreExpr -> Bool -- See Note [exprIsWorkFree]
+exprIsWorkFree = exprIsOk isWorkFreeApp
+
+--------------------
+exprIsOk :: CheapAppFun -> CoreExpr -> Bool
+exprIsOk ok_app e
+ = ok e
+ where
+ ok e = go 0 e
+
+ -- n is the number of value arguments
+ go n (Var v) = ok_app v n
+ go _ (Lit {}) = True
+ go _ (Type {}) = True
+ go _ (Coercion {}) = True
+ go n (Cast e _) = go n e
+ go n (Case scrut _ _ alts) = foldl (&&) (ok scrut)
+ [ go n rhs | (_,_,rhs) <- alts ]
+ go n (Tick t e) | tickishCounts t = False
+ | otherwise = go n e
+ go n (Lam x e) | isRuntimeVar x = n==0 || go (n-1) e
+ | otherwise = go n e
+ go n (App f e) | isRuntimeArg e = go (n+1) f && ok e
+ | otherwise = go n f
+ go _ (Let {}) = False
+
+ -- Case: see Note [Case expressions are work-free]
+ -- App: see Note [Arguments in exprIsOk]
+ -- Let: the old exprIsCheap worked through lets
+
+
+-------------------------------------
+type CheapAppFun = Id -> Arity -> Bool
+ -- Is an application of this function to n *value* args
+ -- always cheap, assuming the arguments are cheap?
+ -- True mainly of data constructors, partial applications;
+ -- but with minor variations:
+ -- isWorkFreeApp
+ -- isCheapApp
+ -- isExpandableApp
+
+ -- NB: isCheapApp and isExpandableApp are called from outside
+ -- this module, so don't be tempted to move the notRedex
+ -- stuff into the call site in exprIsOk, and remove it
+ -- from the CheapAppFun implementations
+
+
+notRedex :: CheapAppFun
+notRedex fn n_val_args
+ = n_val_args == 0 -- No value args
+ || n_val_args < idArity fn -- Partial application
+ || isBottomingId fn -- OK to duplicate calls to bottom;
+ -- it certainly doesn't need to be shared!
+
+isWorkFreeApp :: CheapAppFun
+isWorkFreeApp fn n_val_args
+ | notRedex fn n_val_args
+ = True
+ | otherwise
+ = case idDetails fn of
+ DataConWorkId {} -> True
+ _ -> False
+
+isCheapApp :: CheapAppFun
+isCheapApp fn n_val_args
+ | notRedex fn n_val_args
+ = True
+ | otherwise
+ = case idDetails fn of
+ DataConWorkId {} -> True
+ RecSelId {} -> n_val_args == 1 -- See Note [Record selection]
+ ClassOpId {} -> n_val_args == 1
+ PrimOpId op -> primOpIsCheap op
+ _ -> False
+ -- In principle we should worry about primops
+ -- that return a type variable, since the result
+ -- might be applied to something, but I'm not going
+ -- to bother to check the number of args
+
+isExpandableApp :: CheapAppFun
+isExpandableApp fn n_val_args
+ | notRedex fn n_val_args
+ = True
+ | isConLikeId fn
+ = True
+ | otherwise
+ = case idDetails fn of
+ DataConWorkId {} -> True
+ RecSelId {} -> n_val_args == 1 -- See Note [Record selection]
+ ClassOpId {} -> n_val_args == 1
+ PrimOpId {} -> False
+ _ -> all_pred_args n_val_args (idType fn)
+
+ where
+ -- See if all the arguments are PredTys (implicit params or classes)
+ -- If so we'll regard it as expandable; see Note [Expandable overloadings]
+ all_pred_args n_val_args ty
+ | n_val_args == 0
+ = True
+
+ | Just (bndr, ty) <- splitPiTy_maybe ty
+ = caseBinder bndr
+ (\_tv -> all_pred_args n_val_args ty)
+ (\bndr_ty -> isPredTy bndr_ty && all_pred_args (n_val_args-1) ty)
+
+ | otherwise
+ = False
+
+{- Note [Record selection]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+I'm experimenting with making record selection
+look cheap, so we will substitute it inside a
+lambda. Particularly for dictionary field selection.
+
+BUT: Take care with (sel d x)! The (sel d) might be cheap, but
+there's no guarantee that (sel d x) will be too. Hence (n_val_args == 1)
+
+Note [Expandable overloadings]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose the user wrote this
+ {-# RULE forall x. foo (negate x) = h x #-}
+ f x = ....(foo (negate x))....
+He'd expect the rule to fire. But since negate is overloaded, we might
+get this:
+ f = \d -> let n = negate d in \x -> ...foo (n x)...
+So we treat the application of a function (negate in this case) to a
+*dictionary* as expandable. In effect, every function is CONLIKE when
+it's applied only to dictionaries.
+
+
+************************************************************************
+* *
+ exprOkForSpeculation
+* *
+************************************************************************
+-}
+
+-----------------------------
+-- | 'exprOkForSpeculation' returns True of an expression that is:
+--
+-- * Safe to evaluate even if normal order eval might not
+-- evaluate the expression at all, or
+--
+-- * Safe /not/ to evaluate even if normal order would do so
+--
+-- It is usually called on arguments of unlifted type, but not always
+-- In particular, Simplify.rebuildCase calls it on lifted types
+-- when a 'case' is a plain 'seq'. See the example in
+-- Note [exprOkForSpeculation: case expressions] below
+--
+-- Precisely, it returns @True@ iff:
+-- a) The expression guarantees to terminate,
+-- b) soon,
+-- c) without causing a write side effect (e.g. writing a mutable variable)
+-- d) without throwing a Haskell exception
+-- e) without risking an unchecked runtime exception (array out of bounds,
+-- divide by zero)
+--
+-- For @exprOkForSideEffects@ the list is the same, but omitting (e).
+--
+-- Note that
+-- exprIsHNF implies exprOkForSpeculation
+-- exprOkForSpeculation implies exprOkForSideEffects
+--
+-- See Note [PrimOp can_fail and has_side_effects] in PrimOp
+-- and Note [Implementation: how can_fail/has_side_effects affect transformations]
+--
+-- As an example of the considerations in this test, consider:
+--
+-- > let x = case y# +# 1# of { r# -> I# r# }
+-- > in E
+--
+-- being translated to:
+--
+-- > case y# +# 1# of { r# ->
+-- > let x = I# r#
+-- > in E
+-- > }
+--
+-- We can only do this if the @y + 1@ is ok for speculation: it has no
+-- side effects, and can't diverge or raise an exception.
+exprOkForSpeculation, exprOkForSideEffects :: 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
diff --git a/coreSyn/MkCore.hs b/coreSyn/MkCore.hs
new file mode 100644
--- /dev/null
+++ b/coreSyn/MkCore.hs
@@ -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.
+-}
diff --git a/coreSyn/PprCore.hs b/coreSyn/PprCore.hs
new file mode 100644
--- /dev/null
+++ b/coreSyn/PprCore.hs
@@ -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 ""
+
+instance Outputable Unfolding where
+ ppr NoUnfolding = text "No unfolding"
+ ppr BootUnfolding = text "No unfolding (from boot)"
+ ppr (OtherCon cs) = text "OtherCon" <+> ppr cs
+ ppr (DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = args })
+ = hang (text "DFun:" <+> ptext (sLit "\\")
+ <+> sep (map (pprBndr LambdaBind) bndrs) <+> arrow)
+ 2 (ppr con <+> sep (map ppr args))
+ ppr (CoreUnfolding { uf_src = src
+ , uf_tmpl=rhs, uf_is_top=top, uf_is_value=hnf
+ , uf_is_conlike=conlike, uf_is_work_free=wf
+ , uf_expandable=exp, uf_guidance=g })
+ = text "Unf" <> braces (pp_info $$ pp_rhs)
+ where
+ pp_info = fsep $ punctuate comma
+ [ text "Src=" <> ppr src
+ , text "TopLvl=" <> ppr top
+ , text "Value=" <> ppr hnf
+ , text "ConLike=" <> ppr conlike
+ , text "WorkFree=" <> ppr wf
+ , text "Expandable=" <> ppr exp
+ , text "Guidance=" <> ppr g ]
+ pp_tmpl = sdocWithDynFlags $ \dflags ->
+ ppUnless (gopt Opt_SuppressUnfoldings dflags) $
+ text "Tmpl=" <+> ppr rhs
+ pp_rhs | isStableSource src = pp_tmpl
+ | otherwise = empty
+ -- Don't print the RHS or we get a quadratic
+ -- blowup in the size of the printout!
+
+{-
+-----------------------------------------------------
+-- Rules
+-----------------------------------------------------
+-}
+
+instance Outputable CoreRule where
+ ppr = pprRule
+
+pprRules :: [CoreRule] -> SDoc
+pprRules rules = vcat (map pprRule rules)
+
+pprRule :: CoreRule -> SDoc
+pprRule (BuiltinRule { ru_fn = fn, ru_name = name})
+ = text "Built in rule for" <+> ppr fn <> colon <+> doubleQuotes (ftext name)
+
+pprRule (Rule { ru_name = name, ru_act = act, ru_fn = fn,
+ ru_bndrs = tpl_vars, ru_args = tpl_args,
+ ru_rhs = rhs })
+ = hang (doubleQuotes (ftext name) <+> ppr act)
+ 4 (sep [text "forall" <+>
+ sep (map (pprCoreBinder LambdaBind) tpl_vars) <> dot,
+ nest 2 (ppr fn <+> sep (map pprArg tpl_args)),
+ nest 2 (text "=" <+> pprCoreExpr rhs)
+ ])
+
+{-
+-----------------------------------------------------
+-- Tickish
+-----------------------------------------------------
+-}
+
+instance Outputable id => Outputable (Tickish id) where
+ ppr (HpcTick modl ix) =
+ hcat [text "hpc<",
+ ppr modl, comma,
+ ppr ix,
+ text ">"]
+ ppr (Breakpoint ix vars) =
+ hcat [text "break<",
+ ppr ix,
+ text ">",
+ parens (hcat (punctuate comma (map ppr vars)))]
+ ppr (ProfNote { profNoteCC = cc,
+ profNoteCount = tick,
+ profNoteScope = scope }) =
+ case (tick,scope) of
+ (True,True) -> hcat [text "scctick<", ppr cc, char '>']
+ (True,False) -> hcat [text "tick<", ppr cc, char '>']
+ _ -> hcat [text "scc<", ppr cc, char '>']
+ ppr (SourceNote span _) =
+ hcat [ text "src<", pprUserRealSpan True span, char '>']
+
+{-
+-----------------------------------------------------
+-- Vectorisation declarations
+-----------------------------------------------------
+-}
+
+instance Outputable CoreVect where
+ ppr (Vect var e) = hang (text "VECTORISE" <+> ppr var <+> char '=')
+ 4 (pprCoreExpr e)
+ ppr (NoVect var) = text "NOVECTORISE" <+> ppr var
+ ppr (VectType False var Nothing) = text "VECTORISE type" <+> ppr var
+ ppr (VectType True var Nothing) = text "VECTORISE SCALAR type" <+> ppr var
+ ppr (VectType False var (Just tc)) = text "VECTORISE type" <+> ppr var <+> char '=' <+>
+ ppr tc
+ ppr (VectType True var (Just tc)) = text "VECTORISE SCALAR type" <+> ppr var <+>
+ char '=' <+> ppr tc
+ ppr (VectClass tc) = text "VECTORISE class" <+> ppr tc
+ ppr (VectInst var) = text "VECTORISE SCALAR instance" <+> ppr var
diff --git a/coreSyn/TrieMap.hs b/coreSyn/TrieMap.hs
new file mode 100644
--- /dev/null
+++ b/coreSyn/TrieMap.hs
@@ -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
diff --git a/deSugar/Check.hs b/deSugar/Check.hs
new file mode 100644
--- /dev/null
+++ b/deSugar/Check.hs
@@ -0,0 +1,1859 @@
+{-
+Author: George Karachalias
+
+Pattern Matching Coverage Checking.
+-}
+
+{-# LANGUAGE CPP, GADTs, DataKinds, KindSignatures #-}
+{-# LANGUAGE TupleSections #-}
+
+module Check (
+ -- Checking and printing
+ checkSingle, checkMatches, isAnyPmCheckEnabled,
+
+ -- See Note [Type and Term Equality Propagation]
+ genCaseTmCs1, genCaseTmCs2
+ ) where
+
+#include "HsVersions.h"
+
+import TmOracle
+
+import DynFlags
+import HsSyn
+import TcHsSyn
+import Id
+import ConLike
+import Name
+import FamInstEnv
+import TysWiredIn
+import TyCon
+import SrcLoc
+import Util
+import Outputable
+import FastString
+import DataCon
+import HscTypes (CompleteMatch(..))
+
+import DsMonad
+import TcSimplify (tcCheckSatisfiability)
+import TcType (toTcType, isStringTy, isIntTy, isWordTy)
+import Bag
+import ErrUtils
+import Var (EvVar)
+import Type
+import UniqSupply
+import DsGRHSs (isTrueLHsExpr)
+
+import Data.List (find)
+import Data.Maybe (isJust, fromMaybe)
+import Control.Monad (forM, when, forM_)
+import Coercion
+import TcEvidence
+import IOEnv
+
+import ListT (ListT(..), fold, select)
+
+{-
+This module checks pattern matches for:
+\begin{enumerate}
+ \item Equations that are redundant
+ \item Equations with inaccessible right-hand-side
+ \item Exhaustiveness
+\end{enumerate}
+
+The algorithm is based on the paper:
+
+ "GADTs Meet Their Match:
+ Pattern-matching Warnings That Account for GADTs, Guards, and Laziness"
+
+ http://people.cs.kuleuven.be/~george.karachalias/papers/p424-karachalias.pdf
+
+%************************************************************************
+%* *
+ Pattern Match Check Types
+%* *
+%************************************************************************
+-}
+
+-- We use the non-determinism monad to apply the algorithm to several
+-- possible sets of constructors. Users can specify complete sets of
+-- constructors by using COMPLETE pragmas.
+-- The algorithm only picks out constructor
+-- sets deep in the bowels which makes a simpler `mapM` more difficult to
+-- implement. The non-determinism is only used in one place, see the ConVar
+-- case in `pmCheckHd`.
+
+type PmM a = ListT DsM a
+
+liftD :: DsM a -> PmM a
+liftD m = ListT $ \sk fk -> m >>= \a -> sk a fk
+
+-- Pick the first match complete covered match or otherwise the "best" match.
+-- The best match is the one with the least uncovered clauses, ties broken
+-- by the number of inaccessible clauses followed by number of redudant
+-- clauses
+getResult :: PmM PmResult -> DsM PmResult
+getResult ls = do
+ res <- fold ls goM (pure Nothing)
+ case res of
+ Nothing -> panic "getResult is empty"
+ Just a -> return a
+ where
+ goM :: PmResult -> DsM (Maybe PmResult) -> DsM (Maybe PmResult)
+ goM mpm dpm = do
+ pmr <- dpm
+ return $ go pmr mpm
+ -- Careful not to force unecessary results
+ go :: Maybe PmResult -> PmResult -> Maybe PmResult
+ go Nothing rs = Just rs
+ go old@(Just (PmResult prov rs (UncoveredPatterns us) is)) new
+ | null us && null rs && null is = old
+ | otherwise =
+ let PmResult prov' rs' (UncoveredPatterns us') is' = new
+ lr = length rs
+ lr' = length rs'
+ li = length is
+ li' = length is'
+ in case compare (length us) (length us')
+ `mappend` (compare li li')
+ `mappend` (compare lr lr')
+ `mappend` (compare prov prov') of
+ GT -> Just new
+ EQ -> Just new
+ LT -> old
+ go (Just (PmResult _ _ (TypeOfUncovered _) _)) _new
+ = panic "getResult: No inhabitation candidates"
+
+data PatTy = PAT | VA -- Used only as a kind, to index PmPat
+
+-- The *arity* of a PatVec [p1,..,pn] is
+-- the number of p1..pn that are not Guards
+
+data PmPat :: PatTy -> * where
+ PmCon :: { pm_con_con :: ConLike
+ , pm_con_arg_tys :: [Type]
+ , pm_con_tvs :: [TyVar]
+ , pm_con_dicts :: [EvVar]
+ , pm_con_args :: [PmPat t] } -> PmPat t
+ -- For PmCon arguments' meaning see @ConPatOut@ in hsSyn/HsPat.hs
+ PmVar :: { pm_var_id :: Id } -> PmPat t
+ PmLit :: { pm_lit_lit :: PmLit } -> PmPat t -- See Note [Literals in PmPat]
+ PmNLit :: { pm_lit_id :: Id
+ , pm_lit_not :: [PmLit] } -> PmPat 'VA
+ PmGrd :: { pm_grd_pv :: PatVec
+ , pm_grd_expr :: PmExpr } -> PmPat 'PAT
+
+-- data T a where
+-- MkT :: forall p q. (Eq p, Ord q) => p -> q -> T [p]
+-- or MkT :: forall p q r. (Eq p, Ord q, [p] ~ r) => p -> q -> T r
+
+type Pattern = PmPat 'PAT -- ^ Patterns
+type ValAbs = PmPat 'VA -- ^ Value Abstractions
+
+type PatVec = [Pattern] -- ^ Pattern Vectors
+data ValVec = ValVec [ValAbs] Delta -- ^ Value Vector Abstractions
+
+-- | Term and type constraints to accompany each value vector abstraction.
+-- For efficiency, we store the term oracle state instead of the term
+-- constraints. TODO: Do the same for the type constraints?
+data Delta = MkDelta { delta_ty_cs :: Bag EvVar
+ , delta_tm_cs :: TmState }
+
+type ValSetAbs = [ValVec] -- ^ Value Set Abstractions
+type Uncovered = ValSetAbs
+
+-- Instead of keeping the whole sets in memory, we keep a boolean for both the
+-- covered and the divergent set (we store the uncovered set though, since we
+-- want to print it). For both the covered and the divergent we have:
+--
+-- True <=> The set is non-empty
+--
+-- hence:
+-- C = True ==> Useful clause (no warning)
+-- C = False, D = True ==> Clause with inaccessible RHS
+-- C = False, D = False ==> Redundant clause
+
+data Covered = Covered | NotCovered
+ deriving Show
+
+instance Outputable Covered where
+ ppr (Covered) = text "Covered"
+ ppr (NotCovered) = text "NotCovered"
+
+-- Like the or monoid for booleans
+-- Covered = True, Uncovered = False
+instance Monoid Covered where
+ mempty = NotCovered
+ Covered `mappend` _ = Covered
+ _ `mappend` Covered = Covered
+ NotCovered `mappend` NotCovered = NotCovered
+
+data Diverged = Diverged | NotDiverged
+ deriving Show
+
+instance Outputable Diverged where
+ ppr Diverged = text "Diverged"
+ ppr NotDiverged = text "NotDiverged"
+
+instance Monoid Diverged where
+ mempty = NotDiverged
+ Diverged `mappend` _ = Diverged
+ _ `mappend` Diverged = Diverged
+ NotDiverged `mappend` NotDiverged = NotDiverged
+
+-- | When we learned that a given match group is complete
+data Provenance =
+ FromBuiltin -- ^ From the original definition of the type
+ -- constructor.
+ | FromComplete -- ^ From a user-provided @COMPLETE@ pragma
+ deriving (Show, Eq, Ord)
+
+instance Outputable Provenance where
+ ppr = text . show
+
+instance Monoid Provenance where
+ mempty = FromBuiltin
+ FromComplete `mappend` _ = FromComplete
+ _ `mappend` FromComplete = FromComplete
+ _ `mappend` _ = FromBuiltin
+
+data PartialResult = PartialResult {
+ presultProvenence :: Provenance
+ -- keep track of provenance because we don't want
+ -- to warn about redundant matches if the result
+ -- is contaiminated with a COMPLETE pragma
+ , presultCovered :: Covered
+ , presultUncovered :: Uncovered
+ , presultDivergent :: Diverged }
+
+instance Outputable PartialResult where
+ ppr (PartialResult prov c vsa d)
+ = text "PartialResult" <+> ppr prov <+> ppr c
+ <+> ppr d <+> ppr vsa
+
+instance Monoid PartialResult where
+ mempty = PartialResult mempty mempty [] mempty
+ (PartialResult prov1 cs1 vsa1 ds1)
+ `mappend` (PartialResult prov2 cs2 vsa2 ds2)
+ = PartialResult (prov1 `mappend` prov2)
+ (cs1 `mappend` cs2)
+ (vsa1 `mappend` vsa2)
+ (ds1 `mappend` ds2)
+
+-- newtype ChoiceOf a = ChoiceOf [a]
+
+-- | Pattern check result
+--
+-- * Redundant clauses
+-- * Not-covered clauses (or their type, if no pattern is available)
+-- * Clauses with inaccessible RHS
+--
+-- More details about the classification of clauses into useful, redundant
+-- and with inaccessible right hand side can be found here:
+--
+-- https://ghc.haskell.org/trac/ghc/wiki/PatternMatchCheck
+--
+data PmResult =
+ PmResult {
+ pmresultProvenance :: Provenance
+ , pmresultRedundant :: [Located [LPat Id]]
+ , pmresultUncovered :: UncoveredCandidates
+ , pmresultInaccessible :: [Located [LPat Id]] }
+
+-- | Either a list of patterns that are not covered, or their type, in case we
+-- have no patterns at hand. Not having patterns at hand can arise when
+-- handling EmptyCase expressions, in two cases:
+--
+-- * The type of the scrutinee is a trivially inhabited type (like Int or Char)
+-- * The type of the scrutinee cannot be reduced to WHNF.
+--
+-- In both these cases we have no inhabitation candidates for the type at hand,
+-- but we don't want to issue just a wildcard as missing. Instead, we print a
+-- type annotated wildcard, so that the user knows what kind of patterns is
+-- expected (e.g. (_ :: Int), or (_ :: F Int), where F Int does not reduce).
+data UncoveredCandidates = UncoveredPatterns Uncovered
+ | TypeOfUncovered Type
+
+-- | The empty pattern check result
+emptyPmResult :: PmResult
+emptyPmResult = PmResult FromBuiltin [] (UncoveredPatterns []) []
+
+-- | Non-exhaustive empty case with unknown/trivial inhabitants
+uncoveredWithTy :: Type -> PmResult
+uncoveredWithTy ty = PmResult FromBuiltin [] (TypeOfUncovered ty) []
+
+{-
+%************************************************************************
+%* *
+ Entry points to the checker: checkSingle and checkMatches
+%* *
+%************************************************************************
+-}
+
+-- | Check a single pattern binding (let)
+checkSingle :: DynFlags -> DsMatchContext -> Id -> Pat Id -> DsM ()
+checkSingle dflags ctxt@(DsMatchContext _ locn) var p = do
+ tracePmD "checkSingle" (vcat [ppr ctxt, ppr var, ppr p])
+ mb_pm_res <- tryM (getResult (checkSingle' locn var p))
+ case mb_pm_res of
+ Left _ -> warnPmIters dflags ctxt
+ Right res -> dsPmWarn dflags ctxt res
+
+-- | Check a single pattern binding (let)
+checkSingle' :: SrcSpan -> Id -> Pat Id -> PmM PmResult
+checkSingle' locn var p = do
+ liftD resetPmIterDs -- set the iter-no to zero
+ fam_insts <- liftD dsGetFamInstEnvs
+ clause <- liftD $ translatePat fam_insts p
+ missing <- mkInitialUncovered [var]
+ tracePm "checkSingle: missing" (vcat (map pprValVecDebug missing))
+ -- no guards
+ PartialResult prov cs us ds <- runMany (pmcheckI clause []) missing
+ let us' = UncoveredPatterns us
+ return $ case (cs,ds) of
+ (Covered, _ ) -> PmResult prov [] us' [] -- useful
+ (NotCovered, NotDiverged) -> PmResult prov m us' [] -- redundant
+ (NotCovered, Diverged ) -> PmResult prov [] us' m -- inaccessible rhs
+ where m = [L locn [L locn p]]
+
+-- | Check a matchgroup (case, functions, etc.)
+checkMatches :: DynFlags -> DsMatchContext
+ -> [Id] -> [LMatch Id (LHsExpr Id)] -> DsM ()
+checkMatches dflags ctxt vars matches = do
+ tracePmD "checkMatches" (hang (vcat [ppr ctxt
+ , ppr vars
+ , text "Matches:"])
+ 2
+ (vcat (map ppr matches)))
+ mb_pm_res <- tryM $ getResult $ case matches of
+ -- Check EmptyCase separately
+ -- See Note [Checking EmptyCase Expressions]
+ [] | [var] <- vars -> checkEmptyCase' var
+ _normal_match -> checkMatches' vars matches
+ case mb_pm_res of
+ Left _ -> warnPmIters dflags ctxt
+ Right res -> dsPmWarn dflags ctxt res
+
+-- | Check a matchgroup (case, functions, etc.). To be called on a non-empty
+-- list of matches. For empty case expressions, use checkEmptyCase' instead.
+checkMatches' :: [Id] -> [LMatch Id (LHsExpr Id)] -> PmM PmResult
+checkMatches' vars matches
+ | null matches = panic "checkMatches': EmptyCase"
+ | otherwise = do
+ liftD resetPmIterDs -- set the iter-no to zero
+ missing <- mkInitialUncovered vars
+ tracePm "checkMatches: missing" (vcat (map pprValVecDebug missing))
+ (prov, rs,us,ds) <- go matches missing
+ return $ PmResult {
+ pmresultProvenance = prov
+ , pmresultRedundant = map hsLMatchToLPats rs
+ , pmresultUncovered = UncoveredPatterns us
+ , pmresultInaccessible = map hsLMatchToLPats ds }
+ where
+ go :: [LMatch Id (LHsExpr Id)] -> Uncovered
+ -> PmM (Provenance
+ , [LMatch Id (LHsExpr Id)]
+ , Uncovered
+ , [LMatch Id (LHsExpr Id)])
+ go [] missing = return (mempty, [], missing, [])
+ go (m:ms) missing = do
+ tracePm "checMatches': go" (ppr m $$ ppr missing)
+ fam_insts <- liftD dsGetFamInstEnvs
+ (clause, guards) <- liftD $ translateMatch fam_insts m
+ r@(PartialResult prov cs missing' ds)
+ <- runMany (pmcheckI clause guards) missing
+ tracePm "checMatches': go: res" (ppr r)
+ (ms_prov, rs, final_u, is) <- go ms missing'
+ let final_prov = prov `mappend` ms_prov
+ return $ case (cs, ds) of
+ -- useful
+ (Covered, _ ) -> (final_prov, rs, final_u, is)
+ -- redundant
+ (NotCovered, NotDiverged) -> (final_prov, m:rs, final_u,is)
+ -- inaccessible
+ (NotCovered, Diverged ) -> (final_prov, rs, final_u, m:is)
+
+ hsLMatchToLPats :: LMatch id body -> Located [LPat id]
+ hsLMatchToLPats (L l (Match _ pats _ _)) = L l pats
+
+-- | Check an empty case expression. Since there are no clauses to process, we
+-- only compute the uncovered set. See Note [Checking EmptyCase Expressions]
+-- for details.
+checkEmptyCase' :: Id -> PmM PmResult
+checkEmptyCase' var = do
+ tm_css <- map toComplex . bagToList <$> liftD getTmCsDs
+ case tmOracle initialTmState tm_css of
+ Just tm_state -> do
+ ty_css <- liftD getDictsDs
+ fam_insts <- liftD dsGetFamInstEnvs
+ mb_candidates <- inhabitationCandidates fam_insts (idType var)
+ case mb_candidates of
+ -- Inhabitation checking failed / the type is trivially inhabited
+ Left ty -> return (uncoveredWithTy ty)
+
+ -- A list of inhabitant candidates is available: Check for each
+ -- one for the satisfiability of the constraints it gives rise to.
+ Right candidates -> do
+ missing_m <- flip concatMapM candidates $ \(va,tm_ct,ty_cs) -> do
+ let all_ty_cs = unionBags ty_cs ty_css
+ sat_ty <- tyOracle all_ty_cs
+ return $ case (sat_ty, tmOracle tm_state (tm_ct:tm_css)) of
+ (True, Just tm_state') -> [(va, all_ty_cs, tm_state')]
+ _non_sat -> []
+ let mkValVec (va,all_ty_cs,tm_state')
+ = ValVec [va] (MkDelta all_ty_cs tm_state')
+ uncovered = UncoveredPatterns (map mkValVec missing_m)
+ return $ if null missing_m
+ then emptyPmResult
+ else PmResult FromBuiltin [] uncovered []
+ Nothing -> return emptyPmResult
+
+-- | Generate all inhabitation candidates for a given type. The result is
+-- either (Left ty), if the type cannot be reduced to a closed algebraic type
+-- (or if it's one trivially inhabited, like Int), or (Right candidates), if it
+-- can. In this case, the candidates are the singnature of the tycon, each one
+-- accompanied by the term- and type- constraints it gives rise to.
+-- See also Note [Checking EmptyCase Expressions]
+inhabitationCandidates :: FamInstEnvs -> Type
+ -> PmM (Either Type [(ValAbs, ComplexEq, Bag EvVar)])
+inhabitationCandidates fam_insts ty
+ = case pmTopNormaliseType_maybe fam_insts ty of
+ Just (src_ty, dcs, core_ty) -> alts_to_check src_ty core_ty dcs
+ Nothing -> alts_to_check ty ty []
+ where
+ -- All these types are trivially inhabited
+ trivially_inhabited = [ charTyCon, doubleTyCon, floatTyCon
+ , intTyCon, wordTyCon, word8TyCon ]
+
+ -- Note: At the moment we leave all the typing and constraint fields of
+ -- PmCon empty, since we know that they are not gonna be used. Is the
+ -- right-thing-to-do to actually create them, even if they are never used?
+ build_tm :: ValAbs -> [DataCon] -> ValAbs
+ build_tm = foldr (\dc e -> PmCon (RealDataCon dc) [] [] [] [e])
+
+ -- Inhabitation candidates, using the result of pmTopNormaliseType_maybe
+ alts_to_check :: Type -> Type -> [DataCon]
+ -> PmM (Either Type [(ValAbs, ComplexEq, Bag EvVar)])
+ alts_to_check src_ty core_ty dcs = case splitTyConApp_maybe core_ty of
+ Just (tc, _)
+ | tc `elem` trivially_inhabited -> case dcs of
+ [] -> return (Left src_ty)
+ (_:_) -> do var <- liftD $ mkPmId (toTcType core_ty)
+ let va = build_tm (PmVar var) dcs
+ return $ Right [(va, mkIdEq var, emptyBag)]
+ | isClosedAlgType core_ty -> liftD $ do
+ var <- mkPmId (toTcType core_ty) -- it would be wrong to unify x
+ alts <- mapM (mkOneConFull var . RealDataCon) (tyConDataCons tc)
+ return $ Right [(build_tm va dcs, eq, cs) | (va, eq, cs) <- alts]
+ -- For other types conservatively assume that they are inhabited.
+ _other -> return (Left src_ty)
+
+{- Note [Checking EmptyCase Expressions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Empty case expressions are strict on the scrutinee. That is, `case x of {}`
+will force argument `x`. Hence, `checkMatches` is not sufficient for checking
+empty cases, because it assumes that the match is not strict (which is true
+for all other cases, apart from EmptyCase). This gave rise to #10746. Instead,
+we do the following:
+
+1. We normalise the outermost type family redex, data family redex or newtype,
+ using pmTopNormaliseType_maybe (in types/FamInstEnv.hs). This computes 3
+ things:
+ (a) A normalised type src_ty, which is equal to the type of the scrutinee in
+ source Haskell (does not normalise newtypes or data families)
+ (b) The actual normalised type core_ty, which coincides with the result
+ topNormaliseType_maybe. This type is not necessarily equal to the input
+ type in source Haskell. And this is precicely the reason we compute (a)
+ and (c): the reasoning happens with the underlying types, but both the
+ patterns and types we print should respect newtypes and also show the
+ family type constructors and not the representation constructors.
+
+ (c) A list of all newtype data constructors dcs, each one corresponding to a
+ newtype rewrite performed in (b).
+
+ For an example see also Note [Type normalisation for EmptyCase]
+ in types/FamInstEnv.hs.
+
+2. Function checkEmptyCase' performs the check:
+ - If core_ty is not an algebraic type, then we cannot check for
+ inhabitation, so we emit (_ :: src_ty) as missing, conservatively assuming
+ that the type is inhabited.
+ - If core_ty is an algebraic type, then we unfold the scrutinee to all
+ possible constructor patterns, using inhabitationCandidates, and then
+ check each one for constraint satisfiability, same as we for normal
+ pattern match checking.
+
+%************************************************************************
+%* *
+ Transform source syntax to *our* syntax
+%* *
+%************************************************************************
+-}
+
+-- -----------------------------------------------------------------------
+-- * Utilities
+
+nullaryConPattern :: ConLike -> Pattern
+-- Nullary data constructor and nullary type constructor
+nullaryConPattern con =
+ PmCon { pm_con_con = con, pm_con_arg_tys = []
+ , pm_con_tvs = [], pm_con_dicts = [], pm_con_args = [] }
+{-# INLINE nullaryConPattern #-}
+
+truePattern :: Pattern
+truePattern = nullaryConPattern (RealDataCon trueDataCon)
+{-# INLINE truePattern #-}
+
+-- | A fake guard pattern (True <- _) used to represent cases we cannot handle
+fake_pat :: Pattern
+fake_pat = PmGrd { pm_grd_pv = [truePattern]
+ , pm_grd_expr = PmExprOther EWildPat }
+{-# INLINE fake_pat #-}
+
+-- | Check whether a guard pattern is generated by the checker (unhandled)
+isFakeGuard :: [Pattern] -> PmExpr -> Bool
+isFakeGuard [PmCon { pm_con_con = RealDataCon c }] (PmExprOther EWildPat)
+ | c == trueDataCon = True
+ | otherwise = False
+isFakeGuard _pats _e = False
+
+-- | Generate a `canFail` pattern vector of a specific type
+mkCanFailPmPat :: Type -> DsM PatVec
+mkCanFailPmPat ty = do
+ var <- mkPmVar ty
+ return [var, fake_pat]
+
+vanillaConPattern :: ConLike -> [Type] -> PatVec -> Pattern
+-- ADT constructor pattern => no existentials, no local constraints
+vanillaConPattern con arg_tys args =
+ PmCon { pm_con_con = con, pm_con_arg_tys = arg_tys
+ , pm_con_tvs = [], pm_con_dicts = [], pm_con_args = args }
+{-# INLINE vanillaConPattern #-}
+
+-- | Create an empty list pattern of a given type
+nilPattern :: Type -> Pattern
+nilPattern ty =
+ PmCon { pm_con_con = RealDataCon nilDataCon, pm_con_arg_tys = [ty]
+ , pm_con_tvs = [], pm_con_dicts = []
+ , pm_con_args = [] }
+{-# INLINE nilPattern #-}
+
+mkListPatVec :: Type -> PatVec -> PatVec -> PatVec
+mkListPatVec ty xs ys = [PmCon { pm_con_con = RealDataCon consDataCon
+ , pm_con_arg_tys = [ty]
+ , pm_con_tvs = [], pm_con_dicts = []
+ , pm_con_args = xs++ys }]
+{-# INLINE mkListPatVec #-}
+
+-- | Create a (non-overloaded) literal pattern
+mkLitPattern :: HsLit -> Pattern
+mkLitPattern lit = PmLit { pm_lit_lit = PmSLit lit }
+{-# INLINE mkLitPattern #-}
+
+-- -----------------------------------------------------------------------
+-- * Transform (Pat Id) into of (PmPat Id)
+
+translatePat :: FamInstEnvs -> Pat Id -> DsM PatVec
+translatePat fam_insts pat = case pat of
+ WildPat ty -> mkPmVars [ty]
+ VarPat id -> return [PmVar (unLoc id)]
+ ParPat p -> translatePat fam_insts (unLoc p)
+ LazyPat _ -> mkPmVars [hsPatType pat] -- like a variable
+
+ -- ignore strictness annotations for now
+ BangPat p -> translatePat fam_insts (unLoc p)
+
+ AsPat lid p -> do
+ -- Note [Translating As Patterns]
+ ps <- translatePat fam_insts (unLoc p)
+ let [e] = map vaToPmExpr (coercePatVec ps)
+ g = PmGrd [PmVar (unLoc lid)] e
+ return (ps ++ [g])
+
+ SigPatOut p _ty -> translatePat fam_insts (unLoc p)
+
+ -- See Note [Translate CoPats]
+ CoPat wrapper p ty
+ | isIdHsWrapper wrapper -> translatePat fam_insts p
+ | WpCast co <- wrapper, isReflexiveCo co -> translatePat fam_insts p
+ | otherwise -> do
+ ps <- translatePat fam_insts p
+ (xp,xe) <- mkPmId2Forms ty
+ let g = mkGuard ps (HsWrap wrapper (unLoc xe))
+ return [xp,g]
+
+ -- (n + k) ===> x (True <- x >= k) (n <- x-k)
+ NPlusKPat (L _ _n) _k1 _k2 _ge _minus ty -> mkCanFailPmPat ty
+
+ -- (fun -> pat) ===> x (pat <- fun x)
+ ViewPat lexpr lpat arg_ty -> do
+ ps <- translatePat fam_insts (unLoc lpat)
+ -- See Note [Guards and Approximation]
+ case all cantFailPattern ps of
+ True -> do
+ (xp,xe) <- mkPmId2Forms arg_ty
+ let g = mkGuard ps (HsApp lexpr xe)
+ return [xp,g]
+ False -> mkCanFailPmPat arg_ty
+
+ -- list
+ ListPat ps ty Nothing -> do
+ foldr (mkListPatVec ty) [nilPattern ty]
+ <$> translatePatVec fam_insts (map unLoc ps)
+
+ -- overloaded list
+ ListPat lpats elem_ty (Just (pat_ty, _to_list))
+ | Just e_ty <- splitListTyConApp_maybe pat_ty
+ , (_, norm_elem_ty) <- normaliseType fam_insts Nominal elem_ty
+ -- elem_ty is frequently something like
+ -- `Item [Int]`, but we prefer `Int`
+ , norm_elem_ty `eqType` e_ty ->
+ -- We have to ensure that the element types are exactly the same.
+ -- Otherwise, one may give an instance IsList [Int] (more specific than
+ -- the default IsList [a]) with a different implementation for `toList'
+ translatePat fam_insts (ListPat lpats e_ty Nothing)
+ -- See Note [Guards and Approximation]
+ | otherwise -> mkCanFailPmPat pat_ty
+
+ ConPatOut { pat_con = L _ con
+ , pat_arg_tys = arg_tys
+ , pat_tvs = ex_tvs
+ , pat_dicts = dicts
+ , pat_args = ps } -> do
+ groups <- allCompleteMatches con arg_tys
+ case groups of
+ [] -> mkCanFailPmPat (conLikeResTy con arg_tys)
+ _ -> do
+ args <- translateConPatVec fam_insts arg_tys ex_tvs con ps
+ return [PmCon { pm_con_con = con
+ , pm_con_arg_tys = arg_tys
+ , pm_con_tvs = ex_tvs
+ , pm_con_dicts = dicts
+ , pm_con_args = args }]
+
+ NPat (L _ ol) mb_neg _eq ty -> translateNPat fam_insts ol mb_neg ty
+
+ LitPat lit
+ -- If it is a string then convert it to a list of characters
+ | HsString src s <- lit ->
+ foldr (mkListPatVec charTy) [nilPattern charTy] <$>
+ translatePatVec fam_insts (map (LitPat . HsChar src) (unpackFS s))
+ | otherwise -> return [mkLitPattern lit]
+
+ PArrPat ps ty -> do
+ tidy_ps <- translatePatVec fam_insts (map unLoc ps)
+ let fake_con = RealDataCon (parrFakeCon (length ps))
+ return [vanillaConPattern fake_con [ty] (concat tidy_ps)]
+
+ TuplePat ps boxity tys -> do
+ tidy_ps <- translatePatVec fam_insts (map unLoc ps)
+ let tuple_con = RealDataCon (tupleDataCon boxity (length ps))
+ return [vanillaConPattern tuple_con tys (concat tidy_ps)]
+
+ SumPat p alt arity ty -> do
+ tidy_p <- translatePat fam_insts (unLoc p)
+ let sum_con = RealDataCon (sumDataCon alt arity)
+ return [vanillaConPattern sum_con ty tidy_p]
+
+ -- --------------------------------------------------------------------------
+ -- Not supposed to happen
+ ConPatIn {} -> panic "Check.translatePat: ConPatIn"
+ SplicePat {} -> panic "Check.translatePat: SplicePat"
+ SigPatIn {} -> panic "Check.translatePat: SigPatIn"
+
+-- | Translate an overloaded literal (see `tidyNPat' in deSugar/MatchLit.hs)
+translateNPat :: FamInstEnvs
+ -> HsOverLit Id -> Maybe (SyntaxExpr Id) -> Type -> DsM PatVec
+translateNPat fam_insts (OverLit val False _ ty) mb_neg outer_ty
+ | not type_change, isStringTy ty, HsIsString src s <- val, Nothing <- mb_neg
+ = translatePat fam_insts (LitPat (HsString src s))
+ | not type_change, isIntTy ty, HsIntegral src i <- val
+ = translatePat fam_insts (mk_num_lit HsInt src i)
+ | not type_change, isWordTy ty, HsIntegral src i <- val
+ = translatePat fam_insts (mk_num_lit HsWordPrim src i)
+ where
+ type_change = not (outer_ty `eqType` ty)
+ mk_num_lit c src i = LitPat $ case mb_neg of
+ Nothing -> c src i
+ Just _ -> c src (-i)
+translateNPat _ ol mb_neg _
+ = return [PmLit { pm_lit_lit = PmOLit (isJust mb_neg) ol }]
+
+-- | Translate a list of patterns (Note: each pattern is translated
+-- to a pattern vector but we do not concatenate the results).
+translatePatVec :: FamInstEnvs -> [Pat Id] -> DsM [PatVec]
+translatePatVec fam_insts pats = mapM (translatePat fam_insts) pats
+
+-- | Translate a constructor pattern
+translateConPatVec :: FamInstEnvs -> [Type] -> [TyVar]
+ -> ConLike -> HsConPatDetails Id -> DsM PatVec
+translateConPatVec fam_insts _univ_tys _ex_tvs _ (PrefixCon ps)
+ = concat <$> translatePatVec fam_insts (map unLoc ps)
+translateConPatVec fam_insts _univ_tys _ex_tvs _ (InfixCon p1 p2)
+ = concat <$> translatePatVec fam_insts (map unLoc [p1,p2])
+translateConPatVec fam_insts univ_tys ex_tvs c (RecCon (HsRecFields fs _))
+ -- Nothing matched. Make up some fresh term variables
+ | null fs = mkPmVars arg_tys
+ -- The data constructor was not defined using record syntax. For the
+ -- pattern to be in record syntax it should be empty (e.g. Just {}).
+ -- So just like the previous case.
+ | null orig_lbls = ASSERT(null matched_lbls) mkPmVars arg_tys
+ -- Some of the fields appear, in the original order (there may be holes).
+ -- Generate a simple constructor pattern and make up fresh variables for
+ -- the rest of the fields
+ | matched_lbls `subsetOf` orig_lbls
+ = ASSERT(length orig_lbls == length arg_tys)
+ let translateOne (lbl, ty) = case lookup lbl matched_pats of
+ Just p -> translatePat fam_insts p
+ Nothing -> mkPmVars [ty]
+ in concatMapM translateOne (zip orig_lbls arg_tys)
+ -- The fields that appear are not in the correct order. Make up fresh
+ -- variables for all fields and add guards after matching, to force the
+ -- evaluation in the correct order.
+ | otherwise = do
+ arg_var_pats <- mkPmVars arg_tys
+ translated_pats <- forM matched_pats $ \(x,pat) -> do
+ pvec <- translatePat fam_insts pat
+ return (x, pvec)
+
+ let zipped = zip orig_lbls [ x | PmVar x <- arg_var_pats ]
+ guards = map (\(name,pvec) -> case lookup name zipped of
+ Just x -> PmGrd pvec (PmExprVar (idName x))
+ Nothing -> panic "translateConPatVec: lookup")
+ translated_pats
+
+ return (arg_var_pats ++ guards)
+ where
+ -- The actual argument types (instantiated)
+ arg_tys = conLikeInstOrigArgTys c (univ_tys ++ mkTyVarTys ex_tvs)
+
+ -- Some label information
+ orig_lbls = map flSelector $ conLikeFieldLabels c
+ matched_pats = [ (getName (unLoc (hsRecFieldId x)), unLoc (hsRecFieldArg x))
+ | L _ x <- fs]
+ matched_lbls = [ name | (name, _pat) <- matched_pats ]
+
+ subsetOf :: Eq a => [a] -> [a] -> Bool
+ subsetOf [] _ = True
+ subsetOf (_:_) [] = False
+ subsetOf (x:xs) (y:ys)
+ | x == y = subsetOf xs ys
+ | otherwise = subsetOf (x:xs) ys
+
+-- Translate a single match
+translateMatch :: FamInstEnvs -> LMatch Id (LHsExpr Id) -> DsM (PatVec,[PatVec])
+translateMatch fam_insts (L _ (Match _ lpats _ grhss)) = do
+ pats' <- concat <$> translatePatVec fam_insts pats
+ guards' <- mapM (translateGuards fam_insts) guards
+ return (pats', guards')
+ where
+ extractGuards :: LGRHS Id (LHsExpr Id) -> [GuardStmt Id]
+ extractGuards (L _ (GRHS gs _)) = map unLoc gs
+
+ pats = map unLoc lpats
+ guards = map extractGuards (grhssGRHSs grhss)
+
+-- -----------------------------------------------------------------------
+-- * Transform source guards (GuardStmt Id) to PmPats (Pattern)
+
+-- | Translate a list of guard statements to a pattern vector
+translateGuards :: FamInstEnvs -> [GuardStmt Id] -> DsM PatVec
+translateGuards fam_insts guards = do
+ all_guards <- concat <$> mapM (translateGuard fam_insts) guards
+ return (replace_unhandled all_guards)
+ -- It should have been (return all_guards) but it is too expressive.
+ -- Since the term oracle does not handle all constraints we generate,
+ -- we (hackily) replace all constraints the oracle cannot handle with a
+ -- single one (we need to know if there is a possibility of falure).
+ -- See Note [Guards and Approximation] for all guard-related approximations
+ -- we implement.
+ where
+ replace_unhandled :: PatVec -> PatVec
+ replace_unhandled gv
+ | any_unhandled gv = fake_pat : [ p | p <- gv, shouldKeep p ]
+ | otherwise = gv
+
+ any_unhandled :: PatVec -> Bool
+ any_unhandled gv = any (not . shouldKeep) gv
+
+ shouldKeep :: Pattern -> Bool
+ shouldKeep p
+ | PmVar {} <- p = True
+ | PmCon {} <- p = singleConstructor (pm_con_con p)
+ && all shouldKeep (pm_con_args p)
+ shouldKeep (PmGrd pv e)
+ | all shouldKeep pv = True
+ | isNotPmExprOther e = True -- expensive but we want it
+ shouldKeep _other_pat = False -- let the rest..
+
+-- | Check whether a pattern can fail to match
+cantFailPattern :: Pattern -> Bool
+cantFailPattern p
+ | PmVar {} <- p = True
+ | PmCon {} <- p = singleConstructor (pm_con_con p)
+ && all cantFailPattern (pm_con_args p)
+cantFailPattern (PmGrd pv _e)
+ = all cantFailPattern pv
+cantFailPattern _ = False
+
+-- | Translate a guard statement to Pattern
+translateGuard :: FamInstEnvs -> GuardStmt Id -> DsM PatVec
+translateGuard fam_insts guard = case guard of
+ BodyStmt e _ _ _ -> translateBoolGuard e
+ LetStmt binds -> translateLet (unLoc binds)
+ BindStmt p e _ _ _ -> translateBind fam_insts p e
+ LastStmt {} -> panic "translateGuard LastStmt"
+ ParStmt {} -> panic "translateGuard ParStmt"
+ TransStmt {} -> panic "translateGuard TransStmt"
+ RecStmt {} -> panic "translateGuard RecStmt"
+ ApplicativeStmt {} -> panic "translateGuard ApplicativeLastStmt"
+
+-- | Translate let-bindings
+translateLet :: HsLocalBinds Id -> DsM PatVec
+translateLet _binds = return []
+
+-- | Translate a pattern guard
+translateBind :: FamInstEnvs -> LPat Id -> LHsExpr Id -> DsM PatVec
+translateBind fam_insts (L _ p) e = do
+ ps <- translatePat fam_insts p
+ return [mkGuard ps (unLoc e)]
+
+-- | Translate a boolean guard
+translateBoolGuard :: LHsExpr Id -> DsM PatVec
+translateBoolGuard e
+ | isJust (isTrueLHsExpr e) = return []
+ -- The formal thing to do would be to generate (True <- True)
+ -- but it is trivial to solve so instead we give back an empty
+ -- PatVec for efficiency
+ | otherwise = return [mkGuard [truePattern] (unLoc e)]
+
+{- Note [Guards and Approximation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Even if the algorithm is really expressive, the term oracle we use is not.
+Hence, several features are not translated *properly* but we approximate.
+The list includes:
+
+1. View Patterns
+----------------
+A view pattern @(f -> p)@ should be translated to @x (p <- f x)@. The term
+oracle does not handle function applications so we know that the generated
+constraints will not be handled at the end. Hence, we distinguish between two
+cases:
+ a) Pattern @p@ cannot fail. Then this is just a binding and we do the *right
+ thing*.
+ b) Pattern @p@ can fail. This means that when checking the guard, we will
+ generate several cases, with no useful information. E.g.:
+
+ h (f -> [a,b]) = ...
+ h x ([a,b] <- f x) = ...
+
+ uncovered set = { [x |> { False ~ (f x ~ []) }]
+ , [x |> { False ~ (f x ~ (t1:[])) }]
+ , [x |> { False ~ (f x ~ (t1:t2:t3:t4)) }] }
+
+ So we have two problems:
+ 1) Since we do not print the constraints in the general case (they may
+ be too many), the warning will look like this:
+
+ Pattern match(es) are non-exhaustive
+ In an equation for `h':
+ Patterns not matched:
+ _
+ _
+ _
+ Which is not short and not more useful than a single underscore.
+ 2) The size of the uncovered set increases a lot, without gaining more
+ expressivity in our warnings.
+
+ Hence, in this case, we replace the guard @([a,b] <- f x)@ with a *dummy*
+ @fake_pat@: @True <- _@. That is, we record that there is a possibility
+ of failure but we minimize it to a True/False. This generates a single
+ warning and much smaller uncovered sets.
+
+2. Overloaded Lists
+-------------------
+An overloaded list @[...]@ should be translated to @x ([...] <- toList x)@. The
+problem is exactly like above, as its solution. For future reference, the code
+below is the *right thing to do*:
+
+ ListPat lpats elem_ty (Just (pat_ty, to_list))
+ otherwise -> do
+ (xp, xe) <- mkPmId2Forms pat_ty
+ ps <- translatePatVec (map unLoc lpats)
+ let pats = foldr (mkListPatVec elem_ty) [nilPattern elem_ty] ps
+ g = mkGuard pats (HsApp (noLoc to_list) xe)
+ return [xp,g]
+
+3. Overloaded Literals
+----------------------
+The case with literals is a bit different. a literal @l@ should be translated
+to @x (True <- x == from l)@. Since we want to have better warnings for
+overloaded literals as it is a very common feature, we treat them differently.
+They are mainly covered in Note [Undecidable Equality on Overloaded Literals]
+in PmExpr.
+
+4. N+K Patterns & Pattern Synonyms
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+An n+k pattern (n+k) should be translated to @x (True <- x >= k) (n <- x-k)@.
+Since the only pattern of the three that causes failure is guard @(n <- x-k)@,
+and has two possible outcomes. Hence, there is no benefit in using a dummy and
+we implement the proper thing. Pattern synonyms are simply not implemented yet.
+Hence, to be conservative, we generate a dummy pattern, assuming that the
+pattern can fail.
+
+5. Actual Guards
+----------------
+During translation, boolean guards and pattern guards are translated properly.
+Let bindings though are omitted by function @translateLet@. Since they are lazy
+bindings, we do not actually want to generate a (strict) equality (like we do
+in the pattern bind case). Hence, we safely drop them.
+
+Additionally, top-level guard translation (performed by @translateGuards@)
+replaces guards that cannot be reasoned about (like the ones we described in
+1-4) with a single @fake_pat@ to record the possibility of failure to match.
+
+Note [Translate CoPats]
+~~~~~~~~~~~~~~~~~~~~~~~
+The pattern match checker did not know how to handle coerced patterns `CoPat`
+efficiently, which gave rise to #11276. The original approach translated
+`CoPat`s:
+
+ pat |> co ===> x (pat <- (e |> co))
+
+Instead, we now check whether the coercion is a hole or if it is just refl, in
+which case we can drop it. Unfortunately, data families generate useful
+coercions so guards are still generated in these cases and checking data
+families is not really efficient.
+
+%************************************************************************
+%* *
+ Utilities for Pattern Match Checking
+%* *
+%************************************************************************
+-}
+
+-- ----------------------------------------------------------------------------
+-- * Basic utilities
+
+-- | Get the type out of a PmPat. For guard patterns (ps <- e) we use the type
+-- of the first (or the single -WHEREVER IT IS- valid to use?) pattern
+pmPatType :: PmPat p -> Type
+pmPatType (PmCon { pm_con_con = con, pm_con_arg_tys = tys })
+ = conLikeResTy con tys
+pmPatType (PmVar { pm_var_id = x }) = idType x
+pmPatType (PmLit { pm_lit_lit = l }) = pmLitType l
+pmPatType (PmNLit { pm_lit_id = x }) = idType x
+pmPatType (PmGrd { pm_grd_pv = pv })
+ = ASSERT(patVecArity pv == 1) (pmPatType p)
+ where Just p = find ((==1) . patternArity) pv
+
+-- | Generate a value abstraction for a given constructor (generate
+-- fresh variables of the appropriate type for arguments)
+mkOneConFull :: Id -> ConLike -> DsM (ValAbs, ComplexEq, Bag EvVar)
+-- * x :: T tys, where T is an algebraic data type
+-- NB: in the case of a data family, T is the *representation* TyCon
+-- e.g. data instance T (a,b) = T1 a b
+-- leads to
+-- data TPair a b = T1 a b -- The "representation" type
+-- It is TPair, not T, that is given to mkOneConFull
+--
+-- * 'con' K is a constructor of data type T
+--
+-- After instantiating the universal tyvars of K we get
+-- K tys :: forall bs. Q => s1 .. sn -> T tys
+--
+-- Results: ValAbs: K (y1::s1) .. (yn::sn)
+-- ComplexEq: x ~ K y1..yn
+-- [EvVar]: Q
+mkOneConFull x con = do
+ let -- res_ty == TyConApp (ConLikeTyCon cabs_con) cabs_arg_tys
+ res_ty = idType x
+ (univ_tvs, ex_tvs, eq_spec, thetas, _req_theta , arg_tys, _)
+ = conLikeFullSig con
+ tc_args = case splitTyConApp_maybe res_ty of
+ Just (_, tys) -> tys
+ Nothing -> pprPanic "mkOneConFull: Not TyConApp:" (ppr res_ty)
+ subst1 = zipTvSubst univ_tvs tc_args
+
+ (subst, ex_tvs') <- cloneTyVarBndrs subst1 ex_tvs <$> getUniqueSupplyM
+
+ -- Fresh term variables (VAs) as arguments to the constructor
+ arguments <- mapM mkPmVar (substTys subst arg_tys)
+ -- All constraints bound by the constructor (alpha-renamed)
+ let theta_cs = substTheta subst (eqSpecPreds eq_spec ++ thetas)
+ evvars <- mapM (nameType "pm") theta_cs
+ let con_abs = PmCon { pm_con_con = con
+ , pm_con_arg_tys = tc_args
+ , pm_con_tvs = ex_tvs'
+ , pm_con_dicts = evvars
+ , pm_con_args = arguments }
+ return (con_abs, (PmExprVar (idName x), vaToPmExpr con_abs), listToBag evvars)
+
+-- ----------------------------------------------------------------------------
+-- * More smart constructors and fresh variable generation
+
+-- | Create a guard pattern
+mkGuard :: PatVec -> HsExpr Id -> Pattern
+mkGuard pv e
+ | all cantFailPattern pv = PmGrd pv expr
+ | PmExprOther {} <- expr = fake_pat
+ | otherwise = PmGrd pv expr
+ where
+ expr = hsExprToPmExpr e
+
+-- | Create a term equality of the form: `(False ~ (x ~ lit))`
+mkNegEq :: Id -> PmLit -> ComplexEq
+mkNegEq x l = (falsePmExpr, PmExprVar (idName x) `PmExprEq` PmExprLit l)
+{-# INLINE mkNegEq #-}
+
+-- | Create a term equality of the form: `(x ~ lit)`
+mkPosEq :: Id -> PmLit -> ComplexEq
+mkPosEq x l = (PmExprVar (idName x), PmExprLit l)
+{-# INLINE mkPosEq #-}
+
+-- | Create a term equality of the form: `(x ~ x)`
+-- (always discharged by the term oracle)
+mkIdEq :: Id -> ComplexEq
+mkIdEq x = (PmExprVar name, PmExprVar name)
+ where name = idName x
+{-# INLINE mkIdEq #-}
+
+-- | Generate a variable pattern of a given type
+mkPmVar :: Type -> DsM (PmPat p)
+mkPmVar ty = PmVar <$> mkPmId ty
+{-# INLINE mkPmVar #-}
+
+-- | Generate many variable patterns, given a list of types
+mkPmVars :: [Type] -> DsM PatVec
+mkPmVars tys = mapM mkPmVar tys
+{-# INLINE mkPmVars #-}
+
+-- | Generate a fresh `Id` of a given type
+mkPmId :: Type -> DsM Id
+mkPmId ty = getUniqueM >>= \unique ->
+ let occname = mkVarOccFS (fsLit (show unique))
+ name = mkInternalName unique occname noSrcSpan
+ in return (mkLocalId name ty)
+
+-- | Generate a fresh term variable of a given and return it in two forms:
+-- * A variable pattern
+-- * A variable expression
+mkPmId2Forms :: Type -> DsM (Pattern, LHsExpr Id)
+mkPmId2Forms ty = do
+ x <- mkPmId ty
+ return (PmVar x, noLoc (HsVar (noLoc x)))
+
+-- ----------------------------------------------------------------------------
+-- * Converting between Value Abstractions, Patterns and PmExpr
+
+-- | Convert a value abstraction an expression
+vaToPmExpr :: ValAbs -> PmExpr
+vaToPmExpr (PmCon { pm_con_con = c, pm_con_args = ps })
+ = PmExprCon c (map vaToPmExpr ps)
+vaToPmExpr (PmVar { pm_var_id = x }) = PmExprVar (idName x)
+vaToPmExpr (PmLit { pm_lit_lit = l }) = PmExprLit l
+vaToPmExpr (PmNLit { pm_lit_id = x }) = PmExprVar (idName x)
+
+-- | Convert a pattern vector to a list of value abstractions by dropping the
+-- guards (See Note [Translating As Patterns])
+coercePatVec :: PatVec -> [ValAbs]
+coercePatVec pv = concatMap coercePmPat pv
+
+-- | Convert a pattern to a list of value abstractions (will be either an empty
+-- list if the pattern is a guard pattern, or a singleton list in all other
+-- cases) by dropping the guards (See Note [Translating As Patterns])
+coercePmPat :: Pattern -> [ValAbs]
+coercePmPat (PmVar { pm_var_id = x }) = [PmVar { pm_var_id = x }]
+coercePmPat (PmLit { pm_lit_lit = l }) = [PmLit { pm_lit_lit = l }]
+coercePmPat (PmCon { pm_con_con = con, pm_con_arg_tys = arg_tys
+ , pm_con_tvs = tvs, pm_con_dicts = dicts
+ , pm_con_args = args })
+ = [PmCon { pm_con_con = con, pm_con_arg_tys = arg_tys
+ , pm_con_tvs = tvs, pm_con_dicts = dicts
+ , pm_con_args = coercePatVec args }]
+coercePmPat (PmGrd {}) = [] -- drop the guards
+
+-- | Check whether a data constructor is the only way to construct
+-- a data type.
+singleConstructor :: ConLike -> Bool
+singleConstructor (RealDataCon dc) =
+ case tyConDataCons (dataConTyCon dc) of
+ [_] -> True
+ _ -> False
+singleConstructor _ = False
+
+-- | For a given conlike, finds all the sets of patterns which could
+-- be relevant to that conlike by consulting the result type.
+--
+-- These come from two places.
+-- 1. From data constructors defined with the result type constructor.
+-- 2. From `COMPLETE` pragmas which have the same type as the result
+-- type constructor.
+allCompleteMatches :: ConLike -> [Type] -> DsM [(Provenance, [ConLike])]
+allCompleteMatches cl tys = do
+ let fam = case cl of
+ RealDataCon dc ->
+ [(FromBuiltin, map RealDataCon (tyConDataCons (dataConTyCon dc)))]
+ PatSynCon _ -> []
+
+ pragmas <- case splitTyConApp_maybe (conLikeResTy cl tys) of
+ Just (tc, _) -> dsGetCompleteMatches tc
+ Nothing -> return []
+ let fams cm = fmap (FromComplete,) $
+ mapM dsLookupConLike (completeMatchConLikes cm)
+ from_pragma <- mapM fams pragmas
+
+ let final_groups = fam ++ from_pragma
+ tracePmD "allCompleteMatches" (ppr final_groups)
+ return final_groups
+
+-- -----------------------------------------------------------------------
+-- * Types and constraints
+
+newEvVar :: Name -> Type -> EvVar
+newEvVar name ty = mkLocalId name (toTcType ty)
+
+nameType :: String -> Type -> DsM EvVar
+nameType name ty = do
+ unique <- getUniqueM
+ let occname = mkVarOccFS (fsLit (name++"_"++show unique))
+ idname = mkInternalName unique occname noSrcSpan
+ return (newEvVar idname ty)
+
+{-
+%************************************************************************
+%* *
+ The type oracle
+%* *
+%************************************************************************
+-}
+
+-- | Check whether a set of type constraints is satisfiable.
+tyOracle :: Bag EvVar -> PmM Bool
+tyOracle evs
+ = liftD $
+ do { ((_warns, errs), res) <- initTcDsForSolver $ tcCheckSatisfiability evs
+ ; case res of
+ Just sat -> return sat
+ Nothing -> pprPanic "tyOracle" (vcat $ pprErrMsgBagWithLoc errs) }
+
+{-
+%************************************************************************
+%* *
+ Sanity Checks
+%* *
+%************************************************************************
+-}
+
+-- | The arity of a pattern/pattern vector is the
+-- number of top-level patterns that are not guards
+type PmArity = Int
+
+-- | Compute the arity of a pattern vector
+patVecArity :: PatVec -> PmArity
+patVecArity = sum . map patternArity
+
+-- | Compute the arity of a pattern
+patternArity :: Pattern -> PmArity
+patternArity (PmGrd {}) = 0
+patternArity _other_pat = 1
+
+{-
+%************************************************************************
+%* *
+ Heart of the algorithm: Function pmcheck
+%* *
+%************************************************************************
+
+Main functions are:
+
+* mkInitialUncovered :: [Id] -> PmM Uncovered
+
+ Generates the initial uncovered set. Term and type constraints in scope
+ are checked, if they are inconsistent, the set is empty, otherwise, the
+ set contains only a vector of variables with the constraints in scope.
+
+* pmcheck :: PatVec -> [PatVec] -> ValVec -> PmM PartialResult
+
+ Checks redundancy, coverage and inaccessibility, using auxilary functions
+ `pmcheckGuards` and `pmcheckHd`. Mainly handles the guard case which is
+ common in all three checks (see paper) and calls `pmcheckGuards` when the
+ whole clause is checked, or `pmcheckHd` when the pattern vector does not
+ start with a guard.
+
+* pmcheckGuards :: [PatVec] -> ValVec -> PmM PartialResult
+
+ Processes the guards.
+
+* pmcheckHd :: Pattern -> PatVec -> [PatVec]
+ -> ValAbs -> ValVec -> PmM PartialResult
+
+ Worker: This function implements functions `covered`, `uncovered` and
+ `divergent` from the paper at once. Slightly different from the paper because
+ it does not even produce the covered and uncovered sets. Since we only care
+ about whether a clause covers SOMETHING or if it may forces ANY argument, we
+ only store a boolean in both cases, for efficiency.
+-}
+
+-- | Lift a pattern matching action from a single value vector abstration to a
+-- value set abstraction, but calling it on every vector and the combining the
+-- results.
+runMany :: (ValVec -> PmM PartialResult) -> (Uncovered -> PmM PartialResult)
+runMany _ [] = return mempty
+runMany pm (m:ms) = mappend <$> pm m <*> runMany pm ms
+
+-- | Generate the initial uncovered set. It initializes the
+-- delta with all term and type constraints in scope.
+mkInitialUncovered :: [Id] -> PmM Uncovered
+mkInitialUncovered vars = do
+ ty_cs <- liftD getDictsDs
+ tm_cs <- map toComplex . bagToList <$> liftD getTmCsDs
+ sat_ty <- tyOracle ty_cs
+ let initTyCs = if sat_ty then ty_cs else emptyBag
+ initTmState = fromMaybe initialTmState (tmOracle initialTmState tm_cs)
+ patterns = map PmVar vars
+ -- If any of the term/type constraints are non
+ -- satisfiable then return with the initialTmState. See #12957
+ return [ValVec patterns (MkDelta initTyCs initTmState)]
+
+-- | Increase the counter for elapsed algorithm iterations, check that the
+-- limit is not exceeded and call `pmcheck`
+pmcheckI :: PatVec -> [PatVec] -> ValVec -> PmM PartialResult
+pmcheckI ps guards vva = do
+ n <- liftD incrCheckPmIterDs
+ tracePm "pmCheck" (ppr n <> colon <+> pprPatVec ps
+ $$ hang (text "guards:") 2 (vcat (map pprPatVec guards))
+ $$ pprValVecDebug vva)
+ res <- pmcheck ps guards vva
+ tracePm "pmCheckResult:" (ppr res)
+ return res
+{-# INLINE pmcheckI #-}
+
+-- | Increase the counter for elapsed algorithm iterations, check that the
+-- limit is not exceeded and call `pmcheckGuards`
+pmcheckGuardsI :: [PatVec] -> ValVec -> PmM PartialResult
+pmcheckGuardsI gvs vva = liftD incrCheckPmIterDs >> pmcheckGuards gvs vva
+{-# INLINE pmcheckGuardsI #-}
+
+-- | Increase the counter for elapsed algorithm iterations, check that the
+-- limit is not exceeded and call `pmcheckHd`
+pmcheckHdI :: Pattern -> PatVec -> [PatVec] -> ValAbs -> ValVec
+ -> PmM PartialResult
+pmcheckHdI p ps guards va vva = do
+ n <- liftD incrCheckPmIterDs
+ tracePm "pmCheckHdI" (ppr n <> colon <+> pprPmPatDebug p
+ $$ pprPatVec ps
+ $$ hang (text "guards:") 2 (vcat (map pprPatVec guards))
+ $$ pprPmPatDebug va
+ $$ pprValVecDebug vva)
+
+ res <- pmcheckHd p ps guards va vva
+ tracePm "pmCheckHdI: res" (ppr res)
+ return res
+{-# INLINE pmcheckHdI #-}
+
+-- | Matching function: Check simultaneously a clause (takes separately the
+-- patterns and the list of guards) for exhaustiveness, redundancy and
+-- inaccessibility.
+pmcheck :: PatVec -> [PatVec] -> ValVec -> PmM PartialResult
+pmcheck [] guards vva@(ValVec [] _)
+ | null guards = return $ mempty { presultCovered = Covered }
+ | otherwise = pmcheckGuardsI guards vva
+
+-- Guard
+pmcheck (p@(PmGrd pv e) : ps) guards vva@(ValVec vas delta)
+ -- short-circuit if the guard pattern is useless.
+ -- we just have two possible outcomes: fail here or match and recurse
+ -- none of the two contains any useful information about the failure
+ -- though. So just have these two cases but do not do all the boilerplate
+ | isFakeGuard pv e = forces . mkCons vva <$> pmcheckI ps guards vva
+ | otherwise = do
+ y <- liftD $ mkPmId (pmPatType p)
+ let tm_state = extendSubst y e (delta_tm_cs delta)
+ delta' = delta { delta_tm_cs = tm_state }
+ utail <$> pmcheckI (pv ++ ps) guards (ValVec (PmVar y : vas) delta')
+
+pmcheck [] _ (ValVec (_:_) _) = panic "pmcheck: nil-cons"
+pmcheck (_:_) _ (ValVec [] _) = panic "pmcheck: cons-nil"
+
+pmcheck (p:ps) guards (ValVec (va:vva) delta)
+ = pmcheckHdI p ps guards va (ValVec vva delta)
+
+-- | Check the list of guards
+pmcheckGuards :: [PatVec] -> ValVec -> PmM PartialResult
+pmcheckGuards [] vva = return (usimple [vva])
+pmcheckGuards (gv:gvs) vva = do
+ (PartialResult prov1 cs vsa ds) <- pmcheckI gv [] vva
+ (PartialResult prov2 css vsas dss) <- runMany (pmcheckGuardsI gvs) vsa
+ return $ PartialResult (prov1 `mappend` prov2)
+ (cs `mappend` css)
+ vsas
+ (ds `mappend` dss)
+
+-- | Worker function: Implements all cases described in the paper for all three
+-- functions (`covered`, `uncovered` and `divergent`) apart from the `Guard`
+-- cases which are handled by `pmcheck`
+pmcheckHd :: Pattern -> PatVec -> [PatVec] -> ValAbs -> ValVec
+ -> PmM PartialResult
+
+-- Var
+pmcheckHd (PmVar x) ps guards va (ValVec vva delta)
+ | Just tm_state <- solveOneEq (delta_tm_cs delta)
+ (PmExprVar (idName x), vaToPmExpr va)
+ = ucon va <$> pmcheckI ps guards (ValVec vva (delta {delta_tm_cs = tm_state}))
+ | otherwise = return mempty
+
+-- ConCon
+pmcheckHd ( p@(PmCon {pm_con_con = c1, pm_con_args = args1})) ps guards
+ (va@(PmCon {pm_con_con = c2, pm_con_args = args2})) (ValVec vva delta)
+ | c1 /= c2 =
+ return (usimple [ValVec (va:vva) delta])
+ | otherwise = kcon c1 (pm_con_arg_tys p) (pm_con_tvs p) (pm_con_dicts p)
+ <$> pmcheckI (args1 ++ ps) guards (ValVec (args2 ++ vva) delta)
+
+-- LitLit
+pmcheckHd (PmLit l1) ps guards (va@(PmLit l2)) vva =
+ case eqPmLit l1 l2 of
+ True -> ucon va <$> pmcheckI ps guards vva
+ False -> return $ ucon va (usimple [vva])
+
+-- ConVar
+pmcheckHd (p@(PmCon { pm_con_con = con, pm_con_arg_tys = tys }))
+ ps guards
+ (PmVar x) (ValVec vva delta) = do
+ (prov, complete_match) <- select =<< liftD (allCompleteMatches con tys)
+
+ cons_cs <- mapM (liftD . mkOneConFull x) complete_match
+
+ inst_vsa <- flip concatMapM cons_cs $ \(va, tm_ct, ty_cs) -> do
+ let ty_state = ty_cs `unionBags` delta_ty_cs delta -- not actually a state
+ sat_ty <- if isEmptyBag ty_cs then return True
+ else tyOracle ty_state
+ return $ case (sat_ty, solveOneEq (delta_tm_cs delta) tm_ct) of
+ (True, Just tm_state) -> [ValVec (va:vva) (MkDelta ty_state tm_state)]
+ _ty_or_tm_failed -> []
+
+ set_provenance prov .
+ force_if (canDiverge (idName x) (delta_tm_cs delta)) <$>
+ runMany (pmcheckI (p:ps) guards) inst_vsa
+
+-- LitVar
+pmcheckHd (p@(PmLit l)) ps guards (PmVar x) (ValVec vva delta)
+ = force_if (canDiverge (idName x) (delta_tm_cs delta)) <$>
+ mkUnion non_matched <$>
+ case solveOneEq (delta_tm_cs delta) (mkPosEq x l) of
+ Just tm_state -> pmcheckHdI p ps guards (PmLit l) $
+ ValVec vva (delta {delta_tm_cs = tm_state})
+ Nothing -> return mempty
+ where
+ us | Just tm_state <- solveOneEq (delta_tm_cs delta) (mkNegEq x l)
+ = [ValVec (PmNLit x [l] : vva) (delta { delta_tm_cs = tm_state })]
+ | otherwise = []
+
+ non_matched = usimple us
+
+-- LitNLit
+pmcheckHd (p@(PmLit l)) ps guards
+ (PmNLit { pm_lit_id = x, pm_lit_not = lits }) (ValVec vva delta)
+ | all (not . eqPmLit l) lits
+ , Just tm_state <- solveOneEq (delta_tm_cs delta) (mkPosEq x l)
+ -- Both guards check the same so it would be sufficient to have only
+ -- the second one. Nevertheless, it is much cheaper to check whether
+ -- the literal is in the list so we check it first, to avoid calling
+ -- the term oracle (`solveOneEq`) if possible
+ = mkUnion non_matched <$>
+ pmcheckHdI p ps guards (PmLit l)
+ (ValVec vva (delta { delta_tm_cs = tm_state }))
+ | otherwise = return non_matched
+ where
+ us | Just tm_state <- solveOneEq (delta_tm_cs delta) (mkNegEq x l)
+ = [ValVec (PmNLit x (l:lits) : vva) (delta { delta_tm_cs = tm_state })]
+ | otherwise = []
+
+ non_matched = usimple us
+
+-- ----------------------------------------------------------------------------
+-- The following three can happen only in cases like #322 where constructors
+-- and overloaded literals appear in the same match. The general strategy is
+-- to replace the literal (positive/negative) by a variable and recurse. The
+-- fact that the variable is equal to the literal is recorded in `delta` so
+-- no information is lost
+
+-- LitCon
+pmcheckHd (PmLit l) ps guards (va@(PmCon {})) (ValVec vva delta)
+ = do y <- liftD $ mkPmId (pmPatType va)
+ let tm_state = extendSubst y (PmExprLit l) (delta_tm_cs delta)
+ delta' = delta { delta_tm_cs = tm_state }
+ pmcheckHdI (PmVar y) ps guards va (ValVec vva delta')
+
+-- ConLit
+pmcheckHd (p@(PmCon {})) ps guards (PmLit l) (ValVec vva delta)
+ = do y <- liftD $ mkPmId (pmPatType p)
+ let tm_state = extendSubst y (PmExprLit l) (delta_tm_cs delta)
+ delta' = delta { delta_tm_cs = tm_state }
+ pmcheckHdI p ps guards (PmVar y) (ValVec vva delta')
+
+-- ConNLit
+pmcheckHd (p@(PmCon {})) ps guards (PmNLit { pm_lit_id = x }) vva
+ = pmcheckHdI p ps guards (PmVar x) vva
+
+-- Impossible: handled by pmcheck
+pmcheckHd (PmGrd {}) _ _ _ _ = panic "pmcheckHd: Guard"
+
+-- ----------------------------------------------------------------------------
+-- * Utilities for main checking
+
+updateVsa :: (ValSetAbs -> ValSetAbs) -> (PartialResult -> PartialResult)
+updateVsa f p@(PartialResult { presultUncovered = old })
+ = p { presultUncovered = f old }
+
+
+-- | Initialise with default values for covering and divergent information.
+usimple :: ValSetAbs -> PartialResult
+usimple vsa = mempty { presultUncovered = vsa }
+
+-- | Take the tail of all value vector abstractions in the uncovered set
+utail :: PartialResult -> PartialResult
+utail = updateVsa upd
+ where upd vsa = [ ValVec vva delta | ValVec (_:vva) delta <- vsa ]
+
+-- | Prepend a value abstraction to all value vector abstractions in the
+-- uncovered set
+ucon :: ValAbs -> PartialResult -> PartialResult
+ucon va = updateVsa upd
+ where
+ upd vsa = [ ValVec (va:vva) delta | ValVec vva delta <- vsa ]
+
+-- | Given a data constructor of arity `a` and an uncovered set containing
+-- value vector abstractions of length `(a+n)`, pass the first `n` value
+-- abstractions to the constructor (Hence, the resulting value vector
+-- abstractions will have length `n+1`)
+kcon :: ConLike -> [Type] -> [TyVar] -> [EvVar]
+ -> PartialResult -> PartialResult
+kcon con arg_tys ex_tvs dicts
+ = let n = conLikeArity con
+ upd vsa =
+ [ ValVec (va:vva) delta
+ | ValVec vva' delta <- vsa
+ , let (args, vva) = splitAt n vva'
+ , let va = PmCon { pm_con_con = con
+ , pm_con_arg_tys = arg_tys
+ , pm_con_tvs = ex_tvs
+ , pm_con_dicts = dicts
+ , pm_con_args = args } ]
+ in updateVsa upd
+
+-- | Get the union of two covered, uncovered and divergent value set
+-- abstractions. Since the covered and divergent sets are represented by a
+-- boolean, union means computing the logical or (at least one of the two is
+-- non-empty).
+
+mkUnion :: PartialResult -> PartialResult -> PartialResult
+mkUnion = mappend
+
+-- | Add a value vector abstraction to a value set abstraction (uncovered).
+mkCons :: ValVec -> PartialResult -> PartialResult
+mkCons vva = updateVsa (vva:)
+
+-- | Set the divergent set to not empty
+forces :: PartialResult -> PartialResult
+forces pres = pres { presultDivergent = Diverged }
+
+-- | Set the divergent set to non-empty if the flag is `True`
+force_if :: Bool -> PartialResult -> PartialResult
+force_if True pres = forces pres
+force_if False pres = pres
+
+set_provenance :: Provenance -> PartialResult -> PartialResult
+set_provenance prov pr = pr { presultProvenence = prov }
+
+-- ----------------------------------------------------------------------------
+-- * Propagation of term constraints inwards when checking nested matches
+
+{- Note [Type and Term Equality Propagation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When checking a match it would be great to have all type and term information
+available so we can get more precise results. For this reason we have functions
+`addDictsDs' and `addTmCsDs' in PmMonad that store in the environment type and
+term constraints (respectively) as we go deeper.
+
+The type constraints we propagate inwards are collected by `collectEvVarsPats'
+in HsPat.hs. This handles bug #4139 ( see example
+ https://ghc.haskell.org/trac/ghc/attachment/ticket/4139/GADTbug.hs )
+where this is needed.
+
+For term equalities we do less, we just generate equalities for HsCase. For
+example we accurately give 2 redundancy warnings for the marked cases:
+
+f :: [a] -> Bool
+f x = case x of
+
+ [] -> case x of -- brings (x ~ []) in scope
+ [] -> True
+ (_:_) -> False -- can't happen
+
+ (_:_) -> case x of -- brings (x ~ (_:_)) in scope
+ (_:_) -> True
+ [] -> False -- can't happen
+
+Functions `genCaseTmCs1' and `genCaseTmCs2' are responsible for generating
+these constraints.
+-}
+
+-- | Generate equalities when checking a case expression:
+-- case x of { p1 -> e1; ... pn -> en }
+-- When we go deeper to check e.g. e1 we record two equalities:
+-- (x ~ y), where y is the initial uncovered when checking (p1; .. ; pn)
+-- and (x ~ p1).
+genCaseTmCs2 :: Maybe (LHsExpr Id) -- Scrutinee
+ -> [Pat Id] -- LHS (should have length 1)
+ -> [Id] -- MatchVars (should have length 1)
+ -> DsM (Bag SimpleEq)
+genCaseTmCs2 Nothing _ _ = return emptyBag
+genCaseTmCs2 (Just scr) [p] [var] = do
+ fam_insts <- dsGetFamInstEnvs
+ [e] <- map vaToPmExpr . coercePatVec <$> translatePat fam_insts p
+ let scr_e = lhsExprToPmExpr scr
+ return $ listToBag [(var, e), (var, scr_e)]
+genCaseTmCs2 _ _ _ = panic "genCaseTmCs2: HsCase"
+
+-- | Generate a simple equality when checking a case expression:
+-- case x of { matches }
+-- When checking matches we record that (x ~ y) where y is the initial
+-- uncovered. All matches will have to satisfy this equality.
+genCaseTmCs1 :: Maybe (LHsExpr Id) -> [Id] -> Bag SimpleEq
+genCaseTmCs1 Nothing _ = emptyBag
+genCaseTmCs1 (Just scr) [var] = unitBag (var, lhsExprToPmExpr scr)
+genCaseTmCs1 _ _ = panic "genCaseTmCs1: HsCase"
+
+{- Note [Literals in PmPat]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Instead of translating a literal to a variable accompanied with a guard, we
+treat them like constructor patterns. The following example from
+"./libraries/base/GHC/IO/Encoding.hs" shows why:
+
+mkTextEncoding' :: CodingFailureMode -> String -> IO TextEncoding
+mkTextEncoding' cfm enc = case [toUpper c | c <- enc, c /= '-'] of
+ "UTF8" -> return $ UTF8.mkUTF8 cfm
+ "UTF16" -> return $ UTF16.mkUTF16 cfm
+ "UTF16LE" -> return $ UTF16.mkUTF16le cfm
+ ...
+
+Each clause gets translated to a list of variables with an equal number of
+guards. For every guard we generate two cases (equals True/equals False) which
+means that we generate 2^n cases to feed the oracle with, where n is the sum of
+the length of all strings that appear in the patterns. For this particular
+example this means over 2^40 cases. Instead, by representing them like with
+constructor we get the following:
+ 1. We exploit the common prefix with our representation of VSAs
+ 2. We prune immediately non-reachable cases
+ (e.g. False == (x == "U"), True == (x == "U"))
+
+Note [Translating As Patterns]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Instead of translating x@p as: x (p <- x)
+we instead translate it as: p (x <- coercePattern p)
+for performance reasons. For example:
+
+ f x@True = 1
+ f y@False = 2
+
+Gives the following with the first translation:
+
+ x |> {x == False, x == y, y == True}
+
+If we use the second translation we get an empty set, independently of the
+oracle. Since the pattern `p' may contain guard patterns though, it cannot be
+used as an expression. That's why we call `coercePatVec' to drop the guard and
+`vaToPmExpr' to transform the value abstraction to an expression in the
+guard pattern (value abstractions are a subset of expressions). We keep the
+guards in the first pattern `p' though.
+
+
+%************************************************************************
+%* *
+ Pretty printing of exhaustiveness/redundancy check warnings
+%* *
+%************************************************************************
+-}
+
+-- | Check whether any part of pattern match checking is enabled (does not
+-- matter whether it is the redundancy check or the exhaustiveness check).
+isAnyPmCheckEnabled :: DynFlags -> DsMatchContext -> Bool
+isAnyPmCheckEnabled dflags (DsMatchContext kind _loc)
+ = wopt Opt_WarnOverlappingPatterns dflags || exhaustive dflags kind
+
+instance Outputable ValVec where
+ ppr (ValVec vva delta)
+ = let (residual_eqs, subst) = wrapUpTmState (delta_tm_cs delta)
+ vector = substInValAbs subst vva
+ in ppr_uncovered (vector, residual_eqs)
+
+-- | Apply a term substitution to a value vector abstraction. All VAs are
+-- transformed to PmExpr (used only before pretty printing).
+substInValAbs :: PmVarEnv -> [ValAbs] -> [PmExpr]
+substInValAbs subst = map (exprDeepLookup subst . vaToPmExpr)
+
+-- | Wrap up the term oracle's state once solving is complete. Drop any
+-- information about unhandled constraints (involving HsExprs) and flatten
+-- (height 1) the substitution.
+wrapUpTmState :: TmState -> ([ComplexEq], PmVarEnv)
+wrapUpTmState (residual, (_, subst)) = (residual, flattenPmVarEnv subst)
+
+-- | Issue all the warnings (coverage, exhaustiveness, inaccessibility)
+dsPmWarn :: DynFlags -> DsMatchContext -> PmResult -> DsM ()
+dsPmWarn dflags ctx@(DsMatchContext kind loc) pm_result
+ = when (flag_i || flag_u) $ do
+ let exists_r = flag_i && notNull redundant && onlyBuiltin
+ exists_i = flag_i && notNull inaccessible && onlyBuiltin && not is_rec_upd
+ exists_u = flag_u && (case uncovered of
+ TypeOfUncovered _ -> True
+ UncoveredPatterns u -> notNull u)
+
+ when exists_r $ forM_ redundant $ \(L l q) -> do
+ putSrcSpanDs l (warnDs (Reason Opt_WarnOverlappingPatterns)
+ (pprEqn q "is redundant"))
+ when exists_i $ forM_ inaccessible $ \(L l q) -> do
+ putSrcSpanDs l (warnDs (Reason Opt_WarnOverlappingPatterns)
+ (pprEqn q "has inaccessible right hand side"))
+ when exists_u $ putSrcSpanDs loc $ warnDs flag_u_reason $
+ case uncovered of
+ TypeOfUncovered ty -> warnEmptyCase ty
+ UncoveredPatterns candidates -> pprEqns candidates
+ where
+ PmResult
+ { pmresultProvenance = prov
+ , pmresultRedundant = redundant
+ , pmresultUncovered = uncovered
+ , pmresultInaccessible = inaccessible } = pm_result
+
+ flag_i = wopt Opt_WarnOverlappingPatterns dflags
+ flag_u = exhaustive dflags kind
+ flag_u_reason = maybe NoReason Reason (exhaustiveWarningFlag kind)
+
+ is_rec_upd = case kind of { RecUpd -> True; _ -> False }
+ -- See Note [Inaccessible warnings for record updates]
+
+ onlyBuiltin = prov == FromBuiltin
+
+ maxPatterns = maxUncoveredPatterns dflags
+
+ -- Print a single clause (for redundant/with-inaccessible-rhs)
+ pprEqn q txt = pp_context True ctx (text txt) $ \f -> ppr_eqn f kind q
+
+ -- Print several clauses (for uncovered clauses)
+ pprEqns qs = pp_context False ctx (text "are non-exhaustive") $ \_ ->
+ case qs of -- See #11245
+ [ValVec [] _]
+ -> text "Guards do not cover entire pattern space"
+ _missing -> let us = map ppr qs
+ in hang (text "Patterns not matched:") 4
+ (vcat (take maxPatterns us)
+ $$ dots maxPatterns us)
+
+ -- Print a type-annotated wildcard (for non-exhaustive `EmptyCase`s for
+ -- which we only know the type and have no inhabitants at hand)
+ warnEmptyCase ty = pp_context False ctx (text "are non-exhaustive") $ \_ ->
+ hang (text "Patterns not matched:") 4 (underscore <+> dcolon <+> ppr ty)
+
+{- Note [Inaccessible warnings for record updates]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider (Trac #12957)
+ data T a where
+ T1 :: { x :: Int } -> T Bool
+ T2 :: { x :: Int } -> T a
+ T3 :: T a
+
+ f :: T Char -> T a
+ f r = r { x = 3 }
+
+The desugarer will (conservatively generate a case for T1 even though
+it's impossible:
+ f r = case r of
+ T1 x -> T1 3 -- Inaccessible branch
+ T2 x -> T2 3
+ _ -> error "Missing"
+
+We don't want to warn about the inaccessible branch because the programmer
+didn't put it there! So we filter out the warning here.
+-}
+
+-- | Issue a warning when the predefined number of iterations is exceeded
+-- for the pattern match checker
+warnPmIters :: DynFlags -> DsMatchContext -> DsM ()
+warnPmIters dflags (DsMatchContext kind loc)
+ = when (flag_i || flag_u) $ do
+ iters <- maxPmCheckIterations <$> getDynFlags
+ putSrcSpanDs loc (warnDs NoReason (msg iters))
+ where
+ ctxt = pprMatchContext kind
+ msg is = fsep [ text "Pattern match checker exceeded"
+ , parens (ppr is), text "iterations in", ctxt <> dot
+ , text "(Use -fmax-pmcheck-iterations=n"
+ , text "to set the maximun number of iterations to n)" ]
+
+ flag_i = wopt Opt_WarnOverlappingPatterns dflags
+ flag_u = exhaustive dflags kind
+
+dots :: Int -> [a] -> SDoc
+dots maxPatterns qs
+ | qs `lengthExceeds` maxPatterns = text "..."
+ | otherwise = empty
+
+-- | Check whether the exhaustiveness checker should run (exhaustiveness only)
+exhaustive :: DynFlags -> HsMatchContext id -> Bool
+exhaustive dflags = maybe False (`wopt` dflags) . exhaustiveWarningFlag
+
+-- | Denotes whether an exhaustiveness check is supported, and if so,
+-- via which 'WarningFlag' it's controlled.
+-- Returns 'Nothing' if check is not supported.
+exhaustiveWarningFlag :: HsMatchContext id -> Maybe WarningFlag
+exhaustiveWarningFlag (FunRhs {}) = Just Opt_WarnIncompletePatterns
+exhaustiveWarningFlag CaseAlt = Just Opt_WarnIncompletePatterns
+exhaustiveWarningFlag IfAlt = Nothing
+exhaustiveWarningFlag LambdaExpr = Just Opt_WarnIncompleteUniPatterns
+exhaustiveWarningFlag PatBindRhs = Just Opt_WarnIncompleteUniPatterns
+exhaustiveWarningFlag ProcExpr = Just Opt_WarnIncompleteUniPatterns
+exhaustiveWarningFlag RecUpd = Just Opt_WarnIncompletePatternsRecUpd
+exhaustiveWarningFlag ThPatSplice = Nothing
+exhaustiveWarningFlag PatSyn = Nothing
+exhaustiveWarningFlag ThPatQuote = Nothing
+exhaustiveWarningFlag (StmtCtxt {}) = Nothing -- Don't warn about incomplete patterns
+ -- in list comprehensions, pattern guards
+ -- etc. They are often *supposed* to be
+ -- incomplete
+
+-- True <==> singular
+pp_context :: Bool -> DsMatchContext -> SDoc -> ((SDoc -> SDoc) -> SDoc) -> SDoc
+pp_context singular (DsMatchContext kind _loc) msg rest_of_msg_fun
+ = vcat [text txt <+> msg,
+ sep [ text "In" <+> ppr_match <> char ':'
+ , nest 4 (rest_of_msg_fun pref)]]
+ where
+ txt | singular = "Pattern match"
+ | otherwise = "Pattern match(es)"
+
+ (ppr_match, pref)
+ = case kind of
+ FunRhs (L _ fun) _ _ -> (pprMatchContext kind,
+ \ pp -> ppr fun <+> pp)
+ _ -> (pprMatchContext kind, \ pp -> pp)
+
+ppr_pats :: HsMatchContext Name -> [Pat Id] -> SDoc
+ppr_pats kind pats
+ = sep [sep (map ppr pats), matchSeparator kind, text "..."]
+
+ppr_eqn :: (SDoc -> SDoc) -> HsMatchContext Name -> [LPat Id] -> SDoc
+ppr_eqn prefixF kind eqn = prefixF (ppr_pats kind (map unLoc eqn))
+
+ppr_constraint :: (SDoc,[PmLit]) -> SDoc
+ppr_constraint (var, lits) = var <+> text "is not one of"
+ <+> braces (pprWithCommas ppr lits)
+
+ppr_uncovered :: ([PmExpr], [ComplexEq]) -> SDoc
+ppr_uncovered (expr_vec, complex)
+ | null cs = fsep vec -- there are no literal constraints
+ | otherwise = hang (fsep vec) 4 $
+ text "where" <+> vcat (map ppr_constraint cs)
+ where
+ sdoc_vec = mapM pprPmExprWithParens expr_vec
+ (vec,cs) = runPmPprM sdoc_vec (filterComplex complex)
+
+{- Note [Representation of Term Equalities]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In the paper, term constraints always take the form (x ~ e). Of course, a more
+general constraint of the form (e1 ~ e1) can always be transformed to an
+equivalent set of the former constraints, by introducing a fresh, intermediate
+variable: { y ~ e1, y ~ e1 }. Yet, implementing this representation gave rise
+to #11160 (incredibly bad performance for literal pattern matching). Two are
+the main sources of this problem (the actual problem is how these two interact
+with each other):
+
+1. Pattern matching on literals generates twice as many constraints as needed.
+ Consider the following (tests/ghci/should_run/ghcirun004):
+
+ foo :: Int -> Int
+ foo 1 = 0
+ ...
+ foo 5000 = 4999
+
+ The covered and uncovered set *should* look like:
+ U0 = { x |> {} }
+
+ C1 = { 1 |> { x ~ 1 } }
+ U1 = { x |> { False ~ (x ~ 1) } }
+ ...
+ C10 = { 10 |> { False ~ (x ~ 1), .., False ~ (x ~ 9), x ~ 10 } }
+ U10 = { x |> { False ~ (x ~ 1), .., False ~ (x ~ 9), False ~ (x ~ 10) } }
+ ...
+
+ If we replace { False ~ (x ~ 1) } with { y ~ False, y ~ (x ~ 1) }
+ we get twice as many constraints. Also note that half of them are just the
+ substitution [x |-> False].
+
+2. The term oracle (`tmOracle` in deSugar/TmOracle) uses equalities of the form
+ (x ~ e) as substitutions [x |-> e]. More specifically, function
+ `extendSubstAndSolve` applies such substitutions in the residual constraints
+ and partitions them in the affected and non-affected ones, which are the new
+ worklist. Essentially, this gives quadradic behaviour on the number of the
+ residual constraints. (This would not be the case if the term oracle used
+ mutable variables but, since we use it to handle disjunctions on value set
+ abstractions (`Union` case), we chose a pure, incremental interface).
+
+Now the problem becomes apparent (e.g. for clause 300):
+ * Set U300 contains 300 substituting constraints [y_i |-> False] and 300
+ constraints that we know that will not reduce (stay in the worklist).
+ * To check for consistency, we apply the substituting constraints ONE BY ONE
+ (since `tmOracle` is called incrementally, it does not have all of them
+ available at once). Hence, we go through the (non-progressing) constraints
+ over and over, achieving over-quadradic behaviour.
+
+If instead we allow constraints of the form (e ~ e),
+ * All uncovered sets Ui contain no substituting constraints and i
+ non-progressing constraints of the form (False ~ (x ~ lit)) so the oracle
+ behaves linearly.
+ * All covered sets Ci contain exactly (i-1) non-progressing constraints and
+ a single substituting constraint. So the term oracle goes through the
+ constraints only once.
+
+The performance improvement becomes even more important when more arguments are
+involved.
+-}
+
+-- Debugging Infrastructre
+
+tracePm :: String -> SDoc -> PmM ()
+tracePm herald doc = liftD $ tracePmD herald doc
+
+
+tracePmD :: String -> SDoc -> DsM ()
+tracePmD herald doc = do
+ dflags <- getDynFlags
+ printer <- mkPrintUnqualifiedDs
+ liftIO $ dumpIfSet_dyn_printer printer dflags
+ Opt_D_dump_ec_trace (text herald $$ (nest 2 doc))
+
+
+pprPmPatDebug :: PmPat a -> SDoc
+pprPmPatDebug (PmCon cc _arg_tys _con_tvs _con_dicts con_args)
+ = hsep [text "PmCon", ppr cc, hsep (map pprPmPatDebug con_args)]
+pprPmPatDebug (PmVar vid) = text "PmVar" <+> ppr vid
+pprPmPatDebug (PmLit li) = text "PmLit" <+> ppr li
+pprPmPatDebug (PmNLit i nl) = text "PmNLit" <+> ppr i <+> ppr nl
+pprPmPatDebug (PmGrd pv ge) = text "PmGrd" <+> hsep (map pprPmPatDebug pv)
+ <+> ppr ge
+
+pprPatVec :: PatVec -> SDoc
+pprPatVec ps = hang (text "Pattern:") 2
+ (brackets $ sep
+ $ punctuate (comma <> char '\n') (map pprPmPatDebug ps))
+
+pprValAbs :: [ValAbs] -> SDoc
+pprValAbs ps = hang (text "ValAbs:") 2
+ (brackets $ sep
+ $ punctuate (comma) (map pprPmPatDebug ps))
+
+pprValVecDebug :: ValVec -> SDoc
+pprValVecDebug (ValVec vas _d) = text "ValVec" <+>
+ parens (pprValAbs vas)
diff --git a/deSugar/Coverage.hs b/deSugar/Coverage.hs
new file mode 100644
--- /dev/null
+++ b/deSugar/Coverage.hs
@@ -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 -- counts as a normal char in GHC's
+ -- location ranges.
+
+ createDirectoryIfMissing True hpc_mod_dir
+ modTime <- getModificationUTCTime filename
+ let entries' = [ (hpcPos, box)
+ | (span,_,_,box) <- entries, hpcPos <- [mkHpcPos span] ]
+ when (length entries' /= count) $ do
+ panic "the number of .mix entries are inconsistent"
+ let hashNo = mixHash filename modTime tabStop entries'
+ mixCreate hpc_mod_dir mod_name
+ $ Mix filename modTime (toHash hashNo) tabStop entries'
+ return hashNo
+
+
+-- -----------------------------------------------------------------------------
+-- TickDensity: where to insert ticks
+
+data TickDensity
+ = TickForCoverage -- for Hpc
+ | TickForBreakPoints -- for GHCi
+ | TickAllFunctions -- for -prof-auto-all
+ | TickTopFunctions -- for -prof-auto-top
+ | TickExportedFunctions -- for -prof-auto-exported
+ | TickCallSites -- for stack tracing
+ deriving Eq
+
+mkDensity :: TickishType -> DynFlags -> TickDensity
+mkDensity tickish dflags = case tickish of
+ HpcTicks -> TickForCoverage
+ SourceNotes -> TickForCoverage
+ Breakpoints -> TickForBreakPoints
+ ProfNotes ->
+ case profAuto dflags of
+ ProfAutoAll -> TickAllFunctions
+ ProfAutoTop -> TickTopFunctions
+ ProfAutoExports -> TickExportedFunctions
+ ProfAutoCalls -> TickCallSites
+ _other -> panic "mkDensity"
+
+-- | Decide whether to add a tick to a binding or not.
+shouldTickBind :: TickDensity
+ -> Bool -- top level?
+ -> Bool -- exported?
+ -> Bool -- simple pat bind?
+ -> Bool -- INLINE pragma?
+ -> Bool
+
+shouldTickBind density top_lev exported _simple_pat inline
+ = case density of
+ TickForBreakPoints -> False
+ -- we never add breakpoints to simple pattern bindings
+ -- (there's always a tick on the rhs anyway).
+ TickAllFunctions -> not inline
+ TickTopFunctions -> top_lev && not inline
+ TickExportedFunctions -> exported && not inline
+ TickForCoverage -> True
+ TickCallSites -> False
+
+shouldTickPatBind :: TickDensity -> Bool -> Bool
+shouldTickPatBind density top_lev
+ = case density of
+ TickForBreakPoints -> False
+ TickAllFunctions -> True
+ TickTopFunctions -> top_lev
+ TickExportedFunctions -> False
+ TickForCoverage -> False
+ TickCallSites -> False
+
+-- -----------------------------------------------------------------------------
+-- Adding ticks to bindings
+
+addTickLHsBinds :: LHsBinds Id -> TM (LHsBinds Id)
+addTickLHsBinds = mapBagM addTickLHsBind
+
+addTickLHsBind :: LHsBind Id -> TM (LHsBind Id)
+addTickLHsBind (L pos bind@(AbsBinds { abs_binds = binds,
+ abs_exports = abs_exports })) = do
+ withEnv add_exports $ do
+ withEnv add_inlines $ do
+ binds' <- addTickLHsBinds binds
+ return $ L pos $ bind { abs_binds = binds' }
+ where
+ -- in AbsBinds, the Id on each binding is not the actual top-level
+ -- Id that we are defining, they are related by the abs_exports
+ -- field of AbsBinds. So if we're doing TickExportedFunctions we need
+ -- to add the local Ids to the set of exported Names so that we know to
+ -- tick the right bindings.
+ add_exports env =
+ env{ exports = exports env `extendNameSetList`
+ [ idName mid
+ | ABE{ abe_poly = pid, abe_mono = mid } <- abs_exports
+ , idName pid `elemNameSet` (exports env) ] }
+
+ add_inlines env =
+ env{ inlines = inlines env `extendVarSetList`
+ [ mid
+ | ABE{ abe_poly = pid, abe_mono = mid } <- abs_exports
+ , isAnyInlinePragma (idInlinePragma pid) ] }
+
+addTickLHsBind (L pos bind@(AbsBindsSig { abs_sig_bind = val_bind
+ , abs_sig_export = poly_id }))
+ | L _ FunBind { fun_id = L _ mono_id } <- val_bind
+ = do withEnv (add_export mono_id) $ do
+ withEnv (add_inlines mono_id) $ do
+ val_bind' <- addTickLHsBind val_bind
+ return $ L pos $ bind { abs_sig_bind = val_bind' }
+
+ | otherwise
+ = pprPanic "addTickLHsBind" (ppr bind)
+ where
+ -- see AbsBinds comments
+ add_export mono_id env
+ | idName poly_id `elemNameSet` exports env
+ = env { exports = exports env `extendNameSet` idName mono_id }
+ | otherwise
+ = env
+
+ add_inlines mono_id env
+ | isAnyInlinePragma (idInlinePragma poly_id)
+ = env { inlines = inlines env `extendVarSet` mono_id }
+ | otherwise
+ = env
+
+addTickLHsBind (L pos (funBind@(FunBind { fun_id = (L _ id) }))) = do
+ let name = getOccString id
+ decl_path <- getPathEntry
+ density <- getDensity
+
+ inline_ids <- liftM inlines getEnv
+ let inline = isAnyInlinePragma (idInlinePragma id)
+ || id `elemVarSet` inline_ids
+
+ -- See Note [inline sccs]
+ tickish <- tickishType `liftM` getEnv
+ if inline && tickish == ProfNotes then return (L pos funBind) else do
+
+ (fvs, mg@(MG { mg_alts = matches' })) <-
+ getFreeVars $
+ addPathEntry name $
+ addTickMatchGroup False (fun_matches funBind)
+
+ blackListed <- isBlackListed pos
+ exported_names <- liftM exports getEnv
+
+ -- We don't want to generate code for blacklisted positions
+ -- We don't want redundant ticks on simple pattern bindings
+ -- We don't want to tick non-exported bindings in TickExportedFunctions
+ let simple = isSimplePatBind funBind
+ toplev = null decl_path
+ exported = idName id `elemNameSet` exported_names
+
+ tick <- if not blackListed &&
+ shouldTickBind density toplev exported simple inline
+ then
+ bindTick density name pos fvs
+ else
+ return Nothing
+
+ let mbCons = maybe Prelude.id (:)
+ return $ L pos $ funBind { fun_matches = mg { mg_alts = matches' }
+ , fun_tick = tick `mbCons` fun_tick funBind }
+
+ where
+ -- a binding is a simple pattern binding if it is a funbind with
+ -- zero patterns
+ isSimplePatBind :: HsBind a -> Bool
+ isSimplePatBind funBind = matchGroupArity (fun_matches funBind) == 0
+
+-- TODO: Revisit this
+addTickLHsBind (L pos (pat@(PatBind { pat_lhs = lhs, pat_rhs = rhs }))) = do
+ let name = "(...)"
+ (fvs, rhs') <- getFreeVars $ addPathEntry name $ addTickGRHSs False False rhs
+ let pat' = pat { pat_rhs = rhs'}
+
+ -- Should create ticks here?
+ density <- getDensity
+ decl_path <- getPathEntry
+ let top_lev = null decl_path
+ if not (shouldTickPatBind density top_lev) then return (L pos pat') else do
+
+ -- Allocate the ticks
+ rhs_tick <- bindTick density name pos fvs
+ let patvars = map getOccString (collectPatBinders lhs)
+ patvar_ticks <- mapM (\v -> bindTick density v pos fvs) patvars
+
+ -- Add to pattern
+ let mbCons = maybe id (:)
+ rhs_ticks = rhs_tick `mbCons` fst (pat_ticks pat')
+ patvar_tickss = zipWith mbCons patvar_ticks
+ (snd (pat_ticks pat') ++ repeat [])
+ return $ L pos $ pat' { pat_ticks = (rhs_ticks, patvar_tickss) }
+
+-- Only internal stuff, not from source, uses VarBind, so we ignore it.
+addTickLHsBind var_bind@(L _ (VarBind {})) = return var_bind
+addTickLHsBind patsyn_bind@(L _ (PatSynBind {})) = return patsyn_bind
+
+
+bindTick
+ :: TickDensity -> String -> SrcSpan -> FreeVars -> TM (Maybe (Tickish Id))
+bindTick density name pos fvs = do
+ decl_path <- getPathEntry
+ let
+ toplev = null decl_path
+ count_entries = toplev || density == TickAllFunctions
+ top_only = density /= TickAllFunctions
+ box_label = if toplev then TopLevelBox [name]
+ else LocalBox (decl_path ++ [name])
+ --
+ allocATickBox box_label count_entries top_only pos fvs
+
+
+-- Note [inline sccs]
+--
+-- It should be reasonable to add ticks to INLINE functions; however
+-- currently this tickles a bug later on because the SCCfinal pass
+-- does not look inside unfoldings to find CostCentres. It would be
+-- difficult to fix that, because SCCfinal currently works on STG and
+-- not Core (and since it also generates CostCentres for CAFs,
+-- changing this would be difficult too).
+--
+-- Another reason not to add ticks to INLINE functions is that this
+-- sometimes handy for avoiding adding a tick to a particular function
+-- (see #6131)
+--
+-- So for now we do not add any ticks to INLINE functions at all.
+
+-- -----------------------------------------------------------------------------
+-- Decorate an LHsExpr with ticks
+
+-- selectively add ticks to interesting expressions
+addTickLHsExpr :: LHsExpr Id -> TM (LHsExpr Id)
+addTickLHsExpr e@(L pos e0) = do
+ d <- getDensity
+ case d of
+ TickForBreakPoints | isGoodBreakExpr e0 -> tick_it
+ TickForCoverage -> tick_it
+ TickCallSites | isCallSite e0 -> tick_it
+ _other -> dont_tick_it
+ where
+ tick_it = allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0
+ dont_tick_it = addTickLHsExprNever e
+
+-- Add a tick to an expression which is the RHS of an equation or a binding.
+-- We always consider these to be breakpoints, unless the expression is a 'let'
+-- (because the body will definitely have a tick somewhere). ToDo: perhaps
+-- we should treat 'case' and 'if' the same way?
+addTickLHsExprRHS :: LHsExpr Id -> TM (LHsExpr Id)
+addTickLHsExprRHS e@(L pos e0) = do
+ d <- getDensity
+ case d of
+ TickForBreakPoints | HsLet{} <- e0 -> dont_tick_it
+ | otherwise -> tick_it
+ TickForCoverage -> tick_it
+ TickCallSites | isCallSite e0 -> tick_it
+ _other -> dont_tick_it
+ where
+ tick_it = allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0
+ dont_tick_it = addTickLHsExprNever e
+
+-- The inner expression of an evaluation context:
+-- let binds in [], ( [] )
+-- we never tick these if we're doing HPC, but otherwise
+-- we treat it like an ordinary expression.
+addTickLHsExprEvalInner :: LHsExpr Id -> TM (LHsExpr Id)
+addTickLHsExprEvalInner e = do
+ d <- getDensity
+ case d of
+ TickForCoverage -> addTickLHsExprNever e
+ _otherwise -> addTickLHsExpr e
+
+-- | A let body is treated differently from addTickLHsExprEvalInner
+-- above with TickForBreakPoints, because for breakpoints we always
+-- want to tick the body, even if it is not a redex. See test
+-- break012. This gives the user the opportunity to inspect the
+-- values of the let-bound variables.
+addTickLHsExprLetBody :: LHsExpr Id -> TM (LHsExpr Id)
+addTickLHsExprLetBody e@(L pos e0) = do
+ d <- getDensity
+ case d of
+ TickForBreakPoints | HsLet{} <- e0 -> dont_tick_it
+ | otherwise -> tick_it
+ _other -> addTickLHsExprEvalInner e
+ where
+ tick_it = allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0
+ dont_tick_it = addTickLHsExprNever e
+
+-- version of addTick that does not actually add a tick,
+-- because the scope of this tick is completely subsumed by
+-- another.
+addTickLHsExprNever :: LHsExpr Id -> TM (LHsExpr Id)
+addTickLHsExprNever (L pos e0) = do
+ e1 <- addTickHsExpr e0
+ return $ L pos e1
+
+-- general heuristic: expressions which do not denote values are good
+-- break points
+isGoodBreakExpr :: HsExpr Id -> Bool
+isGoodBreakExpr (HsApp {}) = True
+isGoodBreakExpr (HsAppTypeOut {}) = True
+isGoodBreakExpr (OpApp {}) = True
+isGoodBreakExpr _other = False
+
+isCallSite :: HsExpr Id -> Bool
+isCallSite HsApp{} = True
+isCallSite HsAppTypeOut{} = True
+isCallSite OpApp{} = True
+isCallSite _ = False
+
+addTickLHsExprOptAlt :: Bool -> LHsExpr Id -> TM (LHsExpr Id)
+addTickLHsExprOptAlt oneOfMany (L pos e0)
+ = ifDensity TickForCoverage
+ (allocTickBox (ExpBox oneOfMany) False False pos $ addTickHsExpr e0)
+ (addTickLHsExpr (L pos e0))
+
+addBinTickLHsExpr :: (Bool -> BoxLabel) -> LHsExpr Id -> TM (LHsExpr Id)
+addBinTickLHsExpr boxLabel (L pos e0)
+ = ifDensity TickForCoverage
+ (allocBinTickBox boxLabel pos $ addTickHsExpr e0)
+ (addTickLHsExpr (L pos e0))
+
+
+-- -----------------------------------------------------------------------------
+-- Decorate the body of an HsExpr with ticks.
+-- (Whether to put a tick around the whole expression was already decided,
+-- in the addTickLHsExpr family of functions.)
+
+addTickHsExpr :: HsExpr Id -> TM (HsExpr Id)
+addTickHsExpr e@(HsVar (L _ id)) = do freeVar id; return e
+addTickHsExpr (HsUnboundVar {}) = panic "addTickHsExpr.HsUnboundVar"
+addTickHsExpr e@(HsConLikeOut con)
+ | Just id <- conLikeWrapId_maybe con = do freeVar id; return e
+addTickHsExpr e@(HsIPVar _) = return e
+addTickHsExpr e@(HsOverLit _) = return e
+addTickHsExpr e@(HsOverLabel{}) = return e
+addTickHsExpr e@(HsLit _) = return e
+addTickHsExpr (HsLam matchgroup) = liftM HsLam (addTickMatchGroup True matchgroup)
+addTickHsExpr (HsLamCase mgs) = liftM HsLamCase (addTickMatchGroup True mgs)
+addTickHsExpr (HsApp e1 e2) = liftM2 HsApp (addTickLHsExprNever e1)
+ (addTickLHsExpr e2)
+addTickHsExpr (HsAppTypeOut e ty) = liftM2 HsAppTypeOut (addTickLHsExprNever e)
+ (return ty)
+
+addTickHsExpr (OpApp e1 e2 fix e3) =
+ liftM4 OpApp
+ (addTickLHsExpr e1)
+ (addTickLHsExprNever e2)
+ (return fix)
+ (addTickLHsExpr e3)
+addTickHsExpr (NegApp e neg) =
+ liftM2 NegApp
+ (addTickLHsExpr e)
+ (addTickSyntaxExpr hpcSrcSpan neg)
+addTickHsExpr (HsPar e) =
+ liftM HsPar (addTickLHsExprEvalInner e)
+addTickHsExpr (SectionL e1 e2) =
+ liftM2 SectionL
+ (addTickLHsExpr e1)
+ (addTickLHsExprNever e2)
+addTickHsExpr (SectionR e1 e2) =
+ liftM2 SectionR
+ (addTickLHsExprNever e1)
+ (addTickLHsExpr e2)
+addTickHsExpr (ExplicitTuple es boxity) =
+ liftM2 ExplicitTuple
+ (mapM addTickTupArg es)
+ (return boxity)
+addTickHsExpr (ExplicitSum tag arity e ty) = do
+ e' <- addTickLHsExpr e
+ return (ExplicitSum tag arity e' ty)
+addTickHsExpr (HsCase e mgs) =
+ liftM2 HsCase
+ (addTickLHsExpr e) -- not an EvalInner; e might not necessarily
+ -- be evaluated.
+ (addTickMatchGroup False mgs)
+addTickHsExpr (HsIf cnd e1 e2 e3) =
+ liftM3 (HsIf cnd)
+ (addBinTickLHsExpr (BinBox CondBinBox) e1)
+ (addTickLHsExprOptAlt True e2)
+ (addTickLHsExprOptAlt True e3)
+addTickHsExpr (HsMultiIf ty alts)
+ = do { let isOneOfMany = case alts of [_] -> False; _ -> True
+ ; alts' <- mapM (liftL $ addTickGRHS isOneOfMany False) alts
+ ; return $ HsMultiIf ty alts' }
+addTickHsExpr (HsLet (L l binds) e) =
+ bindLocals (collectLocalBinders binds) $
+ liftM2 (HsLet . L l)
+ (addTickHsLocalBinds binds) -- to think about: !patterns.
+ (addTickLHsExprLetBody e)
+addTickHsExpr (HsDo cxt (L l stmts) srcloc)
+ = do { (stmts', _) <- addTickLStmts' forQual stmts (return ())
+ ; return (HsDo cxt (L l stmts') srcloc) }
+ where
+ forQual = case cxt of
+ ListComp -> Just $ BinBox QualBinBox
+ _ -> Nothing
+addTickHsExpr (ExplicitList ty wit es) =
+ liftM3 ExplicitList
+ (return ty)
+ (addTickWit wit)
+ (mapM (addTickLHsExpr) es)
+ where addTickWit Nothing = return Nothing
+ addTickWit (Just fln)
+ = do fln' <- addTickSyntaxExpr hpcSrcSpan fln
+ return (Just fln')
+addTickHsExpr (ExplicitPArr ty es) =
+ liftM2 ExplicitPArr
+ (return ty)
+ (mapM (addTickLHsExpr) es)
+
+addTickHsExpr (HsStatic fvs e) = HsStatic fvs <$> addTickLHsExpr e
+
+addTickHsExpr expr@(RecordCon { rcon_flds = rec_binds })
+ = do { rec_binds' <- addTickHsRecordBinds rec_binds
+ ; return (expr { rcon_flds = rec_binds' }) }
+
+addTickHsExpr expr@(RecordUpd { rupd_expr = e, rupd_flds = flds })
+ = do { e' <- addTickLHsExpr e
+ ; flds' <- mapM addTickHsRecField flds
+ ; return (expr { rupd_expr = e', rupd_flds = flds' }) }
+
+addTickHsExpr (ExprWithTySig e ty) =
+ liftM2 ExprWithTySig
+ (addTickLHsExprNever e) -- No need to tick the inner expression
+ -- for expressions with signatures
+ (return ty)
+addTickHsExpr (ArithSeq ty wit arith_seq) =
+ liftM3 ArithSeq
+ (return ty)
+ (addTickWit wit)
+ (addTickArithSeqInfo arith_seq)
+ where addTickWit Nothing = return Nothing
+ addTickWit (Just fl) = do fl' <- addTickSyntaxExpr hpcSrcSpan fl
+ return (Just fl')
+
+-- We might encounter existing ticks (multiple Coverage passes)
+addTickHsExpr (HsTick t e) =
+ liftM (HsTick t) (addTickLHsExprNever e)
+addTickHsExpr (HsBinTick t0 t1 e) =
+ liftM (HsBinTick t0 t1) (addTickLHsExprNever e)
+
+addTickHsExpr (HsTickPragma _ _ _ (L pos e0)) = do
+ e2 <- allocTickBox (ExpBox False) False False pos $
+ addTickHsExpr e0
+ return $ unLoc e2
+addTickHsExpr (PArrSeq ty arith_seq) =
+ liftM2 PArrSeq
+ (return ty)
+ (addTickArithSeqInfo arith_seq)
+addTickHsExpr (HsSCC src nm e) =
+ liftM3 HsSCC
+ (return src)
+ (return nm)
+ (addTickLHsExpr e)
+addTickHsExpr (HsCoreAnn src nm e) =
+ liftM3 HsCoreAnn
+ (return src)
+ (return nm)
+ (addTickLHsExpr e)
+addTickHsExpr e@(HsBracket {}) = return e
+addTickHsExpr e@(HsTcBracketOut {}) = return e
+addTickHsExpr e@(HsRnBracketOut {}) = return e
+addTickHsExpr e@(HsSpliceE {}) = return e
+addTickHsExpr (HsProc pat cmdtop) =
+ liftM2 HsProc
+ (addTickLPat pat)
+ (liftL (addTickHsCmdTop) cmdtop)
+addTickHsExpr (HsWrap w e) =
+ liftM2 HsWrap
+ (return w)
+ (addTickHsExpr e) -- Explicitly no tick on inside
+
+addTickHsExpr (ExprWithTySigOut e ty) =
+ liftM2 ExprWithTySigOut
+ (addTickLHsExprNever e) -- No need to tick the inner expression
+ (return ty) -- for expressions with signatures
+
+-- Others should never happen in expression content.
+addTickHsExpr e = pprPanic "addTickHsExpr" (ppr e)
+
+addTickTupArg :: LHsTupArg Id -> TM (LHsTupArg Id)
+addTickTupArg (L l (Present e)) = do { e' <- addTickLHsExpr e
+ ; return (L l (Present e')) }
+addTickTupArg (L l (Missing ty)) = return (L l (Missing ty))
+
+addTickMatchGroup :: Bool{-is lambda-} -> MatchGroup Id (LHsExpr Id) -> TM (MatchGroup Id (LHsExpr Id))
+addTickMatchGroup is_lam mg@(MG { mg_alts = L l matches }) = do
+ let isOneOfMany = matchesOneOfMany matches
+ matches' <- mapM (liftL (addTickMatch isOneOfMany is_lam)) matches
+ return $ mg { mg_alts = L l matches' }
+
+addTickMatch :: Bool -> Bool -> Match Id (LHsExpr Id) -> TM (Match Id (LHsExpr Id))
+addTickMatch isOneOfMany isLambda (Match mf pats opSig gRHSs) =
+ bindLocals (collectPatsBinders pats) $ do
+ gRHSs' <- addTickGRHSs isOneOfMany isLambda gRHSs
+ return $ Match mf pats opSig gRHSs'
+
+addTickGRHSs :: Bool -> Bool -> GRHSs Id (LHsExpr Id) -> TM (GRHSs Id (LHsExpr Id))
+addTickGRHSs isOneOfMany isLambda (GRHSs guarded (L l local_binds)) = do
+ bindLocals binders $ do
+ local_binds' <- addTickHsLocalBinds local_binds
+ guarded' <- mapM (liftL (addTickGRHS isOneOfMany isLambda)) guarded
+ return $ GRHSs guarded' (L l local_binds')
+ where
+ binders = collectLocalBinders local_binds
+
+addTickGRHS :: Bool -> Bool -> GRHS Id (LHsExpr Id) -> TM (GRHS Id (LHsExpr Id))
+addTickGRHS isOneOfMany isLambda (GRHS stmts expr) = do
+ (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox) stmts
+ (addTickGRHSBody isOneOfMany isLambda expr)
+ return $ GRHS stmts' expr'
+
+addTickGRHSBody :: Bool -> Bool -> LHsExpr Id -> TM (LHsExpr Id)
+addTickGRHSBody isOneOfMany isLambda expr@(L pos e0) = do
+ d <- getDensity
+ case d of
+ TickForCoverage -> addTickLHsExprOptAlt isOneOfMany expr
+ TickAllFunctions | isLambda ->
+ addPathEntry "\\" $
+ allocTickBox (ExpBox False) True{-count-} False{-not top-} pos $
+ addTickHsExpr e0
+ _otherwise ->
+ addTickLHsExprRHS expr
+
+addTickLStmts :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt Id] -> TM [ExprLStmt Id]
+addTickLStmts isGuard stmts = do
+ (stmts, _) <- addTickLStmts' isGuard stmts (return ())
+ return stmts
+
+addTickLStmts' :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt Id] -> TM a
+ -> TM ([ExprLStmt Id], a)
+addTickLStmts' isGuard lstmts res
+ = bindLocals (collectLStmtsBinders lstmts) $
+ do { lstmts' <- mapM (liftL (addTickStmt isGuard)) lstmts
+ ; a <- res
+ ; return (lstmts', a) }
+
+addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt Id (LHsExpr Id) -> TM (Stmt Id (LHsExpr Id))
+addTickStmt _isGuard (LastStmt e noret ret) = do
+ liftM3 LastStmt
+ (addTickLHsExpr e)
+ (pure noret)
+ (addTickSyntaxExpr hpcSrcSpan ret)
+addTickStmt _isGuard (BindStmt pat e bind fail ty) = do
+ liftM5 BindStmt
+ (addTickLPat pat)
+ (addTickLHsExprRHS e)
+ (addTickSyntaxExpr hpcSrcSpan bind)
+ (addTickSyntaxExpr hpcSrcSpan fail)
+ (return ty)
+addTickStmt isGuard (BodyStmt e bind' guard' ty) = do
+ liftM4 BodyStmt
+ (addTick isGuard e)
+ (addTickSyntaxExpr hpcSrcSpan bind')
+ (addTickSyntaxExpr hpcSrcSpan guard')
+ (return ty)
+addTickStmt _isGuard (LetStmt (L l binds)) = do
+ liftM (LetStmt . L l)
+ (addTickHsLocalBinds binds)
+addTickStmt isGuard (ParStmt pairs mzipExpr bindExpr ty) = do
+ liftM4 ParStmt
+ (mapM (addTickStmtAndBinders isGuard) pairs)
+ (unLoc <$> addTickLHsExpr (L hpcSrcSpan mzipExpr))
+ (addTickSyntaxExpr hpcSrcSpan bindExpr)
+ (return ty)
+addTickStmt isGuard (ApplicativeStmt args mb_join body_ty) = do
+ args' <- mapM (addTickApplicativeArg isGuard) args
+ return (ApplicativeStmt args' mb_join body_ty)
+
+addTickStmt isGuard stmt@(TransStmt { trS_stmts = stmts
+ , trS_by = by, trS_using = using
+ , trS_ret = returnExpr, trS_bind = bindExpr
+ , trS_fmap = liftMExpr }) = do
+ t_s <- addTickLStmts isGuard stmts
+ t_y <- fmapMaybeM addTickLHsExprRHS by
+ t_u <- addTickLHsExprRHS using
+ t_f <- addTickSyntaxExpr hpcSrcSpan returnExpr
+ t_b <- addTickSyntaxExpr hpcSrcSpan bindExpr
+ L _ t_m <- addTickLHsExpr (L hpcSrcSpan liftMExpr)
+ return $ stmt { trS_stmts = t_s, trS_by = t_y, trS_using = t_u
+ , trS_ret = t_f, trS_bind = t_b, trS_fmap = t_m }
+
+addTickStmt isGuard stmt@(RecStmt {})
+ = do { stmts' <- addTickLStmts isGuard (recS_stmts stmt)
+ ; ret' <- addTickSyntaxExpr hpcSrcSpan (recS_ret_fn stmt)
+ ; mfix' <- addTickSyntaxExpr hpcSrcSpan (recS_mfix_fn stmt)
+ ; bind' <- addTickSyntaxExpr hpcSrcSpan (recS_bind_fn stmt)
+ ; return (stmt { recS_stmts = stmts', recS_ret_fn = ret'
+ , recS_mfix_fn = mfix', recS_bind_fn = bind' }) }
+
+addTick :: Maybe (Bool -> BoxLabel) -> LHsExpr Id -> TM (LHsExpr Id)
+addTick isGuard e | Just fn <- isGuard = addBinTickLHsExpr fn e
+ | otherwise = addTickLHsExprRHS e
+
+addTickApplicativeArg
+ :: Maybe (Bool -> BoxLabel) -> (SyntaxExpr Id, ApplicativeArg Id Id)
+ -> TM (SyntaxExpr Id, ApplicativeArg Id Id)
+addTickApplicativeArg isGuard (op, arg) =
+ liftM2 (,) (addTickSyntaxExpr hpcSrcSpan op) (addTickArg arg)
+ where
+ addTickArg (ApplicativeArgOne pat expr) =
+ ApplicativeArgOne <$> addTickLPat pat <*> addTickLHsExpr expr
+ addTickArg (ApplicativeArgMany stmts ret pat) =
+ ApplicativeArgMany
+ <$> addTickLStmts isGuard stmts
+ <*> (unLoc <$> addTickLHsExpr (L hpcSrcSpan ret))
+ <*> addTickLPat pat
+
+addTickStmtAndBinders :: Maybe (Bool -> BoxLabel) -> ParStmtBlock Id Id
+ -> TM (ParStmtBlock Id Id)
+addTickStmtAndBinders isGuard (ParStmtBlock stmts ids returnExpr) =
+ liftM3 ParStmtBlock
+ (addTickLStmts isGuard stmts)
+ (return ids)
+ (addTickSyntaxExpr hpcSrcSpan returnExpr)
+
+addTickHsLocalBinds :: HsLocalBinds Id -> TM (HsLocalBinds Id)
+addTickHsLocalBinds (HsValBinds binds) =
+ liftM HsValBinds
+ (addTickHsValBinds binds)
+addTickHsLocalBinds (HsIPBinds binds) =
+ liftM HsIPBinds
+ (addTickHsIPBinds binds)
+addTickHsLocalBinds (EmptyLocalBinds) = return EmptyLocalBinds
+
+addTickHsValBinds :: HsValBindsLR Id a -> TM (HsValBindsLR Id b)
+addTickHsValBinds (ValBindsOut binds sigs) =
+ liftM2 ValBindsOut
+ (mapM (\ (rec,binds') ->
+ liftM2 (,)
+ (return rec)
+ (addTickLHsBinds binds'))
+ binds)
+ (return sigs)
+addTickHsValBinds _ = panic "addTickHsValBinds"
+
+addTickHsIPBinds :: HsIPBinds Id -> TM (HsIPBinds Id)
+addTickHsIPBinds (IPBinds ipbinds dictbinds) =
+ liftM2 IPBinds
+ (mapM (liftL (addTickIPBind)) ipbinds)
+ (return dictbinds)
+
+addTickIPBind :: IPBind Id -> TM (IPBind Id)
+addTickIPBind (IPBind nm e) =
+ liftM2 IPBind
+ (return nm)
+ (addTickLHsExpr e)
+
+-- There is no location here, so we might need to use a context location??
+addTickSyntaxExpr :: SrcSpan -> SyntaxExpr Id -> TM (SyntaxExpr Id)
+addTickSyntaxExpr pos syn@(SyntaxExpr { syn_expr = x }) = do
+ L _ x' <- addTickLHsExpr (L pos x)
+ return $ syn { syn_expr = x' }
+-- we do not walk into patterns.
+addTickLPat :: LPat Id -> TM (LPat Id)
+addTickLPat pat = return pat
+
+addTickHsCmdTop :: HsCmdTop Id -> TM (HsCmdTop Id)
+addTickHsCmdTop (HsCmdTop cmd tys ty syntaxtable) =
+ liftM4 HsCmdTop
+ (addTickLHsCmd cmd)
+ (return tys)
+ (return ty)
+ (return syntaxtable)
+
+addTickLHsCmd :: LHsCmd Id -> TM (LHsCmd Id)
+addTickLHsCmd (L pos c0) = do
+ c1 <- addTickHsCmd c0
+ return $ L pos c1
+
+addTickHsCmd :: HsCmd Id -> TM (HsCmd Id)
+addTickHsCmd (HsCmdLam matchgroup) =
+ liftM HsCmdLam (addTickCmdMatchGroup matchgroup)
+addTickHsCmd (HsCmdApp c e) =
+ liftM2 HsCmdApp (addTickLHsCmd c) (addTickLHsExpr e)
+{-
+addTickHsCmd (OpApp e1 c2 fix c3) =
+ liftM4 OpApp
+ (addTickLHsExpr e1)
+ (addTickLHsCmd c2)
+ (return fix)
+ (addTickLHsCmd c3)
+-}
+addTickHsCmd (HsCmdPar e) = liftM HsCmdPar (addTickLHsCmd e)
+addTickHsCmd (HsCmdCase e mgs) =
+ liftM2 HsCmdCase
+ (addTickLHsExpr e)
+ (addTickCmdMatchGroup mgs)
+addTickHsCmd (HsCmdIf cnd e1 c2 c3) =
+ liftM3 (HsCmdIf cnd)
+ (addBinTickLHsExpr (BinBox CondBinBox) e1)
+ (addTickLHsCmd c2)
+ (addTickLHsCmd c3)
+addTickHsCmd (HsCmdLet (L l binds) c) =
+ bindLocals (collectLocalBinders binds) $
+ liftM2 (HsCmdLet . L l)
+ (addTickHsLocalBinds binds) -- to think about: !patterns.
+ (addTickLHsCmd c)
+addTickHsCmd (HsCmdDo (L l stmts) srcloc)
+ = do { (stmts', _) <- addTickLCmdStmts' stmts (return ())
+ ; return (HsCmdDo (L l stmts') srcloc) }
+
+addTickHsCmd (HsCmdArrApp e1 e2 ty1 arr_ty lr) =
+ liftM5 HsCmdArrApp
+ (addTickLHsExpr e1)
+ (addTickLHsExpr e2)
+ (return ty1)
+ (return arr_ty)
+ (return lr)
+addTickHsCmd (HsCmdArrForm e f fix cmdtop) =
+ liftM4 HsCmdArrForm
+ (addTickLHsExpr e)
+ (return f)
+ (return fix)
+ (mapM (liftL (addTickHsCmdTop)) cmdtop)
+
+addTickHsCmd (HsCmdWrap w cmd)
+ = liftM2 HsCmdWrap (return w) (addTickHsCmd cmd)
+
+-- Others should never happen in a command context.
+--addTickHsCmd e = pprPanic "addTickHsCmd" (ppr e)
+
+addTickCmdMatchGroup :: MatchGroup Id (LHsCmd Id) -> TM (MatchGroup Id (LHsCmd Id))
+addTickCmdMatchGroup mg@(MG { mg_alts = L l matches }) = do
+ matches' <- mapM (liftL addTickCmdMatch) matches
+ return $ mg { mg_alts = L l matches' }
+
+addTickCmdMatch :: Match Id (LHsCmd Id) -> TM (Match Id (LHsCmd Id))
+addTickCmdMatch (Match mf pats opSig gRHSs) =
+ bindLocals (collectPatsBinders pats) $ do
+ gRHSs' <- addTickCmdGRHSs gRHSs
+ return $ Match mf pats opSig gRHSs'
+
+addTickCmdGRHSs :: GRHSs Id (LHsCmd Id) -> TM (GRHSs Id (LHsCmd Id))
+addTickCmdGRHSs (GRHSs guarded (L l local_binds)) = do
+ bindLocals binders $ do
+ local_binds' <- addTickHsLocalBinds local_binds
+ guarded' <- mapM (liftL addTickCmdGRHS) guarded
+ return $ GRHSs guarded' (L l local_binds')
+ where
+ binders = collectLocalBinders local_binds
+
+addTickCmdGRHS :: GRHS Id (LHsCmd Id) -> TM (GRHS Id (LHsCmd Id))
+-- The *guards* are *not* Cmds, although the body is
+-- C.f. addTickGRHS for the BinBox stuff
+addTickCmdGRHS (GRHS stmts cmd)
+ = do { (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox)
+ stmts (addTickLHsCmd cmd)
+ ; return $ GRHS stmts' expr' }
+
+addTickLCmdStmts :: [LStmt Id (LHsCmd Id)] -> TM [LStmt Id (LHsCmd Id)]
+addTickLCmdStmts stmts = do
+ (stmts, _) <- addTickLCmdStmts' stmts (return ())
+ return stmts
+
+addTickLCmdStmts' :: [LStmt Id (LHsCmd Id)] -> TM a -> TM ([LStmt Id (LHsCmd Id)], a)
+addTickLCmdStmts' lstmts res
+ = bindLocals binders $ do
+ lstmts' <- mapM (liftL addTickCmdStmt) lstmts
+ a <- res
+ return (lstmts', a)
+ where
+ binders = collectLStmtsBinders lstmts
+
+addTickCmdStmt :: Stmt Id (LHsCmd Id) -> TM (Stmt Id (LHsCmd Id))
+addTickCmdStmt (BindStmt pat c bind fail ty) = do
+ liftM5 BindStmt
+ (addTickLPat pat)
+ (addTickLHsCmd c)
+ (return bind)
+ (return fail)
+ (return ty)
+addTickCmdStmt (LastStmt c noret ret) = do
+ liftM3 LastStmt
+ (addTickLHsCmd c)
+ (pure noret)
+ (addTickSyntaxExpr hpcSrcSpan ret)
+addTickCmdStmt (BodyStmt c bind' guard' ty) = do
+ liftM4 BodyStmt
+ (addTickLHsCmd c)
+ (addTickSyntaxExpr hpcSrcSpan bind')
+ (addTickSyntaxExpr hpcSrcSpan guard')
+ (return ty)
+addTickCmdStmt (LetStmt (L l binds)) = do
+ liftM (LetStmt . L l)
+ (addTickHsLocalBinds binds)
+addTickCmdStmt stmt@(RecStmt {})
+ = do { stmts' <- addTickLCmdStmts (recS_stmts stmt)
+ ; ret' <- addTickSyntaxExpr hpcSrcSpan (recS_ret_fn stmt)
+ ; mfix' <- addTickSyntaxExpr hpcSrcSpan (recS_mfix_fn stmt)
+ ; bind' <- addTickSyntaxExpr hpcSrcSpan (recS_bind_fn stmt)
+ ; return (stmt { recS_stmts = stmts', recS_ret_fn = ret'
+ , recS_mfix_fn = mfix', recS_bind_fn = bind' }) }
+addTickCmdStmt ApplicativeStmt{} =
+ panic "ToDo: addTickCmdStmt ApplicativeLastStmt"
+
+-- Others should never happen in a command context.
+addTickCmdStmt stmt = pprPanic "addTickHsCmd" (ppr stmt)
+
+addTickHsRecordBinds :: HsRecordBinds Id -> TM (HsRecordBinds Id)
+addTickHsRecordBinds (HsRecFields fields dd)
+ = do { fields' <- mapM addTickHsRecField fields
+ ; return (HsRecFields fields' dd) }
+
+addTickHsRecField :: LHsRecField' id (LHsExpr Id) -> TM (LHsRecField' id (LHsExpr Id))
+addTickHsRecField (L l (HsRecField id expr pun))
+ = do { expr' <- addTickLHsExpr expr
+ ; return (L l (HsRecField id expr' pun)) }
+
+
+addTickArithSeqInfo :: ArithSeqInfo Id -> TM (ArithSeqInfo Id)
+addTickArithSeqInfo (From e1) =
+ liftM From
+ (addTickLHsExpr e1)
+addTickArithSeqInfo (FromThen e1 e2) =
+ liftM2 FromThen
+ (addTickLHsExpr e1)
+ (addTickLHsExpr e2)
+addTickArithSeqInfo (FromTo e1 e2) =
+ liftM2 FromTo
+ (addTickLHsExpr e1)
+ (addTickLHsExpr e2)
+addTickArithSeqInfo (FromThenTo e1 e2 e3) =
+ liftM3 FromThenTo
+ (addTickLHsExpr e1)
+ (addTickLHsExpr e2)
+ (addTickLHsExpr e3)
+
+liftL :: (Monad m) => (a -> m a) -> Located a -> m (Located a)
+liftL f (L loc a) = do
+ a' <- f a
+ return $ L loc a'
+
+data TickTransState = TT { tickBoxCount:: Int
+ , mixEntries :: [MixEntry_]
+ , uniqSupply :: UniqSupply
+ }
+
+data TickTransEnv = TTE { fileName :: FastString
+ , density :: TickDensity
+ , tte_dflags :: DynFlags
+ , exports :: NameSet
+ , inlines :: VarSet
+ , declPath :: [String]
+ , inScope :: VarSet
+ , blackList :: Map SrcSpan ()
+ , this_mod :: Module
+ , tickishType :: TickishType
+ }
+
+-- deriving Show
+
+data TickishType = ProfNotes | HpcTicks | Breakpoints | SourceNotes
+ deriving (Eq)
+
+coveragePasses :: DynFlags -> [TickishType]
+coveragePasses dflags =
+ ifa (hscTarget dflags == HscInterpreted) Breakpoints $
+ ifa (gopt Opt_Hpc dflags) HpcTicks $
+ ifa (gopt Opt_SccProfilingOn dflags &&
+ profAuto dflags /= NoProfAuto) ProfNotes $
+ ifa (debugLevel dflags > 0) SourceNotes []
+ where ifa f x xs | f = x:xs
+ | otherwise = xs
+
+-- | Tickishs that only make sense when their source code location
+-- refers to the current file. This might not always be true due to
+-- LINE pragmas in the code - which would confuse at least HPC.
+tickSameFileOnly :: TickishType -> Bool
+tickSameFileOnly HpcTicks = True
+tickSameFileOnly _other = False
+
+type FreeVars = OccEnv Id
+noFVs :: FreeVars
+noFVs = emptyOccEnv
+
+-- Note [freevars]
+-- For breakpoints we want to collect the free variables of an
+-- expression for pinning on the HsTick. We don't want to collect
+-- *all* free variables though: in particular there's no point pinning
+-- on free variables that are will otherwise be in scope at the GHCi
+-- prompt, which means all top-level bindings. Unfortunately detecting
+-- top-level bindings isn't easy (collectHsBindsBinders on the top-level
+-- bindings doesn't do it), so we keep track of a set of "in-scope"
+-- variables in addition to the free variables, and the former is used
+-- to filter additions to the latter. This gives us complete control
+-- over what free variables we track.
+
+data TM a = TM { unTM :: TickTransEnv -> TickTransState -> (a,FreeVars,TickTransState) }
+ -- a combination of a state monad (TickTransState) and a writer
+ -- monad (FreeVars).
+
+instance Functor TM where
+ fmap = liftM
+
+instance Applicative TM where
+ pure a = TM $ \ _env st -> (a,noFVs,st)
+ (<*>) = ap
+
+instance Monad TM where
+ (TM m) >>= k = TM $ \ env st ->
+ case m env st of
+ (r1,fv1,st1) ->
+ case unTM (k r1) env st1 of
+ (r2,fv2,st2) ->
+ (r2, fv1 `plusOccEnv` fv2, st2)
+
+instance HasDynFlags TM where
+ getDynFlags = TM $ \ env st -> (tte_dflags env, noFVs, st)
+
+instance MonadUnique TM where
+ getUniqueSupplyM = TM $ \_ st -> (uniqSupply st, noFVs, st)
+ getUniqueM = TM $ \_ st -> let (u, us') = takeUniqFromSupply (uniqSupply st)
+ in (u, noFVs, st { uniqSupply = us' })
+
+getState :: TM TickTransState
+getState = TM $ \ _ st -> (st, noFVs, st)
+
+setState :: (TickTransState -> TickTransState) -> TM ()
+setState f = TM $ \ _ st -> ((), noFVs, f st)
+
+getEnv :: TM TickTransEnv
+getEnv = TM $ \ env st -> (env, noFVs, st)
+
+withEnv :: (TickTransEnv -> TickTransEnv) -> TM a -> TM a
+withEnv f (TM m) = TM $ \ env st ->
+ case m (f env) st of
+ (a, fvs, st') -> (a, fvs, st')
+
+getDensity :: TM TickDensity
+getDensity = TM $ \env st -> (density env, noFVs, st)
+
+ifDensity :: TickDensity -> TM a -> TM a -> TM a
+ifDensity d th el = do d0 <- getDensity; if d == d0 then th else el
+
+getFreeVars :: TM a -> TM (FreeVars, a)
+getFreeVars (TM m)
+ = TM $ \ env st -> case m env st of (a, fv, st') -> ((fv,a), fv, st')
+
+freeVar :: Id -> TM ()
+freeVar id = TM $ \ env st ->
+ if id `elemVarSet` inScope env
+ then ((), unitOccEnv (nameOccName (idName id)) id, st)
+ else ((), noFVs, st)
+
+addPathEntry :: String -> TM a -> TM a
+addPathEntry nm = withEnv (\ env -> env { declPath = declPath env ++ [nm] })
+
+getPathEntry :: TM [String]
+getPathEntry = declPath `liftM` getEnv
+
+getFileName :: TM FastString
+getFileName = fileName `liftM` getEnv
+
+isGoodSrcSpan' :: SrcSpan -> Bool
+isGoodSrcSpan' pos@(RealSrcSpan _) = srcSpanStart pos /= srcSpanEnd pos
+isGoodSrcSpan' (UnhelpfulSpan _) = False
+
+isGoodTickSrcSpan :: SrcSpan -> TM Bool
+isGoodTickSrcSpan pos = do
+ file_name <- getFileName
+ tickish <- tickishType `liftM` getEnv
+ let need_same_file = tickSameFileOnly tickish
+ same_file = Just file_name == srcSpanFileName_maybe pos
+ return (isGoodSrcSpan' pos && (not need_same_file || same_file))
+
+ifGoodTickSrcSpan :: SrcSpan -> TM a -> TM a -> TM a
+ifGoodTickSrcSpan pos then_code else_code = do
+ good <- isGoodTickSrcSpan pos
+ if good then then_code else else_code
+
+bindLocals :: [Id] -> TM a -> TM a
+bindLocals new_ids (TM m)
+ = TM $ \ env st ->
+ case m env{ inScope = inScope env `extendVarSetList` new_ids } st of
+ (r, fv, st') -> (r, fv `delListFromOccEnv` occs, st')
+ where occs = [ nameOccName (idName id) | id <- new_ids ]
+
+isBlackListed :: SrcSpan -> TM Bool
+isBlackListed pos = TM $ \ env st ->
+ case Map.lookup pos (blackList env) of
+ Nothing -> (False,noFVs,st)
+ Just () -> (True,noFVs,st)
+
+-- the tick application inherits the source position of its
+-- expression argument to support nested box allocations
+allocTickBox :: BoxLabel -> Bool -> Bool -> SrcSpan -> TM (HsExpr Id)
+ -> TM (LHsExpr Id)
+allocTickBox boxLabel countEntries topOnly pos m =
+ ifGoodTickSrcSpan pos (do
+ (fvs, e) <- getFreeVars m
+ env <- getEnv
+ tickish <- mkTickish boxLabel countEntries topOnly pos fvs (declPath env)
+ return (L pos (HsTick tickish (L pos e)))
+ ) (do
+ e <- m
+ return (L pos e)
+ )
+
+-- the tick application inherits the source position of its
+-- expression argument to support nested box allocations
+allocATickBox :: BoxLabel -> Bool -> Bool -> SrcSpan -> FreeVars
+ -> TM (Maybe (Tickish Id))
+allocATickBox boxLabel countEntries topOnly pos fvs =
+ ifGoodTickSrcSpan pos (do
+ let
+ mydecl_path = case boxLabel of
+ TopLevelBox x -> x
+ LocalBox xs -> xs
+ _ -> panic "allocATickBox"
+ tickish <- mkTickish boxLabel countEntries topOnly pos fvs mydecl_path
+ return (Just tickish)
+ ) (return Nothing)
+
+
+mkTickish :: BoxLabel -> Bool -> Bool -> SrcSpan -> OccEnv Id -> [String]
+ -> TM (Tickish Id)
+mkTickish boxLabel countEntries topOnly pos fvs decl_path = do
+
+ let ids = filter (not . isUnliftedType . idType) $ occEnvElts fvs
+ -- unlifted types cause two problems here:
+ -- * we can't bind them at the GHCi prompt
+ -- (bindLocalsAtBreakpoint already fliters them out),
+ -- * the simplifier might try to substitute a literal for
+ -- the Id, and we can't handle that.
+
+ me = (pos, decl_path, map (nameOccName.idName) ids, boxLabel)
+
+ cc_name | topOnly = head decl_path
+ | otherwise = concat (intersperse "." decl_path)
+
+ dflags <- getDynFlags
+ env <- getEnv
+ case tickishType env of
+ HpcTicks -> do
+ c <- liftM tickBoxCount getState
+ setState $ \st -> st { tickBoxCount = c + 1
+ , mixEntries = me : mixEntries st }
+ return $ HpcTick (this_mod env) c
+
+ ProfNotes -> do
+ ccUnique <- getUniqueM
+ let cc = mkUserCC (mkFastString cc_name) (this_mod env) pos ccUnique
+ count = countEntries && gopt Opt_ProfCountEntries dflags
+ return $ ProfNote cc count True{-scopes-}
+
+ Breakpoints -> do
+ c <- liftM tickBoxCount getState
+ setState $ \st -> st { tickBoxCount = c + 1
+ , mixEntries = me:mixEntries st }
+ return $ Breakpoint c ids
+
+ SourceNotes | RealSrcSpan pos' <- pos ->
+ return $ SourceNote pos' cc_name
+
+ _otherwise -> panic "mkTickish: bad source span!"
+
+
+allocBinTickBox :: (Bool -> BoxLabel) -> SrcSpan -> TM (HsExpr Id)
+ -> TM (LHsExpr Id)
+allocBinTickBox boxLabel pos m = do
+ env <- getEnv
+ case tickishType env of
+ HpcTicks -> do e <- liftM (L pos) m
+ ifGoodTickSrcSpan pos
+ (mkBinTickBoxHpc boxLabel pos e)
+ (return e)
+ _other -> allocTickBox (ExpBox False) False False pos m
+
+mkBinTickBoxHpc :: (Bool -> BoxLabel) -> SrcSpan -> LHsExpr Id
+ -> TM (LHsExpr Id)
+mkBinTickBoxHpc boxLabel pos e =
+ TM $ \ env st ->
+ let meT = (pos,declPath env, [],boxLabel True)
+ meF = (pos,declPath env, [],boxLabel False)
+ meE = (pos,declPath env, [],ExpBox False)
+ c = tickBoxCount st
+ mes = mixEntries st
+ in
+ ( L pos $ HsTick (HpcTick (this_mod env) c) $ L pos $ HsBinTick (c+1) (c+2) e
+ -- notice that F and T are reversed,
+ -- because we are building the list in
+ -- reverse...
+ , noFVs
+ , st {tickBoxCount=c+3 , mixEntries=meF:meT:meE:mes}
+ )
+
+mkHpcPos :: SrcSpan -> HpcPos
+mkHpcPos pos@(RealSrcSpan s)
+ | isGoodSrcSpan' pos = toHpcPos (srcSpanStartLine s,
+ srcSpanStartCol s,
+ srcSpanEndLine s,
+ srcSpanEndCol s - 1)
+ -- the end column of a SrcSpan is one
+ -- greater than the last column of the
+ -- span (see SrcLoc), whereas HPC
+ -- expects to the column range to be
+ -- inclusive, hence we subtract one above.
+mkHpcPos _ = panic "bad source span; expected such spans to be filtered out"
+
+hpcSrcSpan :: SrcSpan
+hpcSrcSpan = mkGeneralSrcSpan (fsLit "Haskell Program Coverage internals")
+
+matchesOneOfMany :: [LMatch Id body] -> Bool
+matchesOneOfMany lmatches = sum (map matchCount lmatches) > 1
+ where
+ matchCount (L _ (Match _ _pats _ty (GRHSs grhss _binds))) = length grhss
+
+type MixEntry_ = (SrcSpan, [String], [OccName], BoxLabel)
+
+-- For the hash value, we hash everything: the file name,
+-- the timestamp of the original source file, the tab stop,
+-- and the mix entries. We cheat, and hash the show'd string.
+-- This hash only has to be hashed at Mix creation time,
+-- and is for sanity checking only.
+
+mixHash :: FilePath -> UTCTime -> Int -> [MixEntry] -> Int
+mixHash file tm tabstop entries = fromIntegral $ hashString
+ (show $ Mix file tm 0 tabstop entries)
+
+{-
+************************************************************************
+* *
+* initialisation
+* *
+************************************************************************
+
+Each module compiled with -fhpc declares an initialisation function of
+the form `hpc_init_()`, which is emitted into the _stub.c file
+and annotated with __attribute__((constructor)) so that it gets
+executed at startup time.
+
+The function's purpose is to call hs_hpc_module to register this
+module with the RTS, and it looks something like this:
+
+static void hpc_init_Main(void) __attribute__((constructor));
+static void hpc_init_Main(void)
+{extern StgWord64 _hpc_tickboxes_Main_hpc[];
+ hs_hpc_module("Main",8,1150288664,_hpc_tickboxes_Main_hpc);}
+-}
+
+hpcInitCode :: Module -> HpcInfo -> SDoc
+hpcInitCode _ (NoHpcInfo {}) = Outputable.empty
+hpcInitCode this_mod (HpcInfo tickCount hashNo)
+ = vcat
+ [ text "static void hpc_init_" <> ppr this_mod
+ <> text "(void) __attribute__((constructor));"
+ , text "static void hpc_init_" <> ppr this_mod <> text "(void)"
+ , braces (vcat [
+ text "extern StgWord64 " <> tickboxes <>
+ text "[]" <> semi,
+ text "hs_hpc_module" <>
+ parens (hcat (punctuate comma [
+ doubleQuotes full_name_str,
+ int tickCount, -- really StgWord32
+ int hashNo, -- really StgWord32
+ tickboxes
+ ])) <> semi
+ ])
+ ]
+ where
+ tickboxes = ppr (mkHpcTicksLabel $ this_mod)
+
+ module_name = hcat (map (text.charToC) $
+ bytesFS (moduleNameFS (Module.moduleName this_mod)))
+ package_name = hcat (map (text.charToC) $
+ bytesFS (unitIdFS (moduleUnitId this_mod)))
+ full_name_str
+ | moduleUnitId this_mod == mainUnitId
+ = module_name
+ | otherwise
+ = package_name <> char '/' <> module_name
diff --git a/deSugar/Desugar.hs b/deSugar/Desugar.hs
new file mode 100644
--- /dev/null
+++ b/deSugar/Desugar.hs
@@ -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)
diff --git a/deSugar/DsArrows.hs b/deSugar/DsArrows.hs
new file mode 100644
--- /dev/null
+++ b/deSugar/DsArrows.hs
@@ -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
diff --git a/deSugar/DsBinds.hs b/deSugar/DsBinds.hs
new file mode 100644
--- /dev/null
+++ b/deSugar/DsBinds.hs
@@ -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
+
+Without `Strict`, we get a translation like this:
+
+ let t = /\a. letrec tm = rhs[fm,gm]
+ fm = case t of fm:_ -> fm
+ gm = case t of _:gm -> gm
+ in
+ (fm,gm)
+
+ in let f = /\a. case t a of (fm,_) -> fm
+ in let g = /\a. case t a of (_,gm) -> gm
+ in
+
+Here `tm` is the monomorphic binding for `rhs`.
+
+With `Strict`, we want to force `tm`, but NOT `fm` or `gm`.
+Alas, `tm` isn't in scope in the `in ` part.
+
+The simplest thing is to return it in the polymorphic
+tuple `t`, thus:
+
+ let t = /\a. letrec tm = rhs[fm,gm]
+ fm = case t of fm:_ -> fm
+ gm = case t of _:gm -> gm
+ in
+ (tm, fm, gm)
+
+ in let f = /\a. case t a of (_,fm,_) -> fm
+ in let g = /\a. case t a of (_,_,gm) -> gm
+ in let tm = /\a. case t a of (tm,_,_) -> tm
+ in tm `seq`
+
+
+See https://ghc.haskell.org/trac/ghc/wiki/StrictPragma for a more
+detailed explanation of the desugaring of strict bindings.
+
+Note [Strict binds checks]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+There are several checks around properly formed strict bindings. They
+all link to this Note. These checks must be here in the desugarer because
+we cannot know whether or not a type is unlifted until after zonking, due
+to levity polymorphism. These checks all used to be handled in the typechecker
+in checkStrictBinds (before Jan '17).
+
+We define an "unlifted bind" to be any bind that binds an unlifted id. Note that
+
+ x :: Char
+ (# True, x #) = blah
+
+is *not* an unlifted bind. Unlifted binds are detected by HsUtils.isUnliftedHsBind.
+
+Define a "banged bind" to have a top-level bang. Detected by HsPat.isBangedPatBind.
+Define a "strict bind" to be either an unlifted bind or a banged bind.
+
+The restrictions are:
+ 1. Strict binds may not be top-level. Checked in dsTopLHsBinds.
+
+ 2. Unlifted binds must also be banged. (There is no trouble to compile an unbanged
+ unlifted bind, but an unbanged bind looks lazy, and we don't want users to be
+ surprised by the strictness of an unlifted bind.) Checked in first clause
+ of DsExpr.ds_val_bind.
+
+ 3. Unlifted binds may not have polymorphism (#6078). (That is, no quantified type
+ variables or constraints.) Checked in first clause
+ of DsExpr.ds_val_bind.
+
+ 4. Unlifted binds may not be recursive. Checked in second clause of ds_val_bind.
+
+-}
+
+------------------------
+dsSpecs :: CoreExpr -- Its rhs
+ -> TcSpecPrags
+ -> DsM ( OrdList (Id,CoreExpr) -- Binding for specialised Ids
+ , [CoreRule] ) -- Rules for the Global Ids
+-- See Note [Handling SPECIALISE pragmas] in TcBinds
+dsSpecs _ IsDefaultMethod = return (nilOL, [])
+dsSpecs poly_rhs (SpecPrags sps)
+ = do { pairs <- mapMaybeM (dsSpec (Just poly_rhs)) sps
+ ; let (spec_binds_s, rules) = unzip pairs
+ ; return (concatOL spec_binds_s, rules) }
+
+dsSpec :: Maybe CoreExpr -- Just rhs => RULE is for a local binding
+ -- Nothing => RULE is for an imported Id
+ -- rhs is in the Id's unfolding
+ -> Located TcSpecPrag
+ -> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule))
+dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
+ | isJust (isClassOpId_maybe poly_id)
+ = putSrcSpanDs loc $
+ do { warnDs NoReason (text "Ignoring useless SPECIALISE pragma for class method selector"
+ <+> quotes (ppr poly_id))
+ ; return Nothing } -- There is no point in trying to specialise a class op
+ -- Moreover, classops don't (currently) have an inl_sat arity set
+ -- (it would be Just 0) and that in turn makes makeCorePair bleat
+
+ | no_act_spec && isNeverActive rule_act
+ = putSrcSpanDs loc $
+ do { warnDs NoReason (text "Ignoring useless SPECIALISE pragma for NOINLINE function:"
+ <+> quotes (ppr poly_id))
+ ; return Nothing } -- Function is NOINLINE, and the specialiation inherits that
+ -- See Note [Activation pragmas for SPECIALISE]
+
+ | otherwise
+ = putSrcSpanDs loc $
+ do { uniq <- newUnique
+ ; let poly_name = idName poly_id
+ spec_occ = mkSpecOcc (getOccName poly_name)
+ spec_name = mkInternalName uniq spec_occ (getSrcSpan poly_name)
+ (spec_bndrs, spec_app) = collectHsWrapBinders spec_co
+ -- spec_co looks like
+ -- \spec_bndrs. [] spec_args
+ -- perhaps with the body of the lambda wrapped in some WpLets
+ -- E.g. /\a \(d:Eq a). let d2 = $df d in [] (Maybe a) d2
+
+ ; core_app <- dsHsWrapper spec_app
+
+ ; let ds_lhs = core_app (Var poly_id)
+ spec_ty = mkLamTypes spec_bndrs (exprType ds_lhs)
+ ; -- pprTrace "dsRule" (vcat [ text "Id:" <+> ppr poly_id
+ -- , text "spec_co:" <+> ppr spec_co
+ -- , text "ds_rhs:" <+> ppr ds_lhs ]) $
+ case decomposeRuleLhs spec_bndrs ds_lhs of {
+ Left msg -> do { warnDs NoReason msg; return Nothing } ;
+ Right (rule_bndrs, _fn, args) -> do
+
+ { dflags <- getDynFlags
+ ; this_mod <- getModule
+ ; let fn_unf = realIdUnfolding poly_id
+ spec_unf = specUnfolding spec_bndrs core_app arity_decrease fn_unf
+ spec_id = mkLocalId spec_name spec_ty
+ `setInlinePragma` inl_prag
+ `setIdUnfolding` spec_unf
+ arity_decrease = count isValArg args - count isId spec_bndrs
+
+ ; rule <- dsMkUserRule this_mod is_local_id
+ (mkFastString ("SPEC " ++ showPpr dflags poly_name))
+ rule_act poly_name
+ rule_bndrs args
+ (mkVarApps (Var spec_id) spec_bndrs)
+
+ ; let spec_rhs = mkLams spec_bndrs (core_app poly_rhs)
+
+-- Commented out: see Note [SPECIALISE on INLINE functions]
+-- ; when (isInlinePragma id_inl)
+-- (warnDs $ text "SPECIALISE pragma on INLINE function probably won't fire:"
+-- <+> quotes (ppr poly_name))
+
+ ; return (Just (unitOL (spec_id, spec_rhs), rule))
+ -- NB: do *not* use makeCorePair on (spec_id,spec_rhs), because
+ -- makeCorePair overwrites the unfolding, which we have
+ -- just created using specUnfolding
+ } } }
+ where
+ is_local_id = isJust mb_poly_rhs
+ poly_rhs | Just rhs <- mb_poly_rhs
+ = rhs -- Local Id; this is its rhs
+ | Just unfolding <- maybeUnfoldingTemplate (realIdUnfolding poly_id)
+ = unfolding -- Imported Id; this is its unfolding
+ -- Use realIdUnfolding so we get the unfolding
+ -- even when it is a loop breaker.
+ -- We want to specialise recursive functions!
+ | otherwise = pprPanic "dsImpSpecs" (ppr poly_id)
+ -- The type checker has checked that it *has* an unfolding
+
+ id_inl = idInlinePragma poly_id
+
+ -- See Note [Activation pragmas for SPECIALISE]
+ inl_prag | not (isDefaultInlinePragma spec_inl) = spec_inl
+ | not is_local_id -- See Note [Specialising imported functions]
+ -- in OccurAnal
+ , isStrongLoopBreaker (idOccInfo poly_id) = neverInlinePragma
+ | otherwise = id_inl
+ -- Get the INLINE pragma from SPECIALISE declaration, or,
+ -- failing that, from the original Id
+
+ spec_prag_act = inlinePragmaActivation spec_inl
+
+ -- See Note [Activation pragmas for SPECIALISE]
+ -- no_act_spec is True if the user didn't write an explicit
+ -- phase specification in the SPECIALISE pragma
+ no_act_spec = case inlinePragmaSpec spec_inl of
+ NoInline -> isNeverActive spec_prag_act
+ _ -> isAlwaysActive spec_prag_act
+ rule_act | no_act_spec = inlinePragmaActivation id_inl -- Inherit
+ | otherwise = spec_prag_act -- Specified by user
+
+
+dsMkUserRule :: Module -> Bool -> RuleName -> Activation
+ -> Name -> [CoreBndr] -> [CoreExpr] -> CoreExpr -> DsM CoreRule
+dsMkUserRule this_mod is_local name act fn bndrs args rhs = do
+ let rule = mkRule this_mod False is_local name act fn bndrs args rhs
+ dflags <- getDynFlags
+ when (isOrphan (ru_orphan rule) && wopt Opt_WarnOrphans dflags) $
+ warnDs (Reason Opt_WarnOrphans) (ruleOrphWarn rule)
+ return rule
+
+ruleOrphWarn :: CoreRule -> SDoc
+ruleOrphWarn rule = text "Orphan rule:" <+> ppr rule
+
+{- Note [SPECIALISE on INLINE functions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We used to warn that using SPECIALISE for a function marked INLINE
+would be a no-op; but it isn't! Especially with worker/wrapper split
+we might have
+ {-# INLINE f #-}
+ f :: Ord a => Int -> a -> ...
+ f d x y = case x of I# x' -> $wf d x' y
+
+We might want to specialise 'f' so that we in turn specialise '$wf'.
+We can't even /name/ '$wf' in the source code, so we can't specialise
+it even if we wanted to. Trac #10721 is a case in point.
+
+Note [Activation pragmas for SPECIALISE]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+From a user SPECIALISE pragma for f, we generate
+ a) A top-level binding spec_fn = rhs
+ b) A RULE f dOrd = spec_fn
+
+We need two pragma-like things:
+
+* spec_fn's inline pragma: inherited from f's inline pragma (ignoring
+ activation on SPEC), unless overriden by SPEC INLINE
+
+* Activation of RULE: from SPECIALISE pragma (if activation given)
+ otherwise from f's inline pragma
+
+This is not obvious (see Trac #5237)!
+
+Examples Rule activation Inline prag on spec'd fn
+---------------------------------------------------------------------
+SPEC [n] f :: ty [n] Always, or NOINLINE [n]
+ copy f's prag
+
+NOINLINE f
+SPEC [n] f :: ty [n] NOINLINE
+ copy f's prag
+
+NOINLINE [k] f
+SPEC [n] f :: ty [n] NOINLINE [k]
+ copy f's prag
+
+INLINE [k] f
+SPEC [n] f :: ty [n] INLINE [k]
+ copy f's prag
+
+SPEC INLINE [n] f :: ty [n] INLINE [n]
+ (ignore INLINE prag on f,
+ same activation for rule and spec'd fn)
+
+NOINLINE [k] f
+SPEC f :: ty [n] INLINE [k]
+
+
+************************************************************************
+* *
+\subsection{Adding inline pragmas}
+* *
+************************************************************************
+-}
+
+decomposeRuleLhs :: [Var] -> CoreExpr -> Either SDoc ([Var], Id, [CoreExpr])
+-- (decomposeRuleLhs bndrs lhs) takes apart the LHS of a RULE,
+-- The 'bndrs' are the quantified binders of the rules, but decomposeRuleLhs
+-- may add some extra dictionary binders (see Note [Free dictionaries])
+--
+-- Returns an error message if the LHS isn't of the expected shape
+-- Note [Decomposing the left-hand side of a RULE]
+decomposeRuleLhs orig_bndrs orig_lhs
+ | not (null unbound) -- Check for things unbound on LHS
+ -- See Note [Unused spec binders]
+ = Left (vcat (map dead_msg unbound))
+ | Var funId <- fun2
+ , Just con <- isDataConId_maybe funId
+ = Left (constructor_msg con) -- See Note [No RULES on datacons]
+ | Just (fn_id, args) <- decompose fun2 args2
+ , let extra_bndrs = mk_extra_bndrs fn_id args
+ = -- pprTrace "decmposeRuleLhs" (vcat [ text "orig_bndrs:" <+> ppr orig_bndrs
+ -- , text "orig_lhs:" <+> ppr orig_lhs
+ -- , text "lhs1:" <+> ppr lhs1
+ -- , text "extra_dict_bndrs:" <+> ppr extra_dict_bndrs
+ -- , text "fn_id:" <+> ppr fn_id
+ -- , text "args:" <+> ppr args]) $
+ Right (orig_bndrs ++ extra_bndrs, fn_id, args)
+
+ | otherwise
+ = Left bad_shape_msg
+ where
+ lhs1 = drop_dicts orig_lhs
+ lhs2 = simpleOptExpr lhs1 -- See Note [Simplify rule LHS]
+ (fun2,args2) = collectArgs lhs2
+
+ lhs_fvs = exprFreeVars lhs2
+ unbound = filterOut (`elemVarSet` lhs_fvs) orig_bndrs
+
+ orig_bndr_set = mkVarSet orig_bndrs
+
+ -- Add extra tyvar binders: Note [Free tyvars in rule LHS]
+ -- and extra dict binders: Note [Free dictionaries in rule LHS]
+ mk_extra_bndrs fn_id args
+ = toposortTyVars unbound_tvs ++ unbound_dicts
+ where
+ unbound_tvs = [ v | v <- unbound_vars, isTyVar v ]
+ unbound_dicts = [ mkLocalId (localiseName (idName d)) (idType d)
+ | d <- unbound_vars, isDictId d ]
+ unbound_vars = [ v | v <- exprsFreeVarsList args
+ , not (v `elemVarSet` orig_bndr_set)
+ , not (v == fn_id) ]
+ -- fn_id: do not quantify over the function itself, which may
+ -- itself be a dictionary (in pathological cases, Trac #10251)
+
+ decompose (Var fn_id) args
+ | not (fn_id `elemVarSet` orig_bndr_set)
+ = Just (fn_id, args)
+
+ decompose _ _ = Nothing
+
+ bad_shape_msg = hang (text "RULE left-hand side too complicated to desugar")
+ 2 (vcat [ text "Optimised lhs:" <+> ppr lhs2
+ , text "Orig lhs:" <+> ppr orig_lhs])
+ dead_msg bndr = hang (sep [ text "Forall'd" <+> pp_bndr bndr
+ , text "is not bound in RULE lhs"])
+ 2 (vcat [ text "Orig bndrs:" <+> ppr orig_bndrs
+ , text "Orig lhs:" <+> ppr orig_lhs
+ , text "optimised lhs:" <+> ppr lhs2 ])
+ pp_bndr bndr
+ | isTyVar bndr = text "type variable" <+> quotes (ppr bndr)
+ | Just pred <- evVarPred_maybe bndr = text "constraint" <+> quotes (ppr pred)
+ | otherwise = text "variable" <+> quotes (ppr bndr)
+
+ constructor_msg con = vcat
+ [ text "A constructor," <+> ppr con <>
+ text ", appears as outermost match in RULE lhs."
+ , text "This rule will be ignored." ]
+
+ drop_dicts :: CoreExpr -> CoreExpr
+ drop_dicts e
+ = wrap_lets needed bnds body
+ where
+ needed = orig_bndr_set `minusVarSet` exprFreeVars body
+ (bnds, body) = split_lets (occurAnalyseExpr e)
+ -- The occurAnalyseExpr drops dead bindings which is
+ -- crucial to ensure that every binding is used later;
+ -- which in turn makes wrap_lets work right
+
+ split_lets :: CoreExpr -> ([(DictId,CoreExpr)], CoreExpr)
+ split_lets (Let (NonRec d r) body)
+ | isDictId d
+ = ((d,r):bs, body')
+ where (bs, body') = split_lets body
+
+ -- handle "unlifted lets" too, needed for "map/coerce"
+ split_lets (Case r d _ [(DEFAULT, _, body)])
+ | isCoVar d
+ = ((d,r):bs, body')
+ where (bs, body') = split_lets body
+
+ split_lets e = ([], e)
+
+ wrap_lets :: VarSet -> [(DictId,CoreExpr)] -> CoreExpr -> CoreExpr
+ wrap_lets _ [] body = body
+ wrap_lets needed ((d, r) : bs) body
+ | rhs_fvs `intersectsVarSet` needed = mkCoreLet (NonRec d r) (wrap_lets needed' bs body)
+ | otherwise = wrap_lets needed bs body
+ where
+ rhs_fvs = exprFreeVars r
+ needed' = (needed `minusVarSet` rhs_fvs) `extendVarSet` d
+
+{-
+Note [Decomposing the left-hand side of a RULE]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+There are several things going on here.
+* drop_dicts: see Note [Drop dictionary bindings on rule LHS]
+* simpleOptExpr: see Note [Simplify rule LHS]
+* extra_dict_bndrs: see Note [Free dictionaries]
+
+Note [Free tyvars on rule LHS]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+ data T a = C
+
+ foo :: T a -> Int
+ foo C = 1
+
+ {-# RULES "myrule" foo C = 1 #-}
+
+After type checking the LHS becomes (foo alpha (C alpha)), where alpha
+is an unbound meta-tyvar. The zonker in TcHsSyn is careful not to
+turn the free alpha into Any (as it usually does). Instead it turns it
+into a TyVar 'a'. See TcHsSyn Note [Zonking the LHS of a RULE].
+
+Now we must quantify over that 'a'. It's /really/ inconvenient to do that
+in the zonker, because the HsExpr data type is very large. But it's /easy/
+to do it here in the desugarer.
+
+Moreover, we have to do something rather similar for dictionaries;
+see Note [Free dictionaries on rule LHS]. So that's why we look for
+type variables free on the LHS, and quantify over them.
+
+Note [Free dictionaries on rule LHS]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When the LHS of a specialisation rule, (/\as\ds. f es) has a free dict,
+which is presumably in scope at the function definition site, we can quantify
+over it too. *Any* dict with that type will do.
+
+So for example when you have
+ f :: Eq a => a -> a
+ f =
+ ... SPECIALISE f :: Int -> Int ...
+
+Then we get the SpecPrag
+ SpecPrag (f Int dInt)
+
+And from that we want the rule
+
+ RULE forall dInt. f Int dInt = f_spec
+ f_spec = let f = in f Int dInt
+
+But be careful! That dInt might be GHC.Base.$fOrdInt, which is an External
+Name, and you can't bind them in a lambda or forall without getting things
+confused. Likewise it might have an InlineRule or something, which would be
+utterly bogus. So we really make a fresh Id, with the same unique and type
+as the old one, but with an Internal name and no IdInfo.
+
+Note [Drop dictionary bindings on rule LHS]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+drop_dicts drops dictionary bindings on the LHS where possible.
+ E.g. let d:Eq [Int] = $fEqList $fEqInt in f d
+ --> f d
+ Reasoning here is that there is only one d:Eq [Int], and so we can
+ quantify over it. That makes 'd' free in the LHS, but that is later
+ picked up by extra_dict_bndrs (Note [Dead spec binders]).
+
+ NB 1: We can only drop the binding if the RHS doesn't bind
+ one of the orig_bndrs, which we assume occur on RHS.
+ Example
+ f :: (Eq a) => b -> a -> a
+ {-# SPECIALISE f :: Eq a => b -> [a] -> [a] #-}
+ Here we want to end up with
+ RULE forall d:Eq a. f ($dfEqList d) = f_spec d
+ Of course, the ($dfEqlist d) in the pattern makes it less likely
+ to match, but there is no other way to get d:Eq a
+
+ NB 2: We do drop_dicts *before* simplOptEpxr, so that we expect all
+ the evidence bindings to be wrapped around the outside of the
+ LHS. (After simplOptExpr they'll usually have been inlined.)
+ dsHsWrapper does dependency analysis, so that civilised ones
+ will be simple NonRec bindings. We don't handle recursive
+ dictionaries!
+
+ NB3: In the common case of a non-overloaded, but perhaps-polymorphic
+ specialisation, we don't need to bind *any* dictionaries for use
+ in the RHS. For example (Trac #8331)
+ {-# SPECIALIZE INLINE useAbstractMonad :: ReaderST s Int #-}
+ useAbstractMonad :: MonadAbstractIOST m => m Int
+ Here, deriving (MonadAbstractIOST (ReaderST s)) is a lot of code
+ but the RHS uses no dictionaries, so we want to end up with
+ RULE forall s (d :: MonadAbstractIOST (ReaderT s)).
+ useAbstractMonad (ReaderT s) d = $suseAbstractMonad s
+
+ Trac #8848 is a good example of where there are some intersting
+ dictionary bindings to discard.
+
+The drop_dicts algorithm is based on these observations:
+
+ * Given (let d = rhs in e) where d is a DictId,
+ matching 'e' will bind e's free variables.
+
+ * So we want to keep the binding if one of the needed variables (for
+ which we need a binding) is in fv(rhs) but not already in fv(e).
+
+ * The "needed variables" are simply the orig_bndrs. Consider
+ f :: (Eq a, Show b) => a -> b -> String
+ ... SPECIALISE f :: (Show b) => Int -> b -> String ...
+ Then orig_bndrs includes the *quantified* dictionaries of the type
+ namely (dsb::Show b), but not the one for Eq Int
+
+So we work inside out, applying the above criterion at each step.
+
+
+Note [Simplify rule LHS]
+~~~~~~~~~~~~~~~~~~~~~~~~
+simplOptExpr occurrence-analyses and simplifies the LHS:
+
+ (a) Inline any remaining dictionary bindings (which hopefully
+ occur just once)
+
+ (b) Substitute trivial lets, so that they don't get in the way.
+ Note that we substitute the function too; we might
+ have this as a LHS: let f71 = M.f Int in f71
+
+ (c) Do eta reduction. To see why, consider the fold/build rule,
+ which without simplification looked like:
+ fold k z (build (/\a. g a)) ==> ...
+ This doesn't match unless you do eta reduction on the build argument.
+ Similarly for a LHS like
+ augment g (build h)
+ we do not want to get
+ augment (\a. g a) (build h)
+ otherwise we don't match when given an argument like
+ augment (\a. h a a) (build h)
+
+Note [Matching seqId]
+~~~~~~~~~~~~~~~~~~~
+The desugarer turns (seq e r) into (case e of _ -> r), via a special-case hack
+and this code turns it back into an application of seq!
+See Note [Rules for seq] in MkId for the details.
+
+Note [Unused spec binders]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+ f :: a -> a
+ ... SPECIALISE f :: Eq a => a -> a ...
+It's true that this *is* a more specialised type, but the rule
+we get is something like this:
+ f_spec d = f
+ RULE: f = f_spec d
+Note that the rule is bogus, because it mentions a 'd' that is
+not bound on the LHS! But it's a silly specialisation anyway, because
+the constraint is unused. We could bind 'd' to (error "unused")
+but it seems better to reject the program because it's almost certainly
+a mistake. That's what the isDeadBinder call detects.
+
+Note [No RULES on datacons]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Previously, `RULES` like
+
+ "JustNothing" forall x . Just x = Nothing
+
+were allowed. Simon Peyton Jones says this seems to have been a
+mistake, that such rules have never been supported intentionally,
+and that he doesn't know if they can break in horrible ways.
+Furthermore, Ben Gamari and Reid Barton are considering trying to
+detect the presence of "static data" that the simplifier doesn't
+need to traverse at all. Such rules do not play well with that.
+So for now, we ban them altogether as requested by #13290. See also #7398.
+
+
+************************************************************************
+* *
+ Desugaring evidence
+* *
+************************************************************************
+
+-}
+
+dsHsWrapper :: HsWrapper -> DsM (CoreExpr -> CoreExpr)
+dsHsWrapper WpHole = return $ \e -> e
+dsHsWrapper (WpTyApp ty) = return $ \e -> App e (Type ty)
+dsHsWrapper (WpEvLam ev) = return $ Lam ev
+dsHsWrapper (WpTyLam tv) = return $ Lam tv
+dsHsWrapper (WpLet ev_binds) = do { bs <- dsTcEvBinds ev_binds
+ ; return (mkCoreLets bs) }
+dsHsWrapper (WpCompose c1 c2) = do { w1 <- dsHsWrapper c1
+ ; w2 <- dsHsWrapper c2
+ ; return (w1 . w2) }
+ -- See comments on WpFun in TcEvidence for an explanation of what
+ -- the specification of this clause is
+dsHsWrapper (WpFun c1 c2 t1 doc)
+ = do { x <- newSysLocalDsNoLP t1
+ ; w1 <- dsHsWrapper c1
+ ; w2 <- dsHsWrapper c2
+ ; let app f a = mkCoreAppDs (text "dsHsWrapper") f a
+ arg = w1 (Var x)
+ ; (_, ok) <- askNoErrsDs $ dsNoLevPolyExpr arg doc
+ ; if ok
+ then return (\e -> (Lam x (w2 (app e arg))))
+ else return id } -- this return is irrelevant
+dsHsWrapper (WpCast co) = ASSERT(coercionRole co == Representational)
+ return $ \e -> mkCastDs e co
+dsHsWrapper (WpEvApp tm) = do { core_tm <- dsEvTerm tm
+ ; return (\e -> App e core_tm) }
+
+--------------------------------------
+dsTcEvBinds_s :: [TcEvBinds] -> DsM [CoreBind]
+dsTcEvBinds_s [] = return []
+dsTcEvBinds_s (b:rest) = ASSERT( null rest ) -- Zonker ensures null
+ dsTcEvBinds b
+
+dsTcEvBinds :: TcEvBinds -> DsM [CoreBind]
+dsTcEvBinds (TcEvBinds {}) = panic "dsEvBinds" -- Zonker has got rid of this
+dsTcEvBinds (EvBinds bs) = dsEvBinds bs
+
+dsEvBinds :: Bag EvBind -> DsM [CoreBind]
+dsEvBinds bs = mapM ds_scc (sccEvBinds bs)
+ where
+ ds_scc (AcyclicSCC (EvBind { eb_lhs = v, eb_rhs = r}))
+ = liftM (NonRec v) (dsEvTerm r)
+ ds_scc (CyclicSCC bs) = liftM Rec (mapM dsEvBind bs)
+
+dsEvBind :: EvBind -> DsM (Id, CoreExpr)
+dsEvBind (EvBind { eb_lhs = v, eb_rhs = r}) = liftM ((,) v) (dsEvTerm r)
+
+{-**********************************************************************
+* *
+ Desugaring EvTerms
+* *
+**********************************************************************-}
+
+dsEvTerm :: EvTerm -> DsM CoreExpr
+dsEvTerm (EvId v) = return (Var v)
+dsEvTerm (EvCallStack cs) = dsEvCallStack cs
+dsEvTerm (EvTypeable ty ev) = dsEvTypeable ty ev
+dsEvTerm (EvLit (EvNum n)) = mkNaturalExpr n
+dsEvTerm (EvLit (EvStr s)) = mkStringExprFS s
+
+dsEvTerm (EvCast tm co)
+ = do { tm' <- dsEvTerm tm
+ ; return $ mkCastDs tm' co }
+
+dsEvTerm (EvDFunApp df tys tms)
+ = do { tms' <- mapM dsEvTerm tms
+ ; return $ Var df `mkTyApps` tys `mkApps` tms' }
+ -- The use of mkApps here is OK vis-a-vis levity polymorphism because
+ -- the terms are always evidence variables with types of kind Constraint
+
+dsEvTerm (EvCoercion co) = return (Coercion co)
+dsEvTerm (EvSuperClass d n)
+ = do { d' <- dsEvTerm d
+ ; let (cls, tys) = getClassPredTys (exprType d')
+ sc_sel_id = classSCSelId cls n -- Zero-indexed
+ ; return $ Var sc_sel_id `mkTyApps` tys `App` d' }
+
+dsEvTerm (EvSelector sel_id tys tms)
+ = do { tms' <- mapM dsEvTerm tms
+ ; return $ Var sel_id `mkTyApps` tys `mkApps` tms' }
+
+dsEvTerm (EvDelayedError ty msg) = return $ dsEvDelayedError ty msg
+
+dsEvDelayedError :: Type -> FastString -> CoreExpr
+dsEvDelayedError ty msg
+ = Var errorId `mkTyApps` [getRuntimeRep "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
diff --git a/deSugar/DsCCall.hs b/deSugar/DsCCall.hs
new file mode 100644
--- /dev/null
+++ b/deSugar/DsCCall.hs
@@ -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# result# state#) -> (R# result#, realWorld#)
+\end{verbatim}
+-}
+
+dsCCall :: CLabelString -- C routine to invoke
+ -> [CoreExpr] -- Arguments (desugared)
+ -- Precondition: none have levity-polymorphic types
+ -> Safety -- Safety of the call
+ -> Type -- Type of the result: IO t
+ -> DsM CoreExpr -- Result, of type ???
+
+dsCCall lbl args may_gc result_ty
+ = do (unboxed_args, arg_wrappers) <- mapAndUnzipM unboxArg args
+ (ccall_result_ty, res_wrapper) <- boxResult result_ty
+ uniq <- newUnique
+ dflags <- getDynFlags
+ let
+ target = StaticTarget NoSourceText lbl Nothing True
+ the_fcall = CCall (CCallSpec target CCallConv may_gc)
+ the_prim_app = mkFCall dflags uniq the_fcall unboxed_args ccall_result_ty
+ return (foldr ($) (res_wrapper the_prim_app) arg_wrappers)
+
+mkFCall :: DynFlags -> Unique -> ForeignCall
+ -> [CoreExpr] -- Args
+ -> Type -- Result type
+ -> CoreExpr
+-- Construct the ccall. The only tricky bit is that the ccall Id should have
+-- no free vars, so if any of the arg tys do we must give it a polymorphic type.
+-- [I forget *why* it should have no free vars!]
+-- For example:
+-- mkCCall ... [s::StablePtr (a->b), x::Addr, c::Char]
+--
+-- Here we build a ccall thus
+-- (ccallid::(forall a b. StablePtr (a -> b) -> Addr -> Char -> IO Addr))
+-- a b s x c
+mkFCall dflags uniq the_fcall val_args res_ty
+ = ASSERT( all isTyVar tyvars ) -- this must be true because the type is top-level
+ mkApps (mkVarApps (Var the_fcall_id) tyvars) val_args
+ where
+ arg_tys = map exprType val_args
+ body_ty = (mkFunTys arg_tys res_ty)
+ tyvars = tyCoVarsOfTypeWellScoped body_ty
+ ty = mkInvForAllTys tyvars body_ty
+ the_fcall_id = mkFCallId dflags uniq the_fcall ty
+
+unboxArg :: CoreExpr -- The supplied argument, not levity-polymorphic
+ -> DsM (CoreExpr, -- To pass as the actual argument
+ CoreExpr -> CoreExpr -- Wrapper to unbox the arg
+ )
+-- Example: if the arg is e::Int, unboxArg will return
+-- (x#::Int#, \W. case x of I# x# -> W)
+-- where W is a CoreExpr that probably mentions x#
+
+-- always returns a non-levity-polymorphic expression
+
+unboxArg arg
+ -- Primtive types: nothing to unbox
+ | isPrimitiveType arg_ty
+ = return (arg, \body -> body)
+
+ -- Recursive newtypes
+ | Just(co, _rep_ty) <- topNormaliseNewType_maybe arg_ty
+ = unboxArg (mkCastDs arg co)
+
+ -- Booleans
+ | Just tc <- tyConAppTyCon_maybe arg_ty,
+ tc `hasKey` boolTyConKey
+ = do dflags <- getDynFlags
+ prim_arg <- newSysLocalDs intPrimTy
+ return (Var prim_arg,
+ \ body -> Case (mkWildCase arg arg_ty intPrimTy
+ [(DataAlt falseDataCon,[],mkIntLit dflags 0),
+ (DataAlt trueDataCon, [],mkIntLit dflags 1)])
+ -- In increasing tag order!
+ prim_arg
+ (exprType body)
+ [(DEFAULT,[],body)])
+
+ -- Data types with a single constructor, which has a single, primitive-typed arg
+ -- This deals with Int, Float etc; also Ptr, ForeignPtr
+ | is_product_type && data_con_arity == 1
+ = ASSERT2(isUnliftedType data_con_arg_ty1, pprType arg_ty)
+ -- Typechecker ensures this
+ do case_bndr <- newSysLocalDs arg_ty
+ prim_arg <- newSysLocalDs data_con_arg_ty1
+ return (Var prim_arg,
+ \ body -> Case arg case_bndr (exprType body) [(DataAlt data_con,[prim_arg],body)]
+ )
+
+ -- Byte-arrays, both mutable and otherwise; hack warning
+ -- We're looking for values of type ByteArray, MutableByteArray
+ -- data ByteArray ix = ByteArray ix ix ByteArray#
+ -- data MutableByteArray s ix = MutableByteArray ix ix (MutableByteArray# s)
+ | is_product_type &&
+ data_con_arity == 3 &&
+ isJust maybe_arg3_tycon &&
+ (arg3_tycon == byteArrayPrimTyCon ||
+ arg3_tycon == mutableByteArrayPrimTyCon)
+ = do case_bndr <- newSysLocalDs arg_ty
+ vars@[_l_var, _r_var, arr_cts_var] <- newSysLocalsDs data_con_arg_tys
+ return (Var arr_cts_var,
+ \ body -> Case arg case_bndr (exprType body) [(DataAlt data_con,vars,body)]
+ )
+
+ | otherwise
+ = do l <- getSrcSpanDs
+ pprPanic "unboxArg: " (ppr l <+> ppr arg_ty)
+ where
+ arg_ty = exprType arg
+ maybe_product_type = splitDataProductType_maybe arg_ty
+ is_product_type = isJust maybe_product_type
+ Just (_, _, data_con, data_con_arg_tys) = maybe_product_type
+ data_con_arity = dataConSourceArity data_con
+ (data_con_arg_ty1 : _) = data_con_arg_tys
+
+ (_ : _ : data_con_arg_ty3 : _) = data_con_arg_tys
+ maybe_arg3_tycon = tyConAppTyCon_maybe data_con_arg_ty3
+ Just arg3_tycon = maybe_arg3_tycon
+
+boxResult :: Type
+ -> DsM (Type, CoreExpr -> CoreExpr)
+
+-- Takes the result of the user-level ccall:
+-- either (IO t),
+-- or maybe just t for an side-effect-free call
+-- Returns a wrapper for the primitive ccall itself, along with the
+-- type of the result of the primitive ccall. This result type
+-- will be of the form
+-- State# RealWorld -> (# State# RealWorld, t' #)
+-- where t' is the unwrapped form of t. If t is simply (), then
+-- the result type will be
+-- State# RealWorld -> (# State# RealWorld #)
+
+boxResult result_ty
+ | Just (io_tycon, io_res_ty) <- tcSplitIOType_maybe result_ty
+ -- isIOType_maybe handles the case where the type is a
+ -- simple wrapping of IO. E.g.
+ -- newtype Wrap a = W (IO a)
+ -- No coercion necessary because its a non-recursive newtype
+ -- (If we wanted to handle a *recursive* newtype too, we'd need
+ -- another case, and a coercion.)
+ -- The result is IO t, so wrap the result in an IO constructor
+ = do { res <- resultWrapper io_res_ty
+ ; let extra_result_tys
+ = case res of
+ (Just ty,_)
+ | isUnboxedTupleType ty
+ -> let Just ls = tyConAppArgs_maybe ty in tail ls
+ _ -> []
+
+ return_result state anss
+ = mkCoreUbxTup
+ (realWorldStatePrimTy : io_res_ty : extra_result_tys)
+ (state : anss)
+
+ ; (ccall_res_ty, the_alt) <- mk_alt return_result res
+
+ ; state_id <- newSysLocalDs realWorldStatePrimTy
+ ; let io_data_con = head (tyConDataCons io_tycon)
+ toIOCon = dataConWrapId io_data_con
+
+ wrap the_call =
+ mkApps (Var toIOCon)
+ [ Type io_res_ty,
+ Lam state_id $
+ mkWildCase (App the_call (Var state_id))
+ ccall_res_ty
+ (coreAltType the_alt)
+ [the_alt]
+ ]
+
+ ; return (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap) }
+
+boxResult result_ty
+ = do -- It isn't IO, so do unsafePerformIO
+ -- It's not conveniently available, so we inline it
+ res <- resultWrapper result_ty
+ (ccall_res_ty, the_alt) <- mk_alt return_result res
+ let
+ wrap = \ the_call -> mkWildCase (App the_call (Var realWorldPrimId))
+ ccall_res_ty
+ (coreAltType the_alt)
+ [the_alt]
+ return (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap)
+ where
+ return_result _ [ans] = ans
+ return_result _ _ = panic "return_result: expected single result"
+
+
+mk_alt :: (Expr Var -> [Expr Var] -> Expr Var)
+ -> (Maybe Type, Expr Var -> Expr Var)
+ -> DsM (Type, (AltCon, [Id], Expr Var))
+mk_alt return_result (Nothing, wrap_result)
+ = do -- The ccall returns ()
+ state_id <- newSysLocalDs realWorldStatePrimTy
+ let
+ the_rhs = return_result (Var state_id)
+ [wrap_result (panic "boxResult")]
+
+ ccall_res_ty = mkTupleTy Unboxed [realWorldStatePrimTy]
+ the_alt = (DataAlt (tupleDataCon Unboxed 1), [state_id], the_rhs)
+
+ return (ccall_res_ty, the_alt)
+
+mk_alt return_result (Just prim_res_ty, wrap_result)
+ = -- The ccall returns a non-() value
+ ASSERT2( isPrimitiveType prim_res_ty, ppr prim_res_ty )
+ -- True because resultWrapper ensures it is so
+ do { result_id <- newSysLocalDs prim_res_ty
+ ; state_id <- newSysLocalDs realWorldStatePrimTy
+ ; let the_rhs = return_result (Var state_id)
+ [wrap_result (Var result_id)]
+ ccall_res_ty = mkTupleTy Unboxed [realWorldStatePrimTy, prim_res_ty]
+ the_alt = (DataAlt (tupleDataCon Unboxed 2), [state_id, result_id], the_rhs)
+ ; return (ccall_res_ty, the_alt) }
+
+
+resultWrapper :: Type
+ -> DsM (Maybe Type, -- Type of the expected result, if any
+ CoreExpr -> CoreExpr) -- Wrapper for the result
+-- resultWrapper deals with the result *value*
+-- E.g. foreign import foo :: Int -> IO T
+-- Then resultWrapper deals with marshalling the 'T' part
+-- So if resultWrapper ty = (Just ty_rep, marshal)
+-- then marshal (e :: ty_rep) :: ty
+-- That is, 'marshal' wrape the result returned by the foreign call,
+-- of type ty_rep, into the value Haskell expected, of type 'ty'
+--
+-- Invariant: ty_rep is always a primitive type
+-- i.e. (isPrimitiveType ty_rep) is True
+
+resultWrapper result_ty
+ -- Base case 1: primitive types
+ | isPrimitiveType result_ty
+ = return (Just result_ty, \e -> e)
+
+ -- Base case 2: the unit type ()
+ | Just (tc,_) <- maybe_tc_app
+ , tc `hasKey` unitTyConKey
+ = return (Nothing, \_ -> Var unitDataConId)
+
+ -- Base case 3: the boolean type
+ | Just (tc,_) <- maybe_tc_app
+ , tc `hasKey` boolTyConKey
+ = do { dflags <- getDynFlags
+ ; let marshal_bool e
+ = mkWildCase e intPrimTy boolTy
+ [ (DEFAULT ,[],Var trueDataConId )
+ , (LitAlt (mkMachInt dflags 0),[],Var falseDataConId)]
+ ; return (Just intPrimTy, marshal_bool) }
+
+ -- Newtypes
+ | Just (co, rep_ty) <- topNormaliseNewType_maybe result_ty
+ = do { (maybe_ty, wrapper) <- resultWrapper rep_ty
+ ; return (maybe_ty, \e -> mkCastDs (wrapper e) (mkSymCo co)) }
+
+ -- The type might contain foralls (eg. for dummy type arguments,
+ -- referring to 'Ptr a' is legal).
+ | Just (tyvar, rest) <- splitForAllTy_maybe result_ty
+ = do { (maybe_ty, wrapper) <- resultWrapper rest
+ ; return (maybe_ty, \e -> Lam tyvar (wrapper e)) }
+
+ -- Data types with a single constructor, which has a single arg
+ -- This includes types like Ptr and ForeignPtr
+ | Just (tycon, tycon_arg_tys) <- maybe_tc_app
+ , Just data_con <- isDataProductTyCon_maybe tycon -- One construtor, no existentials
+ , [unwrapped_res_ty] <- dataConInstOrigArgTys data_con tycon_arg_tys -- One argument
+ = do { dflags <- getDynFlags
+ ; (maybe_ty, wrapper) <- resultWrapper unwrapped_res_ty
+ ; let narrow_wrapper = maybeNarrow dflags tycon
+ marshal_con e = Var (dataConWrapId data_con)
+ `mkTyApps` tycon_arg_tys
+ `App` wrapper (narrow_wrapper e)
+ ; return (maybe_ty, marshal_con) }
+
+ | otherwise
+ = pprPanic "resultWrapper" (ppr result_ty)
+ where
+ maybe_tc_app = splitTyConApp_maybe result_ty
+
+-- When the result of a foreign call is smaller than the word size, we
+-- need to sign- or zero-extend the result up to the word size. The C
+-- standard appears to say that this is the responsibility of the
+-- caller, not the callee.
+
+maybeNarrow :: DynFlags -> TyCon -> (CoreExpr -> CoreExpr)
+maybeNarrow dflags tycon
+ | tycon `hasKey` int8TyConKey = \e -> App (Var (mkPrimOpId Narrow8IntOp)) e
+ | tycon `hasKey` int16TyConKey = \e -> App (Var (mkPrimOpId Narrow16IntOp)) e
+ | tycon `hasKey` int32TyConKey
+ && wORD_SIZE dflags > 4 = \e -> App (Var (mkPrimOpId Narrow32IntOp)) e
+
+ | tycon `hasKey` word8TyConKey = \e -> App (Var (mkPrimOpId Narrow8WordOp)) e
+ | tycon `hasKey` word16TyConKey = \e -> App (Var (mkPrimOpId Narrow16WordOp)) e
+ | tycon `hasKey` word32TyConKey
+ && wORD_SIZE dflags > 4 = \e -> App (Var (mkPrimOpId Narrow32WordOp)) e
+ | otherwise = id
diff --git a/deSugar/DsExpr.hs b/deSugar/DsExpr.hs
new file mode 100644
--- /dev/null
+++ b/deSugar/DsExpr.hs
@@ -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)
+ ]
diff --git a/deSugar/DsExpr.hs-boot b/deSugar/DsExpr.hs-boot
new file mode 100644
--- /dev/null
+++ b/deSugar/DsExpr.hs-boot
@@ -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
diff --git a/deSugar/DsForeign.hs b/deSugar/DsForeign.hs
new file mode 100644
--- /dev/null
+++ b/deSugar/DsForeign.hs
@@ -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'' 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"
diff --git a/deSugar/DsGRHSs.hs b/deSugar/DsGRHSs.hs
new file mode 100644
--- /dev/null
+++ b/deSugar/DsGRHSs.hs
@@ -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}
+-}
diff --git a/deSugar/DsListComp.hs b/deSugar/DsListComp.hs
new file mode 100644
--- /dev/null
+++ b/deSugar/DsListComp.hs
@@ -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 <> TE <>
+
+(Rule B)
+TQ << [ e | b , qs ] ++ L >> =
+ if TE << b >> then TQ << [ e | qs ] ++ L >> else TE << L >>
+
+(Rule A')
+TQ << [ e | p <- L1, qs ] ++ L2 >> =
+ letrec
+ h = \ u1 ->
+ case u1 of
+ [] -> TE << L2 >>
+ (u2 : u3) ->
+ (( \ TE << p >> -> ( TQ << [e | qs] ++ (h u3) >> )) u2)
+ [] (h u3)
+ in
+ h ( TE << L1 >> )
+
+"h", "u1", "u2", and "u3" are new variables.
+\end{verbatim}
+
+@deListComp@ is the TQ translation scheme. Roughly speaking, @dsExpr@
+is the TE translation scheme. Note that we carry around the @L@ list
+already desugared. @dsListComp@ does the top TE rule mentioned above.
+
+To the above, we add an additional rule to deal with parallel list
+comprehensions. The translation goes roughly as follows:
+ [ e | p1 <- e11, let v1 = e12, p2 <- e13
+ | q1 <- e21, let v2 = e22, q2 <- e23]
+ =>
+ [ e | ((x1, .., xn), (y1, ..., ym)) <-
+ zip [(x1,..,xn) | p1 <- e11, let v1 = e12, p2 <- e13]
+ [(y1,..,ym) | q1 <- e21, let v2 = e22, q2 <- e23]]
+where (x1, .., xn) are the variables bound in p1, v1, p2
+ (y1, .., ym) are the variables bound in q1, v2, q2
+
+In the translation below, the ParStmt branch translates each parallel branch
+into a sub-comprehension, and desugars each independently. The resulting lists
+are fed to a zip function, we create a binding for all the variables bound in all
+the comprehensions, and then we hand things off the the desugarer for bindings.
+The zip function is generated here a) because it's small, and b) because then we
+don't have to deal with arbitrary limits on the number of zip functions in the
+prelude, nor which library the zip function came from.
+The introduced tuples are Boxed, but only because I couldn't get it to work
+with the Unboxed variety.
+-}
+
+deListComp :: [ExprStmt Id] -> CoreExpr -> DsM CoreExpr
+
+deListComp [] _ = panic "deListComp"
+
+deListComp (LastStmt body _ _ : quals) list
+ = -- Figure 7.4, SLPJ, p 135, rule C above
+ ASSERT( null quals )
+ do { core_body <- dsLExpr body
+ ; return (mkConsExpr (exprType core_body) core_body list) }
+
+ -- Non-last: must be a guard
+deListComp (BodyStmt guard _ _ _ : quals) list = do -- rule B above
+ core_guard <- dsLExpr guard
+ core_rest <- deListComp quals list
+ return (mkIfThenElse core_guard core_rest list)
+
+-- [e | let B, qs] = let B in [e | qs]
+deListComp (LetStmt binds : quals) list = do
+ core_rest <- deListComp quals list
+ dsLocalBinds binds core_rest
+
+deListComp (stmt@(TransStmt {}) : quals) list = do
+ (inner_list_expr, pat) <- dsTransStmt stmt
+ deBindComp pat inner_list_expr quals list
+
+deListComp (BindStmt pat list1 _ _ _ : quals) core_list2 = do -- rule A' above
+ core_list1 <- dsLExprNoLP list1
+ deBindComp pat core_list1 quals core_list2
+
+deListComp (ParStmt stmtss_w_bndrs _ _ _ : quals) list
+ = do { exps_and_qual_tys <- mapM dsInnerListComp stmtss_w_bndrs
+ ; let (exps, qual_tys) = unzip exps_and_qual_tys
+
+ ; (zip_fn, zip_rhs) <- mkZipBind qual_tys
+
+ -- Deal with [e | pat <- zip l1 .. ln] in example above
+ ; deBindComp pat (Let (Rec [(zip_fn, zip_rhs)]) (mkApps (Var zip_fn) exps))
+ quals list }
+ where
+ bndrs_s = [bs | ParStmtBlock _ bs _ <- stmtss_w_bndrs]
+
+ -- pat is the pattern ((x1,..,xn), (y1,..,ym)) in the example above
+ pat = mkBigLHsPatTupId pats
+ pats = map mkBigLHsVarPatTupId bndrs_s
+
+deListComp (RecStmt {} : _) _ = panic "deListComp RecStmt"
+
+deListComp (ApplicativeStmt {} : _) _ =
+ panic "deListComp ApplicativeStmt"
+
+deBindComp :: OutPat Id
+ -> CoreExpr
+ -> [ExprStmt Id]
+ -> CoreExpr
+ -> DsM (Expr Id)
+deBindComp pat core_list1 quals core_list2 = do
+ let u3_ty@u1_ty = exprType core_list1 -- two names, same thing
+
+ -- u1_ty is a [alpha] type, and u2_ty = alpha
+ let u2_ty = hsLPatType pat
+
+ let res_ty = exprType core_list2
+ h_ty = u1_ty `mkFunTy` res_ty
+
+ -- no levity polymorphism here, as list comprehensions don't work
+ -- with RebindableSyntax. NB: These are *not* monad comps.
+ [h, u1, u2, u3] <- newSysLocalsDs [h_ty, u1_ty, u2_ty, u3_ty]
+
+ -- the "fail" value ...
+ let
+ core_fail = App (Var h) (Var u3)
+ letrec_body = App (Var h) core_list1
+
+ rest_expr <- deListComp quals core_fail
+ core_match <- matchSimply (Var u2) (StmtCtxt ListComp) pat rest_expr core_fail
+
+ let
+ rhs = Lam u1 $
+ Case (Var u1) u1 res_ty
+ [(DataAlt nilDataCon, [], core_list2),
+ (DataAlt consDataCon, [u2, u3], core_match)]
+ -- Increasing order of tag
+
+ return (Let (Rec [(h, rhs)]) letrec_body)
+
+{-
+************************************************************************
+* *
+\subsection[DsListComp-foldr-build]{Foldr/Build desugaring of list comprehensions}
+* *
+************************************************************************
+
+@dfListComp@ are the rules used with foldr/build turned on:
+
+\begin{verbatim}
+TE[ e | ] c n = c e n
+TE[ e | b , q ] c n = if b then TE[ e | q ] c n else n
+TE[ e | p <- l , q ] c n = let
+ f = \ x b -> case x of
+ p -> TE[ e | q ] c b
+ _ -> b
+ in
+ foldr f n l
+\end{verbatim}
+-}
+
+dfListComp :: Id -> Id -- 'c' and 'n'
+ -> [ExprStmt Id] -- the rest of the qual's
+ -> DsM CoreExpr
+
+dfListComp _ _ [] = panic "dfListComp"
+
+dfListComp c_id n_id (LastStmt body _ _ : quals)
+ = ASSERT( null quals )
+ do { core_body <- dsLExprNoLP body
+ ; return (mkApps (Var c_id) [core_body, Var n_id]) }
+
+ -- Non-last: must be a guard
+dfListComp c_id n_id (BodyStmt guard _ _ _ : quals) = do
+ core_guard <- dsLExpr guard
+ core_rest <- dfListComp c_id n_id quals
+ return (mkIfThenElse core_guard core_rest (Var n_id))
+
+dfListComp c_id n_id (LetStmt binds : quals) = do
+ -- new in 1.3, local bindings
+ core_rest <- dfListComp c_id n_id quals
+ dsLocalBinds binds core_rest
+
+dfListComp c_id n_id (stmt@(TransStmt {}) : quals) = do
+ (inner_list_expr, pat) <- dsTransStmt stmt
+ -- Anyway, we bind the newly grouped list via the generic binding function
+ dfBindComp c_id n_id (pat, inner_list_expr) quals
+
+dfListComp c_id n_id (BindStmt pat list1 _ _ _ : quals) = do
+ -- evaluate the two lists
+ core_list1 <- dsLExpr list1
+
+ -- Do the rest of the work in the generic binding builder
+ dfBindComp c_id n_id (pat, core_list1) quals
+
+dfListComp _ _ (ParStmt {} : _) = panic "dfListComp ParStmt"
+dfListComp _ _ (RecStmt {} : _) = panic "dfListComp RecStmt"
+dfListComp _ _ (ApplicativeStmt {} : _) =
+ panic "dfListComp ApplicativeStmt"
+
+dfBindComp :: Id -> Id -- 'c' and 'n'
+ -> (LPat Id, CoreExpr)
+ -> [ExprStmt Id] -- the rest of the qual's
+ -> DsM CoreExpr
+dfBindComp c_id n_id (pat, core_list1) quals = do
+ -- find the required type
+ let x_ty = hsLPatType pat
+ let b_ty = idType n_id
+
+ -- create some new local id's
+ b <- newSysLocalDs b_ty
+ x <- newSysLocalDs x_ty
+
+ -- build rest of the comprehesion
+ core_rest <- dfListComp c_id b quals
+
+ -- build the pattern match
+ core_expr <- matchSimply (Var x) (StmtCtxt ListComp)
+ pat core_rest (Var b)
+
+ -- now build the outermost foldr, and return
+ mkFoldrExpr x_ty b_ty (mkLams [x, b] core_expr) (Var n_id) core_list1
+
+{-
+************************************************************************
+* *
+\subsection[DsFunGeneration]{Generation of zip/unzip functions for use in desugaring}
+* *
+************************************************************************
+-}
+
+mkZipBind :: [Type] -> DsM (Id, CoreExpr)
+-- mkZipBind [t1, t2]
+-- = (zip, \as1:[t1] as2:[t2]
+-- -> case as1 of
+-- [] -> []
+-- (a1:as'1) -> case as2 of
+-- [] -> []
+-- (a2:as'2) -> (a1, a2) : zip as'1 as'2)]
+
+mkZipBind elt_tys = do
+ ass <- mapM newSysLocalDs elt_list_tys
+ as' <- mapM newSysLocalDs elt_tys
+ as's <- mapM newSysLocalDs elt_list_tys
+
+ zip_fn <- newSysLocalDs zip_fn_ty
+
+ let inner_rhs = mkConsExpr elt_tuple_ty
+ (mkBigCoreVarTup as')
+ (mkVarApps (Var zip_fn) as's)
+ zip_body = foldr mk_case inner_rhs (zip3 ass as' as's)
+
+ return (zip_fn, mkLams ass zip_body)
+ where
+ elt_list_tys = map mkListTy elt_tys
+ elt_tuple_ty = mkBigCoreTupTy elt_tys
+ elt_tuple_list_ty = mkListTy elt_tuple_ty
+
+ zip_fn_ty = mkFunTys elt_list_tys elt_tuple_list_ty
+
+ mk_case (as, a', as') rest
+ = Case (Var as) as elt_tuple_list_ty
+ [(DataAlt nilDataCon, [], mkNilExpr elt_tuple_ty),
+ (DataAlt consDataCon, [a', as'], rest)]
+ -- Increasing order of tag
+
+
+mkUnzipBind :: TransForm -> [Type] -> DsM (Maybe (Id, CoreExpr))
+-- mkUnzipBind [t1, t2]
+-- = (unzip, \ys :: [(t1, t2)] -> foldr (\ax :: (t1, t2) axs :: ([t1], [t2])
+-- -> case ax of
+-- (x1, x2) -> case axs of
+-- (xs1, xs2) -> (x1 : xs1, x2 : xs2))
+-- ([], [])
+-- ys)
+--
+-- We use foldr here in all cases, even if rules are turned off, because we may as well!
+mkUnzipBind ThenForm _
+ = return Nothing -- No unzipping for ThenForm
+mkUnzipBind _ elt_tys
+ = do { ax <- newSysLocalDs elt_tuple_ty
+ ; axs <- newSysLocalDs elt_list_tuple_ty
+ ; ys <- newSysLocalDs elt_tuple_list_ty
+ ; xs <- mapM newSysLocalDs elt_tys
+ ; xss <- mapM newSysLocalDs elt_list_tys
+
+ ; unzip_fn <- newSysLocalDs unzip_fn_ty
+
+ ; [us1, us2] <- sequence [newUniqueSupply, newUniqueSupply]
+
+ ; let nil_tuple = mkBigCoreTup (map mkNilExpr elt_tys)
+ concat_expressions = map mkConcatExpression (zip3 elt_tys (map Var xs) (map Var xss))
+ tupled_concat_expression = mkBigCoreTup concat_expressions
+
+ folder_body_inner_case = mkTupleCase us1 xss tupled_concat_expression axs (Var axs)
+ folder_body_outer_case = mkTupleCase us2 xs folder_body_inner_case ax (Var ax)
+ folder_body = mkLams [ax, axs] folder_body_outer_case
+
+ ; unzip_body <- mkFoldrExpr elt_tuple_ty elt_list_tuple_ty folder_body nil_tuple (Var ys)
+ ; return (Just (unzip_fn, mkLams [ys] unzip_body)) }
+ where
+ elt_tuple_ty = mkBigCoreTupTy elt_tys
+ elt_tuple_list_ty = mkListTy elt_tuple_ty
+ elt_list_tys = map mkListTy elt_tys
+ elt_list_tuple_ty = mkBigCoreTupTy elt_list_tys
+
+ unzip_fn_ty = elt_tuple_list_ty `mkFunTy` elt_list_tuple_ty
+
+ mkConcatExpression (list_element_ty, head, tail) = mkConsExpr list_element_ty head tail
+
+{-
+************************************************************************
+* *
+\subsection[DsPArrComp]{Desugaring of array comprehensions}
+* *
+************************************************************************
+-}
+
+-- entry point for desugaring a parallel array comprehension
+--
+-- [:e | qss:] = <<[:e | qss:]>> () [:():]
+--
+dsPArrComp :: [ExprStmt Id]
+ -> DsM CoreExpr
+
+-- Special case for parallel comprehension
+dsPArrComp (ParStmt qss _ _ _ : quals) = dePArrParComp qss quals
+
+-- Special case for simple generators:
+--
+-- <<[:e' | p <- e, qs:]>> = <<[: e' | qs :]>> p e
+--
+-- if matching again p cannot fail, or else
+--
+-- <<[:e' | p <- e, qs:]>> =
+-- <<[:e' | qs:]>> p (filterP (\x -> case x of {p -> True; _ -> False}) e)
+--
+dsPArrComp (BindStmt p e _ _ _ : qs) = do
+ filterP <- dsDPHBuiltin filterPVar
+ ce <- dsLExprNoLP e
+ let ety'ce = parrElemType ce
+ false = Var falseDataConId
+ true = Var trueDataConId
+ v <- newSysLocalDs ety'ce
+ pred <- matchSimply (Var v) (StmtCtxt PArrComp) p true false
+ let gen | isIrrefutableHsPat p = ce
+ | otherwise = mkApps (Var filterP) [Type ety'ce, mkLams [v] pred, ce]
+ dePArrComp qs p gen
+
+dsPArrComp qs = do -- no ParStmt in `qs'
+ sglP <- dsDPHBuiltin singletonPVar
+ let unitArray = mkApps (Var sglP) [Type unitTy, mkCoreTup []]
+ dePArrComp qs (noLoc $ WildPat unitTy) unitArray
+
+
+
+-- the work horse
+--
+dePArrComp :: [ExprStmt Id]
+ -> LPat Id -- the current generator pattern
+ -> CoreExpr -- the current generator expression
+ -> DsM CoreExpr
+
+dePArrComp [] _ _ = panic "dePArrComp"
+
+--
+-- <<[:e' | :]>> pa ea = mapP (\pa -> e') ea
+--
+dePArrComp (LastStmt e' _ _ : quals) pa cea
+ = ASSERT( null quals )
+ do { mapP <- dsDPHBuiltin mapPVar
+ ; let ty = parrElemType cea
+ ; (clam, ty'e') <- deLambda ty pa e'
+ ; return $ mkApps (Var mapP) [Type ty, Type ty'e', clam, cea] }
+--
+-- <<[:e' | b, qs:]>> pa ea = <<[:e' | qs:]>> pa (filterP (\pa -> b) ea)
+--
+dePArrComp (BodyStmt b _ _ _ : qs) pa cea = do
+ filterP <- dsDPHBuiltin filterPVar
+ let ty = parrElemType cea
+ (clam,_) <- deLambda ty pa b
+ dePArrComp qs pa (mkApps (Var filterP) [Type ty, clam, cea])
+
+--
+-- <<[:e' | p <- e, qs:]>> pa ea =
+-- let ef = \pa -> e
+-- in
+-- <<[:e' | qs:]>> (pa, p) (crossMap ea ef)
+--
+-- if matching again p cannot fail, or else
+--
+-- <<[:e' | p <- e, qs:]>> pa ea =
+-- let ef = \pa -> filterP (\x -> case x of {p -> True; _ -> False}) e
+-- in
+-- <<[:e' | qs:]>> (pa, p) (crossMapP ea ef)
+--
+dePArrComp (BindStmt p e _ _ _ : qs) pa cea = do
+ filterP <- dsDPHBuiltin filterPVar
+ crossMapP <- dsDPHBuiltin crossMapPVar
+ ce <- dsLExpr e
+ let ety'cea = parrElemType cea
+ ety'ce = parrElemType ce
+ false = Var falseDataConId
+ true = Var trueDataConId
+ v <- newSysLocalDs ety'ce
+ pred <- matchSimply (Var v) (StmtCtxt PArrComp) p true false
+ let cef | isIrrefutableHsPat p = ce
+ | otherwise = mkApps (Var filterP) [Type ety'ce, mkLams [v] pred, ce]
+ (clam, _) <- mkLambda ety'cea pa cef
+ let ety'cef = ety'ce -- filter doesn't change the element type
+ pa' = mkLHsPatTup [pa, p]
+
+ dePArrComp qs pa' (mkApps (Var crossMapP)
+ [Type ety'cea, Type ety'cef, cea, clam])
+--
+-- <<[:e' | let ds, qs:]>> pa ea =
+-- <<[:e' | qs:]>> (pa, (x_1, ..., x_n))
+-- (mapP (\v@pa -> let ds in (v, (x_1, ..., x_n))) ea)
+-- where
+-- {x_1, ..., x_n} = DV (ds) -- Defined Variables
+--
+dePArrComp (LetStmt lds@(L _ ds) : qs) pa cea = do
+ mapP <- dsDPHBuiltin mapPVar
+ let xs = collectLocalBinders ds
+ ty'cea = parrElemType cea
+ v <- newSysLocalDs ty'cea
+ clet <- dsLocalBinds lds (mkCoreTup (map Var xs))
+ let'v <- newSysLocalDs (exprType clet)
+ let projBody = mkCoreLet (NonRec let'v clet) $
+ mkCoreTup [Var v, Var let'v]
+ errTy = exprType projBody
+ errMsg = text "DsListComp.dePArrComp: internal error!"
+ cerr <- mkErrorAppDs pAT_ERROR_ID errTy errMsg
+ ccase <- matchSimply (Var v) (StmtCtxt PArrComp) pa projBody cerr
+ let pa' = mkLHsPatTup [pa, mkLHsPatTup (map nlVarPat xs)]
+ proj = mkLams [v] ccase
+ dePArrComp qs pa' (mkApps (Var mapP)
+ [Type ty'cea, Type errTy, proj, cea])
+--
+-- The parser guarantees that parallel comprehensions can only appear as
+-- singleton qualifier lists, which we already special case in the caller.
+-- So, encountering one here is a bug.
+--
+dePArrComp (ParStmt {} : _) _ _ =
+ panic "DsListComp.dePArrComp: malformed comprehension AST: ParStmt"
+dePArrComp (TransStmt {} : _) _ _ = panic "DsListComp.dePArrComp: TransStmt"
+dePArrComp (RecStmt {} : _) _ _ = panic "DsListComp.dePArrComp: RecStmt"
+dePArrComp (ApplicativeStmt {} : _) _ _ =
+ panic "DsListComp.dePArrComp: ApplicativeStmt"
+
+-- <<[:e' | qs | qss:]>> pa ea =
+-- <<[:e' | qss:]>> (pa, (x_1, ..., x_n))
+-- (zipP ea <<[:(x_1, ..., x_n) | qs:]>>)
+-- where
+-- {x_1, ..., x_n} = DV (qs)
+--
+dePArrParComp :: [ParStmtBlock Id Id] -> [ExprStmt Id] -> DsM CoreExpr
+dePArrParComp qss quals = do
+ (pQss, ceQss) <- deParStmt qss
+ dePArrComp quals pQss ceQss
+ where
+ deParStmt [] =
+ -- empty parallel statement lists have no source representation
+ panic "DsListComp.dePArrComp: Empty parallel list comprehension"
+ deParStmt (ParStmtBlock qs xs _:qss) = do -- first statement
+ let res_expr = mkLHsVarTuple xs
+ cqs <- dsPArrComp (map unLoc qs ++ [mkLastStmt res_expr])
+ parStmts qss (mkLHsVarPatTup xs) cqs
+ ---
+ parStmts [] pa cea = return (pa, cea)
+ parStmts (ParStmtBlock qs xs _:qss) pa cea = do -- subsequent statements (zip'ed)
+ zipP <- dsDPHBuiltin zipPVar
+ let pa' = mkLHsPatTup [pa, mkLHsVarPatTup xs]
+ ty'cea = parrElemType cea
+ res_expr = mkLHsVarTuple xs
+ cqs <- dsPArrComp (map unLoc qs ++ [mkLastStmt res_expr])
+ let ty'cqs = parrElemType cqs
+ cea' = mkApps (Var zipP) [Type ty'cea, Type ty'cqs, cea, cqs]
+ parStmts qss pa' cea'
+
+-- generate Core corresponding to `\p -> e'
+--
+deLambda :: Type -- type of the argument (not levity-polymorphic)
+ -> LPat Id -- argument pattern
+ -> LHsExpr Id -- body
+ -> DsM (CoreExpr, Type)
+deLambda ty p e =
+ mkLambda ty p =<< dsLExpr e
+
+-- generate Core for a lambda pattern match, where the body is already in Core
+--
+mkLambda :: Type -- type of the argument (not levity-polymorphic)
+ -> LPat Id -- argument pattern
+ -> CoreExpr -- desugared body
+ -> DsM (CoreExpr, Type)
+mkLambda ty p ce = do
+ v <- newSysLocalDs ty
+ let errMsg = text "DsListComp.deLambda: internal error!"
+ ce'ty = exprType ce
+ cerr <- mkErrorAppDs pAT_ERROR_ID ce'ty errMsg
+ res <- matchSimply (Var v) (StmtCtxt PArrComp) p ce cerr
+ return (mkLams [v] res, ce'ty)
+
+-- obtain the element type of the parallel array produced by the given Core
+-- expression
+--
+parrElemType :: CoreExpr -> Type
+parrElemType e =
+ case splitTyConApp_maybe (exprType e) of
+ Just (tycon, [ty]) | tycon == parrTyCon -> ty
+ _ -> panic
+ "DsListComp.parrElemType: not a parallel array type"
+
+-- Translation for monad comprehensions
+
+-- Entry point for monad comprehension desugaring
+dsMonadComp :: [ExprLStmt Id] -> DsM CoreExpr
+dsMonadComp stmts = dsMcStmts stmts
+
+dsMcStmts :: [ExprLStmt Id] -> DsM CoreExpr
+dsMcStmts [] = panic "dsMcStmts"
+dsMcStmts (L loc stmt : lstmts) = putSrcSpanDs loc (dsMcStmt stmt lstmts)
+
+---------------
+dsMcStmt :: ExprStmt Id -> [ExprLStmt Id] -> DsM CoreExpr
+
+dsMcStmt (LastStmt body _ ret_op) stmts
+ = ASSERT( null stmts )
+ do { body' <- dsLExpr body
+ ; dsSyntaxExpr ret_op [body'] }
+
+-- [ .. | let binds, stmts ]
+dsMcStmt (LetStmt binds) stmts
+ = do { rest <- dsMcStmts stmts
+ ; dsLocalBinds binds rest }
+
+-- [ .. | a <- m, stmts ]
+dsMcStmt (BindStmt pat rhs bind_op fail_op bind_ty) stmts
+ = do { rhs' <- dsLExpr rhs
+ ; dsMcBindStmt pat rhs' bind_op fail_op bind_ty stmts }
+
+-- Apply `guard` to the `exp` expression
+--
+-- [ .. | exp, stmts ]
+--
+dsMcStmt (BodyStmt exp then_exp guard_exp _) stmts
+ = do { exp' <- dsLExpr exp
+ ; rest <- dsMcStmts stmts
+ ; guard_exp' <- dsSyntaxExpr guard_exp [exp']
+ ; dsSyntaxExpr then_exp [guard_exp', rest] }
+
+-- Group statements desugar like this:
+--
+-- [| (q, then group by e using f); rest |]
+-- ---> f {qt} (\qv -> e) [| q; return qv |] >>= \ n_tup ->
+-- case unzip n_tup of qv' -> [| rest |]
+--
+-- where variables (v1:t1, ..., vk:tk) are bound by q
+-- qv = (v1, ..., vk)
+-- qt = (t1, ..., tk)
+-- (>>=) :: m2 a -> (a -> m3 b) -> m3 b
+-- f :: forall a. (a -> t) -> m1 a -> m2 (n a)
+-- n_tup :: n qt
+-- unzip :: n qt -> (n t1, ..., n tk) (needs Functor n)
+
+dsMcStmt (TransStmt { trS_stmts = stmts, trS_bndrs = bndrs
+ , trS_by = by, trS_using = using
+ , trS_ret = return_op, trS_bind = bind_op
+ , trS_bind_arg_ty = n_tup_ty' -- n (a,b,c)
+ , trS_fmap = fmap_op, trS_form = form }) stmts_rest
+ = do { let (from_bndrs, to_bndrs) = unzip bndrs
+
+ ; let from_bndr_tys = map idType from_bndrs -- Types ty
+
+
+ -- Desugar an inner comprehension which outputs a list of tuples of the "from" binders
+ ; expr' <- dsInnerMonadComp stmts from_bndrs return_op
+
+ -- Work out what arguments should be supplied to that expression: i.e. is an extraction
+ -- function required? If so, create that desugared function and add to arguments
+ ; usingExpr' <- dsLExpr using
+ ; usingArgs' <- case by of
+ Nothing -> return [expr']
+ Just by_e -> do { by_e' <- dsLExpr by_e
+ ; lam' <- matchTuple from_bndrs by_e'
+ ; return [lam', expr'] }
+
+ -- Generate the expressions to build the grouped list
+ -- Build a pattern that ensures the consumer binds into the NEW binders,
+ -- which hold monads rather than single values
+ ; let tup_n_ty' = mkBigCoreVarTupTy to_bndrs
+
+ ; body <- dsMcStmts stmts_rest
+ ; n_tup_var' <- newSysLocalDsNoLP n_tup_ty'
+ ; tup_n_var' <- newSysLocalDs tup_n_ty'
+ ; tup_n_expr' <- mkMcUnzipM form fmap_op n_tup_var' from_bndr_tys
+ ; us <- newUniqueSupply
+ ; let rhs' = mkApps usingExpr' usingArgs'
+ body' = mkTupleCase us to_bndrs body tup_n_var' tup_n_expr'
+
+ ; dsSyntaxExpr bind_op [rhs', Lam n_tup_var' body'] }
+
+-- Parallel statements. Use `Control.Monad.Zip.mzip` to zip parallel
+-- statements, for example:
+--
+-- [ body | qs1 | qs2 | qs3 ]
+-- -> [ body | (bndrs1, (bndrs2, bndrs3))
+-- <- [bndrs1 | qs1] `mzip` ([bndrs2 | qs2] `mzip` [bndrs3 | qs3]) ]
+--
+-- where `mzip` has type
+-- mzip :: forall a b. m a -> m b -> m (a,b)
+-- NB: we need a polymorphic mzip because we call it several times
+
+dsMcStmt (ParStmt blocks mzip_op bind_op bind_ty) stmts_rest
+ = do { exps_w_tys <- mapM ds_inner blocks -- Pairs (exp :: m ty, ty)
+ ; mzip_op' <- dsExpr mzip_op
+
+ ; let -- The pattern variables
+ pats = [ mkBigLHsVarPatTupId bs | ParStmtBlock _ bs _ <- blocks]
+ -- Pattern with tuples of variables
+ -- [v1,v2,v3] => (v1, (v2, v3))
+ pat = foldr1 (\p1 p2 -> mkLHsPatTup [p1, p2]) pats
+ (rhs, _) = foldr1 (\(e1,t1) (e2,t2) ->
+ (mkApps mzip_op' [Type t1, Type t2, e1, e2],
+ mkBoxedTupleTy [t1,t2]))
+ exps_w_tys
+
+ ; dsMcBindStmt pat rhs bind_op noSyntaxExpr bind_ty stmts_rest }
+ where
+ ds_inner (ParStmtBlock stmts bndrs return_op)
+ = do { exp <- dsInnerMonadComp stmts bndrs return_op
+ ; return (exp, mkBigCoreVarTupTy bndrs) }
+
+dsMcStmt stmt _ = pprPanic "dsMcStmt: unexpected stmt" (ppr stmt)
+
+
+matchTuple :: [Id] -> CoreExpr -> DsM CoreExpr
+-- (matchTuple [a,b,c] body)
+-- returns the Core term
+-- \x. case x of (a,b,c) -> body
+matchTuple ids body
+ = do { us <- newUniqueSupply
+ ; tup_id <- newSysLocalDs (mkBigCoreVarTupTy ids)
+ ; return (Lam tup_id $ mkTupleCase us ids body tup_id (Var tup_id)) }
+
+-- general `rhs' >>= \pat -> stmts` desugaring where `rhs'` is already a
+-- desugared `CoreExpr`
+dsMcBindStmt :: LPat Id
+ -> CoreExpr -- ^ the desugared rhs of the bind statement
+ -> SyntaxExpr Id
+ -> SyntaxExpr Id
+ -> Type -- ^ S in (>>=) :: Q -> (R -> S) -> T
+ -> [ExprLStmt Id]
+ -> DsM CoreExpr
+dsMcBindStmt pat rhs' bind_op fail_op res1_ty stmts
+ = do { body <- dsMcStmts stmts
+ ; var <- selectSimpleMatchVarL pat
+ ; match <- matchSinglePat (Var var) (StmtCtxt DoExpr) pat
+ res1_ty (cantFailMatchResult body)
+ ; match_code <- handle_failure pat match fail_op
+ ; dsSyntaxExpr bind_op [rhs', Lam var match_code] }
+
+ where
+ -- In a monad comprehension expression, pattern-match failure just calls
+ -- the monadic `fail` rather than throwing an exception
+ handle_failure pat match fail_op
+ | matchCanFail match
+ = do { dflags <- getDynFlags
+ ; fail_msg <- mkStringExpr (mk_fail_msg dflags pat)
+ ; fail_expr <- dsSyntaxExpr fail_op [fail_msg]
+ ; extractMatchResult match fail_expr }
+ | otherwise
+ = extractMatchResult match (error "It can't fail")
+
+ mk_fail_msg :: DynFlags -> Located e -> String
+ mk_fail_msg dflags pat
+ = "Pattern match failure in monad comprehension at " ++
+ showPpr dflags (getLoc pat)
+
+-- Desugar nested monad comprehensions, for example in `then..` constructs
+-- dsInnerMonadComp quals [a,b,c] ret_op
+-- returns the desugaring of
+-- [ (a,b,c) | quals ]
+
+dsInnerMonadComp :: [ExprLStmt Id]
+ -> [Id] -- Return a tuple of these variables
+ -> SyntaxExpr Id -- The monomorphic "return" operator
+ -> DsM CoreExpr
+dsInnerMonadComp stmts bndrs ret_op
+ = dsMcStmts (stmts ++ [noLoc (LastStmt (mkBigLHsVarTupId bndrs) False ret_op)])
+
+
+-- The `unzip` function for `GroupStmt` in a monad comprehensions
+--
+-- unzip :: m (a,b,..) -> (m a,m b,..)
+-- unzip m_tuple = ( liftM selN1 m_tuple
+-- , liftM selN2 m_tuple
+-- , .. )
+--
+-- mkMcUnzipM fmap ys [t1, t2]
+-- = ( fmap (selN1 :: (t1, t2) -> t1) ys
+-- , fmap (selN2 :: (t1, t2) -> t2) ys )
+
+mkMcUnzipM :: TransForm
+ -> HsExpr TcId -- fmap
+ -> Id -- Of type n (a,b,c)
+ -> [Type] -- [a,b,c] (not levity-polymorphic)
+ -> DsM CoreExpr -- Of type (n a, n b, n c)
+mkMcUnzipM ThenForm _ ys _
+ = return (Var ys) -- No unzipping to do
+
+mkMcUnzipM _ fmap_op ys elt_tys
+ = do { fmap_op' <- dsExpr fmap_op
+ ; xs <- mapM newSysLocalDs elt_tys
+ ; let tup_ty = mkBigCoreTupTy elt_tys
+ ; tup_xs <- newSysLocalDs tup_ty
+
+ ; let mk_elt i = mkApps fmap_op' -- fmap :: forall a b. (a -> b) -> n a -> n b
+ [ Type tup_ty, Type (getNth elt_tys i)
+ , mk_sel i, Var ys]
+
+ mk_sel n = Lam tup_xs $
+ mkTupleSelector xs (getNth xs n) tup_xs (Var tup_xs)
+
+ ; return (mkBigCoreTup (map mk_elt [0..length elt_tys - 1])) }
diff --git a/deSugar/DsMeta.hs b/deSugar/DsMeta.hs
new file mode 100644
--- /dev/null
+++ b/deSugar/DsMeta.hs
@@ -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 : form) for the associated entity
+--
+lookupLOcc :: Located Name -> DsM (Core TH.Name)
+-- Lookup an occurrence; it can't be a splice.
+-- Use the in-scope bindings if they exist
+lookupLOcc (L _ n) = lookupOcc n
+
+lookupOcc :: Name -> DsM (Core TH.Name)
+lookupOcc n
+ = do { mb_val <- dsLookupMetaEnv n ;
+ case mb_val of
+ Nothing -> globalVar n
+ Just (DsBound x) -> return (coreVar x)
+ Just (DsSplice _) -> pprPanic "repE:lookupOcc" (ppr n)
+ }
+
+globalVar :: Name -> DsM (Core TH.Name)
+-- Not bound by the meta-env
+-- Could be top-level; or could be local
+-- f x = $(g [| x |])
+-- Here the x will be local
+globalVar name
+ | isExternalName name
+ = do { MkC mod <- coreStringLit name_mod
+ ; MkC pkg <- coreStringLit name_pkg
+ ; MkC occ <- nameLit name
+ ; rep2 mk_varg [pkg,mod,occ] }
+ | otherwise
+ = do { MkC occ <- nameLit name
+ ; MkC uni <- coreIntLit (getKey (getUnique name))
+ ; rep2 mkNameLName [occ,uni] }
+ where
+ mod = ASSERT( isExternalName name) nameModule name
+ name_mod = moduleNameString (moduleName mod)
+ name_pkg = unitIdString (moduleUnitId mod)
+ name_occ = nameOccName name
+ mk_varg | OccName.isDataOcc name_occ = mkNameG_dName
+ | OccName.isVarOcc name_occ = mkNameG_vName
+ | OccName.isTcOcc name_occ = mkNameG_tcName
+ | otherwise = pprPanic "DsMeta.globalVar" (ppr name)
+
+lookupType :: Name -- Name of type constructor (e.g. TH.ExpQ)
+ -> DsM Type -- The type
+lookupType tc_name = do { tc <- dsLookupTyCon tc_name ;
+ return (mkTyConApp tc []) }
+
+wrapGenSyms :: [GenSymBind]
+ -> Core (TH.Q a) -> DsM (Core (TH.Q a))
+-- wrapGenSyms [(nm1,id1), (nm2,id2)] y
+-- --> bindQ (gensym nm1) (\ id1 ->
+-- bindQ (gensym nm2 (\ id2 ->
+-- y))
+
+wrapGenSyms binds body@(MkC b)
+ = do { var_ty <- lookupType nameTyConName
+ ; go var_ty binds }
+ where
+ [elt_ty] = tcTyConAppArgs (exprType b)
+ -- b :: Q a, so we can get the type 'a' by looking at the
+ -- argument type. NB: this relies on Q being a data/newtype,
+ -- not a type synonym
+
+ go _ [] = return body
+ go var_ty ((name,id) : binds)
+ = do { MkC body' <- go var_ty binds
+ ; lit_str <- nameLit name
+ ; gensym_app <- repGensym lit_str
+ ; repBindQ var_ty elt_ty
+ gensym_app (MkC (Lam id body')) }
+
+nameLit :: Name -> DsM (Core String)
+nameLit n = coreStringLit (occNameString (nameOccName n))
+
+occNameLit :: OccName -> DsM (Core String)
+occNameLit name = coreStringLit (occNameString name)
+
+
+-- %*********************************************************************
+-- %* *
+-- Constructing code
+-- %* *
+-- %*********************************************************************
+
+-----------------------------------------------------------------------------
+-- PHANTOM TYPES for consistency. In order to make sure we do this correct
+-- we invent a new datatype which uses phantom types.
+
+newtype Core a = MkC CoreExpr
+unC :: Core a -> CoreExpr
+unC (MkC x) = x
+
+rep2 :: Name -> [ CoreExpr ] -> DsM (Core a)
+rep2 n xs = do { id <- dsLookupGlobalId n
+ ; return (MkC (foldl App (Var id) xs)) }
+
+dataCon' :: Name -> [CoreExpr] -> DsM (Core a)
+dataCon' n args = do { id <- dsLookupDataCon n
+ ; return $ MkC $ mkCoreConApps id args }
+
+dataCon :: Name -> DsM (Core a)
+dataCon n = dataCon' n []
+
+
+-- %*********************************************************************
+-- %* *
+-- The 'smart constructors'
+-- %* *
+-- %*********************************************************************
+
+--------------- Patterns -----------------
+repPlit :: Core TH.Lit -> DsM (Core TH.PatQ)
+repPlit (MkC l) = rep2 litPName [l]
+
+repPvar :: Core TH.Name -> DsM (Core TH.PatQ)
+repPvar (MkC s) = rep2 varPName [s]
+
+repPtup :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
+repPtup (MkC ps) = rep2 tupPName [ps]
+
+repPunboxedTup :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
+repPunboxedTup (MkC ps) = rep2 unboxedTupPName [ps]
+
+repPunboxedSum :: Core TH.PatQ -> TH.SumAlt -> TH.SumArity -> DsM (Core TH.PatQ)
+-- Note: not Core TH.SumAlt or Core TH.SumArity; it's easier to be direct here
+repPunboxedSum (MkC p) alt arity
+ = do { dflags <- getDynFlags
+ ; rep2 unboxedSumPName [ p
+ , mkIntExprInt dflags alt
+ , mkIntExprInt dflags arity ] }
+
+repPcon :: Core TH.Name -> Core [TH.PatQ] -> DsM (Core TH.PatQ)
+repPcon (MkC s) (MkC ps) = rep2 conPName [s, ps]
+
+repPrec :: Core TH.Name -> Core [(TH.Name,TH.PatQ)] -> DsM (Core TH.PatQ)
+repPrec (MkC c) (MkC rps) = rep2 recPName [c,rps]
+
+repPinfix :: Core TH.PatQ -> Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ)
+repPinfix (MkC p1) (MkC n) (MkC p2) = rep2 infixPName [p1, n, p2]
+
+repPtilde :: Core TH.PatQ -> DsM (Core TH.PatQ)
+repPtilde (MkC p) = rep2 tildePName [p]
+
+repPbang :: Core TH.PatQ -> DsM (Core TH.PatQ)
+repPbang (MkC p) = rep2 bangPName [p]
+
+repPaspat :: Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ)
+repPaspat (MkC s) (MkC p) = rep2 asPName [s, p]
+
+repPwild :: DsM (Core TH.PatQ)
+repPwild = rep2 wildPName []
+
+repPlist :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
+repPlist (MkC ps) = rep2 listPName [ps]
+
+repPview :: Core TH.ExpQ -> Core TH.PatQ -> DsM (Core TH.PatQ)
+repPview (MkC e) (MkC p) = rep2 viewPName [e,p]
+
+repPsig :: Core TH.PatQ -> Core TH.TypeQ -> DsM (Core TH.PatQ)
+repPsig (MkC p) (MkC t) = rep2 sigPName [p, t]
+
+--------------- Expressions -----------------
+repVarOrCon :: Name -> Core TH.Name -> DsM (Core TH.ExpQ)
+repVarOrCon vc str | isDataOcc (nameOccName vc) = repCon str
+ | otherwise = repVar str
+
+repVar :: Core TH.Name -> DsM (Core TH.ExpQ)
+repVar (MkC s) = rep2 varEName [s]
+
+repCon :: Core TH.Name -> DsM (Core TH.ExpQ)
+repCon (MkC s) = rep2 conEName [s]
+
+repLit :: Core TH.Lit -> DsM (Core TH.ExpQ)
+repLit (MkC c) = rep2 litEName [c]
+
+repApp :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
+repApp (MkC x) (MkC y) = rep2 appEName [x,y]
+
+repAppType :: Core TH.ExpQ -> Core TH.TypeQ -> DsM (Core TH.ExpQ)
+repAppType (MkC x) (MkC y) = rep2 appTypeEName [x,y]
+
+repLam :: Core [TH.PatQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
+repLam (MkC ps) (MkC e) = rep2 lamEName [ps, e]
+
+repLamCase :: Core [TH.MatchQ] -> DsM (Core TH.ExpQ)
+repLamCase (MkC ms) = rep2 lamCaseEName [ms]
+
+repTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
+repTup (MkC es) = rep2 tupEName [es]
+
+repUnboxedTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
+repUnboxedTup (MkC es) = rep2 unboxedTupEName [es]
+
+repUnboxedSum :: Core TH.ExpQ -> TH.SumAlt -> TH.SumArity -> DsM (Core TH.ExpQ)
+-- Note: not Core TH.SumAlt or Core TH.SumArity; it's easier to be direct here
+repUnboxedSum (MkC e) alt arity
+ = do { dflags <- getDynFlags
+ ; rep2 unboxedSumEName [ e
+ , mkIntExprInt dflags alt
+ , mkIntExprInt dflags arity ] }
+
+repCond :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
+repCond (MkC x) (MkC y) (MkC z) = rep2 condEName [x,y,z]
+
+repMultiIf :: Core [TH.Q (TH.Guard, TH.Exp)] -> DsM (Core TH.ExpQ)
+repMultiIf (MkC alts) = rep2 multiIfEName [alts]
+
+repLetE :: Core [TH.DecQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
+repLetE (MkC ds) (MkC e) = rep2 letEName [ds, e]
+
+repCaseE :: Core TH.ExpQ -> Core [TH.MatchQ] -> DsM( Core TH.ExpQ)
+repCaseE (MkC e) (MkC ms) = rep2 caseEName [e, ms]
+
+repDoE :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)
+repDoE (MkC ss) = rep2 doEName [ss]
+
+repComp :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)
+repComp (MkC ss) = rep2 compEName [ss]
+
+repListExp :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
+repListExp (MkC es) = rep2 listEName [es]
+
+repSigExp :: Core TH.ExpQ -> Core TH.TypeQ -> DsM (Core TH.ExpQ)
+repSigExp (MkC e) (MkC t) = rep2 sigEName [e,t]
+
+repRecCon :: Core TH.Name -> Core [TH.Q TH.FieldExp]-> DsM (Core TH.ExpQ)
+repRecCon (MkC c) (MkC fs) = rep2 recConEName [c,fs]
+
+repRecUpd :: Core TH.ExpQ -> Core [TH.Q TH.FieldExp] -> DsM (Core TH.ExpQ)
+repRecUpd (MkC e) (MkC fs) = rep2 recUpdEName [e,fs]
+
+repFieldExp :: Core TH.Name -> Core TH.ExpQ -> DsM (Core (TH.Q TH.FieldExp))
+repFieldExp (MkC n) (MkC x) = rep2 fieldExpName [n,x]
+
+repInfixApp :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
+repInfixApp (MkC x) (MkC y) (MkC z) = rep2 infixAppName [x,y,z]
+
+repSectionL :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
+repSectionL (MkC x) (MkC y) = rep2 sectionLName [x,y]
+
+repSectionR :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
+repSectionR (MkC x) (MkC y) = rep2 sectionRName [x,y]
+
+------------ Right hand sides (guarded expressions) ----
+repGuarded :: Core [TH.Q (TH.Guard, TH.Exp)] -> DsM (Core TH.BodyQ)
+repGuarded (MkC pairs) = rep2 guardedBName [pairs]
+
+repNormal :: Core TH.ExpQ -> DsM (Core TH.BodyQ)
+repNormal (MkC e) = rep2 normalBName [e]
+
+------------ Guards ----
+repLNormalGE :: LHsExpr Name -> LHsExpr Name -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
+repLNormalGE g e = do g' <- repLE g
+ e' <- repLE e
+ repNormalGE g' e'
+
+repNormalGE :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
+repNormalGE (MkC g) (MkC e) = rep2 normalGEName [g, e]
+
+repPatGE :: Core [TH.StmtQ] -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
+repPatGE (MkC ss) (MkC e) = rep2 patGEName [ss, e]
+
+------------- Stmts -------------------
+repBindSt :: Core TH.PatQ -> Core TH.ExpQ -> DsM (Core TH.StmtQ)
+repBindSt (MkC p) (MkC e) = rep2 bindSName [p,e]
+
+repLetSt :: Core [TH.DecQ] -> DsM (Core TH.StmtQ)
+repLetSt (MkC ds) = rep2 letSName [ds]
+
+repNoBindSt :: Core TH.ExpQ -> DsM (Core TH.StmtQ)
+repNoBindSt (MkC e) = rep2 noBindSName [e]
+
+repParSt :: Core [[TH.StmtQ]] -> DsM (Core TH.StmtQ)
+repParSt (MkC sss) = rep2 parSName [sss]
+
+-------------- Range (Arithmetic sequences) -----------
+repFrom :: Core TH.ExpQ -> DsM (Core TH.ExpQ)
+repFrom (MkC x) = rep2 fromEName [x]
+
+repFromThen :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
+repFromThen (MkC x) (MkC y) = rep2 fromThenEName [x,y]
+
+repFromTo :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
+repFromTo (MkC x) (MkC y) = rep2 fromToEName [x,y]
+
+repFromThenTo :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
+repFromThenTo (MkC x) (MkC y) (MkC z) = rep2 fromThenToEName [x,y,z]
+
+------------ Match and Clause Tuples -----------
+repMatch :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.MatchQ)
+repMatch (MkC p) (MkC bod) (MkC ds) = rep2 matchName [p, bod, ds]
+
+repClause :: Core [TH.PatQ] -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.ClauseQ)
+repClause (MkC ps) (MkC bod) (MkC ds) = rep2 clauseName [ps, bod, ds]
+
+-------------- Dec -----------------------------
+repVal :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
+repVal (MkC p) (MkC b) (MkC ds) = rep2 valDName [p, b, ds]
+
+repFun :: Core TH.Name -> Core [TH.ClauseQ] -> DsM (Core TH.DecQ)
+repFun (MkC nm) (MkC b) = rep2 funDName [nm, b]
+
+repData :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr]
+ -> Maybe (Core [TH.TypeQ]) -> Core (Maybe TH.Kind)
+ -> Core [TH.ConQ] -> Core [TH.DerivClauseQ] -> DsM (Core TH.DecQ)
+repData (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC ksig) (MkC cons) (MkC derivs)
+ = rep2 dataDName [cxt, nm, tvs, ksig, cons, derivs]
+repData (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC ksig) (MkC cons)
+ (MkC derivs)
+ = rep2 dataInstDName [cxt, nm, tys, ksig, cons, derivs]
+
+repNewtype :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr]
+ -> Maybe (Core [TH.TypeQ]) -> Core (Maybe TH.Kind)
+ -> Core TH.ConQ -> Core [TH.DerivClauseQ] -> DsM (Core TH.DecQ)
+repNewtype (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC ksig) (MkC con)
+ (MkC derivs)
+ = rep2 newtypeDName [cxt, nm, tvs, ksig, con, derivs]
+repNewtype (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC ksig) (MkC con)
+ (MkC derivs)
+ = rep2 newtypeInstDName [cxt, nm, tys, ksig, con, derivs]
+
+repTySyn :: Core TH.Name -> Core [TH.TyVarBndr]
+ -> Core TH.TypeQ -> DsM (Core TH.DecQ)
+repTySyn (MkC nm) (MkC tvs) (MkC rhs)
+ = rep2 tySynDName [nm, tvs, rhs]
+
+repInst :: Core (Maybe TH.Overlap) ->
+ Core TH.CxtQ -> Core TH.TypeQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
+repInst (MkC o) (MkC cxt) (MkC ty) (MkC ds) = rep2 instanceWithOverlapDName
+ [o, cxt, ty, ds]
+
+repDerivStrategy :: Maybe (Located DerivStrategy)
+ -> DsM (Core (Maybe TH.DerivStrategy))
+repDerivStrategy mds =
+ case mds of
+ Nothing -> nothing
+ Just (L _ ds) ->
+ case ds of
+ StockStrategy -> just =<< dataCon stockStrategyDataConName
+ AnyclassStrategy -> just =<< dataCon anyclassStrategyDataConName
+ NewtypeStrategy -> just =<< dataCon newtypeStrategyDataConName
+ where
+ nothing = coreNothing derivStrategyTyConName
+ just = coreJust derivStrategyTyConName
+
+repOverlap :: Maybe OverlapMode -> DsM (Core (Maybe TH.Overlap))
+repOverlap mb =
+ case mb of
+ Nothing -> nothing
+ Just o ->
+ case o of
+ NoOverlap _ -> nothing
+ Overlappable _ -> just =<< dataCon overlappableDataConName
+ Overlapping _ -> just =<< dataCon overlappingDataConName
+ Overlaps _ -> just =<< dataCon overlapsDataConName
+ Incoherent _ -> just =<< dataCon incoherentDataConName
+ where
+ nothing = coreNothing overlapTyConName
+ just = coreJust overlapTyConName
+
+
+repClass :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr]
+ -> Core [TH.FunDep] -> Core [TH.DecQ]
+ -> DsM (Core TH.DecQ)
+repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC fds) (MkC ds)
+ = rep2 classDName [cxt, cls, tvs, fds, ds]
+
+repDeriv :: Core (Maybe TH.DerivStrategy)
+ -> Core TH.CxtQ -> Core TH.TypeQ
+ -> DsM (Core TH.DecQ)
+repDeriv (MkC ds) (MkC cxt) (MkC ty)
+ = rep2 standaloneDerivWithStrategyDName [ds, cxt, ty]
+
+repPragInl :: Core TH.Name -> Core TH.Inline -> Core TH.RuleMatch
+ -> Core TH.Phases -> DsM (Core TH.DecQ)
+repPragInl (MkC nm) (MkC inline) (MkC rm) (MkC phases)
+ = rep2 pragInlDName [nm, inline, rm, phases]
+
+repPragSpec :: Core TH.Name -> Core TH.TypeQ -> Core TH.Phases
+ -> DsM (Core TH.DecQ)
+repPragSpec (MkC nm) (MkC ty) (MkC phases)
+ = rep2 pragSpecDName [nm, ty, phases]
+
+repPragSpecInl :: Core TH.Name -> Core TH.TypeQ -> Core TH.Inline
+ -> Core TH.Phases -> DsM (Core TH.DecQ)
+repPragSpecInl (MkC nm) (MkC ty) (MkC inline) (MkC phases)
+ = rep2 pragSpecInlDName [nm, ty, inline, phases]
+
+repPragSpecInst :: Core TH.TypeQ -> DsM (Core TH.DecQ)
+repPragSpecInst (MkC ty) = rep2 pragSpecInstDName [ty]
+
+repPragComplete :: Core [TH.Name] -> Core (Maybe TH.Name) -> DsM (Core TH.DecQ)
+repPragComplete (MkC cls) (MkC mty) = rep2 pragCompleteDName [cls, mty]
+
+repPragRule :: Core String -> Core [TH.RuleBndrQ] -> Core TH.ExpQ
+ -> Core TH.ExpQ -> Core TH.Phases -> DsM (Core TH.DecQ)
+repPragRule (MkC nm) (MkC bndrs) (MkC lhs) (MkC rhs) (MkC phases)
+ = rep2 pragRuleDName [nm, bndrs, lhs, rhs, phases]
+
+repPragAnn :: Core TH.AnnTarget -> Core TH.ExpQ -> DsM (Core TH.DecQ)
+repPragAnn (MkC targ) (MkC e) = rep2 pragAnnDName [targ, e]
+
+repTySynInst :: Core TH.Name -> Core TH.TySynEqnQ -> DsM (Core TH.DecQ)
+repTySynInst (MkC nm) (MkC eqn)
+ = rep2 tySynInstDName [nm, eqn]
+
+repDataFamilyD :: Core TH.Name -> Core [TH.TyVarBndr]
+ -> Core (Maybe TH.Kind) -> DsM (Core TH.DecQ)
+repDataFamilyD (MkC nm) (MkC tvs) (MkC kind)
+ = rep2 dataFamilyDName [nm, tvs, kind]
+
+repOpenFamilyD :: Core TH.Name
+ -> Core [TH.TyVarBndr]
+ -> Core TH.FamilyResultSig
+ -> Core (Maybe TH.InjectivityAnn)
+ -> DsM (Core TH.DecQ)
+repOpenFamilyD (MkC nm) (MkC tvs) (MkC result) (MkC inj)
+ = rep2 openTypeFamilyDName [nm, tvs, result, inj]
+
+repClosedFamilyD :: Core TH.Name
+ -> Core [TH.TyVarBndr]
+ -> Core TH.FamilyResultSig
+ -> Core (Maybe TH.InjectivityAnn)
+ -> Core [TH.TySynEqnQ]
+ -> DsM (Core TH.DecQ)
+repClosedFamilyD (MkC nm) (MkC tvs) (MkC res) (MkC inj) (MkC eqns)
+ = rep2 closedTypeFamilyDName [nm, tvs, res, inj, eqns]
+
+repTySynEqn :: Core [TH.TypeQ] -> Core TH.TypeQ -> DsM (Core TH.TySynEqnQ)
+repTySynEqn (MkC lhs) (MkC rhs)
+ = rep2 tySynEqnName [lhs, rhs]
+
+repRoleAnnotD :: Core TH.Name -> Core [TH.Role] -> DsM (Core TH.DecQ)
+repRoleAnnotD (MkC n) (MkC roles) = rep2 roleAnnotDName [n, roles]
+
+repFunDep :: Core [TH.Name] -> Core [TH.Name] -> DsM (Core TH.FunDep)
+repFunDep (MkC xs) (MkC ys) = rep2 funDepName [xs, ys]
+
+repProto :: Name -> Core TH.Name -> Core TH.TypeQ -> DsM (Core TH.DecQ)
+repProto mk_sig (MkC s) (MkC ty) = rep2 mk_sig [s, ty]
+
+repCtxt :: Core [TH.PredQ] -> DsM (Core TH.CxtQ)
+repCtxt (MkC tys) = rep2 cxtName [tys]
+
+repDataCon :: Located Name
+ -> HsConDeclDetails Name
+ -> DsM (Core TH.ConQ)
+repDataCon con details
+ = do con' <- lookupLOcc con -- See Note [Binders and occurrences]
+ repConstr details Nothing [con']
+
+repGadtDataCons :: [Located Name]
+ -> HsConDeclDetails Name
+ -> LHsType Name
+ -> DsM (Core TH.ConQ)
+repGadtDataCons cons details res_ty
+ = do cons' <- mapM lookupLOcc cons -- See Note [Binders and occurrences]
+ repConstr details (Just res_ty) cons'
+
+-- Invariant:
+-- * for plain H98 data constructors second argument is Nothing and third
+-- argument is a singleton list
+-- * for GADTs data constructors second argument is (Just return_type) and
+-- third argument is a non-empty list
+repConstr :: HsConDeclDetails Name
+ -> Maybe (LHsType Name)
+ -> [Core TH.Name]
+ -> DsM (Core TH.ConQ)
+repConstr (PrefixCon ps) Nothing [con]
+ = do arg_tys <- repList bangTypeQTyConName repBangTy ps
+ rep2 normalCName [unC con, unC arg_tys]
+
+repConstr (PrefixCon ps) (Just (L _ res_ty)) cons
+ = do arg_tys <- repList bangTypeQTyConName repBangTy ps
+ res_ty' <- repTy res_ty
+ rep2 gadtCName [ unC (nonEmptyCoreList cons), unC arg_tys, unC res_ty']
+
+repConstr (RecCon (L _ ips)) resTy cons
+ = do args <- concatMapM rep_ip ips
+ arg_vtys <- coreList varBangTypeQTyConName args
+ case resTy of
+ Nothing -> rep2 recCName [unC (head cons), unC arg_vtys]
+ Just (L _ res_ty) -> do
+ res_ty' <- repTy res_ty
+ rep2 recGadtCName [unC (nonEmptyCoreList cons), unC arg_vtys,
+ unC res_ty']
+
+ where
+ rep_ip (L _ ip) = mapM (rep_one_ip (cd_fld_type ip)) (cd_fld_names ip)
+
+ rep_one_ip :: LBangType Name -> LFieldOcc Name -> DsM (Core a)
+ rep_one_ip t n = do { MkC v <- lookupOcc (selectorFieldOcc $ unLoc n)
+ ; MkC ty <- repBangTy t
+ ; rep2 varBangTypeName [v,ty] }
+
+repConstr (InfixCon st1 st2) Nothing [con]
+ = do arg1 <- repBangTy st1
+ arg2 <- repBangTy st2
+ rep2 infixCName [unC arg1, unC con, unC arg2]
+
+repConstr (InfixCon {}) (Just _) _ =
+ panic "repConstr: infix GADT constructor should be in a PrefixCon"
+repConstr _ _ _ =
+ panic "repConstr: invariant violated"
+
+------------ Types -------------------
+
+repTForall :: Core [TH.TyVarBndr] -> Core TH.CxtQ -> Core TH.TypeQ
+ -> DsM (Core TH.TypeQ)
+repTForall (MkC tvars) (MkC ctxt) (MkC ty)
+ = rep2 forallTName [tvars, ctxt, ty]
+
+repTvar :: Core TH.Name -> DsM (Core TH.TypeQ)
+repTvar (MkC s) = rep2 varTName [s]
+
+repTapp :: Core TH.TypeQ -> Core TH.TypeQ -> DsM (Core TH.TypeQ)
+repTapp (MkC t1) (MkC t2) = rep2 appTName [t1, t2]
+
+repTapps :: Core TH.TypeQ -> [Core TH.TypeQ] -> DsM (Core TH.TypeQ)
+repTapps f [] = return f
+repTapps f (t:ts) = do { f1 <- repTapp f t; repTapps f1 ts }
+
+repTSig :: Core TH.TypeQ -> Core TH.Kind -> DsM (Core TH.TypeQ)
+repTSig (MkC ty) (MkC ki) = rep2 sigTName [ty, ki]
+
+repTequality :: DsM (Core TH.TypeQ)
+repTequality = rep2 equalityTName []
+
+repTPromotedList :: [Core TH.TypeQ] -> DsM (Core TH.TypeQ)
+repTPromotedList [] = repPromotedNilTyCon
+repTPromotedList (t:ts) = do { tcon <- repPromotedConsTyCon
+ ; f <- repTapp tcon t
+ ; t' <- repTPromotedList ts
+ ; repTapp f t'
+ }
+
+repTLit :: Core TH.TyLitQ -> DsM (Core TH.TypeQ)
+repTLit (MkC lit) = rep2 litTName [lit]
+
+repTWildCard :: DsM (Core TH.TypeQ)
+repTWildCard = rep2 wildCardTName []
+
+--------- Type constructors --------------
+
+repNamedTyCon :: Core TH.Name -> DsM (Core TH.TypeQ)
+repNamedTyCon (MkC s) = rep2 conTName [s]
+
+repTupleTyCon :: Int -> DsM (Core TH.TypeQ)
+-- Note: not Core Int; it's easier to be direct here
+repTupleTyCon i = do dflags <- getDynFlags
+ rep2 tupleTName [mkIntExprInt dflags i]
+
+repUnboxedTupleTyCon :: Int -> DsM (Core TH.TypeQ)
+-- Note: not Core Int; it's easier to be direct here
+repUnboxedTupleTyCon i = do dflags <- getDynFlags
+ rep2 unboxedTupleTName [mkIntExprInt dflags i]
+
+repUnboxedSumTyCon :: TH.SumArity -> DsM (Core TH.TypeQ)
+-- Note: not Core TH.SumArity; it's easier to be direct here
+repUnboxedSumTyCon arity = do dflags <- getDynFlags
+ rep2 unboxedSumTName [mkIntExprInt dflags arity]
+
+repArrowTyCon :: DsM (Core TH.TypeQ)
+repArrowTyCon = rep2 arrowTName []
+
+repListTyCon :: DsM (Core TH.TypeQ)
+repListTyCon = rep2 listTName []
+
+repPromotedDataCon :: Core TH.Name -> DsM (Core TH.TypeQ)
+repPromotedDataCon (MkC s) = rep2 promotedTName [s]
+
+repPromotedTupleTyCon :: Int -> DsM (Core TH.TypeQ)
+repPromotedTupleTyCon i = do dflags <- getDynFlags
+ rep2 promotedTupleTName [mkIntExprInt dflags i]
+
+repPromotedNilTyCon :: DsM (Core TH.TypeQ)
+repPromotedNilTyCon = rep2 promotedNilTName []
+
+repPromotedConsTyCon :: DsM (Core TH.TypeQ)
+repPromotedConsTyCon = rep2 promotedConsTName []
+
+------------ Kinds -------------------
+
+repPlainTV :: Core TH.Name -> DsM (Core TH.TyVarBndr)
+repPlainTV (MkC nm) = rep2 plainTVName [nm]
+
+repKindedTV :: Core TH.Name -> Core TH.Kind -> DsM (Core TH.TyVarBndr)
+repKindedTV (MkC nm) (MkC ki) = rep2 kindedTVName [nm, ki]
+
+repKVar :: Core TH.Name -> DsM (Core TH.Kind)
+repKVar (MkC s) = rep2 varKName [s]
+
+repKCon :: Core TH.Name -> DsM (Core TH.Kind)
+repKCon (MkC s) = rep2 conKName [s]
+
+repKTuple :: Int -> DsM (Core TH.Kind)
+repKTuple i = do dflags <- getDynFlags
+ rep2 tupleKName [mkIntExprInt dflags i]
+
+repKArrow :: DsM (Core TH.Kind)
+repKArrow = rep2 arrowKName []
+
+repKList :: DsM (Core TH.Kind)
+repKList = rep2 listKName []
+
+repKApp :: Core TH.Kind -> Core TH.Kind -> DsM (Core TH.Kind)
+repKApp (MkC k1) (MkC k2) = rep2 appKName [k1, k2]
+
+repKApps :: Core TH.Kind -> [Core TH.Kind] -> DsM (Core TH.Kind)
+repKApps f [] = return f
+repKApps f (k:ks) = do { f' <- repKApp f k; repKApps f' ks }
+
+repKStar :: DsM (Core TH.Kind)
+repKStar = rep2 starKName []
+
+repKConstraint :: DsM (Core TH.Kind)
+repKConstraint = rep2 constraintKName []
+
+----------------------------------------------------------
+-- Type family result signature
+
+repNoSig :: DsM (Core TH.FamilyResultSig)
+repNoSig = rep2 noSigName []
+
+repKindSig :: Core TH.Kind -> DsM (Core TH.FamilyResultSig)
+repKindSig (MkC ki) = rep2 kindSigName [ki]
+
+repTyVarSig :: Core TH.TyVarBndr -> DsM (Core TH.FamilyResultSig)
+repTyVarSig (MkC bndr) = rep2 tyVarSigName [bndr]
+
+----------------------------------------------------------
+-- Literals
+
+repLiteral :: HsLit -> DsM (Core TH.Lit)
+repLiteral (HsStringPrim _ bs)
+ = do dflags <- getDynFlags
+ word8_ty <- lookupType word8TyConName
+ let w8s = unpack bs
+ w8s_expr = map (\w8 -> mkCoreConApps word8DataCon
+ [mkWordLit dflags (toInteger w8)]) w8s
+ rep2 stringPrimLName [mkListExpr word8_ty w8s_expr]
+repLiteral lit
+ = do lit' <- case lit of
+ HsIntPrim _ i -> mk_integer i
+ HsWordPrim _ w -> mk_integer w
+ HsInt _ i -> mk_integer i
+ HsFloatPrim r -> mk_rational r
+ HsDoublePrim r -> mk_rational r
+ HsCharPrim _ c -> mk_char c
+ _ -> return lit
+ lit_expr <- dsLit lit'
+ case mb_lit_name of
+ Just lit_name -> rep2 lit_name [lit_expr]
+ Nothing -> notHandled "Exotic literal" (ppr lit)
+ where
+ mb_lit_name = case lit of
+ HsInteger _ _ _ -> Just integerLName
+ HsInt _ _ -> Just integerLName
+ HsIntPrim _ _ -> Just intPrimLName
+ HsWordPrim _ _ -> Just wordPrimLName
+ HsFloatPrim _ -> Just floatPrimLName
+ HsDoublePrim _ -> Just doublePrimLName
+ HsChar _ _ -> Just charLName
+ HsCharPrim _ _ -> Just charPrimLName
+ HsString _ _ -> Just stringLName
+ HsRat _ _ -> Just rationalLName
+ _ -> Nothing
+
+mk_integer :: Integer -> DsM HsLit
+mk_integer i = do integer_ty <- lookupType integerTyConName
+ return $ HsInteger NoSourceText i integer_ty
+mk_rational :: FractionalLit -> DsM HsLit
+mk_rational r = do rat_ty <- lookupType rationalTyConName
+ return $ HsRat r rat_ty
+mk_string :: FastString -> DsM HsLit
+mk_string s = return $ HsString NoSourceText s
+
+mk_char :: Char -> DsM HsLit
+mk_char c = return $ HsChar NoSourceText c
+
+repOverloadedLiteral :: HsOverLit Name -> DsM (Core TH.Lit)
+repOverloadedLiteral (OverLit { ol_val = val})
+ = do { lit <- mk_lit val; repLiteral lit }
+ -- The type Rational will be in the environment, because
+ -- the smart constructor 'TH.Syntax.rationalL' uses it in its type,
+ -- and rationalL is sucked in when any TH stuff is used
+
+mk_lit :: OverLitVal -> DsM HsLit
+mk_lit (HsIntegral _ i) = mk_integer i
+mk_lit (HsFractional f) = mk_rational f
+mk_lit (HsIsString _ s) = mk_string s
+
+repNameS :: Core String -> DsM (Core TH.Name)
+repNameS (MkC name) = rep2 mkNameSName [name]
+
+--------------- Miscellaneous -------------------
+
+repGensym :: Core String -> DsM (Core (TH.Q TH.Name))
+repGensym (MkC lit_str) = rep2 newNameName [lit_str]
+
+repBindQ :: Type -> Type -- a and b
+ -> Core (TH.Q a) -> Core (a -> TH.Q b) -> DsM (Core (TH.Q b))
+repBindQ ty_a ty_b (MkC x) (MkC y)
+ = rep2 bindQName [Type ty_a, Type ty_b, x, y]
+
+repSequenceQ :: Type -> Core [TH.Q a] -> DsM (Core (TH.Q [a]))
+repSequenceQ ty_a (MkC list)
+ = rep2 sequenceQName [Type ty_a, list]
+
+repUnboundVar :: Core TH.Name -> DsM (Core TH.ExpQ)
+repUnboundVar (MkC name) = rep2 unboundVarEName [name]
+
+------------ Lists -------------------
+-- turn a list of patterns into a single pattern matching a list
+
+repList :: Name -> (a -> DsM (Core b))
+ -> [a] -> DsM (Core [b])
+repList tc_name f args
+ = do { args1 <- mapM f args
+ ; coreList tc_name args1 }
+
+coreList :: Name -- Of the TyCon of the element type
+ -> [Core a] -> DsM (Core [a])
+coreList tc_name es
+ = do { elt_ty <- lookupType tc_name; return (coreList' elt_ty es) }
+
+coreList' :: Type -- The element type
+ -> [Core a] -> Core [a]
+coreList' elt_ty es = MkC (mkListExpr elt_ty (map unC es ))
+
+nonEmptyCoreList :: [Core a] -> Core [a]
+ -- The list must be non-empty so we can get the element type
+ -- Otherwise use coreList
+nonEmptyCoreList [] = panic "coreList: empty argument"
+nonEmptyCoreList xs@(MkC x:_) = MkC (mkListExpr (exprType x) (map unC xs))
+
+coreStringLit :: String -> DsM (Core String)
+coreStringLit s = do { z <- mkStringExpr s; return(MkC z) }
+
+------------------- Maybe ------------------
+
+-- | Construct Core expression for Nothing of a given type name
+coreNothing :: Name -- ^ Name of the TyCon of the element type
+ -> DsM (Core (Maybe a))
+coreNothing tc_name =
+ do { elt_ty <- lookupType tc_name; return (coreNothing' elt_ty) }
+
+-- | Construct Core expression for Nothing of a given type
+coreNothing' :: Type -- ^ The element type
+ -> Core (Maybe a)
+coreNothing' elt_ty = MkC (mkNothingExpr elt_ty)
+
+-- | Store given Core expression in a Just of a given type name
+coreJust :: Name -- ^ Name of the TyCon of the element type
+ -> Core a -> DsM (Core (Maybe a))
+coreJust tc_name es
+ = do { elt_ty <- lookupType tc_name; return (coreJust' elt_ty es) }
+
+-- | Store given Core expression in a Just of a given type
+coreJust' :: Type -- ^ The element type
+ -> Core a -> Core (Maybe a)
+coreJust' elt_ty es = MkC (mkJustExpr elt_ty (unC es))
+
+------------ Literals & Variables -------------------
+
+coreIntLit :: Int -> DsM (Core Int)
+coreIntLit i = do dflags <- getDynFlags
+ return (MkC (mkIntExprInt dflags i))
+
+coreVar :: Id -> Core TH.Name -- The Id has type Name
+coreVar id = MkC (Var id)
+
+----------------- Failure -----------------------
+notHandledL :: SrcSpan -> String -> SDoc -> DsM a
+notHandledL loc what doc
+ | isGoodSrcSpan loc
+ = putSrcSpanDs loc $ notHandled what doc
+ | otherwise
+ = notHandled what doc
+
+notHandled :: String -> SDoc -> DsM a
+notHandled what doc = failWithDs msg
+ where
+ msg = hang (text what <+> text "not (yet) handled by Template Haskell")
+ 2 doc
diff --git a/deSugar/DsMonad.hs b/deSugar/DsMonad.hs
new file mode 100644
--- /dev/null
+++ b/deSugar/DsMonad.hs
@@ -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
+, levity
+polymorphism is forbidden in precisely two places: in the type of a bound
+term-level argument and in the type of an argument to a function. The paper
+explains it more fully, but briefly: expressions in these contexts need to be
+stored in registers, and it's hard (read, impossible) to store something
+that's levity polymorphic.
+
+We cannot check for bad levity polymorphism conveniently in the type checker,
+because we can't tell, a priori, which levity metavariables will be solved.
+At one point, I (Richard) thought we could check in the zonker, but it's hard
+to know where precisely are the abstracted variables and the arguments. So
+we check in the desugarer, the only place where we can see the Core code and
+still report respectable syntax to the user. This covers the vast majority
+of cases; see calls to DsMonad.dsNoLevPoly and friends.
+
+Levity polymorphism is also prohibited in the types of binders, and the
+desugarer checks for this in GHC-generated Ids. (The zonker handles
+the user-writted ids in zonkIdBndr.) This is done in newSysLocalDsNoLP.
+The newSysLocalDs variant is used in the vast majority of cases where
+the binder is obviously not levity polymorphic, omitting the check.
+It would be nice to ASSERT that there is no levity polymorphism here,
+but we can't, because of the fixM in DsArrows. It's all OK, though:
+Core Lint will catch an error here.
+
+However, the desugarer is the wrong place for certain checks. In particular,
+the desugarer can't report a sensible error message if an HsWrapper is malformed.
+After all, GHC itself produced the HsWrapper. So we store some message text
+in the appropriate HsWrappers (e.g. WpFun) that we can print out in the
+desugarer.
+
+There are a few more checks in places where Core is generated outside the
+desugarer. For example, in datatype and class declarations, where levity
+polymorphism is checked for during validity checking. It would be nice to
+have one central place for all this, but that doesn't seem possible while
+still reporting nice error messages.
+
+-}
+
+-- Make a new Id with the same print name, but different type, and new unique
+newUniqueId :: Id -> Type -> DsM Id
+newUniqueId id = mk_local (occNameFS (nameOccName (idName id)))
+
+duplicateLocalDs :: Id -> DsM Id
+duplicateLocalDs old_local
+ = do { uniq <- newUnique
+ ; return (setIdUnique old_local uniq) }
+
+newPredVarDs :: PredType -> DsM Var
+newPredVarDs pred
+ = newSysLocalDs pred
+
+newSysLocalDsNoLP, newSysLocalDs, newFailLocalDs :: Type -> DsM Id
+newSysLocalDsNoLP = mk_local (fsLit "ds")
+
+-- this variant should be used when the caller can be sure that the variable type
+-- is not levity-polymorphic. It is necessary when the type is knot-tied because
+-- of the fixM used in DsArrows. See Note [Levity polymorphism checking]
+newSysLocalDs = mkSysLocalOrCoVarM (fsLit "ds")
+newFailLocalDs = mkSysLocalOrCoVarM (fsLit "fail")
+ -- the fail variable is used only in a situation where we can tell that
+ -- levity-polymorphism is impossible.
+
+newSysLocalsDsNoLP, newSysLocalsDs :: [Type] -> DsM [Id]
+newSysLocalsDsNoLP = mapM newSysLocalDsNoLP
+newSysLocalsDs = mapM newSysLocalDs
+
+mk_local :: FastString -> Type -> DsM Id
+mk_local fs ty = do { dsNoLevPoly ty (text "When trying to create a variable of type:" <+>
+ ppr ty) -- could improve the msg with another
+ -- parameter indicating context
+ ; mkSysLocalOrCoVarM fs ty }
+
+{-
+We can also reach out and either set/grab location information from
+the @SrcSpan@ being carried around.
+-}
+
+getGhcModeDs :: DsM GhcMode
+getGhcModeDs = getDynFlags >>= return . ghcMode
+
+-- | Get in-scope type constraints (pm check)
+getDictsDs :: DsM (Bag EvVar)
+getDictsDs = do { env <- getLclEnv; return (dsl_dicts env) }
+
+-- | Add in-scope type constraints (pm check)
+addDictsDs :: Bag EvVar -> DsM a -> DsM a
+addDictsDs ev_vars
+ = updLclEnv (\env -> env { dsl_dicts = unionBags ev_vars (dsl_dicts env) })
+
+-- | Get in-scope term constraints (pm check)
+getTmCsDs :: DsM (Bag SimpleEq)
+getTmCsDs = do { env <- getLclEnv; return (dsl_tm_cs env) }
+
+-- | Add in-scope term constraints (pm check)
+addTmCsDs :: Bag SimpleEq -> DsM a -> DsM a
+addTmCsDs tm_cs
+ = updLclEnv (\env -> env { dsl_tm_cs = unionBags tm_cs (dsl_tm_cs env) })
+
+-- | Increase the counter for elapsed pattern match check iterations.
+-- If the current counter is already over the limit, fail
+incrCheckPmIterDs :: DsM Int
+incrCheckPmIterDs = do
+ env <- getLclEnv
+ cnt <- readTcRef (dsl_pm_iter env)
+ max_iters <- maxPmCheckIterations <$> getDynFlags
+ if cnt >= max_iters
+ then failM
+ else updTcRef (dsl_pm_iter env) (+1)
+ return cnt
+
+-- | Reset the counter for pattern match check iterations to zero
+resetPmIterDs :: DsM ()
+resetPmIterDs = do { env <- getLclEnv; writeTcRef (dsl_pm_iter env) 0 }
+
+getSrcSpanDs :: DsM SrcSpan
+getSrcSpanDs = do { env <- getLclEnv
+ ; return (RealSrcSpan (dsl_loc env)) }
+
+putSrcSpanDs :: SrcSpan -> DsM a -> DsM a
+putSrcSpanDs (UnhelpfulSpan {}) thing_inside
+ = thing_inside
+putSrcSpanDs (RealSrcSpan real_span) thing_inside
+ = updLclEnv (\ env -> env {dsl_loc = real_span}) thing_inside
+
+-- | Emit a warning for the current source location
+-- NB: Warns whether or not -Wxyz is set
+warnDs :: WarnReason -> SDoc -> DsM ()
+warnDs reason warn
+ = do { env <- getGblEnv
+ ; loc <- getSrcSpanDs
+ ; dflags <- getDynFlags
+ ; let msg = makeIntoWarning reason $
+ mkWarnMsg dflags loc (ds_unqual env) warn
+ ; updMutVar (ds_msgs env) (\ (w,e) -> (w `snocBag` msg, e)) }
+
+-- | Emit a warning only if the correct WarnReason is set in the DynFlags
+warnIfSetDs :: WarningFlag -> SDoc -> DsM ()
+warnIfSetDs flag warn
+ = whenWOptM flag $
+ warnDs (Reason flag) warn
+
+errDs :: SDoc -> DsM ()
+errDs err
+ = do { env <- getGblEnv
+ ; loc <- getSrcSpanDs
+ ; dflags <- getDynFlags
+ ; let msg = mkErrMsg dflags loc (ds_unqual env) err
+ ; updMutVar (ds_msgs env) (\ (w,e) -> (w, e `snocBag` msg)) }
+
+-- | Issue an error, but return the expression for (), so that we can continue
+-- reporting errors.
+errDsCoreExpr :: SDoc -> DsM CoreExpr
+errDsCoreExpr err
+ = do { errDs err
+ ; return unitExpr }
+
+failWithDs :: SDoc -> DsM a
+failWithDs err
+ = do { errDs err
+ ; failM }
+
+failDs :: DsM a
+failDs = failM
+
+-- (askNoErrsDs m) runs m
+-- If m fails,
+-- then (askNoErrsDs m) fails
+-- If m succeeds with result r,
+-- then (askNoErrsDs m) succeeds with result (r, b),
+-- where b is True iff m generated no errors
+-- Regardless of success or failure,
+-- propagate any errors/warnings generated by m
+--
+-- c.f. TcRnMonad.askNoErrs
+askNoErrsDs :: DsM a -> DsM (a, Bool)
+askNoErrsDs thing_inside
+ = do { errs_var <- newMutVar emptyMessages
+ ; env <- getGblEnv
+ ; mb_res <- tryM $ -- Be careful to catch exceptions
+ -- so that we propagate errors correctly
+ -- (Trac #13642)
+ setGblEnv (env { ds_msgs = errs_var }) $
+ thing_inside
+
+ -- Propagate errors
+ ; msgs@(warns, errs) <- readMutVar errs_var
+ ; updMutVar (ds_msgs env) (\ (w,e) -> (w `unionBags` warns, e `unionBags` errs))
+
+ -- And return
+ ; case mb_res of
+ Left _ -> failM
+ Right res -> do { dflags <- getDynFlags
+ ; let errs_found = errorsFound dflags msgs
+ ; return (res, not errs_found) } }
+
+mkPrintUnqualifiedDs :: DsM PrintUnqualified
+mkPrintUnqualifiedDs = ds_unqual <$> getGblEnv
+
+instance MonadThings (IOEnv (Env DsGblEnv DsLclEnv)) where
+ lookupThing = dsLookupGlobal
+
+-- | Attempt to load the given module and return its exported entities if
+-- successful.
+dsLoadModule :: SDoc -> Module -> DsM GlobalRdrEnv
+dsLoadModule doc mod
+ = do { env <- getGblEnv
+ ; setEnvs (ds_if_env env) $ do
+ { iface <- loadInterface doc mod ImportBySystem
+ ; case iface of
+ Failed err -> pprPanic "DsMonad.dsLoadModule: failed to load" (err $$ doc)
+ Succeeded iface -> return $ mkGlobalRdrEnv . gresFromAvails prov . mi_exports $ iface
+ } }
+ where
+ prov = Just (ImpSpec { is_decl = imp_spec, is_item = ImpAll })
+ imp_spec = ImpDeclSpec { is_mod = name, is_qual = True,
+ is_dloc = wiredInSrcSpan, is_as = name }
+ name = moduleName mod
+
+dsLookupGlobal :: Name -> DsM TyThing
+-- Very like TcEnv.tcLookupGlobal
+dsLookupGlobal name
+ = do { env <- getGblEnv
+ ; setEnvs (ds_if_env env)
+ (tcIfaceGlobal name) }
+
+dsLookupGlobalId :: Name -> DsM Id
+dsLookupGlobalId name
+ = tyThingId <$> dsLookupGlobal name
+
+dsLookupTyCon :: Name -> DsM TyCon
+dsLookupTyCon name
+ = tyThingTyCon <$> dsLookupGlobal name
+
+dsLookupDataCon :: Name -> DsM DataCon
+dsLookupDataCon name
+ = tyThingDataCon <$> dsLookupGlobal name
+
+dsLookupConLike :: Name -> DsM ConLike
+dsLookupConLike name
+ = tyThingConLike <$> dsLookupGlobal name
+
+
+dsGetFamInstEnvs :: DsM FamInstEnvs
+-- Gets both the external-package inst-env
+-- and the home-pkg inst env (includes module being compiled)
+dsGetFamInstEnvs
+ = do { eps <- getEps; env <- getGblEnv
+ ; return (eps_fam_inst_env eps, ds_fam_inst_env env) }
+
+dsGetMetaEnv :: DsM (NameEnv DsMetaVal)
+dsGetMetaEnv = do { env <- getLclEnv; return (dsl_meta env) }
+
+-- | The @COMPLETE@ pragams provided by the user for a given `TyCon`.
+dsGetCompleteMatches :: TyCon -> DsM [CompleteMatch]
+dsGetCompleteMatches tc = do
+ eps <- getEps
+ env <- getGblEnv
+ let lookup_completes ufm = lookupWithDefaultUFM ufm [] tc
+ eps_matches_list = lookup_completes $ eps_complete_matches eps
+ env_matches_list = lookup_completes $ ds_complete_matches env
+ return $ eps_matches_list ++ env_matches_list
+
+dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal)
+dsLookupMetaEnv name = do { env <- getLclEnv; return (lookupNameEnv (dsl_meta env) name) }
+
+dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a
+dsExtendMetaEnv menv thing_inside
+ = updLclEnv (\env -> env { dsl_meta = dsl_meta env `plusNameEnv` menv }) thing_inside
+
+discardWarningsDs :: DsM a -> DsM a
+-- Ignore warnings inside the thing inside;
+-- used to ignore inaccessable cases etc. inside generated code
+discardWarningsDs thing_inside
+ = do { env <- getGblEnv
+ ; old_msgs <- readTcRef (ds_msgs env)
+
+ ; result <- thing_inside
+
+ -- Revert messages to old_msgs
+ ; writeTcRef (ds_msgs env) old_msgs
+
+ ; return result }
+
+-- | Fail with an error message if the type is levity polymorphic.
+dsNoLevPoly :: Type -> SDoc -> DsM ()
+-- See Note [Levity polymorphism checking]
+dsNoLevPoly ty doc = checkForLevPolyX errDs doc ty
+
+-- | Check an expression for levity polymorphism, failing if it is
+-- levity polymorphic.
+dsNoLevPolyExpr :: CoreExpr -> SDoc -> DsM ()
+-- See Note [Levity polymorphism checking]
+dsNoLevPolyExpr e doc
+ | isExprLevPoly e = errDs (formatLevPolyErr (exprType e) $$ doc)
+ | otherwise = return ()
+
+-- | Runs the thing_inside. If there are no errors, then returns the expr
+-- given. Otherwise, returns unitExpr. This is useful for doing a bunch
+-- of levity polymorphism checks and then avoiding making a core App.
+-- (If we make a core App on a levity polymorphic argument, detecting how
+-- to handle the let/app invariant might call isUnliftedType, which panics
+-- on a levity polymorphic type.)
+-- See #12709 for an example of why this machinery is necessary.
+dsWhenNoErrs :: DsM a -> (a -> CoreExpr) -> DsM CoreExpr
+dsWhenNoErrs thing_inside mk_expr
+ = do { (result, no_errs) <- askNoErrsDs thing_inside
+ ; return $ if no_errs
+ then mk_expr result
+ else unitExpr }
+
+--------------------------------------------------------------------------
+-- Data Parallel Haskell
+--------------------------------------------------------------------------
+
+-- | Run a 'DsM' with DPH things in scope if necessary.
+initDPH :: DsM a -> DsM a
+initDPH = loadDAP . initDPHBuiltins
+
+-- | Extend the global environment with a 'GlobalRdrEnv' containing the exported
+-- entities of,
+--
+-- * 'Data.Array.Parallel' iff '-XParallelArrays' specified (see also 'checkLoadDAP').
+-- * 'Data.Array.Parallel.Prim' iff '-fvectorise' specified.
+loadDAP :: DsM a -> DsM a
+loadDAP thing_inside
+ = do { dapEnv <- loadOneModule dATA_ARRAY_PARALLEL_NAME checkLoadDAP paErr
+ ; dappEnv <- loadOneModule dATA_ARRAY_PARALLEL_PRIM_NAME (goptM Opt_Vectorise) veErr
+ ; updGblEnv (\env -> env {ds_dph_env = dapEnv `plusOccEnv` dappEnv }) thing_inside
+ }
+ where
+ loadOneModule :: ModuleName -- the module to load
+ -> DsM Bool -- under which condition
+ -> MsgDoc -- error message if module not found
+ -> DsM GlobalRdrEnv -- empty if condition 'False'
+ loadOneModule modname check err
+ = do { doLoad <- check
+ ; if not doLoad
+ then return emptyGlobalRdrEnv
+ else do {
+ ; hsc_env <- getTopEnv
+ ; result <- liftIO $ findImportedModule hsc_env modname Nothing
+ ; case result of
+ Found _ mod -> dsLoadModule err mod
+ _ -> pprPgmError "Unable to use Data Parallel Haskell (DPH):" err
+ } }
+
+ paErr = text "To use ParallelArrays," <+> specBackend $$ hint1 $$ hint2
+ veErr = text "To use -fvectorise," <+> specBackend $$ hint1 $$ hint2
+ specBackend = text "you must specify a DPH backend package"
+ hint1 = text "Look for packages named 'dph-lifted-*' with 'ghc-pkg'"
+ hint2 = text "You may need to install them with 'cabal install dph-examples'"
+
+-- | If '-XParallelArrays' given, we populate the builtin table for desugaring
+-- those.
+initDPHBuiltins :: DsM a -> DsM a
+initDPHBuiltins thing_inside
+ = do { doInitBuiltins <- checkLoadDAP
+ ; if doInitBuiltins
+ then dsInitPArrBuiltin thing_inside
+ else thing_inside
+ }
+
+checkLoadDAP :: DsM Bool
+checkLoadDAP
+ = do { paEnabled <- xoptM LangExt.ParallelArrays
+ ; mod <- getModule
+ -- do not load 'Data.Array.Parallel' iff compiling 'base:GHC.PArr' or a
+ -- module called 'dATA_ARRAY_PARALLEL_NAME'; see also the comments at the top
+ -- of 'base:GHC.PArr' and 'Data.Array.Parallel' in the DPH libraries
+ ; return $ paEnabled &&
+ mod /= gHC_PARR' &&
+ moduleName mod /= dATA_ARRAY_PARALLEL_NAME
+ }
+
+-- | Populate 'ds_parr_bi' from 'ds_dph_env'.
+--
+dsInitPArrBuiltin :: DsM a -> DsM a
+dsInitPArrBuiltin thing_inside
+ = do { lengthPVar <- externalVar (fsLit "lengthP")
+ ; replicatePVar <- externalVar (fsLit "replicateP")
+ ; singletonPVar <- externalVar (fsLit "singletonP")
+ ; mapPVar <- externalVar (fsLit "mapP")
+ ; filterPVar <- externalVar (fsLit "filterP")
+ ; zipPVar <- externalVar (fsLit "zipP")
+ ; crossMapPVar <- externalVar (fsLit "crossMapP")
+ ; indexPVar <- externalVar (fsLit "!:")
+ ; emptyPVar <- externalVar (fsLit "emptyP")
+ ; appPVar <- externalVar (fsLit "+:+")
+ -- ; enumFromToPVar <- externalVar (fsLit "enumFromToP")
+ -- ; enumFromThenToPVar <- externalVar (fsLit "enumFromThenToP")
+ ; enumFromToPVar <- return arithErr
+ ; enumFromThenToPVar <- return arithErr
+
+ ; updGblEnv (\env -> env {ds_parr_bi = PArrBuiltin
+ { lengthPVar = lengthPVar
+ , replicatePVar = replicatePVar
+ , singletonPVar = singletonPVar
+ , mapPVar = mapPVar
+ , filterPVar = filterPVar
+ , zipPVar = zipPVar
+ , crossMapPVar = crossMapPVar
+ , indexPVar = indexPVar
+ , emptyPVar = emptyPVar
+ , appPVar = appPVar
+ , enumFromToPVar = enumFromToPVar
+ , enumFromThenToPVar = enumFromThenToPVar
+ } })
+ thing_inside
+ }
+ where
+ externalVar :: FastString -> DsM Var
+ externalVar fs = dsLookupDPHRdrEnv (mkVarOccFS fs) >>= dsLookupGlobalId
+
+ arithErr = panic "Arithmetic sequences have to wait until we support type classes"
+
+-- |Get a name from "Data.Array.Parallel" for the desugarer, from the
+-- 'ds_parr_bi' component of the global desugerar environment.
+--
+dsDPHBuiltin :: (PArrBuiltin -> a) -> DsM a
+dsDPHBuiltin sel = (sel . ds_parr_bi) <$> getGblEnv
+
+-- |Lookup a name exported by 'Data.Array.Parallel.Prim' or 'Data.Array.Parallel.Prim'.
+-- Panic if there isn't one, or if it is defined multiple times.
+dsLookupDPHRdrEnv :: OccName -> DsM Name
+dsLookupDPHRdrEnv occ
+ = liftM (fromMaybe (pprPanic nameNotFound (ppr occ)))
+ $ dsLookupDPHRdrEnv_maybe occ
+ where nameNotFound = "Name not found in 'Data.Array.Parallel' or 'Data.Array.Parallel.Prim':"
+
+-- |Lookup a name exported by 'Data.Array.Parallel.Prim' or 'Data.Array.Parallel.Prim',
+-- returning `Nothing` if it's not defined. Panic if it's defined multiple times.
+dsLookupDPHRdrEnv_maybe :: OccName -> DsM (Maybe Name)
+dsLookupDPHRdrEnv_maybe occ
+ = do { env <- ds_dph_env <$> getGblEnv
+ ; let gres = lookupGlobalRdrEnv env occ
+ ; case gres of
+ [] -> return $ Nothing
+ [gre] -> return $ Just $ gre_name gre
+ _ -> pprPanic multipleNames (ppr occ)
+ }
+ where multipleNames = "Multiple definitions in 'Data.Array.Parallel' and 'Data.Array.Parallel.Prim':"
diff --git a/deSugar/DsUsage.hs b/deSugar/DsUsage.hs
new file mode 100644
--- /dev/null
+++ b/deSugar/DsUsage.hs
@@ -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!
+ -}
diff --git a/deSugar/DsUtils.hs b/deSugar/DsUtils.hs
new file mode 100644
--- /dev/null
+++ b/deSugar/DsUtils.hs
@@ -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)
diff --git a/deSugar/Match.hs b/deSugar/Match.hs
new file mode 100644
--- /dev/null
+++ b/deSugar/Match.hs
@@ -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
+in
+\end{verbatim}
+\item
+and finally: (ToDo: fill in)
+
+The right way to think about the ``after-match function'' is that it
+is an embryonic @CoreExpr@ with a ``hole'' at the end for the
+final ``else expression''.
+\end{itemize}
+
+There is a data type, @EquationInfo@, defined in module @DsMonad@.
+
+An experiment with re-ordering this information about equations (in
+particular, having the patterns available in column-major order)
+showed no benefit.
+
+\item
+A default expression---what to evaluate if the overall pattern-match
+fails. This expression will (almost?) always be
+a measly expression @Var@, unless we know it will only be used once
+(as we do in @glue_success_exprs@).
+
+Leaving out this third argument to @match@ (and slamming in lots of
+@Var "fail"@s) is a positively {\em bad} idea, because it makes it
+impossible to share the default expressions. (Also, it stands no
+chance of working in our post-upheaval world of @Locals@.)
+\end{enumerate}
+
+Note: @match@ is often called via @matchWrapper@ (end of this module),
+a function that does much of the house-keeping that goes with a call
+to @match@.
+
+It is also worth mentioning the {\em typical} way a block of equations
+is desugared with @match@. At each stage, it is the first column of
+patterns that is examined. The steps carried out are roughly:
+\begin{enumerate}
+\item
+Tidy the patterns in column~1 with @tidyEqnInfo@ (this may add
+bindings to the second component of the equation-info):
+\begin{itemize}
+\item
+Remove the `as' patterns from column~1.
+\item
+Make all constructor patterns in column~1 into @ConPats@, notably
+@ListPats@ and @TuplePats@.
+\item
+Handle any irrefutable (or ``twiddle'') @LazyPats@.
+\end{itemize}
+\item
+Now {\em unmix} the equations into {\em blocks} [w\/ local function
+@unmix_eqns@], in which the equations in a block all have variable
+patterns in column~1, or they all have constructor patterns in ...
+(see ``the mixture rule'' in SLPJ).
+\item
+Call @matchEqnBlock@ on each block of equations; it will do the
+appropriate thing for each kind of column-1 pattern, usually ending up
+in a recursive call to @match@.
+\end{enumerate}
+
+We are a little more paranoid about the ``empty rule'' (SLPJ, p.~87)
+than the Wadler-chapter code for @match@ (p.~93, first @match@ clause).
+And gluing the ``success expressions'' together isn't quite so pretty.
+
+This (more interesting) clause of @match@ uses @tidy_and_unmix_eqns@
+(a)~to get `as'- and `twiddle'-patterns out of the way (tidying), and
+(b)~to do ``the mixture rule'' (SLPJ, p.~88) [which really {\em
+un}mixes the equations], producing a list of equation-info
+blocks, each block having as its first column of patterns either all
+constructors, or all variables (or similar beasts), etc.
+
+@match_unmixed_eqn_blks@ simply takes the place of the @foldr@ in the
+Wadler-chapter @match@ (p.~93, last clause), and @match_unmixed_blk@
+corresponds roughly to @matchVarCon@.
+
+Note [Match Ids]
+~~~~~~~~~~~~~~~~
+Most of the matching fuctions take an Id or [Id] as argument. This Id
+is the scrutinee(s) of the match. The desugared expression may
+sometimes use that Id in a local binding or as a case binder. So it
+should not have an External name; Lint rejects non-top-level binders
+with External names (Trac #13043).
+-}
+
+type MatchId = Id -- See Note [Match Ids]
+
+match :: [MatchId] -- Variables rep\'ing the exprs we\'re matching with
+ -- See Note [Match Ids]
+ -> Type -- Type of the case expression
+ -> [EquationInfo] -- Info about patterns, etc. (type synonym below)
+ -> DsM MatchResult -- Desugared result!
+
+match [] ty eqns
+ = ASSERT2( not (null eqns), ppr ty )
+ return (foldr1 combineMatchResults match_results)
+ where
+ match_results = [ ASSERT( null (eqn_pats eqn) )
+ eqn_rhs eqn
+ | eqn <- eqns ]
+
+match vars@(v:_) ty eqns -- Eqns *can* be empty
+ = ASSERT2( all (isInternalName . idName) vars, ppr vars )
+ do { dflags <- getDynFlags
+ -- Tidy the first pattern, generating
+ -- auxiliary bindings if necessary
+ ; (aux_binds, tidy_eqns) <- mapAndUnzipM (tidyEqnInfo v) eqns
+
+ -- Group the equations and match each group in turn
+ ; let grouped = groupEquations dflags tidy_eqns
+
+ -- print the view patterns that are commoned up to help debug
+ ; whenDOptM Opt_D_dump_view_pattern_commoning (debug grouped)
+
+ ; match_results <- match_groups grouped
+ ; return (adjustMatchResult (foldr (.) id aux_binds) $
+ foldr1 combineMatchResults match_results) }
+ where
+ dropGroup :: [(PatGroup,EquationInfo)] -> [EquationInfo]
+ dropGroup = map snd
+
+ match_groups :: [[(PatGroup,EquationInfo)]] -> DsM [MatchResult]
+ -- Result list of [MatchResult] is always non-empty
+ match_groups [] = matchEmpty v ty
+ match_groups gs = mapM match_group gs
+
+ match_group :: [(PatGroup,EquationInfo)] -> DsM MatchResult
+ match_group [] = panic "match_group"
+ match_group eqns@((group,_) : _)
+ = case group of
+ PgCon {} -> matchConFamily vars ty (subGroupUniq [(c,e) | (PgCon c, e) <- eqns])
+ PgSyn {} -> matchPatSyn vars ty (dropGroup eqns)
+ PgLit {} -> matchLiterals vars ty (subGroupOrd [(l,e) | (PgLit l, e) <- eqns])
+ PgAny -> matchVariables vars ty (dropGroup eqns)
+ PgN {} -> matchNPats vars ty (dropGroup eqns)
+ PgOverS {}-> matchNPats vars ty (dropGroup eqns)
+ PgNpK {} -> matchNPlusKPats vars ty (dropGroup eqns)
+ PgBang -> matchBangs vars ty (dropGroup eqns)
+ PgCo {} -> matchCoercion vars ty (dropGroup eqns)
+ PgView {} -> matchView vars ty (dropGroup eqns)
+ PgOverloadedList -> matchOverloadedList vars ty (dropGroup eqns)
+
+ -- FIXME: we should also warn about view patterns that should be
+ -- commoned up but are not
+
+ -- print some stuff to see what's getting grouped
+ -- use -dppr-debug to see the resolution of overloaded literals
+ debug eqns =
+ let gs = map (\group -> foldr (\ (p,_) -> \acc ->
+ case p of PgView e _ -> e:acc
+ _ -> acc) [] group) eqns
+ maybeWarn [] = return ()
+ maybeWarn l = warnDs NoReason (vcat l)
+ in
+ maybeWarn $ (map (\g -> text "Putting these view expressions into the same case:" <+> (ppr g))
+ (filter (not . null) gs))
+
+matchEmpty :: MatchId -> Type -> DsM [MatchResult]
+-- See Note [Empty case expressions]
+matchEmpty var res_ty
+ = return [MatchResult CanFail mk_seq]
+ where
+ mk_seq fail = return $ mkWildCase (Var var) (idType var) res_ty
+ [(DEFAULT, [], fail)]
+
+matchVariables :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult
+-- Real true variables, just like in matchVar, SLPJ p 94
+-- No binding to do: they'll all be wildcards by now (done in tidy)
+matchVariables (_:vars) ty eqns = match vars ty (shiftEqns eqns)
+matchVariables [] _ _ = panic "matchVariables"
+
+matchBangs :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult
+matchBangs (var:vars) ty eqns
+ = do { match_result <- match (var:vars) ty $
+ map (decomposeFirstPat getBangPat) eqns
+ ; return (mkEvalMatchResult var ty match_result) }
+matchBangs [] _ _ = panic "matchBangs"
+
+matchCoercion :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult
+-- Apply the coercion to the match variable and then match that
+matchCoercion (var:vars) ty (eqns@(eqn1:_))
+ = do { let CoPat co pat _ = firstPat eqn1
+ ; let pat_ty' = hsPatType pat
+ ; var' <- newUniqueId var pat_ty'
+ ; match_result <- match (var':vars) ty $
+ map (decomposeFirstPat getCoPat) eqns
+ ; core_wrap <- dsHsWrapper co
+ ; let bind = NonRec var' (core_wrap (Var var))
+ ; return (mkCoLetMatchResult bind match_result) }
+matchCoercion _ _ _ = panic "matchCoercion"
+
+matchView :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult
+-- Apply the view function to the match variable and then match that
+matchView (var:vars) ty (eqns@(eqn1:_))
+ = do { -- we could pass in the expr from the PgView,
+ -- but this needs to extract the pat anyway
+ -- to figure out the type of the fresh variable
+ let ViewPat viewExpr (L _ pat) _ = firstPat eqn1
+ -- do the rest of the compilation
+ ; let pat_ty' = hsPatType pat
+ ; var' <- newUniqueId var pat_ty'
+ ; match_result <- match (var':vars) ty $
+ map (decomposeFirstPat getViewPat) eqns
+ -- compile the view expressions
+ ; viewExpr' <- dsLExpr viewExpr
+ ; return (mkViewMatchResult var'
+ (mkCoreAppDs (text "matchView") viewExpr' (Var var))
+ match_result) }
+matchView _ _ _ = panic "matchView"
+
+matchOverloadedList :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult
+matchOverloadedList (var:vars) ty (eqns@(eqn1:_))
+-- Since overloaded list patterns are treated as view patterns,
+-- the code is roughly the same as for matchView
+ = do { let ListPat _ elt_ty (Just (_,e)) = firstPat eqn1
+ ; var' <- newUniqueId var (mkListTy elt_ty) -- we construct the overall type by hand
+ ; match_result <- match (var':vars) ty $
+ map (decomposeFirstPat getOLPat) eqns -- getOLPat builds the pattern inside as a non-overloaded version of the overloaded list pattern
+ ; e' <- dsSyntaxExpr e [Var var]
+ ; return (mkViewMatchResult var' e' match_result) }
+matchOverloadedList _ _ _ = panic "matchOverloadedList"
+
+-- decompose the first pattern and leave the rest alone
+decomposeFirstPat :: (Pat Id -> Pat Id) -> EquationInfo -> EquationInfo
+decomposeFirstPat extractpat (eqn@(EqnInfo { eqn_pats = pat : pats }))
+ = eqn { eqn_pats = extractpat pat : pats}
+decomposeFirstPat _ _ = panic "decomposeFirstPat"
+
+getCoPat, getBangPat, getViewPat, getOLPat :: Pat Id -> Pat Id
+getCoPat (CoPat _ pat _) = pat
+getCoPat _ = panic "getCoPat"
+getBangPat (BangPat pat ) = unLoc pat
+getBangPat _ = panic "getBangPat"
+getViewPat (ViewPat _ pat _) = unLoc pat
+getViewPat _ = panic "getViewPat"
+getOLPat (ListPat pats ty (Just _)) = ListPat pats ty Nothing
+getOLPat _ = panic "getOLPat"
+
+{-
+Note [Empty case alternatives]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The list of EquationInfo can be empty, arising from
+ case x of {} or \case {}
+In that situation we desugar to
+ case x of { _ -> error "pattern match failure" }
+The *desugarer* isn't certain whether there really should be no
+alternatives, so it adds a default case, as it always does. A later
+pass may remove it if it's inaccessible. (See also Note [Empty case
+alternatives] in CoreSyn.)
+
+We do *not* desugar simply to
+ error "empty case"
+or some such, because 'x' might be bound to (error "hello"), in which
+case we want to see that "hello" exception, not (error "empty case").
+See also Note [Case elimination: lifted case] in Simplify.
+
+
+************************************************************************
+* *
+ Tidying patterns
+* *
+************************************************************************
+
+Tidy up the leftmost pattern in an @EquationInfo@, given the variable @v@
+which will be scrutinised. This means:
+\begin{itemize}
+\item
+Replace variable patterns @x@ (@x /= v@) with the pattern @_@,
+together with the binding @x = v@.
+\item
+Replace the `as' pattern @x@@p@ with the pattern p and a binding @x = v@.
+\item
+Removing lazy (irrefutable) patterns (you don't want to know...).
+\item
+Converting explicit tuple-, list-, and parallel-array-pats into ordinary
+@ConPats@.
+\item
+Convert the literal pat "" to [].
+\end{itemize}
+
+The result of this tidying is that the column of patterns will include
+{\em only}:
+\begin{description}
+\item[@WildPats@:]
+The @VarPat@ information isn't needed any more after this.
+
+\item[@ConPats@:]
+@ListPats@, @TuplePats@, etc., are all converted into @ConPats@.
+
+\item[@LitPats@ and @NPats@:]
+@LitPats@/@NPats@ of ``known friendly types'' (Int, Char,
+Float, Double, at least) are converted to unboxed form; e.g.,
+\tr{(NPat (HsInt i) _ _)} is converted to:
+\begin{verbatim}
+(ConPat I# _ _ [LitPat (HsIntPrim i)])
+\end{verbatim}
+\end{description}
+-}
+
+tidyEqnInfo :: Id -> EquationInfo
+ -> DsM (DsWrapper, EquationInfo)
+ -- DsM'd because of internal call to dsLHsBinds
+ -- and mkSelectorBinds.
+ -- "tidy1" does the interesting stuff, looking at
+ -- one pattern and fiddling the list of bindings.
+ --
+ -- POST CONDITION: head pattern in the EqnInfo is
+ -- WildPat
+ -- ConPat
+ -- NPat
+ -- LitPat
+ -- NPlusKPat
+ -- but no other
+
+tidyEqnInfo _ (EqnInfo { eqn_pats = [] })
+ = panic "tidyEqnInfo"
+
+tidyEqnInfo v eqn@(EqnInfo { eqn_pats = pat : pats })
+ = do { (wrap, pat') <- tidy1 v pat
+ ; return (wrap, eqn { eqn_pats = do pat' : pats }) }
+
+tidy1 :: Id -- The Id being scrutinised
+ -> Pat Id -- The pattern against which it is to be matched
+ -> DsM (DsWrapper, -- Extra bindings to do before the match
+ Pat Id) -- Equivalent pattern
+
+-------------------------------------------------------
+-- (pat', mr') = tidy1 v pat mr
+-- tidies the *outer level only* of pat, giving pat'
+-- It eliminates many pattern forms (as-patterns, variable patterns,
+-- list patterns, etc) yielding one of:
+-- WildPat
+-- ConPatOut
+-- LitPat
+-- NPat
+-- NPlusKPat
+
+tidy1 v (ParPat pat) = tidy1 v (unLoc pat)
+tidy1 v (SigPatOut pat _) = tidy1 v (unLoc pat)
+tidy1 _ (WildPat ty) = return (idDsWrapper, WildPat ty)
+tidy1 v (BangPat (L l p)) = tidy_bang_pat v l p
+
+ -- case v of { x -> mr[] }
+ -- = case v of { _ -> let x=v in mr[] }
+tidy1 v (VarPat (L _ var))
+ = return (wrapBind var v, WildPat (idType var))
+
+ -- case v of { x@p -> mr[] }
+ -- = case v of { p -> let x=v in mr[] }
+tidy1 v (AsPat (L _ var) pat)
+ = do { (wrap, pat') <- tidy1 v (unLoc pat)
+ ; return (wrapBind var v . wrap, pat') }
+
+{- now, here we handle lazy patterns:
+ tidy1 v ~p bs = (v, v1 = case v of p -> v1 :
+ v2 = case v of p -> v2 : ... : bs )
+
+ where the v_i's are the binders in the pattern.
+
+ ToDo: in "v_i = ... -> v_i", are the v_i's really the same thing?
+
+ The case expr for v_i is just: match [v] [(p, [], \ x -> Var v_i)] any_expr
+-}
+
+tidy1 v (LazyPat pat)
+ -- This is a convenient place to check for unlifted types under a lazy pattern.
+ -- Doing this check during type-checking is unsatisfactory because we may
+ -- not fully know the zonked types yet. We sure do here.
+ = do { let unlifted_bndrs = filter (isUnliftedType . idType) (collectPatBinders pat)
+ ; unless (null unlifted_bndrs) $
+ putSrcSpanDs (getLoc pat) $
+ errDs (hang (text "A lazy (~) pattern cannot bind variables of unlifted type." $$
+ text "Unlifted variables:")
+ 2 (vcat (map (\id -> ppr id <+> dcolon <+> ppr (idType id))
+ unlifted_bndrs)))
+
+ ; (_,sel_prs) <- mkSelectorBinds [] pat (Var v)
+ ; let sel_binds = [NonRec b rhs | (b,rhs) <- sel_prs]
+ ; return (mkCoreLets sel_binds, WildPat (idType v)) }
+
+tidy1 _ (ListPat pats ty Nothing)
+ = return (idDsWrapper, unLoc list_ConPat)
+ where
+ list_ConPat = foldr (\ x y -> mkPrefixConPat consDataCon [x, y] [ty])
+ (mkNilPat ty)
+ pats
+
+-- Introduce fake parallel array constructors to be able to handle parallel
+-- arrays with the existing machinery for constructor pattern
+tidy1 _ (PArrPat pats ty)
+ = return (idDsWrapper, unLoc parrConPat)
+ where
+ arity = length pats
+ parrConPat = mkPrefixConPat (parrFakeCon arity) pats [ty]
+
+tidy1 _ (TuplePat pats boxity tys)
+ = return (idDsWrapper, unLoc tuple_ConPat)
+ where
+ arity = length pats
+ tuple_ConPat = mkPrefixConPat (tupleDataCon boxity arity) pats tys
+
+tidy1 _ (SumPat pat alt arity tys)
+ = return (idDsWrapper, unLoc sum_ConPat)
+ where
+ sum_ConPat = mkPrefixConPat (sumDataCon alt arity) [pat] tys
+
+-- LitPats: we *might* be able to replace these w/ a simpler form
+tidy1 _ (LitPat lit)
+ = return (idDsWrapper, tidyLitPat lit)
+
+-- NPats: we *might* be able to replace these w/ a simpler form
+tidy1 _ (NPat (L _ lit) mb_neg eq ty)
+ = return (idDsWrapper, tidyNPat tidyLitPat lit mb_neg eq ty)
+
+-- Everything else goes through unchanged...
+
+tidy1 _ non_interesting_pat
+ = return (idDsWrapper, non_interesting_pat)
+
+--------------------
+tidy_bang_pat :: Id -> SrcSpan -> Pat Id -> DsM (DsWrapper, Pat Id)
+
+-- Discard par/sig under a bang
+tidy_bang_pat v _ (ParPat (L l p)) = tidy_bang_pat v l p
+tidy_bang_pat v _ (SigPatOut (L l p) _) = tidy_bang_pat v l p
+
+-- Push the bang-pattern inwards, in the hope that
+-- it may disappear next time
+tidy_bang_pat v l (AsPat v' p) = tidy1 v (AsPat v' (L l (BangPat p)))
+tidy_bang_pat v l (CoPat w p t) = tidy1 v (CoPat w (BangPat (L l p)) t)
+
+-- Discard bang around strict pattern
+tidy_bang_pat v _ p@(LitPat {}) = tidy1 v p
+tidy_bang_pat v _ p@(ListPat {}) = tidy1 v p
+tidy_bang_pat v _ p@(TuplePat {}) = tidy1 v p
+tidy_bang_pat v _ p@(SumPat {}) = tidy1 v p
+tidy_bang_pat v _ p@(PArrPat {}) = tidy1 v p
+
+-- Data/newtype constructors
+tidy_bang_pat v l p@(ConPatOut { pat_con = L _ (RealDataCon dc)
+ , pat_args = args
+ , pat_arg_tys = arg_tys })
+ -- Newtypes: push bang inwards (Trac #9844)
+ =
+ if isNewTyCon (dataConTyCon dc)
+ then tidy1 v (p { pat_args = push_bang_into_newtype_arg l ty args })
+ else tidy1 v p -- Data types: discard the bang
+ where
+ (ty:_) = dataConInstArgTys dc arg_tys
+
+-------------------
+-- Default case, leave the bang there:
+-- VarPat,
+-- LazyPat,
+-- WildPat,
+-- ViewPat,
+-- pattern synonyms (ConPatOut with PatSynCon)
+-- NPat,
+-- NPlusKPat
+--
+-- For LazyPat, remember that it's semantically like a VarPat
+-- i.e. !(~p) is not like ~p, or p! (Trac #8952)
+--
+-- NB: SigPatIn, ConPatIn should not happen
+
+tidy_bang_pat _ l p = return (idDsWrapper, BangPat (L l p))
+
+-------------------
+push_bang_into_newtype_arg :: SrcSpan
+ -> Type -- The type of the argument we are pushing
+ -- onto
+ -> HsConPatDetails Id -> HsConPatDetails Id
+-- See Note [Bang patterns and newtypes]
+-- We are transforming !(N p) into (N !p)
+push_bang_into_newtype_arg l _ty (PrefixCon (arg:args))
+ = ASSERT( null args)
+ PrefixCon [L l (BangPat arg)]
+push_bang_into_newtype_arg l _ty (RecCon rf)
+ | HsRecFields { rec_flds = L lf fld : flds } <- rf
+ , HsRecField { hsRecFieldArg = arg } <- fld
+ = ASSERT( null flds)
+ RecCon (rf { rec_flds = [L lf (fld { hsRecFieldArg = L l (BangPat arg) })] })
+push_bang_into_newtype_arg l ty (RecCon rf) -- If a user writes !(T {})
+ | HsRecFields { rec_flds = [] } <- rf
+ = PrefixCon [L l (BangPat (noLoc (WildPat ty)))]
+push_bang_into_newtype_arg _ _ cd
+ = pprPanic "push_bang_into_newtype_arg" (pprConArgs cd)
+
+{-
+Note [Bang patterns and newtypes]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For the pattern !(Just pat) we can discard the bang, because
+the pattern is strict anyway. But for !(N pat), where
+ newtype NT = N Int
+we definitely can't discard the bang. Trac #9844.
+
+So what we do is to push the bang inwards, in the hope that it will
+get discarded there. So we transform
+ !(N pat) into (N !pat)
+
+But what if there is nothing to push the bang onto? In at least one instance
+a user has written !(N {}) which we translate into (N !_). See #13215
+
+
+\noindent
+{\bf Previous @matchTwiddled@ stuff:}
+
+Now we get to the only interesting part; note: there are choices for
+translation [from Simon's notes]; translation~1:
+\begin{verbatim}
+deTwiddle [s,t] e
+\end{verbatim}
+returns
+\begin{verbatim}
+[ w = e,
+ s = case w of [s,t] -> s
+ t = case w of [s,t] -> t
+]
+\end{verbatim}
+
+Here \tr{w} is a fresh variable, and the \tr{w}-binding prevents multiple
+evaluation of \tr{e}. An alternative translation (No.~2):
+\begin{verbatim}
+[ w = case e of [s,t] -> (s,t)
+ s = case w of (s,t) -> s
+ t = case w of (s,t) -> t
+]
+\end{verbatim}
+
+************************************************************************
+* *
+\subsubsection[improved-unmixing]{UNIMPLEMENTED idea for improved unmixing}
+* *
+************************************************************************
+
+We might be able to optimise unmixing when confronted by
+only-one-constructor-possible, of which tuples are the most notable
+examples. Consider:
+\begin{verbatim}
+f (a,b,c) ... = ...
+f d ... (e:f) = ...
+f (g,h,i) ... = ...
+f j ... = ...
+\end{verbatim}
+This definition would normally be unmixed into four equation blocks,
+one per equation. But it could be unmixed into just one equation
+block, because if the one equation matches (on the first column),
+the others certainly will.
+
+You have to be careful, though; the example
+\begin{verbatim}
+f j ... = ...
+-------------------
+f (a,b,c) ... = ...
+f d ... (e:f) = ...
+f (g,h,i) ... = ...
+\end{verbatim}
+{\em must} be broken into two blocks at the line shown; otherwise, you
+are forcing unnecessary evaluation. In any case, the top-left pattern
+always gives the cue. You could then unmix blocks into groups of...
+\begin{description}
+\item[all variables:]
+As it is now.
+\item[constructors or variables (mixed):]
+Need to make sure the right names get bound for the variable patterns.
+\item[literals or variables (mixed):]
+Presumably just a variant on the constructor case (as it is now).
+\end{description}
+
+************************************************************************
+* *
+* matchWrapper: a convenient way to call @match@ *
+* *
+************************************************************************
+\subsection[matchWrapper]{@matchWrapper@: a convenient interface to @match@}
+
+Calls to @match@ often involve similar (non-trivial) work; that work
+is collected here, in @matchWrapper@. This function takes as
+arguments:
+\begin{itemize}
+\item
+Typchecked @Matches@ (of a function definition, or a case or lambda
+expression)---the main input;
+\item
+An error message to be inserted into any (runtime) pattern-matching
+failure messages.
+\end{itemize}
+
+As results, @matchWrapper@ produces:
+\begin{itemize}
+\item
+A list of variables (@Locals@) that the caller must ``promise'' to
+bind to appropriate values; and
+\item
+a @CoreExpr@, the desugared output (main result).
+\end{itemize}
+
+The main actions of @matchWrapper@ include:
+\begin{enumerate}
+\item
+Flatten the @[TypecheckedMatch]@ into a suitable list of
+@EquationInfo@s.
+\item
+Create as many new variables as there are patterns in a pattern-list
+(in any one of the @EquationInfo@s).
+\item
+Create a suitable ``if it fails'' expression---a call to @error@ using
+the error-string input; the {\em type} of this fail value can be found
+by examining one of the RHS expressions in one of the @EquationInfo@s.
+\item
+Call @match@ with all of this information!
+\end{enumerate}
+-}
+
+matchWrapper :: HsMatchContext Name -- For shadowing warning messages
+ -> Maybe (LHsExpr Id) -- The scrutinee, if we check a case expr
+ -> MatchGroup Id (LHsExpr Id) -- Matches being desugared
+ -> DsM ([Id], CoreExpr) -- Results
+
+{-
+ There is one small problem with the Lambda Patterns, when somebody
+ writes something similar to:
+\begin{verbatim}
+ (\ (x:xs) -> ...)
+\end{verbatim}
+ he/she don't want a warning about incomplete patterns, that is done with
+ the flag @opt_WarnSimplePatterns@.
+ This problem also appears in the:
+\begin{itemize}
+\item @do@ patterns, but if the @do@ can fail
+ it creates another equation if the match can fail
+ (see @DsExpr.doDo@ function)
+\item @let@ patterns, are treated by @matchSimply@
+ List Comprension Patterns, are treated by @matchSimply@ also
+\end{itemize}
+
+We can't call @matchSimply@ with Lambda patterns,
+due to the fact that lambda patterns can have more than
+one pattern, and match simply only accepts one pattern.
+
+JJQC 30-Nov-1997
+-}
+
+matchWrapper ctxt mb_scr (MG { mg_alts = L _ matches
+ , mg_arg_tys = arg_tys
+ , mg_res_ty = rhs_ty
+ , mg_origin = origin })
+ = do { dflags <- getDynFlags
+ ; locn <- getSrcSpanDs
+
+ ; new_vars <- case matches of
+ [] -> mapM newSysLocalDsNoLP arg_tys
+ (m:_) -> selectMatchVars (map unLoc (hsLMatchPats m))
+
+ ; eqns_info <- mapM (mk_eqn_info new_vars) matches
+
+ -- pattern match check warnings
+ ; unless (isGenerated origin) $
+ when (isAnyPmCheckEnabled dflags (DsMatchContext ctxt locn)) $
+ addTmCsDs (genCaseTmCs1 mb_scr new_vars) $
+ -- See Note [Type and Term Equality Propagation]
+ checkMatches dflags (DsMatchContext ctxt locn) new_vars matches
+
+ ; result_expr <- handleWarnings $
+ matchEquations ctxt new_vars eqns_info rhs_ty
+ ; return (new_vars, result_expr) }
+ where
+ mk_eqn_info vars (L _ (Match ctx pats _ grhss))
+ = do { dflags <- getDynFlags
+ ; let add_bang
+ | FunRhs {mc_strictness=SrcStrict} <- ctx
+ = pprTrace "addBang" empty addBang
+ | otherwise
+ = decideBangHood dflags
+ upats = map (unLoc . add_bang) pats
+ dicts = toTcTypeBag (collectEvVarsPats upats) -- Only TcTyVars
+ ; tm_cs <- genCaseTmCs2 mb_scr upats vars
+ ; match_result <- addDictsDs dicts $ -- See Note [Type and Term Equality Propagation]
+ addTmCsDs tm_cs $ -- See Note [Type and Term Equality Propagation]
+ dsGRHSs ctxt upats grhss rhs_ty
+ ; return (EqnInfo { eqn_pats = upats, eqn_rhs = match_result}) }
+
+ handleWarnings = if isGenerated origin
+ then discardWarningsDs
+ else id
+
+
+matchEquations :: HsMatchContext Name
+ -> [MatchId] -> [EquationInfo] -> Type
+ -> DsM CoreExpr
+matchEquations ctxt vars eqns_info rhs_ty
+ = do { let error_doc = matchContextErrString ctxt
+
+ ; match_result <- match vars rhs_ty eqns_info
+
+ ; fail_expr <- mkErrorAppDs pAT_ERROR_ID rhs_ty error_doc
+ ; extractMatchResult match_result fail_expr }
+
+{-
+************************************************************************
+* *
+\subsection[matchSimply]{@matchSimply@: match a single expression against a single pattern}
+* *
+************************************************************************
+
+@mkSimpleMatch@ is a wrapper for @match@ which deals with the
+situation where we want to match a single expression against a single
+pattern. It returns an expression.
+-}
+
+matchSimply :: CoreExpr -- Scrutinee
+ -> HsMatchContext Name -- Match kind
+ -> LPat Id -- Pattern it should match
+ -> CoreExpr -- Return this if it matches
+ -> CoreExpr -- Return this if it doesn't
+ -> DsM CoreExpr
+-- Do not warn about incomplete patterns; see matchSinglePat comments
+matchSimply scrut hs_ctx pat result_expr fail_expr = do
+ let
+ match_result = cantFailMatchResult result_expr
+ rhs_ty = exprType fail_expr
+ -- Use exprType of fail_expr, because won't refine in the case of failure!
+ match_result' <- matchSinglePat scrut hs_ctx pat rhs_ty match_result
+ extractMatchResult match_result' fail_expr
+
+matchSinglePat :: CoreExpr -> HsMatchContext Name -> LPat Id
+ -> Type -> MatchResult -> DsM MatchResult
+-- matchSinglePat ensures that the scrutinee is a variable
+-- and then calls match_single_pat_var
+--
+-- matchSinglePat does not warn about incomplete patterns
+-- Used for things like [ e | pat <- stuff ], where
+-- incomplete patterns are just fine
+
+matchSinglePat (Var var) ctx pat ty match_result
+ | not (isExternalName (idName var))
+ = match_single_pat_var var ctx pat ty match_result
+
+matchSinglePat scrut hs_ctx pat ty match_result
+ = do { var <- selectSimpleMatchVarL pat
+ ; match_result' <- match_single_pat_var var hs_ctx pat ty match_result
+ ; return (adjustMatchResult (bindNonRec var scrut) match_result') }
+
+match_single_pat_var :: Id -- See Note [Match Ids]
+ -> HsMatchContext Name -> LPat Id
+ -> Type -> MatchResult -> DsM MatchResult
+match_single_pat_var var ctx pat ty match_result
+ = ASSERT2( isInternalName (idName var), ppr var )
+ do { dflags <- getDynFlags
+ ; locn <- getSrcSpanDs
+
+ -- Pattern match check warnings
+ ; checkSingle dflags (DsMatchContext ctx locn) var (unLoc pat)
+
+ ; let eqn_info = EqnInfo { eqn_pats = [unLoc (decideBangHood dflags pat)]
+ , eqn_rhs = match_result }
+ ; match [var] ty [eqn_info] }
+
+
+{-
+************************************************************************
+* *
+ Pattern classification
+* *
+************************************************************************
+-}
+
+data PatGroup
+ = PgAny -- Immediate match: variables, wildcards,
+ -- lazy patterns
+ | PgCon DataCon -- Constructor patterns (incl list, tuple)
+ | PgSyn PatSyn [Type] -- See Note [Pattern synonym groups]
+ | PgLit Literal -- Literal patterns
+ | PgN Rational -- Overloaded numeric literals;
+ -- see Note [Don't use Literal for PgN]
+ | PgOverS FastString -- Overloaded string literals
+ | PgNpK Integer -- n+k patterns
+ | PgBang -- Bang patterns
+ | PgCo Type -- Coercion patterns; the type is the type
+ -- of the pattern *inside*
+ | PgView (LHsExpr Id) -- view pattern (e -> p):
+ -- the LHsExpr is the expression e
+ Type -- the Type is the type of p (equivalently, the result type of e)
+ | PgOverloadedList
+
+{- Note [Don't use Literal for PgN]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Previously we had, as PatGroup constructors
+
+ | ...
+ | PgN Literal -- Overloaded literals
+ | PgNpK Literal -- n+k patterns
+ | ...
+
+But Literal is really supposed to represent an *unboxed* literal, like Int#.
+We were sticking the literal from, say, an overloaded numeric literal pattern
+into a MachInt constructor. This didn't really make sense; and we now have
+the invariant that value in a MachInt must be in the range of the target
+machine's Int# type, and an overloaded literal could meaningfully be larger.
+
+Solution: For pattern grouping purposes, just store the literal directly in
+the PgN constructor as a Rational if numeric, and add a PgOverStr constructor
+for overloaded strings.
+-}
+
+groupEquations :: DynFlags -> [EquationInfo] -> [[(PatGroup, EquationInfo)]]
+-- If the result is of form [g1, g2, g3],
+-- (a) all the (pg,eq) pairs in g1 have the same pg
+-- (b) none of the gi are empty
+-- The ordering of equations is unchanged
+groupEquations dflags eqns
+ = runs same_gp [(patGroup dflags (firstPat eqn), eqn) | eqn <- eqns]
+ where
+ same_gp :: (PatGroup,EquationInfo) -> (PatGroup,EquationInfo) -> Bool
+ (pg1,_) `same_gp` (pg2,_) = pg1 `sameGroup` pg2
+
+subGroup :: (m -> [[EquationInfo]]) -- Map.elems
+ -> m -- Map.empty
+ -> (a -> m -> Maybe [EquationInfo]) -- Map.lookup
+ -> (a -> [EquationInfo] -> m -> m) -- Map.insert
+ -> [(a, EquationInfo)] -> [[EquationInfo]]
+-- Input is a particular group. The result sub-groups the
+-- equations by with particular constructor, literal etc they match.
+-- Each sub-list in the result has the same PatGroup
+-- See Note [Take care with pattern order]
+-- Parameterized by map operations to allow different implementations
+-- and constraints, eg. types without Ord instance.
+subGroup elems empty lookup insert group
+ = map reverse $ elems $ foldl accumulate empty group
+ where
+ accumulate pg_map (pg, eqn)
+ = case lookup pg pg_map of
+ Just eqns -> insert pg (eqn:eqns) pg_map
+ Nothing -> insert pg [eqn] pg_map
+ -- pg_map :: Map a [EquationInfo]
+ -- Equations seen so far in reverse order of appearance
+
+subGroupOrd :: Ord a => [(a, EquationInfo)] -> [[EquationInfo]]
+subGroupOrd = subGroup Map.elems Map.empty Map.lookup Map.insert
+
+subGroupUniq :: Uniquable a => [(a, EquationInfo)] -> [[EquationInfo]]
+subGroupUniq =
+ subGroup eltsUDFM emptyUDFM (flip lookupUDFM) (\k v m -> addToUDFM m k v)
+
+{- Note [Pattern synonym groups]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If we see
+ f (P a) = e1
+ f (P b) = e2
+ ...
+where P is a pattern synonym, can we put (P a -> e1) and (P b -> e2) in the
+same group? We can if P is a constructor, but /not/ if P is a pattern synonym.
+Consider (Trac #11224)
+ -- readMaybe :: Read a => String -> Maybe a
+ pattern PRead :: Read a => () => a -> String
+ pattern PRead a <- (readMaybe -> Just a)
+
+ f (PRead (x::Int)) = e1
+ f (PRead (y::Bool)) = e2
+This is all fine: we match the string by trying to read an Int; if that
+fails we try to read a Bool. But clearly we can't combine the two into a single
+match.
+
+Conclusion: we can combine when we invoke PRead /at the same type/. Hence
+in PgSyn we record the instantiaing types, and use them in sameGroup.
+
+Note [Take care with pattern order]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In the subGroup function we must be very careful about pattern re-ordering,
+Consider the patterns [ (True, Nothing), (False, x), (True, y) ]
+Then in bringing together the patterns for True, we must not
+swap the Nothing and y!
+-}
+
+sameGroup :: PatGroup -> PatGroup -> Bool
+-- Same group means that a single case expression
+-- or test will suffice to match both, *and* the order
+-- of testing within the group is insignificant.
+sameGroup PgAny PgAny = True
+sameGroup PgBang PgBang = True
+sameGroup (PgCon _) (PgCon _) = True -- One case expression
+sameGroup (PgSyn p1 t1) (PgSyn p2 t2) = p1==p2 && eqTypes t1 t2
+ -- eqTypes: See Note [Pattern synonym groups]
+sameGroup (PgLit _) (PgLit _) = True -- One case expression
+sameGroup (PgN l1) (PgN l2) = l1==l2 -- Order is significant
+sameGroup (PgOverS s1) (PgOverS s2) = s1==s2
+sameGroup (PgNpK l1) (PgNpK l2) = l1==l2 -- See Note [Grouping overloaded literal patterns]
+sameGroup (PgCo t1) (PgCo t2) = t1 `eqType` t2
+ -- CoPats are in the same goup only if the type of the
+ -- enclosed pattern is the same. The patterns outside the CoPat
+ -- always have the same type, so this boils down to saying that
+ -- the two coercions are identical.
+sameGroup (PgView e1 t1) (PgView e2 t2) = viewLExprEq (e1,t1) (e2,t2)
+ -- ViewPats are in the same group iff the expressions
+ -- are "equal"---conservatively, we use syntactic equality
+sameGroup _ _ = False
+
+-- An approximation of syntactic equality used for determining when view
+-- exprs are in the same group.
+-- This function can always safely return false;
+-- but doing so will result in the application of the view function being repeated.
+--
+-- Currently: compare applications of literals and variables
+-- and anything else that we can do without involving other
+-- HsSyn types in the recursion
+--
+-- NB we can't assume that the two view expressions have the same type. Consider
+-- f (e1 -> True) = ...
+-- f (e2 -> "hi") = ...
+viewLExprEq :: (LHsExpr Id,Type) -> (LHsExpr Id,Type) -> Bool
+viewLExprEq (e1,_) (e2,_) = lexp e1 e2
+ where
+ lexp :: LHsExpr Id -> LHsExpr Id -> Bool
+ lexp e e' = exp (unLoc e) (unLoc e')
+
+ ---------
+ exp :: HsExpr Id -> HsExpr Id -> Bool
+ -- real comparison is on HsExpr's
+ -- strip parens
+ exp (HsPar (L _ e)) e' = exp e e'
+ exp e (HsPar (L _ e')) = exp e e'
+ -- because the expressions do not necessarily have the same type,
+ -- we have to compare the wrappers
+ exp (HsWrap h e) (HsWrap h' e') = wrap h h' && exp e e'
+ exp (HsVar i) (HsVar i') = i == i'
+ exp (HsConLikeOut c) (HsConLikeOut c') = c == c'
+ -- the instance for IPName derives using the id, so this works if the
+ -- above does
+ exp (HsIPVar i) (HsIPVar i') = i == i'
+ exp (HsOverLabel l x) (HsOverLabel l' x') = l == l' && x == x'
+ exp (HsOverLit l) (HsOverLit l') =
+ -- Overloaded lits are equal if they have the same type
+ -- and the data is the same.
+ -- this is coarser than comparing the SyntaxExpr's in l and l',
+ -- which resolve the overloading (e.g., fromInteger 1),
+ -- because these expressions get written as a bunch of different variables
+ -- (presumably to improve sharing)
+ eqType (overLitType l) (overLitType l') && l == l'
+ exp (HsApp e1 e2) (HsApp e1' e2') = lexp e1 e1' && lexp e2 e2'
+ -- the fixities have been straightened out by now, so it's safe
+ -- to ignore them?
+ exp (OpApp l o _ ri) (OpApp l' o' _ ri') =
+ lexp l l' && lexp o o' && lexp ri ri'
+ exp (NegApp e n) (NegApp e' n') = lexp e e' && syn_exp n n'
+ exp (SectionL e1 e2) (SectionL e1' e2') =
+ lexp e1 e1' && lexp e2 e2'
+ exp (SectionR e1 e2) (SectionR e1' e2') =
+ lexp e1 e1' && lexp e2 e2'
+ exp (ExplicitTuple es1 _) (ExplicitTuple es2 _) =
+ eq_list tup_arg es1 es2
+ exp (ExplicitSum _ _ e _) (ExplicitSum _ _ e' _) = lexp e e'
+ exp (HsIf _ e e1 e2) (HsIf _ e' e1' e2') =
+ lexp e e' && lexp e1 e1' && lexp e2 e2'
+
+ -- Enhancement: could implement equality for more expressions
+ -- if it seems useful
+ -- But no need for HsLit, ExplicitList, ExplicitTuple,
+ -- because they cannot be functions
+ exp _ _ = False
+
+ ---------
+ syn_exp :: SyntaxExpr Id -> SyntaxExpr Id -> Bool
+ syn_exp (SyntaxExpr { syn_expr = expr1
+ , syn_arg_wraps = arg_wraps1
+ , syn_res_wrap = res_wrap1 })
+ (SyntaxExpr { syn_expr = expr2
+ , syn_arg_wraps = arg_wraps2
+ , syn_res_wrap = res_wrap2 })
+ = exp expr1 expr2 &&
+ and (zipWithEqual "viewLExprEq" wrap arg_wraps1 arg_wraps2) &&
+ wrap res_wrap1 res_wrap2
+
+ ---------
+ tup_arg (L _ (Present e1)) (L _ (Present e2)) = lexp e1 e2
+ tup_arg (L _ (Missing t1)) (L _ (Missing t2)) = eqType t1 t2
+ tup_arg _ _ = False
+
+ ---------
+ wrap :: HsWrapper -> HsWrapper -> Bool
+ -- Conservative, in that it demands that wrappers be
+ -- syntactically identical and doesn't look under binders
+ --
+ -- Coarser notions of equality are possible
+ -- (e.g., reassociating compositions,
+ -- equating different ways of writing a coercion)
+ wrap WpHole WpHole = True
+ wrap (WpCompose w1 w2) (WpCompose w1' w2') = wrap w1 w1' && wrap w2 w2'
+ wrap (WpFun w1 w2 _ _) (WpFun w1' w2' _ _) = wrap w1 w1' && wrap w2 w2'
+ wrap (WpCast co) (WpCast co') = co `eqCoercion` co'
+ wrap (WpEvApp et1) (WpEvApp et2) = et1 `ev_term` et2
+ wrap (WpTyApp t) (WpTyApp t') = eqType t t'
+ -- Enhancement: could implement equality for more wrappers
+ -- if it seems useful (lams and lets)
+ wrap _ _ = False
+
+ ---------
+ ev_term :: EvTerm -> EvTerm -> Bool
+ ev_term (EvId a) (EvId b) = a==b
+ ev_term (EvCoercion a) (EvCoercion b) = a `eqCoercion` b
+ ev_term _ _ = False
+
+ ---------
+ eq_list :: (a->a->Bool) -> [a] -> [a] -> Bool
+ eq_list _ [] [] = True
+ eq_list _ [] (_:_) = False
+ eq_list _ (_:_) [] = False
+ eq_list eq (x:xs) (y:ys) = eq x y && eq_list eq xs ys
+
+patGroup :: DynFlags -> Pat Id -> PatGroup
+patGroup _ (ConPatOut { pat_con = L _ con
+ , pat_arg_tys = tys })
+ | RealDataCon dcon <- con = PgCon dcon
+ | PatSynCon psyn <- con = PgSyn psyn tys
+patGroup _ (WildPat {}) = PgAny
+patGroup _ (BangPat {}) = PgBang
+patGroup _ (NPat (L _ OverLit {ol_val=oval}) mb_neg _ _) =
+ case (oval, isJust mb_neg) of
+ (HsIntegral _ i, False) -> PgN (fromInteger i)
+ (HsIntegral _ i, True ) -> PgN (-fromInteger i)
+ (HsFractional r, False) -> PgN (fl_value r)
+ (HsFractional r, True ) -> PgN (-fl_value r)
+ (HsIsString _ s, _) -> ASSERT(isNothing mb_neg)
+ PgOverS s
+patGroup _ (NPlusKPat _ (L _ OverLit {ol_val=oval}) _ _ _ _) =
+ case oval of
+ HsIntegral _ i -> PgNpK i
+ _ -> pprPanic "patGroup NPlusKPat" (ppr oval)
+patGroup _ (CoPat _ p _) = PgCo (hsPatType p) -- Type of innelexp pattern
+patGroup _ (ViewPat expr p _) = PgView expr (hsPatType (unLoc p))
+patGroup _ (ListPat _ _ (Just _)) = PgOverloadedList
+patGroup dflags (LitPat lit) = PgLit (hsLitKey dflags lit)
+patGroup _ pat = pprPanic "patGroup" (ppr pat)
+
+{-
+Note [Grouping overloaded literal patterns]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+WATCH OUT! Consider
+
+ f (n+1) = ...
+ f (n+2) = ...
+ f (n+1) = ...
+
+We can't group the first and third together, because the second may match
+the same thing as the first. Same goes for *overloaded* literal patterns
+ f 1 True = ...
+ f 2 False = ...
+ f 1 False = ...
+If the first arg matches '1' but the second does not match 'True', we
+cannot jump to the third equation! Because the same argument might
+match '2'!
+Hence we don't regard 1 and 2, or (n+1) and (n+2), as part of the same group.
+-}
diff --git a/deSugar/Match.hs-boot b/deSugar/Match.hs-boot
new file mode 100644
--- /dev/null
+++ b/deSugar/Match.hs-boot
@@ -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
diff --git a/deSugar/MatchCon.hs b/deSugar/MatchCon.hs
new file mode 100644
--- /dev/null
+++ b/deSugar/MatchCon.hs
@@ -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.
+
+-}
diff --git a/deSugar/MatchLit.hs b/deSugar/MatchLit.hs
new file mode 100644
--- /dev/null
+++ b/deSugar/MatchLit.hs
@@ -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
+ else
+
+\end{verbatim}
+-}
+
+matchNPlusKPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
+-- All NPlusKPats, for the *same* literal k
+matchNPlusKPats (var:vars) ty (eqn1:eqns)
+ = do { let NPlusKPat (L _ n1) (L _ lit1) lit2 ge minus _ = firstPat eqn1
+ ; lit1_expr <- dsOverLit lit1
+ ; lit2_expr <- dsOverLit lit2
+ ; pred_expr <- dsSyntaxExpr ge [Var var, lit1_expr]
+ ; minusk_expr <- dsSyntaxExpr minus [Var var, lit2_expr]
+ ; let (wraps, eqns') = mapAndUnzip (shift n1) (eqn1:eqns)
+ ; match_result <- match vars ty eqns'
+ ; return (mkGuardedMatchResult pred_expr $
+ mkCoLetMatchResult (NonRec n1 minusk_expr) $
+ adjustMatchResult (foldr1 (.) wraps) $
+ match_result) }
+ where
+ shift n1 eqn@(EqnInfo { eqn_pats = NPlusKPat (L _ n) _ _ _ _ _ : pats })
+ = (wrapBind n n1, eqn { eqn_pats = pats })
+ -- The wrapBind is a no-op for the first equation
+ shift _ e = pprPanic "matchNPlusKPats/shift" (ppr e)
+
+matchNPlusKPats vars _ eqns = pprPanic "matchNPlusKPats" (ppr (vars, eqns))
diff --git a/deSugar/PmExpr.hs b/deSugar/PmExpr.hs
new file mode 100644
--- /dev/null
+++ b/deSugar/PmExpr.hs
@@ -0,0 +1,449 @@
+{-
+Author: George Karachalias
+
+Haskell expressions (as used by the pattern matching checker) and utilities.
+-}
+
+{-# LANGUAGE CPP #-}
+
+module PmExpr (
+ PmExpr(..), PmLit(..), SimpleEq, ComplexEq, toComplex, eqPmLit,
+ truePmExpr, falsePmExpr, isTruePmExpr, isFalsePmExpr, isNotPmExprOther,
+ lhsExprToPmExpr, hsExprToPmExpr, substComplexEq, filterComplex,
+ pprPmExprWithParens, runPmPprM
+ ) where
+
+#include "HsVersions.h"
+
+import HsSyn
+import Id
+import Name
+import NameSet
+import DataCon
+import ConLike
+import TysWiredIn
+import Outputable
+import Util
+import SrcLoc
+
+import Data.Maybe (mapMaybe)
+import Data.List (groupBy, sortBy, nubBy)
+import Control.Monad.Trans.State.Lazy
+
+{-
+%************************************************************************
+%* *
+ Lifted Expressions
+%* *
+%************************************************************************
+-}
+
+{- Note [PmExprOther in PmExpr]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Since there is no plan to extend the (currently pretty naive) term oracle in
+the near future, instead of playing with the verbose (HsExpr Id), we lift it to
+PmExpr. All expressions the term oracle does not handle are wrapped by the
+constructor PmExprOther. Note that we do not perform substitution in
+PmExprOther. Because of this, we do not even print PmExprOther, since they may
+refer to variables that are otherwise substituted away.
+-}
+
+-- ----------------------------------------------------------------------------
+-- ** Types
+
+-- | Lifted expressions for pattern match checking.
+data PmExpr = PmExprVar Name
+ | PmExprCon ConLike [PmExpr]
+ | PmExprLit PmLit
+ | PmExprEq PmExpr PmExpr -- Syntactic equality
+ | PmExprOther (HsExpr Id) -- Note [PmExprOther in PmExpr]
+
+
+mkPmExprData :: DataCon -> [PmExpr] -> PmExpr
+mkPmExprData dc args = PmExprCon (RealDataCon dc) args
+
+-- | Literals (simple and overloaded ones) for pattern match checking.
+data PmLit = PmSLit HsLit -- simple
+ | PmOLit Bool {- is it negated? -} (HsOverLit Id) -- overloaded
+
+-- | Equality between literals for pattern match checking.
+eqPmLit :: PmLit -> PmLit -> Bool
+eqPmLit (PmSLit l1) (PmSLit l2) = l1 == l2
+eqPmLit (PmOLit b1 l1) (PmOLit b2 l2) = b1 == b2 && l1 == l2
+ -- See Note [Undecidable Equality for Overloaded Literals]
+eqPmLit _ _ = False
+
+{- Note [Undecidable Equality for Overloaded Literals]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Equality on overloaded literals is undecidable in the general case. Consider
+the following example:
+
+ instance Num Bool where
+ ...
+ fromInteger 0 = False -- C-like representation of booleans
+ fromInteger _ = True
+
+ f :: Bool -> ()
+ f 1 = () -- Clause A
+ f 2 = () -- Clause B
+
+Clause B is redundant but to detect this, we should be able to solve the
+constraint: False ~ (fromInteger 2 ~ fromInteger 1) which means that we
+have to look through function `fromInteger`, whose implementation could
+be anything. This poses difficulties for:
+
+1. The expressive power of the check.
+ We cannot expect a reasonable implementation of pattern matching to detect
+ that fromInteger 2 ~ fromInteger 1 is True, unless we unfold function
+ fromInteger. This puts termination at risk and is undecidable in the
+ general case.
+
+2. Performance.
+ Having an unresolved constraint False ~ (fromInteger 2 ~ fromInteger 1)
+ lying around could become expensive really fast. Ticket #11161 illustrates
+ how heavy use of overloaded literals can generate plenty of those
+ constraints, effectively undermining the term oracle's performance.
+
+3. Error nessages/Warnings.
+ What should our message for `f` above be? A reasonable approach would be
+ to issue:
+
+ Pattern matches are (potentially) redundant:
+ f 2 = ... under the assumption that 1 == 2
+
+ but seems to complex and confusing for the user.
+
+We choose to treat overloaded literals that look different as different. The
+impact of this is the following:
+
+ * Redundancy checking is rather conservative, since it cannot see that clause
+ B above is redundant.
+
+ * We have instant equality check for overloaded literals (we do not rely on
+ the term oracle which is rather expensive, both in terms of performance and
+ memory). This significantly improves the performance of functions `covered`
+ `uncovered` and `divergent` in deSugar/Check.hs and effectively addresses
+ #11161.
+
+ * The warnings issued are simpler.
+
+ * We do not play on the safe side, strictly speaking. The assumption that
+ 1 /= 2 makes the redundancy check more conservative but at the same time
+ makes its dual (exhaustiveness check) unsafe. This we can live with, mainly
+ for two reasons:
+ 1. At the moment we do not use the results of the check during compilation
+ where this would be a disaster (could result in runtime errors even if
+ our function was deemed exhaustive).
+ 2. Pattern matcing on literals can never be considered exhaustive unless we
+ have a catch-all clause. Hence, this assumption affects mainly the
+ appearance of the warnings and is, in practice safe.
+-}
+
+nubPmLit :: [PmLit] -> [PmLit]
+nubPmLit = nubBy eqPmLit
+
+-- | Term equalities
+type SimpleEq = (Id, PmExpr) -- We always use this orientation
+type ComplexEq = (PmExpr, PmExpr)
+
+-- | Lift a `SimpleEq` to a `ComplexEq`
+toComplex :: SimpleEq -> ComplexEq
+toComplex (x,e) = (PmExprVar (idName x), e)
+
+-- | Expression `True'
+truePmExpr :: PmExpr
+truePmExpr = mkPmExprData trueDataCon []
+
+-- | Expression `False'
+falsePmExpr :: PmExpr
+falsePmExpr = mkPmExprData falseDataCon []
+
+-- ----------------------------------------------------------------------------
+-- ** Predicates on PmExpr
+
+-- | Check if an expression is lifted or not
+isNotPmExprOther :: PmExpr -> Bool
+isNotPmExprOther (PmExprOther _) = False
+isNotPmExprOther _expr = True
+
+-- | Check whether a literal is negated
+isNegatedPmLit :: PmLit -> Bool
+isNegatedPmLit (PmOLit b _) = b
+isNegatedPmLit _other_lit = False
+
+-- | Check whether a PmExpr is syntactically equal to term `True'.
+isTruePmExpr :: PmExpr -> Bool
+isTruePmExpr (PmExprCon c []) = c == RealDataCon trueDataCon
+isTruePmExpr _other_expr = False
+
+-- | Check whether a PmExpr is syntactically equal to term `False'.
+isFalsePmExpr :: PmExpr -> Bool
+isFalsePmExpr (PmExprCon c []) = c == RealDataCon falseDataCon
+isFalsePmExpr _other_expr = False
+
+-- | Check whether a PmExpr is syntactically e
+isNilPmExpr :: PmExpr -> Bool
+isNilPmExpr (PmExprCon c _) = c == RealDataCon nilDataCon
+isNilPmExpr _other_expr = False
+
+-- | Check whether a PmExpr is syntactically equal to (x == y).
+-- Since (==) is overloaded and can have an arbitrary implementation, we use
+-- the PmExprEq constructor to represent only equalities with non-overloaded
+-- literals where it coincides with a syntactic equality check.
+isPmExprEq :: PmExpr -> Maybe (PmExpr, PmExpr)
+isPmExprEq (PmExprEq e1 e2) = Just (e1,e2)
+isPmExprEq _other_expr = Nothing
+
+-- | Check if a DataCon is (:).
+isConsDataCon :: DataCon -> Bool
+isConsDataCon con = consDataCon == con
+
+-- ----------------------------------------------------------------------------
+-- ** Substitution in PmExpr
+
+-- | We return a boolean along with the expression. Hence, if substitution was
+-- a no-op, we know that the expression still cannot progress.
+substPmExpr :: Name -> PmExpr -> PmExpr -> (PmExpr, Bool)
+substPmExpr x e1 e =
+ case e of
+ PmExprVar z | x == z -> (e1, True)
+ | otherwise -> (e, False)
+ PmExprCon c ps -> let (ps', bs) = mapAndUnzip (substPmExpr x e1) ps
+ in (PmExprCon c ps', or bs)
+ PmExprEq ex ey -> let (ex', bx) = substPmExpr x e1 ex
+ (ey', by) = substPmExpr x e1 ey
+ in (PmExprEq ex' ey', bx || by)
+ _other_expr -> (e, False) -- The rest are terminals (We silently ignore
+ -- Other). See Note [PmExprOther in PmExpr]
+
+-- | Substitute in a complex equality. We return (Left eq) if the substitution
+-- affected the equality or (Right eq) if nothing happened.
+substComplexEq :: Name -> PmExpr -> ComplexEq -> Either ComplexEq ComplexEq
+substComplexEq x e (ex, ey)
+ | bx || by = Left (ex', ey')
+ | otherwise = Right (ex', ey')
+ where
+ (ex', bx) = substPmExpr x e ex
+ (ey', by) = substPmExpr x e ey
+
+-- -----------------------------------------------------------------------
+-- ** Lift source expressions (HsExpr Id) to PmExpr
+
+lhsExprToPmExpr :: LHsExpr Id -> PmExpr
+lhsExprToPmExpr (L _ e) = hsExprToPmExpr e
+
+hsExprToPmExpr :: HsExpr Id -> PmExpr
+
+hsExprToPmExpr (HsVar x) = PmExprVar (idName (unLoc x))
+hsExprToPmExpr (HsConLikeOut c) = PmExprVar (conLikeName c)
+hsExprToPmExpr (HsOverLit olit) = PmExprLit (PmOLit False olit)
+hsExprToPmExpr (HsLit lit) = PmExprLit (PmSLit lit)
+
+hsExprToPmExpr e@(NegApp _ neg_e)
+ | PmExprLit (PmOLit False ol) <- synExprToPmExpr neg_e
+ = PmExprLit (PmOLit True ol)
+ | otherwise = PmExprOther e
+hsExprToPmExpr (HsPar (L _ e)) = hsExprToPmExpr e
+
+hsExprToPmExpr e@(ExplicitTuple ps boxity)
+ | all tupArgPresent ps = mkPmExprData tuple_con tuple_args
+ | otherwise = PmExprOther e
+ where
+ tuple_con = tupleDataCon boxity (length ps)
+ tuple_args = [ lhsExprToPmExpr e | L _ (Present e) <- ps ]
+
+hsExprToPmExpr e@(ExplicitList _elem_ty mb_ol elems)
+ | Nothing <- mb_ol = foldr cons nil (map lhsExprToPmExpr elems)
+ | otherwise = PmExprOther e {- overloaded list: No PmExprApp -}
+ where
+ cons x xs = mkPmExprData consDataCon [x,xs]
+ nil = mkPmExprData nilDataCon []
+
+hsExprToPmExpr (ExplicitPArr _elem_ty elems)
+ = mkPmExprData (parrFakeCon (length elems)) (map lhsExprToPmExpr elems)
+
+
+-- we want this but we would have to make everything monadic :/
+-- ./compiler/deSugar/DsMonad.hs:397:dsLookupDataCon :: Name -> DsM DataCon
+--
+-- hsExprToPmExpr (RecordCon c _ binds) = do
+-- con <- dsLookupDataCon (unLoc c)
+-- args <- mapM lhsExprToPmExpr (hsRecFieldsArgs binds)
+-- return (PmExprCon con args)
+hsExprToPmExpr e@(RecordCon _ _ _ _) = PmExprOther e
+
+hsExprToPmExpr (HsTick _ e) = lhsExprToPmExpr e
+hsExprToPmExpr (HsBinTick _ _ e) = lhsExprToPmExpr e
+hsExprToPmExpr (HsTickPragma _ _ _ e) = lhsExprToPmExpr e
+hsExprToPmExpr (HsSCC _ _ e) = lhsExprToPmExpr e
+hsExprToPmExpr (HsCoreAnn _ _ e) = lhsExprToPmExpr e
+hsExprToPmExpr (ExprWithTySig e _) = lhsExprToPmExpr e
+hsExprToPmExpr (ExprWithTySigOut e _) = lhsExprToPmExpr e
+hsExprToPmExpr (HsWrap _ e) = hsExprToPmExpr e
+hsExprToPmExpr e = PmExprOther e -- the rest are not handled by the oracle
+
+synExprToPmExpr :: SyntaxExpr Id -> PmExpr
+synExprToPmExpr = hsExprToPmExpr . syn_expr -- ignore the wrappers
+
+{-
+%************************************************************************
+%* *
+ Pretty printing
+%* *
+%************************************************************************
+-}
+
+{- 1. Literals
+~~~~~~~~~~~~~~
+Starting with a function definition like:
+
+ f :: Int -> Bool
+ f 5 = True
+ f 6 = True
+
+The uncovered set looks like:
+ { var |> False == (var == 5), False == (var == 6) }
+
+Yet, we would like to print this nicely as follows:
+ x , where x not one of {5,6}
+
+Function `filterComplex' takes the set of residual constraints and packs
+together the negative constraints that refer to the same variable so we can do
+just this. Since these variables will be shown to the programmer, we also give
+them better names (t1, t2, ..), hence the SDoc in PmNegLitCt.
+
+2. Residual Constraints
+~~~~~~~~~~~~~~~~~~~~~~~
+Unhandled constraints that refer to HsExpr are typically ignored by the solver
+(it does not even substitute in HsExpr so they are even printed as wildcards).
+Additionally, the oracle returns a substitution if it succeeds so we apply this
+substitution to the vectors before printing them out (see function `pprOne' in
+Check.hs) to be more precice.
+-}
+
+-- -----------------------------------------------------------------------------
+-- ** Transform residual constraints in appropriate form for pretty printing
+
+type PmNegLitCt = (Name, (SDoc, [PmLit]))
+
+filterComplex :: [ComplexEq] -> [PmNegLitCt]
+filterComplex = zipWith rename nameList . map mkGroup
+ . groupBy name . sortBy order . mapMaybe isNegLitCs
+ where
+ order x y = compare (fst x) (fst y)
+ name x y = fst x == fst y
+ mkGroup l = (fst (head l), nubPmLit $ map snd l)
+ rename new (old, lits) = (old, (new, lits))
+
+ isNegLitCs (e1,e2)
+ | isFalsePmExpr e1, Just (x,y) <- isPmExprEq e2 = isNegLitCs' x y
+ | isFalsePmExpr e2, Just (x,y) <- isPmExprEq e1 = isNegLitCs' x y
+ | otherwise = Nothing
+
+ isNegLitCs' (PmExprVar x) (PmExprLit l) = Just (x, l)
+ isNegLitCs' (PmExprLit l) (PmExprVar x) = Just (x, l)
+ isNegLitCs' _ _ = Nothing
+
+ -- Try nice names p,q,r,s,t before using the (ugly) t_i
+ nameList :: [SDoc]
+ nameList = map text ["p","q","r","s","t"] ++
+ [ text ('t':show u) | u <- [(0 :: Int)..] ]
+
+-- ----------------------------------------------------------------------------
+
+runPmPprM :: PmPprM a -> [PmNegLitCt] -> (a, [(SDoc,[PmLit])])
+runPmPprM m lit_env = (result, mapMaybe is_used lit_env)
+ where
+ (result, (_lit_env, used)) = runState m (lit_env, emptyNameSet)
+
+ is_used (x,(name, lits))
+ | elemNameSet x used = Just (name, lits)
+ | otherwise = Nothing
+
+type PmPprM a = State ([PmNegLitCt], NameSet) a
+-- (the first part of the state is read only. make it a reader?)
+
+addUsed :: Name -> PmPprM ()
+addUsed x = modify (\(negated, used) -> (negated, extendNameSet used x))
+
+checkNegation :: Name -> PmPprM (Maybe SDoc) -- the clean name if it is negated
+checkNegation x = do
+ negated <- gets fst
+ return $ case lookup x negated of
+ Just (new, _) -> Just new
+ Nothing -> Nothing
+
+-- | Pretty print a pmexpr, but remember to prettify the names of the variables
+-- that refer to neg-literals. The ones that cannot be shown are printed as
+-- underscores.
+pprPmExpr :: PmExpr -> PmPprM SDoc
+pprPmExpr (PmExprVar x) = do
+ mb_name <- checkNegation x
+ case mb_name of
+ Just name -> addUsed x >> return name
+ Nothing -> return underscore
+
+pprPmExpr (PmExprCon con args) = pprPmExprCon con args
+pprPmExpr (PmExprLit l) = return (ppr l)
+pprPmExpr (PmExprEq _ _) = return underscore -- don't show
+pprPmExpr (PmExprOther _) = return underscore -- don't show
+
+needsParens :: PmExpr -> Bool
+needsParens (PmExprVar {}) = False
+needsParens (PmExprLit l) = isNegatedPmLit l
+needsParens (PmExprEq {}) = False -- will become a wildcard
+needsParens (PmExprOther {}) = False -- will become a wildcard
+needsParens (PmExprCon (RealDataCon c) es)
+ | isTupleDataCon c || isPArrFakeCon c
+ || isConsDataCon c || null es = False
+ | otherwise = True
+needsParens (PmExprCon (PatSynCon _) es) = not (null es)
+
+pprPmExprWithParens :: PmExpr -> PmPprM SDoc
+pprPmExprWithParens expr
+ | needsParens expr = parens <$> pprPmExpr expr
+ | otherwise = pprPmExpr expr
+
+pprPmExprCon :: ConLike -> [PmExpr] -> PmPprM SDoc
+pprPmExprCon (RealDataCon con) args
+ | isTupleDataCon con = mkTuple <$> mapM pprPmExpr args
+ | isPArrFakeCon con = mkPArr <$> mapM pprPmExpr args
+ | isConsDataCon con = pretty_list
+ where
+ mkTuple, mkPArr :: [SDoc] -> SDoc
+ mkTuple = parens . fsep . punctuate comma
+ mkPArr = paBrackets . fsep . punctuate comma
+
+ -- lazily, to be used in the list case only
+ pretty_list :: PmPprM SDoc
+ pretty_list = case isNilPmExpr (last list) of
+ True -> brackets . fsep . punctuate comma <$> mapM pprPmExpr (init list)
+ False -> parens . hcat . punctuate colon <$> mapM pprPmExpr list
+
+ list = list_elements args
+
+ list_elements [x,y]
+ | PmExprCon c es <- y, RealDataCon nilDataCon == c
+ = ASSERT(null es) [x,y]
+ | PmExprCon c es <- y, RealDataCon consDataCon == c
+ = x : list_elements es
+ | otherwise = [x,y]
+ list_elements list = pprPanic "list_elements:" (ppr list)
+pprPmExprCon cl args
+ | conLikeIsInfix cl = case args of
+ [x, y] -> do x' <- pprPmExprWithParens x
+ y' <- pprPmExprWithParens y
+ return (x' <+> ppr cl <+> y')
+ -- can it be infix but have more than two arguments?
+ list -> pprPanic "pprPmExprCon:" (ppr list)
+ | null args = return (ppr cl)
+ | otherwise = do args' <- mapM pprPmExprWithParens args
+ return (fsep (ppr cl : args'))
+
+instance Outputable PmLit where
+ ppr (PmSLit l) = pmPprHsLit l
+ ppr (PmOLit neg l) = (if neg then char '-' else empty) <> ppr l
+
+-- not really useful for pmexprs per se
+instance Outputable PmExpr where
+ ppr e = fst $ runPmPprM (pprPmExpr e) []
diff --git a/deSugar/TmOracle.hs b/deSugar/TmOracle.hs
new file mode 100644
--- /dev/null
+++ b/deSugar/TmOracle.hs
@@ -0,0 +1,257 @@
+{-
+Author: George Karachalias
+
+The term equality oracle. The main export of the module is function `tmOracle'.
+-}
+
+{-# LANGUAGE CPP, MultiWayIf #-}
+
+module TmOracle (
+
+ -- re-exported from PmExpr
+ PmExpr(..), PmLit(..), SimpleEq, ComplexEq, PmVarEnv, falsePmExpr,
+ eqPmLit, filterComplex, isNotPmExprOther, runPmPprM, lhsExprToPmExpr,
+ hsExprToPmExpr, pprPmExprWithParens,
+
+ -- the term oracle
+ tmOracle, TmState, initialTmState, solveOneEq, extendSubst, canDiverge,
+
+ -- misc.
+ toComplex, exprDeepLookup, pmLitType, flattenPmVarEnv
+ ) where
+
+#include "HsVersions.h"
+
+import PmExpr
+
+import Id
+import Name
+import Type
+import HsLit
+import TcHsSyn
+import MonadUtils
+import Util
+
+import NameEnv
+
+{-
+%************************************************************************
+%* *
+ The term equality oracle
+%* *
+%************************************************************************
+-}
+
+-- | The type of substitutions.
+type PmVarEnv = NameEnv PmExpr
+
+-- | The environment of the oracle contains
+-- 1. A Bool (are there any constraints we cannot handle? (PmExprOther)).
+-- 2. A substitution we extend with every step and return as a result.
+type TmOracleEnv = (Bool, PmVarEnv)
+
+-- | Check whether a constraint (x ~ BOT) can succeed,
+-- given the resulting state of the term oracle.
+canDiverge :: Name -> TmState -> Bool
+canDiverge x (standby, (_unhandled, env))
+ -- If the variable seems not evaluated, there is a possibility for
+ -- constraint x ~ BOT to be satisfiable.
+ | PmExprVar y <- varDeepLookup env x -- seems not forced
+ -- If it is involved (directly or indirectly) in any equality in the
+ -- worklist, we can assume that it is already indirectly evaluated,
+ -- as a side-effect of equality checking. If not, then we can assume
+ -- that the constraint is satisfiable.
+ = not $ any (isForcedByEq x) standby || any (isForcedByEq y) standby
+ -- Variable x is already in WHNF so the constraint is non-satisfiable
+ | otherwise = False
+
+ where
+ isForcedByEq :: Name -> ComplexEq -> Bool
+ isForcedByEq y (e1, e2) = varIn y e1 || varIn y e2
+
+-- | Check whether a variable is in the free variables of an expression
+varIn :: Name -> PmExpr -> Bool
+varIn x e = case e of
+ PmExprVar y -> x == y
+ PmExprCon _ es -> any (x `varIn`) es
+ PmExprLit _ -> False
+ PmExprEq e1 e2 -> (x `varIn` e1) || (x `varIn` e2)
+ PmExprOther _ -> False
+
+-- | Flatten the DAG (Could be improved in terms of performance.).
+flattenPmVarEnv :: PmVarEnv -> PmVarEnv
+flattenPmVarEnv env = mapNameEnv (exprDeepLookup env) env
+
+-- | The state of the term oracle (includes complex constraints that cannot
+-- progress unless we get more information).
+type TmState = ([ComplexEq], TmOracleEnv)
+
+-- | Initial state of the oracle.
+initialTmState :: TmState
+initialTmState = ([], (False, emptyNameEnv))
+
+-- | Solve a complex equality (top-level).
+solveOneEq :: TmState -> ComplexEq -> Maybe TmState
+solveOneEq solver_env@(_,(_,env)) complex
+ = solveComplexEq solver_env -- do the actual *merging* with existing state
+ $ simplifyComplexEq -- simplify as much as you can
+ $ applySubstComplexEq env complex -- replace everything we already know
+
+-- | Solve a complex equality.
+solveComplexEq :: TmState -> ComplexEq -> Maybe TmState
+solveComplexEq solver_state@(standby, (unhandled, env)) eq@(e1, e2) = case eq of
+ -- We cannot do a thing about these cases
+ (PmExprOther _,_) -> Just (standby, (True, env))
+ (_,PmExprOther _) -> Just (standby, (True, env))
+
+ (PmExprLit l1, PmExprLit l2) -> case eqPmLit l1 l2 of
+ -- See Note [Undecidable Equality for Overloaded Literals]
+ True -> Just solver_state
+ False -> Nothing
+
+ (PmExprCon c1 ts1, PmExprCon c2 ts2)
+ | c1 == c2 -> foldlM solveComplexEq solver_state (zip ts1 ts2)
+ | otherwise -> Nothing
+ (PmExprCon _ [], PmExprEq t1 t2)
+ | isTruePmExpr e1 -> solveComplexEq solver_state (t1, t2)
+ | isFalsePmExpr e1 -> Just (eq:standby, (unhandled, env))
+ (PmExprEq t1 t2, PmExprCon _ [])
+ | isTruePmExpr e2 -> solveComplexEq solver_state (t1, t2)
+ | isFalsePmExpr e2 -> Just (eq:standby, (unhandled, env))
+
+ (PmExprVar x, PmExprVar y)
+ | x == y -> Just solver_state
+ | otherwise -> extendSubstAndSolve x e2 solver_state
+
+ (PmExprVar x, _) -> extendSubstAndSolve x e2 solver_state
+ (_, PmExprVar x) -> extendSubstAndSolve x e1 solver_state
+
+ (PmExprEq _ _, PmExprEq _ _) -> Just (eq:standby, (unhandled, env))
+
+ _ -> Just (standby, (True, env)) -- I HATE CATCH-ALLS
+
+-- | Extend the substitution and solve the (possibly updated) constraints.
+extendSubstAndSolve :: Name -> PmExpr -> TmState -> Maybe TmState
+extendSubstAndSolve x e (standby, (unhandled, env))
+ = foldlM solveComplexEq new_incr_state (map simplifyComplexEq changed)
+ where
+ -- Apply the substitution to the worklist and partition them to the ones
+ -- that had some progress and the rest. Then, recurse over the ones that
+ -- had some progress. Careful about performance:
+ -- See Note [Representation of Term Equalities] in deSugar/Check.hs
+ (changed, unchanged) = partitionWith (substComplexEq x e) standby
+ new_incr_state = (unchanged, (unhandled, extendNameEnv env x e))
+
+-- | When we know that a variable is fresh, we do not actually have to
+-- check whether anything changes, we know that nothing does. Hence,
+-- `extendSubst` simply extends the substitution, unlike what
+-- `extendSubstAndSolve` does.
+extendSubst :: Id -> PmExpr -> TmState -> TmState
+extendSubst y e (standby, (unhandled, env))
+ | isNotPmExprOther simpl_e
+ = (standby, (unhandled, extendNameEnv env x simpl_e))
+ | otherwise = (standby, (True, env))
+ where
+ x = idName y
+ simpl_e = fst $ simplifyPmExpr $ exprDeepLookup env e
+
+-- | Simplify a complex equality.
+simplifyComplexEq :: ComplexEq -> ComplexEq
+simplifyComplexEq (e1, e2) = (fst $ simplifyPmExpr e1, fst $ simplifyPmExpr e2)
+
+-- | Simplify an expression. The boolean indicates if there has been any
+-- simplification or if the operation was a no-op.
+simplifyPmExpr :: PmExpr -> (PmExpr, Bool)
+-- See Note [Deep equalities]
+simplifyPmExpr e = case e of
+ PmExprCon c ts -> case mapAndUnzip simplifyPmExpr ts of
+ (ts', bs) -> (PmExprCon c ts', or bs)
+ PmExprEq t1 t2 -> simplifyEqExpr t1 t2
+ _other_expr -> (e, False) -- the others are terminals
+
+-- | Simplify an equality expression. The equality is given in parts.
+simplifyEqExpr :: PmExpr -> PmExpr -> (PmExpr, Bool)
+-- See Note [Deep equalities]
+simplifyEqExpr e1 e2 = case (e1, e2) of
+ -- Varables
+ (PmExprVar x, PmExprVar y)
+ | x == y -> (truePmExpr, True)
+
+ -- Literals
+ (PmExprLit l1, PmExprLit l2) -> case eqPmLit l1 l2 of
+ -- See Note [Undecidable Equality for Overloaded Literals]
+ True -> (truePmExpr, True)
+ False -> (falsePmExpr, True)
+
+ -- Can potentially be simplified
+ (PmExprEq {}, _) -> case (simplifyPmExpr e1, simplifyPmExpr e2) of
+ ((e1', True ), (e2', _ )) -> simplifyEqExpr e1' e2'
+ ((e1', _ ), (e2', True )) -> simplifyEqExpr e1' e2'
+ ((e1', False), (e2', False)) -> (PmExprEq e1' e2', False) -- cannot progress
+ (_, PmExprEq {}) -> case (simplifyPmExpr e1, simplifyPmExpr e2) of
+ ((e1', True ), (e2', _ )) -> simplifyEqExpr e1' e2'
+ ((e1', _ ), (e2', True )) -> simplifyEqExpr e1' e2'
+ ((e1', False), (e2', False)) -> (PmExprEq e1' e2', False) -- cannot progress
+
+ -- Constructors
+ (PmExprCon c1 ts1, PmExprCon c2 ts2)
+ | c1 == c2 ->
+ let (ts1', bs1) = mapAndUnzip simplifyPmExpr ts1
+ (ts2', bs2) = mapAndUnzip simplifyPmExpr ts2
+ (tss, _bss) = zipWithAndUnzip simplifyEqExpr ts1' ts2'
+ worst_case = PmExprEq (PmExprCon c1 ts1') (PmExprCon c2 ts2')
+ in if | not (or bs1 || or bs2) -> (worst_case, False) -- no progress
+ | all isTruePmExpr tss -> (truePmExpr, True)
+ | any isFalsePmExpr tss -> (falsePmExpr, True)
+ | otherwise -> (worst_case, False)
+ | otherwise -> (falsePmExpr, True)
+
+ -- We cannot do anything about the rest..
+ _other_equality -> (original, False)
+
+ where
+ original = PmExprEq e1 e2 -- reconstruct equality
+
+-- | Apply an (un-flattened) substitution to a simple equality.
+applySubstComplexEq :: PmVarEnv -> ComplexEq -> ComplexEq
+applySubstComplexEq env (e1,e2) = (exprDeepLookup env e1, exprDeepLookup env e2)
+
+-- | Apply an (un-flattened) substitution to a variable.
+varDeepLookup :: PmVarEnv -> Name -> PmExpr
+varDeepLookup env x
+ | Just e <- lookupNameEnv env x = exprDeepLookup env e -- go deeper
+ | otherwise = PmExprVar x -- terminal
+{-# INLINE varDeepLookup #-}
+
+-- | Apply an (un-flattened) substitution to an expression.
+exprDeepLookup :: PmVarEnv -> PmExpr -> PmExpr
+exprDeepLookup env (PmExprVar x) = varDeepLookup env x
+exprDeepLookup env (PmExprCon c es) = PmExprCon c (map (exprDeepLookup env) es)
+exprDeepLookup env (PmExprEq e1 e2) = PmExprEq (exprDeepLookup env e1)
+ (exprDeepLookup env e2)
+exprDeepLookup _ other_expr = other_expr -- PmExprLit, PmExprOther
+
+-- | External interface to the term oracle.
+tmOracle :: TmState -> [ComplexEq] -> Maybe TmState
+tmOracle tm_state eqs = foldlM solveOneEq tm_state eqs
+
+-- | Type of a PmLit
+pmLitType :: PmLit -> Type -- should be in PmExpr but gives cyclic imports :(
+pmLitType (PmSLit lit) = hsLitType lit
+pmLitType (PmOLit _ lit) = overLitType lit
+
+{- Note [Deep equalities]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+Solving nested equalities is the most difficult part. The general strategy
+is the following:
+
+ * Equalities of the form (True ~ (e1 ~ e2)) are transformed to just
+ (e1 ~ e2) and then treated recursively.
+
+ * Equalities of the form (False ~ (e1 ~ e2)) cannot be analyzed unless
+ we know more about the inner equality (e1 ~ e2). That's exactly what
+ `simplifyEqExpr' tries to do: It takes e1 and e2 and either returns
+ truePmExpr, falsePmExpr or (e1' ~ e2') in case it is uncertain. Note
+ that it is not e but rather e', since it may perform some
+ simplifications deeper.
+-}
diff --git a/ghc.cabal b/ghc.cabal
new file mode 100644
--- /dev/null
+++ b/ghc.cabal
@@ -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
diff --git a/ghci/ByteCodeAsm.hs b/ghci/ByteCodeAsm.hs
new file mode 100644
--- /dev/null
+++ b/ghci/ByteCodeAsm.hs
@@ -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
diff --git a/ghci/ByteCodeGen.hs b/ghci/ByteCodeGen.hs
new file mode 100644
--- /dev/null
+++ b/ghci/ByteCodeGen.hs
@@ -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 e
+ -- in f realWorld#
+ -- When we stop at the breakpoint, _result will have an unlifted
+ -- type and hence won't be bound in the environment, but the
+ -- breakpoint will otherwise work fine.
+ --
+ -- NB (Trac #12007) this /also/ applies for if (ty :: TYPE r), where
+ -- r :: RuntimeRep is a variable. This can happen in the
+ -- continuations for a pattern-synonym matcher
+ -- match = /\(r::RuntimeRep) /\(a::TYPE r).
+ -- \(k :: Int -> a) \(v::T).
+ -- case v of MkV n -> k n
+ -- Here (k n) :: a :: Type r, so we don't know if it's lifted
+ -- or not; but that should be fine provided we add that void arg.
+
+ id <- newId (mkFunTy realWorldStatePrimTy ty)
+ st <- newId realWorldStatePrimTy
+ let letExp = AnnLet (AnnNonRec id (fvs, AnnLam st (emptyDVarSet, exp)))
+ (emptyDVarSet, (AnnApp (emptyDVarSet, AnnVar id)
+ (emptyDVarSet, AnnVar realWorldPrimId)))
+ schemeE d s p letExp
+
+ where
+ exp' = deAnnotate' exp
+ fvs = exprFreeVarsDSet exp'
+ ty = exprType exp'
+
+-- ignore other kinds of tick
+schemeE d s p (AnnTick _ (_, rhs)) = schemeE d s p rhs
+
+schemeE d s p (AnnCase (_,scrut) _ _ []) = schemeE d s p scrut
+ -- no alts: scrut is guaranteed to diverge
+
+schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1, bind2], rhs)])
+ | isUnboxedTupleCon dc -- handles pairs with one void argument (e.g. state token)
+ -- Convert
+ -- case .... of x { (# V'd-thing, a #) -> ... }
+ -- to
+ -- case .... of a { DEFAULT -> ... }
+ -- because the return convention for both are identical.
+ --
+ -- Note that it does not matter losing the void-rep thing from the
+ -- envt (it won't be bound now) because we never look such things up.
+ , Just res <- case (typePrimRep (idType bind1), typePrimRep (idType bind2)) of
+ ([], [_])
+ -> Just $ doCase d s p scrut bind2 [(DEFAULT, [], rhs)] (Just bndr)
+ ([_], [])
+ -> Just $ doCase d s p scrut bind1 [(DEFAULT, [], rhs)] (Just bndr)
+ _ -> Nothing
+ = res
+
+schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1], rhs)])
+ | isUnboxedTupleCon dc
+ , length (typePrimRep (idType bndr)) <= 1 -- handles unit tuples
+ = doCase d s p scrut bind1 [(DEFAULT, [], rhs)] (Just bndr)
+
+schemeE d s p (AnnCase scrut bndr _ alt@[(DEFAULT, [], _)])
+ | isUnboxedTupleType (idType bndr)
+ , Just ty <- case typePrimRep (idType bndr) of
+ [_] -> Just (unwrapType (idType bndr))
+ [] -> Just voidPrimTy
+ _ -> Nothing
+ -- handles any pattern with a single non-void binder; in particular I/O
+ -- monad returns (# RealWorld#, a #)
+ = doCase d s p scrut (bndr `setIdType` ty) alt (Just bndr)
+
+schemeE d s p (AnnCase scrut bndr _ alts)
+ = doCase d s p scrut bndr alts Nothing{-not an unboxed tuple-}
+
+schemeE _ _ _ expr
+ = pprPanic "ByteCodeGen.schemeE: unhandled case"
+ (pprCoreExpr (deAnnotate' expr))
+
+{-
+ Ticked Expressions
+ ------------------
+
+ The idea is that the "breakpoint E" is really just an annotation on
+ the code. When we find such a thing, we pull out the useful information,
+ and then compile the code as if it was just the expression E.
+
+-}
+
+-- Compile code to do a tail call. Specifically, push the fn,
+-- slide the on-stack app back down to the sequel depth,
+-- and enter. Four cases:
+--
+-- 0. (Nasty hack).
+-- An application "GHC.Prim.tagToEnum# unboxed-int".
+-- The int will be on the stack. Generate a code sequence
+-- to convert it to the relevant constructor, SLIDE and ENTER.
+--
+-- 1. The fn denotes a ccall. Defer to generateCCall.
+--
+-- 2. (Another nasty hack). Spot (# a::V, b #) and treat
+-- it simply as b -- since the representations are identical
+-- (the V takes up zero stack space). Also, spot
+-- (# b #) and treat it as b.
+--
+-- 3. Application of a constructor, by defn saturated.
+-- Split the args into ptrs and non-ptrs, and push the nonptrs,
+-- then the ptrs, and then do PACK and RETURN.
+--
+-- 4. Otherwise, it must be a function call. Push the args
+-- right to left, SLIDE and ENTER.
+
+schemeT :: Word -- Stack depth
+ -> Sequel -- Sequel depth
+ -> BCEnv -- stack env
+ -> AnnExpr' Id DVarSet
+ -> BcM BCInstrList
+
+schemeT d s p app
+
+-- | trace ("schemeT: env in = \n" ++ showSDocDebug (ppBCEnv p)) False
+-- = panic "schemeT ?!?!"
+
+-- | trace ("\nschemeT\n" ++ showSDoc (pprCoreExpr (deAnnotate' app)) ++ "\n") False
+-- = error "?!?!"
+
+ -- Case 0
+ | Just (arg, constr_names) <- maybe_is_tagToEnum_call app
+ = implement_tagToId d s p arg constr_names
+
+ -- Case 1
+ | Just (CCall ccall_spec) <- isFCallId_maybe fn
+ = if isSupportedCConv ccall_spec
+ then generateCCall d s p ccall_spec fn args_r_to_l
+ else unsupportedCConvException
+
+
+ -- Case 2: Constructor application
+ | Just con <- maybe_saturated_dcon
+ , isUnboxedTupleCon con
+ = case args_r_to_l of
+ [arg1,arg2] | isVAtom arg1 ->
+ unboxedTupleReturn d s p arg2
+ [arg1,arg2] | isVAtom arg2 ->
+ unboxedTupleReturn d s p arg1
+ _other -> multiValException
+
+ -- Case 3: Ordinary data constructor
+ | Just con <- maybe_saturated_dcon
+ = do alloc_con <- mkConAppCode d s p con args_r_to_l
+ return (alloc_con `appOL`
+ mkSLIDE 1 (d - s) `snocOL`
+ ENTER)
+
+ -- Case 4: Tail call of function
+ | otherwise
+ = doTailCall d s p fn args_r_to_l
+
+ where
+ -- Extract the args (R->L) and fn
+ -- The function will necessarily be a variable,
+ -- because we are compiling a tail call
+ (AnnVar fn, args_r_to_l) = splitApp app
+
+ -- Only consider this to be a constructor application iff it is
+ -- saturated. Otherwise, we'll call the constructor wrapper.
+ n_args = length args_r_to_l
+ maybe_saturated_dcon
+ = case isDataConWorkId_maybe fn of
+ Just con | dataConRepArity con == n_args -> Just con
+ _ -> Nothing
+
+-- -----------------------------------------------------------------------------
+-- Generate code to build a constructor application,
+-- leaving it on top of the stack
+
+mkConAppCode :: Word -> Sequel -> BCEnv
+ -> DataCon -- The data constructor
+ -> [AnnExpr' Id DVarSet] -- Args, in *reverse* order
+ -> BcM BCInstrList
+
+mkConAppCode _ _ _ con [] -- Nullary constructor
+ = ASSERT( isNullaryRepDataCon con )
+ return (unitOL (PUSH_G (getName (dataConWorkId con))))
+ -- Instead of doing a PACK, which would allocate a fresh
+ -- copy of this constructor, use the single shared version.
+
+mkConAppCode orig_d _ p con args_r_to_l
+ = ASSERT( dataConRepArity con == length args_r_to_l )
+ do_pushery orig_d (non_ptr_args ++ ptr_args)
+ where
+ -- The args are already in reverse order, which is the way PACK
+ -- expects them to be. We must push the non-ptrs after the ptrs.
+ (ptr_args, non_ptr_args) = partition isPtrAtom args_r_to_l
+
+ do_pushery d (arg:args)
+ = do (push, arg_words) <- pushAtom d p arg
+ more_push_code <- do_pushery (d + fromIntegral arg_words) args
+ return (push `appOL` more_push_code)
+ do_pushery d []
+ = return (unitOL (PACK con n_arg_words))
+ where
+ n_arg_words = trunc16 $ d - orig_d
+
+
+-- -----------------------------------------------------------------------------
+-- Returning an unboxed tuple with one non-void component (the only
+-- case we can handle).
+--
+-- Remember, we don't want to *evaluate* the component that is being
+-- returned, even if it is a pointed type. We always just return.
+
+unboxedTupleReturn
+ :: Word -> Sequel -> BCEnv
+ -> AnnExpr' Id DVarSet -> BcM BCInstrList
+unboxedTupleReturn d s p arg = returnUnboxedAtom d s p arg (atomRep arg)
+
+-- -----------------------------------------------------------------------------
+-- Generate code for a tail-call
+
+doTailCall
+ :: Word -> Sequel -> BCEnv
+ -> Id -> [AnnExpr' Id DVarSet]
+ -> BcM BCInstrList
+doTailCall init_d s p fn args
+ = do_pushes init_d args (map atomRep args)
+ where
+ do_pushes d [] reps = do
+ ASSERT( null reps ) return ()
+ (push_fn, sz) <- pushAtom d p (AnnVar fn)
+ ASSERT( sz == 1 ) return ()
+ return (push_fn `appOL` (
+ mkSLIDE (trunc16 $ d - init_d + 1) (init_d - s) `appOL`
+ unitOL ENTER))
+ do_pushes d args reps = do
+ let (push_apply, n, rest_of_reps) = findPushSeq reps
+ (these_args, rest_of_args) = splitAt n args
+ (next_d, push_code) <- push_seq d these_args
+ instrs <- do_pushes (next_d + 1) rest_of_args rest_of_reps
+ -- ^^^ for the PUSH_APPLY_ instruction
+ return (push_code `appOL` (push_apply `consOL` instrs))
+
+ push_seq d [] = return (d, nilOL)
+ push_seq d (arg:args) = do
+ (push_code, sz) <- pushAtom d p arg
+ (final_d, more_push_code) <- push_seq (d + fromIntegral sz) args
+ return (final_d, push_code `appOL` more_push_code)
+
+-- v. similar to CgStackery.findMatch, ToDo: merge
+findPushSeq :: [ArgRep] -> (BCInstr, Int, [ArgRep])
+findPushSeq (P: P: P: P: P: P: rest)
+ = (PUSH_APPLY_PPPPPP, 6, rest)
+findPushSeq (P: P: P: P: P: rest)
+ = (PUSH_APPLY_PPPPP, 5, rest)
+findPushSeq (P: P: P: P: rest)
+ = (PUSH_APPLY_PPPP, 4, rest)
+findPushSeq (P: P: P: rest)
+ = (PUSH_APPLY_PPP, 3, rest)
+findPushSeq (P: P: rest)
+ = (PUSH_APPLY_PP, 2, rest)
+findPushSeq (P: rest)
+ = (PUSH_APPLY_P, 1, rest)
+findPushSeq (V: rest)
+ = (PUSH_APPLY_V, 1, rest)
+findPushSeq (N: rest)
+ = (PUSH_APPLY_N, 1, rest)
+findPushSeq (F: rest)
+ = (PUSH_APPLY_F, 1, rest)
+findPushSeq (D: rest)
+ = (PUSH_APPLY_D, 1, rest)
+findPushSeq (L: rest)
+ = (PUSH_APPLY_L, 1, rest)
+findPushSeq _
+ = panic "ByteCodeGen.findPushSeq"
+
+-- -----------------------------------------------------------------------------
+-- Case expressions
+
+doCase :: Word -> Sequel -> BCEnv
+ -> AnnExpr Id DVarSet -> Id -> [AnnAlt Id DVarSet]
+ -> Maybe Id -- Just x <=> is an unboxed tuple case with scrut binder, don't enter the result
+ -> BcM BCInstrList
+doCase d s p (_,scrut) bndr alts is_unboxed_tuple
+ | typePrimRep (idType bndr) `lengthExceeds` 1
+ = multiValException
+ | otherwise
+ = do
+ dflags <- getDynFlags
+ let
+ profiling
+ | gopt Opt_ExternalInterpreter dflags = gopt Opt_SccProfilingOn dflags
+ | otherwise = rtsIsProfiled
+
+ -- Top of stack is the return itbl, as usual.
+ -- underneath it is the pointer to the alt_code BCO.
+ -- When an alt is entered, it assumes the returned value is
+ -- on top of the itbl.
+ ret_frame_sizeW :: Word
+ ret_frame_sizeW = 2
+
+ -- The extra frame we push to save/restor the CCCS when profiling
+ save_ccs_sizeW | profiling = 2
+ | otherwise = 0
+
+ -- An unlifted value gets an extra info table pushed on top
+ -- when it is returned.
+ unlifted_itbl_sizeW :: Word
+ unlifted_itbl_sizeW | isAlgCase = 0
+ | otherwise = 1
+
+ -- depth of stack after the return value has been pushed
+ d_bndr = d + ret_frame_sizeW + fromIntegral (idSizeW dflags bndr)
+
+ -- depth of stack after the extra info table for an unboxed return
+ -- has been pushed, if any. This is the stack depth at the
+ -- continuation.
+ d_alts = d_bndr + unlifted_itbl_sizeW
+
+ -- Env in which to compile the alts, not including
+ -- any vars bound by the alts themselves
+ d_bndr' = fromIntegral d_bndr - 1
+ p_alts0 = Map.insert bndr d_bndr' p
+ p_alts = case is_unboxed_tuple of
+ Just ubx_bndr -> Map.insert ubx_bndr d_bndr' p_alts0
+ Nothing -> p_alts0
+
+ bndr_ty = idType bndr
+ isAlgCase = not (isUnliftedType bndr_ty) && isNothing is_unboxed_tuple
+
+ -- given an alt, return a discr and code for it.
+ codeAlt (DEFAULT, _, (_,rhs))
+ = do rhs_code <- schemeE d_alts s p_alts rhs
+ return (NoDiscr, rhs_code)
+
+ codeAlt alt@(_, bndrs, (_,rhs))
+ -- primitive or nullary constructor alt: no need to UNPACK
+ | null real_bndrs = do
+ rhs_code <- schemeE d_alts s p_alts rhs
+ return (my_discr alt, rhs_code)
+ -- algebraic alt with some binders
+ | otherwise =
+ let
+ (ptrs,nptrs) = partition (isFollowableArg.bcIdArgRep) real_bndrs
+ ptr_sizes = map (fromIntegral . idSizeW dflags) ptrs
+ nptrs_sizes = map (fromIntegral . idSizeW dflags) nptrs
+ bind_sizes = ptr_sizes ++ nptrs_sizes
+ size = sum ptr_sizes + sum nptrs_sizes
+ -- the UNPACK instruction unpacks in reverse order...
+ p' = Map.insertList
+ (zip (reverse (ptrs ++ nptrs))
+ (mkStackOffsets d_alts (reverse bind_sizes)))
+ p_alts
+ in do
+ MASSERT(isAlgCase)
+ rhs_code <- schemeE (d_alts + size) s p' rhs
+ return (my_discr alt, unitOL (UNPACK (trunc16 size)) `appOL` rhs_code)
+ where
+ real_bndrs = filterOut isTyVar bndrs
+
+ my_discr (DEFAULT, _, _) = NoDiscr {-shouldn't really happen-}
+ my_discr (DataAlt dc, _, _)
+ | isUnboxedTupleCon dc || isUnboxedSumCon dc
+ = multiValException
+ | otherwise
+ = DiscrP (fromIntegral (dataConTag dc - fIRST_TAG))
+ my_discr (LitAlt l, _, _)
+ = case l of MachInt i -> DiscrI (fromInteger i)
+ MachWord w -> DiscrW (fromInteger w)
+ MachFloat r -> DiscrF (fromRational r)
+ MachDouble r -> DiscrD (fromRational r)
+ MachChar i -> DiscrI (ord i)
+ _ -> pprPanic "schemeE(AnnCase).my_discr" (ppr l)
+
+ maybe_ncons
+ | not isAlgCase = Nothing
+ | otherwise
+ = case [dc | (DataAlt dc, _, _) <- alts] of
+ [] -> Nothing
+ (dc:_) -> Just (tyConFamilySize (dataConTyCon dc))
+
+ -- the bitmap is relative to stack depth d, i.e. before the
+ -- BCO, info table and return value are pushed on.
+ -- This bit of code is v. similar to buildLivenessMask in CgBindery,
+ -- except that here we build the bitmap from the known bindings of
+ -- things that are pointers, whereas in CgBindery the code builds the
+ -- bitmap from the free slots and unboxed bindings.
+ -- (ToDo: merge?)
+ --
+ -- NOTE [7/12/2006] bug #1013, testcase ghci/should_run/ghci002.
+ -- The bitmap must cover the portion of the stack up to the sequel only.
+ -- Previously we were building a bitmap for the whole depth (d), but we
+ -- really want a bitmap up to depth (d-s). This affects compilation of
+ -- case-of-case expressions, which is the only time we can be compiling a
+ -- case expression with s /= 0.
+ bitmap_size = trunc16 $ d-s
+ bitmap_size' :: Int
+ bitmap_size' = fromIntegral bitmap_size
+ bitmap = intsToReverseBitmap dflags bitmap_size'{-size-}
+ (sort (filter (< bitmap_size') rel_slots))
+ where
+ binds = Map.toList p
+ -- NB: unboxed tuple cases bind the scrut binder to the same offset
+ -- as one of the alt binders, so we have to remove any duplicates here:
+ rel_slots = nub $ map fromIntegral $ concat (map spread binds)
+ spread (id, offset) | isFollowableArg (bcIdArgRep id) = [ rel_offset ]
+ | otherwise = []
+ where rel_offset = trunc16 $ d - fromIntegral offset - 1
+
+ alt_stuff <- mapM codeAlt alts
+ alt_final <- mkMultiBranch maybe_ncons alt_stuff
+
+ let
+ alt_bco_name = getName bndr
+ alt_bco = mkProtoBCO dflags alt_bco_name alt_final (Left alts)
+ 0{-no arity-} bitmap_size bitmap True{-is alts-}
+-- trace ("case: bndr = " ++ showSDocDebug (ppr bndr) ++ "\ndepth = " ++ show d ++ "\nenv = \n" ++ showSDocDebug (ppBCEnv p) ++
+-- "\n bitmap = " ++ show bitmap) $ do
+
+ scrut_code <- schemeE (d + ret_frame_sizeW + save_ccs_sizeW)
+ (d + ret_frame_sizeW + save_ccs_sizeW)
+ p scrut
+ alt_bco' <- emitBc alt_bco
+ let push_alts
+ | isAlgCase = PUSH_ALTS alt_bco'
+ | otherwise = PUSH_ALTS_UNLIFTED alt_bco' (typeArgRep bndr_ty)
+ return (push_alts `consOL` scrut_code)
+
+
+-- -----------------------------------------------------------------------------
+-- Deal with a CCall.
+
+-- Taggedly push the args onto the stack R->L,
+-- deferencing ForeignObj#s and adjusting addrs to point to
+-- payloads in Ptr/Byte arrays. Then, generate the marshalling
+-- (machine) code for the ccall, and create bytecodes to call that and
+-- then return in the right way.
+
+generateCCall :: Word -> Sequel -- stack and sequel depths
+ -> BCEnv
+ -> CCallSpec -- where to call
+ -> Id -- of target, for type info
+ -> [AnnExpr' Id DVarSet] -- args (atoms)
+ -> BcM BCInstrList
+
+generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
+ = do
+ dflags <- getDynFlags
+
+ let
+ -- useful constants
+ addr_sizeW :: Word16
+ addr_sizeW = fromIntegral (argRepSizeW dflags N)
+
+ -- Get the args on the stack, with tags and suitably
+ -- dereferenced for the CCall. For each arg, return the
+ -- depth to the first word of the bits for that arg, and the
+ -- ArgRep of what was actually pushed.
+
+ pargs _ [] = return []
+ pargs d (a:az)
+ = let arg_ty = unwrapType (exprType (deAnnotate' a))
+
+ in case tyConAppTyCon_maybe arg_ty of
+ -- Don't push the FO; instead push the Addr# it
+ -- contains.
+ Just t
+ | t == arrayPrimTyCon || t == mutableArrayPrimTyCon
+ -> do rest <- pargs (d + fromIntegral addr_sizeW) az
+ code <- parg_ArrayishRep (fromIntegral (arrPtrsHdrSize dflags)) d p a
+ return ((code,AddrRep):rest)
+
+ | t == smallArrayPrimTyCon || t == smallMutableArrayPrimTyCon
+ -> do rest <- pargs (d + fromIntegral addr_sizeW) az
+ code <- parg_ArrayishRep (fromIntegral (smallArrPtrsHdrSize dflags)) d p a
+ return ((code,AddrRep):rest)
+
+ | t == byteArrayPrimTyCon || t == mutableByteArrayPrimTyCon
+ -> do rest <- pargs (d + fromIntegral addr_sizeW) az
+ code <- parg_ArrayishRep (fromIntegral (arrWordsHdrSize dflags)) d p a
+ return ((code,AddrRep):rest)
+
+ -- Default case: push taggedly, but otherwise intact.
+ _
+ -> do (code_a, sz_a) <- pushAtom d p a
+ rest <- pargs (d + fromIntegral sz_a) az
+ return ((code_a, atomPrimRep a) : rest)
+
+ -- Do magic for Ptr/Byte arrays. Push a ptr to the array on
+ -- the stack but then advance it over the headers, so as to
+ -- point to the payload.
+ parg_ArrayishRep :: Word16 -> Word -> BCEnv -> AnnExpr' Id DVarSet
+ -> BcM BCInstrList
+ parg_ArrayishRep hdrSize d p a
+ = do (push_fo, _) <- pushAtom d p a
+ -- The ptr points at the header. Advance it over the
+ -- header and then pretend this is an Addr#.
+ return (push_fo `snocOL` SWIZZLE 0 hdrSize)
+
+ code_n_reps <- pargs d0 args_r_to_l
+ let
+ (pushs_arg, a_reps_pushed_r_to_l) = unzip code_n_reps
+ a_reps_sizeW = fromIntegral (sum (map (primRepSizeW dflags) a_reps_pushed_r_to_l))
+
+ push_args = concatOL pushs_arg
+ d_after_args = d0 + a_reps_sizeW
+ a_reps_pushed_RAW
+ | null a_reps_pushed_r_to_l || head a_reps_pushed_r_to_l /= VoidRep
+ = panic "ByteCodeGen.generateCCall: missing or invalid World token?"
+ | otherwise
+ = reverse (tail a_reps_pushed_r_to_l)
+
+ -- Now: a_reps_pushed_RAW are the reps which are actually on the stack.
+ -- push_args is the code to do that.
+ -- d_after_args is the stack depth once the args are on.
+
+ -- Get the result rep.
+ (returns_void, r_rep)
+ = case maybe_getCCallReturnRep (idType fn) of
+ Nothing -> (True, VoidRep)
+ Just rr -> (False, rr)
+ {-
+ Because the Haskell stack grows down, the a_reps refer to
+ lowest to highest addresses in that order. The args for the call
+ are on the stack. Now push an unboxed Addr# indicating
+ the C function to call. Then push a dummy placeholder for the
+ result. Finally, emit a CCALL insn with an offset pointing to the
+ Addr# just pushed, and a literal field holding the mallocville
+ address of the piece of marshalling code we generate.
+ So, just prior to the CCALL insn, the stack looks like this
+ (growing down, as usual):
+
+
+ ...
+
+ Addr# address_of_C_fn
+ (must be an unboxed type)
+
+ The interpreter then calls the marshall code mentioned
+ in the CCALL insn, passing it (& ),
+ that is, the addr of the topmost word in the stack.
+ When this returns, the placeholder will have been
+ filled in. The placeholder is slid down to the sequel
+ depth, and we RETURN.
+
+ This arrangement makes it simple to do f-i-dynamic since the Addr#
+ value is the first arg anyway.
+
+ The marshalling code is generated specifically for this
+ call site, and so knows exactly the (Haskell) stack
+ offsets of the args, fn address and placeholder. It
+ copies the args to the C stack, calls the stacked addr,
+ and parks the result back in the placeholder. The interpreter
+ calls it as a normal C call, assuming it has a signature
+ void marshall_code ( StgWord* ptr_to_top_of_stack )
+ -}
+ -- resolve static address
+ maybe_static_target =
+ case target of
+ DynamicTarget -> Nothing
+ StaticTarget _ _ _ False ->
+ panic "generateCCall: unexpected FFI value import"
+ StaticTarget _ target _ True ->
+ Just (MachLabel target mb_size IsFunction)
+ where
+ mb_size
+ | OSMinGW32 <- platformOS (targetPlatform dflags)
+ , StdCallConv <- cconv
+ = Just (fromIntegral a_reps_sizeW * wORD_SIZE dflags)
+ | otherwise
+ = Nothing
+
+ let
+ is_static = isJust maybe_static_target
+
+ -- Get the arg reps, zapping the leading Addr# in the dynamic case
+ a_reps -- | trace (showSDoc (ppr a_reps_pushed_RAW)) False = error "???"
+ | is_static = a_reps_pushed_RAW
+ | otherwise = if null a_reps_pushed_RAW
+ then panic "ByteCodeGen.generateCCall: dyn with no args"
+ else tail a_reps_pushed_RAW
+
+ -- push the Addr#
+ (push_Addr, d_after_Addr)
+ | Just machlabel <- maybe_static_target
+ = (toOL [PUSH_UBX machlabel addr_sizeW],
+ d_after_args + fromIntegral addr_sizeW)
+ | otherwise -- is already on the stack
+ = (nilOL, d_after_args)
+
+ -- Push the return placeholder. For a call returning nothing,
+ -- this is a V (tag).
+ r_sizeW = fromIntegral (primRepSizeW dflags r_rep)
+ d_after_r = d_after_Addr + fromIntegral r_sizeW
+ push_r = (if returns_void
+ then nilOL
+ else unitOL (PUSH_UBX (mkDummyLiteral r_rep) r_sizeW))
+
+ -- generate the marshalling code we're going to call
+
+ -- Offset of the next stack frame down the stack. The CCALL
+ -- instruction needs to describe the chunk of stack containing
+ -- the ccall args to the GC, so it needs to know how large it
+ -- is. See comment in Interpreter.c with the CCALL instruction.
+ stk_offset = trunc16 $ d_after_r - s
+
+ conv = case cconv of
+ CCallConv -> FFICCall
+ StdCallConv -> FFIStdCall
+ _ -> panic "ByteCodeGen: unexpected calling convention"
+
+ -- the only difference in libffi mode is that we prepare a cif
+ -- describing the call type by calling libffi, and we attach the
+ -- address of this to the CCALL instruction.
+
+
+ let ffires = primRepToFFIType dflags r_rep
+ ffiargs = map (primRepToFFIType dflags) a_reps
+ hsc_env <- getHscEnv
+ token <- ioToBc $ iservCmd hsc_env (PrepFFI conv ffiargs ffires)
+ recordFFIBc token
+
+ let
+ -- do the call
+ do_call = unitOL (CCALL stk_offset token
+ (fromIntegral (fromEnum (playInterruptible safety))))
+ -- slide and return
+ wrapup = mkSLIDE r_sizeW (d_after_r - fromIntegral r_sizeW - s)
+ `snocOL` RETURN_UBX (toArgRep r_rep)
+ --trace (show (arg1_offW, args_offW , (map argRepSizeW a_reps) )) $
+ return (
+ push_args `appOL`
+ push_Addr `appOL` push_r `appOL` do_call `appOL` wrapup
+ )
+
+primRepToFFIType :: DynFlags -> PrimRep -> FFIType
+primRepToFFIType dflags r
+ = case r of
+ VoidRep -> FFIVoid
+ IntRep -> signed_word
+ WordRep -> unsigned_word
+ Int64Rep -> FFISInt64
+ Word64Rep -> FFIUInt64
+ AddrRep -> FFIPointer
+ FloatRep -> FFIFloat
+ DoubleRep -> FFIDouble
+ _ -> panic "primRepToFFIType"
+ where
+ (signed_word, unsigned_word)
+ | wORD_SIZE dflags == 4 = (FFISInt32, FFIUInt32)
+ | wORD_SIZE dflags == 8 = (FFISInt64, FFIUInt64)
+ | otherwise = panic "primTyDescChar"
+
+-- Make a dummy literal, to be used as a placeholder for FFI return
+-- values on the stack.
+mkDummyLiteral :: PrimRep -> Literal
+mkDummyLiteral pr
+ = case pr of
+ IntRep -> MachInt 0
+ WordRep -> MachWord 0
+ AddrRep -> MachNullAddr
+ DoubleRep -> MachDouble 0
+ FloatRep -> MachFloat 0
+ Int64Rep -> MachInt64 0
+ Word64Rep -> MachWord64 0
+ _ -> pprPanic "mkDummyLiteral" (ppr pr)
+
+
+-- Convert (eg)
+-- GHC.Prim.Char# -> GHC.Prim.State# GHC.Prim.RealWorld
+-- -> (# GHC.Prim.State# GHC.Prim.RealWorld, GHC.Prim.Int# #)
+--
+-- to Just IntRep
+-- and check that an unboxed pair is returned wherein the first arg is V'd.
+--
+-- Alternatively, for call-targets returning nothing, convert
+--
+-- GHC.Prim.Char# -> GHC.Prim.State# GHC.Prim.RealWorld
+-- -> (# GHC.Prim.State# GHC.Prim.RealWorld #)
+--
+-- to Nothing
+
+maybe_getCCallReturnRep :: Type -> Maybe PrimRep
+maybe_getCCallReturnRep fn_ty
+ = let
+ (_a_tys, r_ty) = splitFunTys (dropForAlls fn_ty)
+ r_reps = typePrimRepArgs r_ty
+
+ blargh :: a -- Used at more than one type
+ blargh = pprPanic "maybe_getCCallReturn: can't handle:"
+ (pprType fn_ty)
+ in
+ case r_reps of
+ [] -> panic "empty typePrimRepArgs"
+ [VoidRep] -> Nothing
+ [rep]
+ | isGcPtrRep rep -> blargh
+ | otherwise -> Just rep
+
+ -- if it was, it would be impossible to create a
+ -- valid return value placeholder on the stack
+ _ -> blargh
+
+maybe_is_tagToEnum_call :: AnnExpr' Id DVarSet -> Maybe (AnnExpr' Id DVarSet, [Name])
+-- Detect and extract relevant info for the tagToEnum kludge.
+maybe_is_tagToEnum_call app
+ | AnnApp (_, AnnApp (_, AnnVar v) (_, AnnType t)) arg <- app
+ , Just TagToEnumOp <- isPrimOpId_maybe v
+ = Just (snd arg, extract_constr_Names t)
+ | otherwise
+ = Nothing
+ where
+ extract_constr_Names ty
+ | rep_ty <- unwrapType ty
+ , Just tyc <- tyConAppTyCon_maybe rep_ty
+ , isDataTyCon tyc
+ = map (getName . dataConWorkId) (tyConDataCons tyc)
+ -- NOTE: use the worker name, not the source name of
+ -- the DataCon. See DataCon.hs for details.
+ | otherwise
+ = pprPanic "maybe_is_tagToEnum_call.extract_constr_Ids" (ppr ty)
+
+{- -----------------------------------------------------------------------------
+Note [Implementing tagToEnum#]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+(implement_tagToId arg names) compiles code which takes an argument
+'arg', (call it i), and enters the i'th closure in the supplied list
+as a consequence. The [Name] is a list of the constructors of this
+(enumeration) type.
+
+The code we generate is this:
+ push arg
+ push bogus-word
+
+ TESTEQ_I 0 L1
+ PUSH_G
+ JMP L_Exit
+
+ L1: TESTEQ_I 1 L2
+ PUSH_G
+ JMP L_Exit
+ ...etc...
+ Ln: TESTEQ_I n L_fail
+ PUSH_G
+ JMP L_Exit
+
+ L_fail: CASEFAIL
+
+ L_exit: SLIDE 1 n
+ ENTER
+
+The 'bogus-word' push is because TESTEQ_I expects the top of the stack
+to have an info-table, and the next word to have the value to be
+tested. This is very weird, but it's the way it is right now. See
+Interpreter.c. We don't acutally need an info-table here; we just
+need to have the argument to be one-from-top on the stack, hence pushing
+a 1-word null. See Trac #8383.
+-}
+
+
+implement_tagToId :: Word -> Sequel -> BCEnv
+ -> AnnExpr' Id DVarSet -> [Name] -> BcM BCInstrList
+-- See Note [Implementing tagToEnum#]
+implement_tagToId d s p arg names
+ = ASSERT( notNull names )
+ do (push_arg, arg_words) <- pushAtom d p arg
+ labels <- getLabelsBc (genericLength names)
+ label_fail <- getLabelBc
+ label_exit <- getLabelBc
+ let infos = zip4 labels (tail labels ++ [label_fail])
+ [0 ..] names
+ steps = map (mkStep label_exit) infos
+
+ return (push_arg
+ `appOL` unitOL (PUSH_UBX MachNullAddr 1)
+ -- Push bogus word (see Note [Implementing tagToEnum#])
+ `appOL` concatOL steps
+ `appOL` toOL [ LABEL label_fail, CASEFAIL,
+ LABEL label_exit ]
+ `appOL` mkSLIDE 1 (d - s + fromIntegral arg_words + 1)
+ -- "+1" to account for bogus word
+ -- (see Note [Implementing tagToEnum#])
+ `appOL` unitOL ENTER)
+ where
+ mkStep l_exit (my_label, next_label, n, name_for_n)
+ = toOL [LABEL my_label,
+ TESTEQ_I n next_label,
+ PUSH_G name_for_n,
+ JMP l_exit]
+
+
+-- -----------------------------------------------------------------------------
+-- pushAtom
+
+-- Push an atom onto the stack, returning suitable code & number of
+-- stack words used.
+--
+-- The env p must map each variable to the highest- numbered stack
+-- slot for it. For example, if the stack has depth 4 and we
+-- tagged-ly push (v :: Int#) on it, the value will be in stack[4],
+-- the tag in stack[5], the stack will have depth 6, and p must map v
+-- to 5 and not to 4. Stack locations are numbered from zero, so a
+-- depth 6 stack has valid words 0 .. 5.
+
+pushAtom :: Word -> BCEnv -> AnnExpr' Id DVarSet -> BcM (BCInstrList, Word16)
+
+pushAtom d p e
+ | Just e' <- bcView e
+ = pushAtom d p e'
+
+pushAtom _ _ (AnnCoercion {}) -- Coercions are zero-width things,
+ = return (nilOL, 0) -- treated just like a variable V
+
+-- See Note [Empty case alternatives] in coreSyn/CoreSyn.hs
+-- and Note [Bottoming expressions] in coreSyn/CoreUtils.hs:
+-- The scrutinee of an empty case evaluates to bottom
+pushAtom d p (AnnCase (_, a) _ _ []) -- trac #12128
+ = pushAtom d p a
+
+pushAtom d p (AnnVar v)
+ | [] <- typePrimRep (idType v)
+ = return (nilOL, 0)
+
+ | isFCallId v
+ = pprPanic "pushAtom: shouldn't get an FCallId here" (ppr v)
+
+ | Just primop <- isPrimOpId_maybe v
+ = return (unitOL (PUSH_PRIMOP primop), 1)
+
+ | Just d_v <- lookupBCEnv_maybe v p -- v is a local variable
+ = do dflags <- getDynFlags
+ let sz :: Word16
+ sz = fromIntegral (idSizeW dflags v)
+ l = trunc16 $ d - d_v + fromIntegral sz - 2
+ return (toOL (genericReplicate sz (PUSH_L l)), sz)
+ -- d - d_v the number of words between the TOS
+ -- and the 1st slot of the object
+ --
+ -- d - d_v - 1 the offset from the TOS of the 1st slot
+ --
+ -- d - d_v - 1 + sz - 1 the offset from the TOS of the last slot
+ -- of the object.
+ --
+ -- Having found the last slot, we proceed to copy the right number of
+ -- slots on to the top of the stack.
+
+ | otherwise -- v must be a global variable
+ = do topStrings <- getTopStrings
+ case lookupVarEnv topStrings v of
+ Just ptr -> pushAtom d p $ AnnLit $ MachWord $ fromIntegral $
+ ptrToWordPtr $ fromRemotePtr ptr
+ Nothing -> do
+ dflags <- getDynFlags
+ let sz :: Word16
+ sz = fromIntegral (idSizeW dflags v)
+ MASSERT(sz == 1)
+ return (unitOL (PUSH_G (getName v)), sz)
+
+
+pushAtom _ _ (AnnLit lit) = do
+ dflags <- getDynFlags
+ let code rep
+ = let size_host_words = fromIntegral (argRepSizeW dflags rep)
+ in return (unitOL (PUSH_UBX lit size_host_words),
+ size_host_words)
+
+ case lit of
+ MachLabel _ _ _ -> code N
+ MachWord _ -> code N
+ MachInt _ -> code N
+ MachWord64 _ -> code L
+ MachInt64 _ -> code L
+ MachFloat _ -> code F
+ MachDouble _ -> code D
+ MachChar _ -> code N
+ MachNullAddr -> code N
+ MachStr _ -> code N
+ -- No LitInteger's should be left by the time this is called.
+ -- CorePrep should have converted them all to a real core
+ -- representation.
+ LitInteger {} -> panic "pushAtom: LitInteger"
+
+pushAtom _ _ expr
+ = pprPanic "ByteCodeGen.pushAtom"
+ (pprCoreExpr (deAnnotate' expr))
+
+
+-- -----------------------------------------------------------------------------
+-- Given a bunch of alts code and their discrs, do the donkey work
+-- of making a multiway branch using a switch tree.
+-- What a load of hassle!
+
+mkMultiBranch :: Maybe Int -- # datacons in tycon, if alg alt
+ -- a hint; generates better code
+ -- Nothing is always safe
+ -> [(Discr, BCInstrList)]
+ -> BcM BCInstrList
+mkMultiBranch maybe_ncons raw_ways = do
+ lbl_default <- getLabelBc
+
+ let
+ mkTree :: [(Discr, BCInstrList)] -> Discr -> Discr -> BcM BCInstrList
+ mkTree [] _range_lo _range_hi = return (unitOL (JMP lbl_default))
+ -- shouldn't happen?
+
+ mkTree [val] range_lo range_hi
+ | range_lo == range_hi
+ = return (snd val)
+ | null defaults -- Note [CASEFAIL]
+ = do lbl <- getLabelBc
+ return (testEQ (fst val) lbl
+ `consOL` (snd val
+ `appOL` (LABEL lbl `consOL` unitOL CASEFAIL)))
+ | otherwise
+ = return (testEQ (fst val) lbl_default `consOL` snd val)
+
+ -- Note [CASEFAIL] It may be that this case has no default
+ -- branch, but the alternatives are not exhaustive - this
+ -- happens for GADT cases for example, where the types
+ -- prove that certain branches are impossible. We could
+ -- just assume that the other cases won't occur, but if
+ -- this assumption was wrong (because of a bug in GHC)
+ -- then the result would be a segfault. So instead we
+ -- emit an explicit test and a CASEFAIL instruction that
+ -- causes the interpreter to barf() if it is ever
+ -- executed.
+
+ mkTree vals range_lo range_hi
+ = let n = length vals `div` 2
+ vals_lo = take n vals
+ vals_hi = drop n vals
+ v_mid = fst (head vals_hi)
+ in do
+ label_geq <- getLabelBc
+ code_lo <- mkTree vals_lo range_lo (dec v_mid)
+ code_hi <- mkTree vals_hi v_mid range_hi
+ return (testLT v_mid label_geq
+ `consOL` (code_lo
+ `appOL` unitOL (LABEL label_geq)
+ `appOL` code_hi))
+
+ the_default
+ = case defaults of
+ [] -> nilOL
+ [(_, def)] -> LABEL lbl_default `consOL` def
+ _ -> panic "mkMultiBranch/the_default"
+ instrs <- mkTree notd_ways init_lo init_hi
+ return (instrs `appOL` the_default)
+ where
+ (defaults, not_defaults) = partition (isNoDiscr.fst) raw_ways
+ notd_ways = sortBy (comparing fst) not_defaults
+
+ testLT (DiscrI i) fail_label = TESTLT_I i fail_label
+ testLT (DiscrW i) fail_label = TESTLT_W i fail_label
+ testLT (DiscrF i) fail_label = TESTLT_F i fail_label
+ testLT (DiscrD i) fail_label = TESTLT_D i fail_label
+ testLT (DiscrP i) fail_label = TESTLT_P i fail_label
+ testLT NoDiscr _ = panic "mkMultiBranch NoDiscr"
+
+ testEQ (DiscrI i) fail_label = TESTEQ_I i fail_label
+ testEQ (DiscrW i) fail_label = TESTEQ_W i fail_label
+ testEQ (DiscrF i) fail_label = TESTEQ_F i fail_label
+ testEQ (DiscrD i) fail_label = TESTEQ_D i fail_label
+ testEQ (DiscrP i) fail_label = TESTEQ_P i fail_label
+ testEQ NoDiscr _ = panic "mkMultiBranch NoDiscr"
+
+ -- None of these will be needed if there are no non-default alts
+ (init_lo, init_hi)
+ | null notd_ways
+ = panic "mkMultiBranch: awesome foursome"
+ | otherwise
+ = case fst (head notd_ways) of
+ DiscrI _ -> ( DiscrI minBound, DiscrI maxBound )
+ DiscrW _ -> ( DiscrW minBound, DiscrW maxBound )
+ DiscrF _ -> ( DiscrF minF, DiscrF maxF )
+ DiscrD _ -> ( DiscrD minD, DiscrD maxD )
+ DiscrP _ -> ( DiscrP algMinBound, DiscrP algMaxBound )
+ NoDiscr -> panic "mkMultiBranch NoDiscr"
+
+ (algMinBound, algMaxBound)
+ = case maybe_ncons of
+ -- XXX What happens when n == 0?
+ Just n -> (0, fromIntegral n - 1)
+ Nothing -> (minBound, maxBound)
+
+ isNoDiscr NoDiscr = True
+ isNoDiscr _ = False
+
+ dec (DiscrI i) = DiscrI (i-1)
+ dec (DiscrW w) = DiscrW (w-1)
+ dec (DiscrP i) = DiscrP (i-1)
+ dec other = other -- not really right, but if you
+ -- do cases on floating values, you'll get what you deserve
+
+ -- same snotty comment applies to the following
+ minF, maxF :: Float
+ minD, maxD :: Double
+ minF = -1.0e37
+ maxF = 1.0e37
+ minD = -1.0e308
+ maxD = 1.0e308
+
+
+-- -----------------------------------------------------------------------------
+-- Supporting junk for the compilation schemes
+
+-- Describes case alts
+data Discr
+ = DiscrI Int
+ | DiscrW Word
+ | DiscrF Float
+ | DiscrD Double
+ | DiscrP Word16
+ | NoDiscr
+ deriving (Eq, Ord)
+
+instance Outputable Discr where
+ ppr (DiscrI i) = int i
+ ppr (DiscrW w) = text (show w)
+ ppr (DiscrF f) = text (show f)
+ ppr (DiscrD d) = text (show d)
+ ppr (DiscrP i) = ppr i
+ ppr NoDiscr = text "DEF"
+
+
+lookupBCEnv_maybe :: Id -> BCEnv -> Maybe Word
+lookupBCEnv_maybe = Map.lookup
+
+idSizeW :: DynFlags -> Id -> Int
+idSizeW dflags = argRepSizeW dflags . bcIdArgRep
+
+bcIdArgRep :: Id -> ArgRep
+bcIdArgRep = toArgRep . bcIdPrimRep
+
+bcIdPrimRep :: Id -> PrimRep
+bcIdPrimRep id
+ | [rep] <- typePrimRepArgs (idType id)
+ = rep
+ | otherwise
+ = pprPanic "bcIdPrimRep" (ppr id <+> dcolon <+> ppr (idType id))
+
+isFollowableArg :: ArgRep -> Bool
+isFollowableArg P = True
+isFollowableArg _ = False
+
+isVoidArg :: ArgRep -> Bool
+isVoidArg V = True
+isVoidArg _ = False
+
+-- See bug #1257
+multiValException :: a
+multiValException = throwGhcException (ProgramError
+ ("Error: bytecode compiler can't handle unboxed tuples and sums.\n"++
+ " Possibly due to foreign import/export decls in source.\n"++
+ " Workaround: use -fobject-code, or compile this module to .o separately."))
+
+-- | Indicate if the calling convention is supported
+isSupportedCConv :: CCallSpec -> Bool
+isSupportedCConv (CCallSpec _ cconv _) = case cconv of
+ CCallConv -> True -- we explicitly pattern match on every
+ StdCallConv -> True -- convention to ensure that a warning
+ PrimCallConv -> False -- is triggered when a new one is added
+ JavaScriptCallConv -> False
+ CApiConv -> False
+
+-- See bug #10462
+unsupportedCConvException :: a
+unsupportedCConvException = throwGhcException (ProgramError
+ ("Error: bytecode compiler can't handle some foreign calling conventions\n"++
+ " Workaround: use -fobject-code, or compile this module to .o separately."))
+
+mkSLIDE :: Word16 -> Word -> OrdList BCInstr
+mkSLIDE n d
+ -- if the amount to slide doesn't fit in a word,
+ -- generate multiple slide instructions
+ | d > fromIntegral limit
+ = SLIDE n limit `consOL` mkSLIDE n (d - fromIntegral limit)
+ | d == 0
+ = nilOL
+ | otherwise
+ = if d == 0 then nilOL else unitOL (SLIDE n $ fromIntegral d)
+ where
+ limit :: Word16
+ limit = maxBound
+
+splitApp :: AnnExpr' Var ann -> (AnnExpr' Var ann, [AnnExpr' Var ann])
+ -- The arguments are returned in *right-to-left* order
+splitApp e | Just e' <- bcView e = splitApp e'
+splitApp (AnnApp (_,f) (_,a)) = case splitApp f of
+ (f', as) -> (f', a:as)
+splitApp e = (e, [])
+
+
+bcView :: AnnExpr' Var ann -> Maybe (AnnExpr' Var ann)
+-- The "bytecode view" of a term discards
+-- a) type abstractions
+-- b) type applications
+-- c) casts
+-- d) ticks (but not breakpoints)
+-- Type lambdas *can* occur in random expressions,
+-- whereas value lambdas cannot; that is why they are nuked here
+bcView (AnnCast (_,e) _) = Just e
+bcView (AnnLam v (_,e)) | isTyVar v = Just e
+bcView (AnnApp (_,e) (_, AnnType _)) = Just e
+bcView (AnnTick Breakpoint{} _) = Nothing
+bcView (AnnTick _other_tick (_,e)) = Just e
+bcView _ = Nothing
+
+isVAtom :: AnnExpr' Var ann -> Bool
+isVAtom e | Just e' <- bcView e = isVAtom e'
+isVAtom (AnnVar v) = isVoidArg (bcIdArgRep v)
+isVAtom (AnnCoercion {}) = True
+isVAtom _ = False
+
+atomPrimRep :: AnnExpr' Id ann -> PrimRep
+atomPrimRep e | Just e' <- bcView e = atomPrimRep e'
+atomPrimRep (AnnVar v) = bcIdPrimRep v
+atomPrimRep (AnnLit l) = typePrimRep1 (literalType l)
+
+-- Trac #12128:
+-- A case expression can be an atom because empty cases evaluate to bottom.
+-- See Note [Empty case alternatives] in coreSyn/CoreSyn.hs
+atomPrimRep (AnnCase _ _ ty _) = ASSERT(typePrimRep ty == [LiftedRep]) LiftedRep
+atomPrimRep (AnnCoercion {}) = VoidRep
+atomPrimRep other = pprPanic "atomPrimRep" (ppr (deAnnotate' other))
+
+atomRep :: AnnExpr' Id ann -> ArgRep
+atomRep e = toArgRep (atomPrimRep e)
+
+isPtrAtom :: AnnExpr' Id ann -> Bool
+isPtrAtom e = isFollowableArg (atomRep e)
+
+-- Let szsw be the sizes in words of some items pushed onto the stack,
+-- which has initial depth d'. Return the values which the stack environment
+-- should map these items to.
+mkStackOffsets :: Word -> [Word] -> [Word]
+mkStackOffsets original_depth szsw
+ = map (subtract 1) (tail (scanl (+) original_depth szsw))
+
+typeArgRep :: Type -> ArgRep
+typeArgRep = toArgRep . typePrimRep1
+
+-- -----------------------------------------------------------------------------
+-- The bytecode generator's monad
+
+data BcM_State
+ = BcM_State
+ { bcm_hsc_env :: HscEnv
+ , uniqSupply :: UniqSupply -- for generating fresh variable names
+ , thisModule :: Module -- current module (for breakpoints)
+ , nextlabel :: Word16 -- for generating local labels
+ , ffis :: [FFIInfo] -- ffi info blocks, to free later
+ -- Should be free()d when it is GCd
+ , modBreaks :: Maybe ModBreaks -- info about breakpoints
+ , breakInfo :: IntMap CgBreakInfo
+ , topStrings :: IdEnv (RemotePtr ()) -- top-level string literals
+ -- See Note [generating code for top-level string literal bindings].
+ }
+
+newtype BcM r = BcM (BcM_State -> IO (BcM_State, r))
+
+ioToBc :: IO a -> BcM a
+ioToBc io = BcM $ \st -> do
+ x <- io
+ return (st, x)
+
+runBc :: HscEnv -> UniqSupply -> Module -> Maybe ModBreaks
+ -> IdEnv (RemotePtr ())
+ -> BcM r
+ -> IO (BcM_State, r)
+runBc hsc_env us this_mod modBreaks topStrings (BcM m)
+ = m (BcM_State hsc_env us this_mod 0 [] modBreaks IntMap.empty topStrings)
+
+thenBc :: BcM a -> (a -> BcM b) -> BcM b
+thenBc (BcM expr) cont = BcM $ \st0 -> do
+ (st1, q) <- expr st0
+ let BcM k = cont q
+ (st2, r) <- k st1
+ return (st2, r)
+
+thenBc_ :: BcM a -> BcM b -> BcM b
+thenBc_ (BcM expr) (BcM cont) = BcM $ \st0 -> do
+ (st1, _) <- expr st0
+ (st2, r) <- cont st1
+ return (st2, r)
+
+returnBc :: a -> BcM a
+returnBc result = BcM $ \st -> (return (st, result))
+
+instance Functor BcM where
+ fmap = liftM
+
+instance Applicative BcM where
+ pure = returnBc
+ (<*>) = ap
+ (*>) = thenBc_
+
+instance Monad BcM where
+ (>>=) = thenBc
+ (>>) = (*>)
+
+instance HasDynFlags BcM where
+ getDynFlags = BcM $ \st -> return (st, hsc_dflags (bcm_hsc_env st))
+
+getHscEnv :: BcM HscEnv
+getHscEnv = BcM $ \st -> return (st, bcm_hsc_env st)
+
+emitBc :: ([FFIInfo] -> ProtoBCO Name) -> BcM (ProtoBCO Name)
+emitBc bco
+ = BcM $ \st -> return (st{ffis=[]}, bco (ffis st))
+
+recordFFIBc :: RemotePtr C_ffi_cif -> BcM ()
+recordFFIBc a
+ = BcM $ \st -> return (st{ffis = FFIInfo a : ffis st}, ())
+
+getLabelBc :: BcM Word16
+getLabelBc
+ = BcM $ \st -> do let nl = nextlabel st
+ when (nl == maxBound) $
+ panic "getLabelBc: Ran out of labels"
+ return (st{nextlabel = nl + 1}, nl)
+
+getLabelsBc :: Word16 -> BcM [Word16]
+getLabelsBc n
+ = BcM $ \st -> let ctr = nextlabel st
+ in return (st{nextlabel = ctr+n}, [ctr .. ctr+n-1])
+
+getCCArray :: BcM (Array BreakIndex (RemotePtr CostCentre))
+getCCArray = BcM $ \st ->
+ let breaks = expectJust "ByteCodeGen.getCCArray" $ modBreaks st in
+ return (st, modBreaks_ccs breaks)
+
+
+newBreakInfo :: BreakIndex -> CgBreakInfo -> BcM ()
+newBreakInfo ix info = BcM $ \st ->
+ return (st{breakInfo = IntMap.insert ix info (breakInfo st)}, ())
+
+newUnique :: BcM Unique
+newUnique = BcM $
+ \st -> case takeUniqFromSupply (uniqSupply st) of
+ (uniq, us) -> let newState = st { uniqSupply = us }
+ in return (newState, uniq)
+
+getCurrentModule :: BcM Module
+getCurrentModule = BcM $ \st -> return (st, thisModule st)
+
+getTopStrings :: BcM (IdEnv (RemotePtr ()))
+getTopStrings = BcM $ \st -> return (st, topStrings st)
+
+newId :: Type -> BcM Id
+newId ty = do
+ uniq <- newUnique
+ return $ mkSysLocal tickFS uniq ty
+
+tickFS :: FastString
+tickFS = fsLit "ticked"
diff --git a/ghci/ByteCodeInstr.hs b/ghci/ByteCodeInstr.hs
new file mode 100644
--- /dev/null
+++ b/ghci/ByteCodeInstr.hs
@@ -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 ""
+
+-- -----------------------------------------------------------------------------
+-- The stack use, in words, of each bytecode insn. These _must_ be
+-- correct, or overestimates of reality, to be safe.
+
+-- NOTE: we aggregate the stack use from case alternatives too, so that
+-- we can do a single stack check at the beginning of a function only.
+
+-- This could all be made more accurate by keeping track of a proper
+-- stack high water mark, but it doesn't seem worth the hassle.
+
+protoBCOStackUse :: ProtoBCO a -> Word
+protoBCOStackUse bco = sum (map bciStackUse (protoBCOInstrs bco))
+
+bciStackUse :: BCInstr -> Word
+bciStackUse STKCHECK{} = 0
+bciStackUse PUSH_L{} = 1
+bciStackUse PUSH_LL{} = 2
+bciStackUse PUSH_LLL{} = 3
+bciStackUse PUSH_G{} = 1
+bciStackUse PUSH_PRIMOP{} = 1
+bciStackUse PUSH_BCO{} = 1
+bciStackUse (PUSH_ALTS bco) = 2 + protoBCOStackUse bco
+bciStackUse (PUSH_ALTS_UNLIFTED bco _) = 2 + protoBCOStackUse bco
+bciStackUse (PUSH_UBX _ nw) = fromIntegral nw
+bciStackUse PUSH_APPLY_N{} = 1
+bciStackUse PUSH_APPLY_V{} = 1
+bciStackUse PUSH_APPLY_F{} = 1
+bciStackUse PUSH_APPLY_D{} = 1
+bciStackUse PUSH_APPLY_L{} = 1
+bciStackUse PUSH_APPLY_P{} = 1
+bciStackUse PUSH_APPLY_PP{} = 1
+bciStackUse PUSH_APPLY_PPP{} = 1
+bciStackUse PUSH_APPLY_PPPP{} = 1
+bciStackUse PUSH_APPLY_PPPPP{} = 1
+bciStackUse PUSH_APPLY_PPPPPP{} = 1
+bciStackUse ALLOC_AP{} = 1
+bciStackUse ALLOC_AP_NOUPD{} = 1
+bciStackUse ALLOC_PAP{} = 1
+bciStackUse (UNPACK sz) = fromIntegral sz
+bciStackUse LABEL{} = 0
+bciStackUse TESTLT_I{} = 0
+bciStackUse TESTEQ_I{} = 0
+bciStackUse TESTLT_W{} = 0
+bciStackUse TESTEQ_W{} = 0
+bciStackUse TESTLT_F{} = 0
+bciStackUse TESTEQ_F{} = 0
+bciStackUse TESTLT_D{} = 0
+bciStackUse TESTEQ_D{} = 0
+bciStackUse TESTLT_P{} = 0
+bciStackUse TESTEQ_P{} = 0
+bciStackUse CASEFAIL{} = 0
+bciStackUse JMP{} = 0
+bciStackUse ENTER{} = 0
+bciStackUse RETURN{} = 0
+bciStackUse RETURN_UBX{} = 1
+bciStackUse CCALL{} = 0
+bciStackUse SWIZZLE{} = 0
+bciStackUse BRK_FUN{} = 0
+
+-- These insns actually reduce stack use, but we need the high-tide level,
+-- so can't use this info. Not that it matters much.
+bciStackUse SLIDE{} = 0
+bciStackUse MKAP{} = 0
+bciStackUse MKPAP{} = 0
+bciStackUse PACK{} = 1 -- worst case is PACK 0 words
diff --git a/ghci/ByteCodeItbls.hs b/ghci/ByteCodeItbls.hs
new file mode 100644
--- /dev/null
+++ b/ghci/ByteCodeItbls.hs
@@ -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)
diff --git a/ghci/ByteCodeLink.hs b/ghci/ByteCodeLink.hs
new file mode 100644
--- /dev/null
+++ b/ghci/ByteCodeLink.hs
@@ -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
+ ]
diff --git a/ghci/ByteCodeTypes.hs b/ghci/ByteCodeTypes.hs
new file mode 100644
--- /dev/null
+++ b/ghci/ByteCodeTypes.hs
@@ -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
+ }
diff --git a/ghci/Debugger.hs b/ghci/Debugger.hs
new file mode 100644
--- /dev/null
+++ b/ghci/Debugger.hs
@@ -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
diff --git a/ghci/DebuggerUtils.hs b/ghci/DebuggerUtils.hs
new file mode 100644
--- /dev/null
+++ b/ghci/DebuggerUtils.hs
@@ -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)
diff --git a/ghci/GHCi.hsc b/ghci/GHCi.hsc
new file mode 100644
--- /dev/null
+++ b/ghci/GHCi.hsc
@@ -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) parallelise the serialization.
+ if (n_jobs == 1)
+ then
+ iservCmd hsc_env (CreateBCOs [runPut (put rbcos)])
+
+ else do
+ old_caps <- getNumCapabilities
+ if old_caps == n_jobs
+ then void $ evaluate puts
+ else bracket_ (setNumCapabilities n_jobs)
+ (setNumCapabilities old_caps)
+ (void $ evaluate puts)
+ iservCmd hsc_env (CreateBCOs puts)
+ where
+ puts = parMap doChunk (chunkList 100 rbcos)
+
+ -- make sure we force the whole lazy ByteString
+ doChunk c = pseq (LB.length bs) bs
+ where bs = runPut (put c)
+
+ -- We don't have the parallel package, so roll our own simple parMap
+ parMap _ [] = []
+ parMap f (x:xs) = fx `par` (fxs `pseq` (fx : fxs))
+ where fx = f x; fxs = parMap f xs
+
+addSptEntry :: HscEnv -> Fingerprint -> ForeignHValue -> IO ()
+addSptEntry hsc_env fpr ref =
+ withForeignRef ref $ \val ->
+ iservCmd hsc_env (AddSptEntry fpr val)
+
+costCentreStackInfo :: HscEnv -> RemotePtr CostCentreStack -> IO [String]
+costCentreStackInfo hsc_env ccs =
+ iservCmd hsc_env (CostCentreStackInfo ccs)
+
+newBreakArray :: HscEnv -> Int -> IO (ForeignRef BreakArray)
+newBreakArray hsc_env size = do
+ breakArray <- iservCmd hsc_env (NewBreakArray size)
+ mkFinalizedHValue hsc_env breakArray
+
+enableBreakpoint :: HscEnv -> ForeignRef BreakArray -> Int -> Bool -> IO ()
+enableBreakpoint hsc_env ref ix b = do
+ withForeignRef ref $ \breakarray ->
+ iservCmd hsc_env (EnableBreakpoint breakarray ix b)
+
+breakpointStatus :: HscEnv -> ForeignRef BreakArray -> Int -> IO Bool
+breakpointStatus hsc_env ref ix = do
+ withForeignRef ref $ \breakarray ->
+ iservCmd hsc_env (BreakpointStatus breakarray ix)
+
+getBreakpointVar :: HscEnv -> ForeignHValue -> Int -> IO (Maybe ForeignHValue)
+getBreakpointVar hsc_env ref ix =
+ withForeignRef ref $ \apStack -> do
+ mb <- iservCmd hsc_env (GetBreakpointVar apStack ix)
+ mapM (mkFinalizedHValue hsc_env) mb
+
+-- -----------------------------------------------------------------------------
+-- Interface to the object-code linker
+
+initObjLinker :: HscEnv -> IO ()
+initObjLinker hsc_env = iservCmd hsc_env InitLinker
+
+lookupSymbol :: HscEnv -> FastString -> IO (Maybe (Ptr ()))
+lookupSymbol hsc_env@HscEnv{..} str
+ | gopt Opt_ExternalInterpreter hsc_dflags =
+ -- Profiling of GHCi showed a lot of time and allocation spent
+ -- making cross-process LookupSymbol calls, so I added a GHC-side
+ -- cache which sped things up quite a lot. We have to be careful
+ -- to purge this cache when unloading code though.
+ withIServ hsc_env $ \iserv@IServ{..} -> do
+ cache <- readIORef iservLookupSymbolCache
+ case lookupUFM cache str of
+ Just p -> return (Just p)
+ Nothing -> do
+ m <- uninterruptibleMask_ $
+ iservCall iserv (LookupSymbol (unpackFS str))
+ case m of
+ Nothing -> return Nothing
+ Just r -> do
+ let p = fromRemotePtr r
+ writeIORef iservLookupSymbolCache $! addToUFM cache str p
+ return (Just p)
+ | otherwise =
+#ifdef GHCI
+ fmap fromRemotePtr <$> run (LookupSymbol (unpackFS str))
+#else
+ needExtInt
+#endif
+
+lookupClosure :: HscEnv -> String -> IO (Maybe HValueRef)
+lookupClosure hsc_env str =
+ iservCmd hsc_env (LookupClosure str)
+
+purgeLookupSymbolCache :: HscEnv -> IO ()
+purgeLookupSymbolCache hsc_env@HscEnv{..} =
+ when (gopt Opt_ExternalInterpreter hsc_dflags) $
+ withIServ hsc_env $ \IServ{..} ->
+ writeIORef iservLookupSymbolCache emptyUFM
+
+
+-- | loadDLL loads a dynamic library using the OS's native linker
+-- (i.e. dlopen() on Unix, LoadLibrary() on Windows). It takes either
+-- an absolute pathname to the file, or a relative filename
+-- (e.g. "libfoo.so" or "foo.dll"). In the latter case, loadDLL
+-- searches the standard locations for the appropriate library.
+--
+-- Returns:
+--
+-- Nothing => success
+-- Just err_msg => failure
+loadDLL :: HscEnv -> String -> IO (Maybe String)
+loadDLL hsc_env str = iservCmd hsc_env (LoadDLL str)
+
+loadArchive :: HscEnv -> String -> IO ()
+loadArchive hsc_env path = do
+ path' <- canonicalizePath path -- Note [loadObj and relative paths]
+ iservCmd hsc_env (LoadArchive path')
+
+loadObj :: HscEnv -> String -> IO ()
+loadObj hsc_env path = do
+ path' <- canonicalizePath path -- Note [loadObj and relative paths]
+ iservCmd hsc_env (LoadObj path')
+
+unloadObj :: HscEnv -> String -> IO ()
+unloadObj hsc_env path = do
+ path' <- canonicalizePath path -- Note [loadObj and relative paths]
+ iservCmd hsc_env (UnloadObj path')
+
+-- Note [loadObj and relative paths]
+-- the iserv process might have a different current directory from the
+-- GHC process, so we must make paths absolute before sending them
+-- over.
+
+addLibrarySearchPath :: HscEnv -> String -> IO (Ptr ())
+addLibrarySearchPath hsc_env str =
+ fromRemotePtr <$> iservCmd hsc_env (AddLibrarySearchPath str)
+
+removeLibrarySearchPath :: HscEnv -> Ptr () -> IO Bool
+removeLibrarySearchPath hsc_env p =
+ iservCmd hsc_env (RemoveLibrarySearchPath (toRemotePtr p))
+
+resolveObjs :: HscEnv -> IO SuccessFlag
+resolveObjs hsc_env = successIf <$> iservCmd hsc_env ResolveObjs
+
+findSystemLibrary :: HscEnv -> String -> IO (Maybe String)
+findSystemLibrary hsc_env str = iservCmd hsc_env (FindSystemLibrary str)
+
+
+-- -----------------------------------------------------------------------------
+-- Raw calls and messages
+
+-- | Send a 'Message' and receive the response from the iserv process
+iservCall :: Binary a => IServ -> Message a -> IO a
+iservCall iserv@IServ{..} msg =
+ remoteCall iservPipe msg
+ `catch` \(e :: SomeException) -> handleIServFailure iserv e
+
+-- | Read a value from the iserv process
+readIServ :: IServ -> Get a -> IO a
+readIServ iserv@IServ{..} get =
+ readPipe iservPipe get
+ `catch` \(e :: SomeException) -> handleIServFailure iserv e
+
+-- | Send a value to the iserv process
+writeIServ :: IServ -> Put -> IO ()
+writeIServ iserv@IServ{..} put =
+ writePipe iservPipe put
+ `catch` \(e :: SomeException) -> handleIServFailure iserv e
+
+handleIServFailure :: IServ -> SomeException -> IO a
+handleIServFailure IServ{..} e = do
+ ex <- getProcessExitCode iservProcess
+ case ex of
+ Just (ExitFailure n) ->
+ throw (InstallationError ("ghc-iserv terminated (" ++ show n ++ ")"))
+ _ -> do
+ terminateProcess iservProcess
+ _ <- waitForProcess iservProcess
+ throw e
+
+-- -----------------------------------------------------------------------------
+-- Starting and stopping the iserv process
+
+startIServ :: DynFlags -> IO IServ
+startIServ dflags = do
+ let flavour
+ | WayProf `elem` ways dflags = "-prof"
+ | WayDyn `elem` ways dflags = "-dyn"
+ | otherwise = ""
+ prog = pgm_i dflags ++ flavour
+ opts = getOpts dflags opt_i
+ debugTraceMsg dflags 3 $ text "Starting " <> text prog
+ let createProc = lookupHook createIservProcessHook
+ (\cp -> do { (_,_,_,ph) <- createProcess cp
+ ; return ph })
+ dflags
+ (ph, rh, wh) <- runWithPipes createProc prog opts
+ lo_ref <- newIORef Nothing
+ cache_ref <- newIORef emptyUFM
+ return $ IServ
+ { iservPipe = Pipe { pipeRead = rh
+ , pipeWrite = wh
+ , pipeLeftovers = lo_ref }
+ , iservProcess = ph
+ , iservLookupSymbolCache = cache_ref
+ , iservPendingFrees = []
+ }
+
+stopIServ :: HscEnv -> IO ()
+stopIServ HscEnv{..} =
+ gmask $ \_restore -> do
+ m <- takeMVar hsc_iserv
+ maybe (return ()) stop m
+ putMVar hsc_iserv Nothing
+ where
+ stop iserv = do
+ ex <- getProcessExitCode (iservProcess iserv)
+ if isJust ex
+ then return ()
+ else iservCall iserv Shutdown
+
+runWithPipes :: (CreateProcess -> IO ProcessHandle)
+ -> FilePath -> [String] -> IO (ProcessHandle, Handle, Handle)
+#ifdef mingw32_HOST_OS
+foreign import ccall "io.h _close"
+ c__close :: CInt -> IO CInt
+
+foreign import ccall unsafe "io.h _get_osfhandle"
+ _get_osfhandle :: CInt -> IO CInt
+
+runWithPipes createProc prog opts = do
+ (rfd1, wfd1) <- createPipeFd -- we read on rfd1
+ (rfd2, wfd2) <- createPipeFd -- we write on wfd2
+ wh_client <- _get_osfhandle wfd1
+ rh_client <- _get_osfhandle rfd2
+ let args = show wh_client : show rh_client : opts
+ ph <- createProc (proc prog args)
+ rh <- mkHandle rfd1
+ wh <- mkHandle wfd2
+ return (ph, rh, wh)
+ where mkHandle :: CInt -> IO Handle
+ mkHandle fd = (fdToHandle fd) `onException` (c__close fd)
+
+#if !MIN_VERSION_process(1,4,2)
+-- This #include and the _O_BINARY below are the only reason this is hsc,
+-- so we can remove that once we can depend on process 1.4.2
+#include
+
+createPipeFd :: IO (FD, FD)
+createPipeFd = do
+ allocaArray 2 $ \ pfds -> do
+ throwErrnoIfMinus1_ "_pipe" $ c__pipe pfds 2 (#const _O_BINARY)
+ readfd <- peek pfds
+ writefd <- peekElemOff pfds 1
+ return (readfd, writefd)
+
+foreign import ccall "io.h _pipe" c__pipe ::
+ Ptr CInt -> CUInt -> CInt -> IO CInt
+#endif
+#else
+runWithPipes createProc prog opts = do
+ (rfd1, wfd1) <- Posix.createPipe -- we read on rfd1
+ (rfd2, wfd2) <- Posix.createPipe -- we write on wfd2
+ setFdOption rfd1 CloseOnExec True
+ setFdOption wfd2 CloseOnExec True
+ let args = show wfd1 : show rfd2 : opts
+ ph <- createProc (proc prog args)
+ closeFd wfd1
+ closeFd rfd2
+ rh <- fdToHandle rfd1
+ wh <- fdToHandle wfd2
+ return (ph, rh, wh)
+#endif
+
+-- -----------------------------------------------------------------------------
+{- Note [External GHCi pointers]
+
+We have the following ways to reference things in GHCi:
+
+HValue
+------
+
+HValue is a direct reference to an value in the local heap. Obviously
+we cannot use this to refer to things in the external process.
+
+
+RemoteRef
+---------
+
+RemoteRef is a StablePtr to a heap-resident value. When
+-fexternal-interpreter is used, this value resides in the external
+process's heap. RemoteRefs are mostly used to send pointers in
+messages between GHC and iserv.
+
+A RemoteRef must be explicitly freed when no longer required, using
+freeHValueRefs, or by attaching a finalizer with mkForeignHValue.
+
+To get from a RemoteRef to an HValue you can use 'wormholeRef', which
+fails with an error message if -fexternal-interpreter is in use.
+
+ForeignRef
+----------
+
+A ForeignRef is a RemoteRef with a finalizer that will free the
+'RemoteRef' when it is garbage collected. We mostly use ForeignHValue
+on the GHC side.
+
+The finalizer adds the RemoteRef to the iservPendingFrees list in the
+IServ record. The next call to iservCmd will free any RemoteRefs in
+the list. It was done this way rather than calling iservCmd directly,
+because I didn't want to have arbitrary threads calling iservCmd. In
+principle it would probably be ok, but it seems less hairy this way.
+-}
+
+-- | Creates a 'ForeignRef' that will automatically release the
+-- 'RemoteRef' when it is no longer referenced.
+mkFinalizedHValue :: HscEnv -> RemoteRef a -> IO (ForeignRef a)
+mkFinalizedHValue HscEnv{..} rref = mkForeignRef rref free
+ where
+ !external = gopt Opt_ExternalInterpreter hsc_dflags
+ hvref = toHValueRef rref
+
+ free :: IO ()
+ free
+ | not external = freeRemoteRef hvref
+ | otherwise =
+ modifyMVar_ hsc_iserv $ \mb_iserv ->
+ case mb_iserv of
+ Nothing -> return Nothing -- already shut down
+ Just iserv@IServ{..} ->
+ return (Just iserv{iservPendingFrees = hvref : iservPendingFrees})
+
+freeHValueRefs :: HscEnv -> [HValueRef] -> IO ()
+freeHValueRefs _ [] = return ()
+freeHValueRefs hsc_env refs = iservCmd hsc_env (FreeHValueRefs refs)
+
+-- | Convert a 'ForeignRef' to the value it references directly. This
+-- only works when the interpreter is running in the same process as
+-- the compiler, so it fails when @-fexternal-interpreter@ is on.
+wormhole :: DynFlags -> ForeignRef a -> IO a
+wormhole dflags r = wormholeRef dflags (unsafeForeignRefToRemoteRef r)
+
+-- | Convert an 'RemoteRef' to the value it references directly. This
+-- only works when the interpreter is running in the same process as
+-- the compiler, so it fails when @-fexternal-interpreter@ is on.
+wormholeRef :: DynFlags -> RemoteRef a -> IO a
+wormholeRef dflags _r
+ | gopt Opt_ExternalInterpreter dflags
+ = throwIO (InstallationError
+ "this operation requires -fno-external-interpreter")
+#ifdef GHCI
+ | otherwise
+ = localRef _r
+#else
+ | otherwise
+ = throwIO (InstallationError
+ "can't wormhole a value in a stage1 compiler")
+#endif
+
+-- -----------------------------------------------------------------------------
+-- Misc utils
+
+mkEvalOpts :: DynFlags -> Bool -> EvalOpts
+mkEvalOpts dflags step =
+ EvalOpts
+ { useSandboxThread = gopt Opt_GhciSandbox dflags
+ , singleStep = step
+ , breakOnException = gopt Opt_BreakOnException dflags
+ , breakOnError = gopt Opt_BreakOnError dflags }
+
+fromEvalResult :: EvalResult a -> IO a
+fromEvalResult (EvalException e) = throwIO (fromSerializableException e)
+fromEvalResult (EvalSuccess a) = return a
diff --git a/ghci/Linker.hs b/ghci/Linker.hs
new file mode 100644
--- /dev/null
+++ b/ghci/Linker.hs
@@ -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")
diff --git a/ghci/RtClosureInspect.hs b/ghci/RtClosureInspect.hs
new file mode 100644
--- /dev/null
+++ b/ghci/RtClosureInspect.hs
@@ -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("")
+ | otherwise = return$ parens$ ppr n <> text "::" <> ppr ty
+ppr_termM1 Term{} = panic "ppr_termM1 - Term"
+ppr_termM1 RefWrap{} = panic "ppr_termM1 - RefWrap"
+ppr_termM1 NewtypeWrap{} = panic "ppr_termM1 - NewtypeWrap"
+
+pprNewtypeWrap y p NewtypeWrap{ty=ty, wrapped_term=t}
+ | Just (tc,_) <- tcSplitTyConApp_maybe ty
+ , ASSERT(isNewTyCon tc) True
+ , Just new_dc <- tyConSingleDataCon_maybe tc = do
+ real_term <- y max_prec t
+ return $ cparen (p >= app_prec) (ppr new_dc <+> real_term)
+pprNewtypeWrap _ _ _ = panic "pprNewtypeWrap"
+
+-------------------------------------------------------
+-- Custom Term Pretty Printers
+-------------------------------------------------------
+
+-- We can want to customize the representation of a
+-- term depending on its type.
+-- However, note that custom printers have to work with
+-- type representations, instead of directly with types.
+-- We cannot use type classes here, unless we employ some
+-- typerep trickery (e.g. Weirich's RepLib tricks),
+-- which I didn't. Therefore, this code replicates a lot
+-- of what type classes provide for free.
+
+type CustomTermPrinter m = TermPrinterM m
+ -> [Precedence -> Term -> (m (Maybe SDoc))]
+
+-- | Takes a list of custom printers with a explicit recursion knot and a term,
+-- and returns the output of the first successful printer, or the default printer
+cPprTerm :: Monad m => CustomTermPrinter m -> Term -> m SDoc
+cPprTerm printers_ = go 0 where
+ printers = printers_ go
+ go prec t = do
+ let default_ = Just `liftM` pprTermM go prec t
+ mb_customDocs = [pp prec t | pp <- printers] ++ [default_]
+ Just doc <- firstJustM mb_customDocs
+ return$ cparen (prec>app_prec+1) doc
+
+ firstJustM (mb:mbs) = mb >>= maybe (firstJustM mbs) (return . Just)
+ firstJustM [] = return Nothing
+
+-- Default set of custom printers. Note that the recursion knot is explicit
+cPprTermBase :: forall m. Monad m => CustomTermPrinter m
+cPprTermBase y =
+ [ ifTerm (isTupleTy.ty) (\_p -> liftM (parens . hcat . punctuate comma)
+ . mapM (y (-1))
+ . subTerms)
+ , ifTerm (\t -> isTyCon listTyCon (ty t) && subTerms t `lengthIs` 2)
+ ppr_list
+ , ifTerm (isTyCon intTyCon . ty) ppr_int
+ , ifTerm (isTyCon charTyCon . ty) ppr_char
+ , ifTerm (isTyCon floatTyCon . ty) ppr_float
+ , ifTerm (isTyCon doubleTyCon . ty) ppr_double
+ , ifTerm (isIntegerTy . ty) ppr_integer
+ ]
+ where
+ ifTerm :: (Term -> Bool)
+ -> (Precedence -> Term -> m SDoc)
+ -> Precedence -> Term -> m (Maybe SDoc)
+ ifTerm pred f prec t@Term{}
+ | pred t = Just `liftM` f prec t
+ ifTerm _ _ _ _ = return Nothing
+
+ isTupleTy ty = fromMaybe False $ do
+ (tc,_) <- tcSplitTyConApp_maybe ty
+ return (isBoxedTupleTyCon tc)
+
+ isTyCon a_tc ty = fromMaybe False $ do
+ (tc,_) <- tcSplitTyConApp_maybe ty
+ return (a_tc == tc)
+
+ isIntegerTy ty = fromMaybe False $ do
+ (tc,_) <- tcSplitTyConApp_maybe ty
+ return (tyConName tc == integerTyConName)
+
+ ppr_int, ppr_char, ppr_float, ppr_double, ppr_integer
+ :: Precedence -> Term -> m SDoc
+ ppr_int _ v = return (Ppr.int (unsafeCoerce# (val v)))
+ ppr_char _ v = return (Ppr.char '\'' <> Ppr.char (unsafeCoerce# (val v)) <> Ppr.char '\'')
+ ppr_float _ v = return (Ppr.float (unsafeCoerce# (val v)))
+ ppr_double _ v = return (Ppr.double (unsafeCoerce# (val v)))
+ ppr_integer _ v = return (Ppr.integer (unsafeCoerce# (val v)))
+
+ --Note pprinting of list terms is not lazy
+ ppr_list :: Precedence -> Term -> m SDoc
+ ppr_list p (Term{subTerms=[h,t]}) = do
+ let elems = h : getListTerms t
+ isConsLast = not (termType (last elems) `eqType` termType h)
+ is_string = all (isCharTy . ty) elems
+
+ print_elems <- mapM (y cons_prec) elems
+ if is_string
+ then return (Ppr.doubleQuotes (Ppr.text (unsafeCoerce# (map val elems))))
+ else if isConsLast
+ then return $ cparen (p >= cons_prec)
+ $ pprDeeperList fsep
+ $ punctuate (space<>colon) print_elems
+ else return $ brackets
+ $ pprDeeperList fcat
+ $ punctuate comma print_elems
+
+ where getListTerms Term{subTerms=[h,t]} = h : getListTerms t
+ getListTerms Term{subTerms=[]} = []
+ getListTerms t@Suspension{} = [t]
+ getListTerms t = pprPanic "getListTerms" (ppr t)
+ ppr_list _ _ = panic "doList"
+
+
+repPrim :: TyCon -> [Word] -> SDoc
+repPrim t = rep where
+ rep x
+ | t == charPrimTyCon = text $ show (build x :: Char)
+ | t == intPrimTyCon = text $ show (build x :: Int)
+ | t == wordPrimTyCon = text $ show (build x :: Word)
+ | t == floatPrimTyCon = text $ show (build x :: Float)
+ | t == doublePrimTyCon = text $ show (build x :: Double)
+ | t == int32PrimTyCon = text $ show (build x :: Int32)
+ | t == word32PrimTyCon = text $ show (build x :: Word32)
+ | t == int64PrimTyCon = text $ show (build x :: Int64)
+ | t == word64PrimTyCon = text $ show (build x :: Word64)
+ | t == addrPrimTyCon = text $ show (nullPtr `plusPtr` build x)
+ | t == stablePtrPrimTyCon = text ""
+ | t == stableNamePrimTyCon = text ""
+ | t == statePrimTyCon = text ""
+ | t == proxyPrimTyCon = text ""
+ | t == realWorldTyCon = text ""
+ | t == threadIdPrimTyCon = text ""
+ | t == weakPrimTyCon = text ""
+ | t == arrayPrimTyCon = text ""
+ | t == smallArrayPrimTyCon = text ""
+ | t == byteArrayPrimTyCon = text ""
+ | t == mutableArrayPrimTyCon = text ""
+ | t == smallMutableArrayPrimTyCon = text ""
+ | t == mutableByteArrayPrimTyCon = text ""
+ | t == mutVarPrimTyCon = text ""
+ | t == mVarPrimTyCon = text ""
+ | t == tVarPrimTyCon = text ""
+ | otherwise = char '<' <> ppr t <> char '>'
+ where build ww = unsafePerformIO $ withArray ww (peek . castPtr)
+-- This ^^^ relies on the representation of Haskell heap values being
+-- the same as in a C array.
+
+-----------------------------------
+-- Type Reconstruction
+-----------------------------------
+{-
+Type Reconstruction is type inference done on heap closures.
+The algorithm walks the heap generating a set of equations, which
+are solved with syntactic unification.
+A type reconstruction equation looks like:
+
+ =
+
+The full equation set is generated by traversing all the subterms, starting
+from a given term.
+
+The only difficult part is that newtypes are only found in the lhs of equations.
+Right hand sides are missing them. We can either (a) drop them from the lhs, or
+(b) reconstruct them in the rhs when possible.
+
+The function congruenceNewtypes takes a shot at (b)
+-}
+
+
+-- A (non-mutable) tau type containing
+-- existentially quantified tyvars.
+-- (since GHC type language currently does not support
+-- existentials, we leave these variables unquantified)
+type RttiType = Type
+
+-- An incomplete type as stored in GHCi:
+-- no polymorphism: no quantifiers & all tyvars are skolem.
+type GhciType = Type
+
+
+-- The Type Reconstruction monad
+--------------------------------
+type TR a = TcM a
+
+runTR :: HscEnv -> TR a -> IO a
+runTR hsc_env thing = do
+ mb_val <- runTR_maybe hsc_env thing
+ case mb_val of
+ Nothing -> error "unable to :print the term"
+ Just x -> return x
+
+runTR_maybe :: HscEnv -> TR a -> IO (Maybe a)
+runTR_maybe hsc_env thing_inside
+ = do { (_errs, res) <- initTcInteractive hsc_env thing_inside
+ ; return res }
+
+-- | Term Reconstruction trace
+traceTR :: SDoc -> TR ()
+traceTR = liftTcM . traceOptTcRn Opt_D_dump_rtti
+
+
+-- Semantically different to recoverM in TcRnMonad
+-- recoverM retains the errors in the first action,
+-- whereas recoverTc here does not
+recoverTR :: TR a -> TR a -> TR a
+recoverTR = tryTcDiscardingErrs
+
+trIO :: IO a -> TR a
+trIO = liftTcM . liftIO
+
+liftTcM :: TcM a -> TR a
+liftTcM = id
+
+newVar :: Kind -> TR TcType
+newVar = liftTcM . newFlexiTyVarTy
+
+newOpenVar :: TR TcType
+newOpenVar = liftTcM newOpenFlexiTyVarTy
+
+instTyVars :: [TyVar] -> TR (TCvSubst, [TcTyVar])
+-- Instantiate fresh mutable type variables from some TyVars
+-- This function preserves the print-name, which helps error messages
+instTyVars tvs
+ = liftTcM $ fst <$> captureConstraints (newMetaTyVars tvs)
+
+type RttiInstantiation = [(TcTyVar, TyVar)]
+ -- Associates the typechecker-world meta type variables
+ -- (which are mutable and may be refined), to their
+ -- debugger-world RuntimeUnk counterparts.
+ -- If the TcTyVar has not been refined by the runtime type
+ -- elaboration, then we want to turn it back into the
+ -- original RuntimeUnk
+
+-- | Returns the instantiated type scheme ty', and the
+-- mapping from new (instantiated) -to- old (skolem) type variables
+instScheme :: QuantifiedType -> TR (TcType, RttiInstantiation)
+instScheme (tvs, ty)
+ = do { (subst, tvs') <- instTyVars tvs
+ ; let rtti_inst = [(tv',tv) | (tv',tv) <- tvs' `zip` tvs]
+ ; return (substTy subst ty, rtti_inst) }
+
+applyRevSubst :: RttiInstantiation -> TR ()
+-- Apply the *reverse* substitution in-place to any un-filled-in
+-- meta tyvars. This recovers the original debugger-world variable
+-- unless it has been refined by new information from the heap
+applyRevSubst pairs = liftTcM (mapM_ do_pair pairs)
+ where
+ do_pair (tc_tv, rtti_tv)
+ = do { tc_ty <- zonkTcTyVar tc_tv
+ ; case tcGetTyVar_maybe tc_ty of
+ Just tv | isMetaTyVar tv -> writeMetaTyVar tv (mkTyVarTy rtti_tv)
+ _ -> return () }
+
+-- Adds a constraint of the form t1 == t2
+-- t1 is expected to come from walking the heap
+-- t2 is expected to come from a datacon signature
+-- Before unification, congruenceNewtypes needs to
+-- do its magic.
+addConstraint :: TcType -> TcType -> TR ()
+addConstraint actual expected = do
+ traceTR (text "add constraint:" <+> fsep [ppr actual, equals, ppr expected])
+ recoverTR (traceTR $ fsep [text "Failed to unify", ppr actual,
+ text "with", ppr expected]) $
+ discardResult $
+ captureConstraints $
+ do { (ty1, ty2) <- congruenceNewtypes actual expected
+ ; unifyType noThing ty1 ty2 }
+ -- TOMDO: what about the coercion?
+ -- we should consider family instances
+
+-- Type & Term reconstruction
+------------------------------
+cvObtainTerm :: HscEnv -> Int -> Bool -> RttiType -> HValue -> IO Term
+cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
+ -- we quantify existential tyvars as universal,
+ -- as this is needed to be able to manipulate
+ -- them properly
+ let quant_old_ty@(old_tvs, old_tau) = quantifyType old_ty
+ sigma_old_ty = mkInvForAllTys old_tvs old_tau
+ traceTR (text "Term reconstruction started with initial type " <> ppr old_ty)
+ term <-
+ if null old_tvs
+ then do
+ term <- go max_depth sigma_old_ty sigma_old_ty hval
+ term' <- zonkTerm term
+ return $ fixFunDictionaries $ expandNewtypes term'
+ else do
+ (old_ty', rev_subst) <- instScheme quant_old_ty
+ my_ty <- newOpenVar
+ when (check1 quant_old_ty) (traceTR (text "check1 passed") >>
+ addConstraint my_ty old_ty')
+ term <- go max_depth my_ty sigma_old_ty hval
+ new_ty <- zonkTcType (termType term)
+ if isMonomorphic new_ty || check2 (quantifyType new_ty) quant_old_ty
+ then do
+ traceTR (text "check2 passed")
+ addConstraint new_ty old_ty'
+ applyRevSubst rev_subst
+ zterm' <- zonkTerm term
+ return ((fixFunDictionaries . expandNewtypes) zterm')
+ else do
+ traceTR (text "check2 failed" <+> parens
+ (ppr term <+> text "::" <+> ppr new_ty))
+ -- we have unsound types. Replace constructor types in
+ -- subterms with tyvars
+ zterm' <- mapTermTypeM
+ (\ty -> case tcSplitTyConApp_maybe ty of
+ Just (tc, _:_) | tc /= funTyCon
+ -> newOpenVar
+ _ -> return ty)
+ term
+ zonkTerm zterm'
+ traceTR (text "Term reconstruction completed." $$
+ text "Term obtained: " <> ppr term $$
+ text "Type obtained: " <> ppr (termType term))
+ return term
+ where
+ dflags = hsc_dflags hsc_env
+
+ go :: Int -> Type -> Type -> HValue -> TcM Term
+ -- I believe that my_ty should not have any enclosing
+ -- foralls, nor any free RuntimeUnk skolems;
+ -- that is partly what the quantifyType stuff achieved
+ --
+ -- [SPJ May 11] I don't understand the difference between my_ty and old_ty
+
+ go 0 my_ty _old_ty a = do
+ traceTR (text "Gave up reconstructing a term after" <>
+ int max_depth <> text " steps")
+ clos <- trIO $ getClosureData dflags a
+ return (Suspension (tipe clos) my_ty a Nothing)
+ go !max_depth my_ty old_ty a = do
+ let monomorphic = not(isTyVarTy my_ty)
+ -- This ^^^ is a convention. The ancestor tests for
+ -- monomorphism and passes a type instead of a tv
+ clos <- trIO $ getClosureData dflags a
+ case tipe clos of
+-- Thunks we may want to force
+ t | isThunk t && force -> traceTR (text "Forcing a " <> text (show t)) >>
+ seq a (go (pred max_depth) my_ty old_ty a)
+-- Blackholes are indirections iff the payload is not TSO or BLOCKING_QUEUE. So we
+-- treat them like indirections; if the payload is TSO or BLOCKING_QUEUE, we'll end up
+-- showing '_' which is what we want.
+ Blackhole -> do traceTR (text "Following a BLACKHOLE")
+ appArr (go max_depth my_ty old_ty) (ptrs clos) 0
+-- We always follow indirections
+ Indirection i -> do traceTR (text "Following an indirection" <> parens (int i) )
+ go max_depth my_ty old_ty $! (ptrs clos ! 0)
+-- We also follow references
+ MutVar _ | Just (tycon,[world,contents_ty]) <- tcSplitTyConApp_maybe old_ty
+ -> do
+ -- Deal with the MutVar# primitive
+ -- It does not have a constructor at all,
+ -- so we simulate the following one
+ -- MutVar# :: contents_ty -> MutVar# s contents_ty
+ traceTR (text "Following a MutVar")
+ contents_tv <- newVar liftedTypeKind
+ contents <- trIO$ IO$ \w -> readMutVar# (unsafeCoerce# a) w
+ ASSERT(isUnliftedType my_ty) return ()
+ (mutvar_ty,_) <- instScheme $ quantifyType $ mkFunTy
+ contents_ty (mkTyConApp tycon [world,contents_ty])
+ addConstraint (mkFunTy contents_tv my_ty) mutvar_ty
+ x <- go (pred max_depth) contents_tv contents_ty contents
+ return (RefWrap my_ty x)
+
+ -- The interesting case
+ Constr -> do
+ traceTR (text "entering a constructor " <>
+ if monomorphic
+ then parens (text "already monomorphic: " <> ppr my_ty)
+ else Ppr.empty)
+ Right dcname <- dataConInfoPtrToName (infoPtr clos)
+ (_,mb_dc) <- tryTc (tcLookupDataCon dcname)
+ case mb_dc of
+ Nothing -> do -- This can happen for private constructors compiled -O0
+ -- where the .hi descriptor does not export them
+ -- In such case, we return a best approximation:
+ -- ignore the unpointed args, and recover the pointeds
+ -- This preserves laziness, and should be safe.
+ traceTR (text "Not constructor" <+> ppr dcname)
+ let dflags = hsc_dflags hsc_env
+ tag = showPpr dflags dcname
+ vars <- replicateM (length$ elems$ ptrs clos)
+ (newVar liftedTypeKind)
+ subTerms <- sequence [appArr (go (pred max_depth) tv tv) (ptrs clos) i
+ | (i, tv) <- zip [0..] vars]
+ return (Term my_ty (Left ('<' : tag ++ ">")) a subTerms)
+ Just dc -> do
+ traceTR (text "Is constructor" <+> (ppr dc $$ ppr my_ty))
+ subTtypes <- getDataConArgTys dc my_ty
+ subTerms <- extractSubTerms (\ty -> go (pred max_depth) ty ty) clos subTtypes
+ return (Term my_ty (Right dc) a subTerms)
+
+-- The otherwise case: can be a Thunk,AP,PAP,etc.
+ tipe_clos -> do
+ traceTR (text "Unknown closure:" <+> ppr tipe_clos)
+ return (Suspension tipe_clos my_ty a Nothing)
+
+ -- insert NewtypeWraps around newtypes
+ expandNewtypes = foldTerm idTermFold { fTerm = worker } where
+ worker ty dc hval tt
+ | Just (tc, args) <- tcSplitTyConApp_maybe ty
+ , isNewTyCon tc
+ , wrapped_type <- newTyConInstRhs tc args
+ , Just dc' <- tyConSingleDataCon_maybe tc
+ , t' <- worker wrapped_type dc hval tt
+ = NewtypeWrap ty (Right dc') t'
+ | otherwise = Term ty dc hval tt
+
+
+ -- Avoid returning types where predicates have been expanded to dictionaries.
+ fixFunDictionaries = foldTerm idTermFold {fSuspension = worker} where
+ worker ct ty hval n | isFunTy ty = Suspension ct (dictsView ty) hval n
+ | otherwise = Suspension ct ty hval n
+
+extractSubTerms :: (Type -> HValue -> TcM Term)
+ -> Closure -> [Type] -> TcM [Term]
+extractSubTerms recurse clos = liftM thdOf3 . go 0 (nonPtrs clos)
+ where
+ go ptr_i ws [] = return (ptr_i, ws, [])
+ go ptr_i ws (ty:tys)
+ | Just (tc, elem_tys) <- tcSplitTyConApp_maybe ty
+ , isUnboxedTupleTyCon tc
+ -- See Note [Unboxed tuple RuntimeRep vars] in TyCon
+ = do (ptr_i, ws, terms0) <- go ptr_i ws (dropRuntimeRepArgs elem_tys)
+ (ptr_i, ws, terms1) <- go ptr_i ws tys
+ return (ptr_i, ws, unboxedTupleTerm ty terms0 : terms1)
+ | otherwise
+ = case typePrimRepArgs ty of
+ [rep_ty] -> do
+ (ptr_i, ws, term0) <- go_rep ptr_i ws ty rep_ty
+ (ptr_i, ws, terms1) <- go ptr_i ws tys
+ return (ptr_i, ws, term0 : terms1)
+ rep_tys -> do
+ (ptr_i, ws, terms0) <- go_unary_types ptr_i ws rep_tys
+ (ptr_i, ws, terms1) <- go ptr_i ws tys
+ return (ptr_i, ws, unboxedTupleTerm ty terms0 : terms1)
+
+ go_unary_types ptr_i ws [] = return (ptr_i, ws, [])
+ go_unary_types ptr_i ws (rep_ty:rep_tys) = do
+ tv <- newVar liftedTypeKind
+ (ptr_i, ws, term0) <- go_rep ptr_i ws tv rep_ty
+ (ptr_i, ws, terms1) <- go_unary_types ptr_i ws rep_tys
+ return (ptr_i, ws, term0 : terms1)
+
+ go_rep ptr_i ws ty rep
+ | isGcPtrRep rep
+ = do t <- appArr (recurse ty) (ptrs clos) ptr_i
+ return (ptr_i + 1, ws, t)
+ | otherwise
+ = do dflags <- getDynFlags
+ let (ws0, ws1) = splitAt (primRepSizeW dflags rep) ws
+ return (ptr_i, ws1, Prim ty ws0)
+
+ unboxedTupleTerm ty terms
+ = Term ty (Right (tupleDataCon Unboxed (length terms)))
+ (error "unboxedTupleTerm: no HValue for unboxed tuple") terms
+
+
+-- Fast, breadth-first Type reconstruction
+------------------------------------------
+cvReconstructType :: HscEnv -> Int -> GhciType -> HValue -> IO (Maybe Type)
+cvReconstructType hsc_env max_depth old_ty hval = runTR_maybe hsc_env $ do
+ traceTR (text "RTTI started with initial type " <> ppr old_ty)
+ let sigma_old_ty@(old_tvs, _) = quantifyType old_ty
+ new_ty <-
+ if null old_tvs
+ then return old_ty
+ else do
+ (old_ty', rev_subst) <- instScheme sigma_old_ty
+ my_ty <- newOpenVar
+ when (check1 sigma_old_ty) (traceTR (text "check1 passed") >>
+ addConstraint my_ty old_ty')
+ search (isMonomorphic `fmap` zonkTcType my_ty)
+ (\(ty,a) -> go ty a)
+ (Seq.singleton (my_ty, hval))
+ max_depth
+ new_ty <- zonkTcType my_ty
+ if isMonomorphic new_ty || check2 (quantifyType new_ty) sigma_old_ty
+ then do
+ traceTR (text "check2 passed" <+> ppr old_ty $$ ppr new_ty)
+ addConstraint my_ty old_ty'
+ applyRevSubst rev_subst
+ zonkRttiType new_ty
+ else traceTR (text "check2 failed" <+> parens (ppr new_ty)) >>
+ return old_ty
+ traceTR (text "RTTI completed. Type obtained:" <+> ppr new_ty)
+ return new_ty
+ where
+ dflags = hsc_dflags hsc_env
+
+-- search :: m Bool -> ([a] -> [a] -> [a]) -> [a] -> m ()
+ search _ _ _ 0 = traceTR (text "Failed to reconstruct a type after " <>
+ int max_depth <> text " steps")
+ search stop expand l d =
+ case viewl l of
+ EmptyL -> return ()
+ x :< xx -> unlessM stop $ do
+ new <- expand x
+ search stop expand (xx `mappend` Seq.fromList new) $! (pred d)
+
+ -- returns unification tasks,since we are going to want a breadth-first search
+ go :: Type -> HValue -> TR [(Type, HValue)]
+ go my_ty a = do
+ traceTR (text "go" <+> ppr my_ty)
+ clos <- trIO $ getClosureData dflags a
+ case tipe clos of
+ Blackhole -> appArr (go my_ty) (ptrs clos) 0 -- carefully, don't eval the TSO
+ Indirection _ -> go my_ty $! (ptrs clos ! 0)
+ MutVar _ -> do
+ contents <- trIO$ IO$ \w -> readMutVar# (unsafeCoerce# a) w
+ tv' <- newVar liftedTypeKind
+ world <- newVar liftedTypeKind
+ addConstraint my_ty (mkTyConApp mutVarPrimTyCon [world,tv'])
+ return [(tv', contents)]
+ Constr -> do
+ Right dcname <- dataConInfoPtrToName (infoPtr clos)
+ traceTR (text "Constr1" <+> ppr dcname)
+ (_,mb_dc) <- tryTc (tcLookupDataCon dcname)
+ case mb_dc of
+ Nothing-> do
+ forM (elems $ ptrs clos) $ \a -> do
+ tv <- newVar liftedTypeKind
+ return (tv, a)
+
+ Just dc -> do
+ arg_tys <- getDataConArgTys dc my_ty
+ (_, itys) <- findPtrTyss 0 arg_tys
+ traceTR (text "Constr2" <+> ppr dcname <+> ppr arg_tys)
+ return $ [ appArr (\e-> (ty,e)) (ptrs clos) i
+ | (i,ty) <- itys]
+ _ -> return []
+
+findPtrTys :: Int -- Current pointer index
+ -> Type -- Type
+ -> TR (Int, [(Int, Type)])
+findPtrTys i ty
+ | Just (tc, elem_tys) <- tcSplitTyConApp_maybe ty
+ , isUnboxedTupleTyCon tc
+ = findPtrTyss i elem_tys
+
+ | otherwise
+ = case typePrimRep ty of
+ [rep] | isGcPtrRep rep -> return (i + 1, [(i, ty)])
+ | otherwise -> return (i, [])
+ prim_reps ->
+ foldM (\(i, extras) prim_rep ->
+ if isGcPtrRep prim_rep
+ then newVar liftedTypeKind >>= \tv -> return (i + 1, extras ++ [(i, tv)])
+ else return (i, extras))
+ (i, []) prim_reps
+
+findPtrTyss :: Int
+ -> [Type]
+ -> TR (Int, [(Int, Type)])
+findPtrTyss i tys = foldM step (i, []) tys
+ where step (i, discovered) elem_ty = do
+ (i, extras) <- findPtrTys i elem_ty
+ return (i, discovered ++ extras)
+
+
+-- Compute the difference between a base type and the type found by RTTI
+-- improveType
+-- The types can contain skolem type variables, which need to be treated as normal vars.
+-- In particular, we want them to unify with things.
+improveRTTIType :: HscEnv -> RttiType -> RttiType -> Maybe TCvSubst
+improveRTTIType _ base_ty new_ty = U.tcUnifyTyKi base_ty new_ty
+
+getDataConArgTys :: DataCon -> Type -> TR [Type]
+-- Given the result type ty of a constructor application (D a b c :: ty)
+-- return the types of the arguments. This is RTTI-land, so 'ty' might
+-- not be fully known. Moreover, the arg types might involve existentials;
+-- if so, make up fresh RTTI type variables for them
+--
+-- I believe that con_app_ty should not have any enclosing foralls
+getDataConArgTys dc con_app_ty
+ = do { let rep_con_app_ty = unwrapType con_app_ty
+ ; traceTR (text "getDataConArgTys 1" <+> (ppr con_app_ty $$ ppr rep_con_app_ty
+ $$ ppr (tcSplitTyConApp_maybe rep_con_app_ty)))
+ ; (subst, _) <- instTyVars (univ_tvs ++ ex_tvs)
+ ; addConstraint rep_con_app_ty (substTy subst (dataConOrigResTy dc))
+ -- See Note [Constructor arg types]
+ ; let con_arg_tys = substTys subst (dataConRepArgTys dc)
+ ; traceTR (text "getDataConArgTys 2" <+> (ppr rep_con_app_ty $$ ppr con_arg_tys $$ ppr subst))
+ ; return con_arg_tys }
+ where
+ univ_tvs = dataConUnivTyVars dc
+ ex_tvs = dataConExTyVars dc
+
+{- Note [Constructor arg types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider a GADT (cf Trac #7386)
+ data family D a b
+ data instance D [a] a where
+ MkT :: a -> D [a] (Maybe a)
+ ...
+
+In getDataConArgTys
+* con_app_ty is the known type (from outside) of the constructor application,
+ say D [Int] Int
+
+* The data constructor MkT has a (representation) dataConTyCon = DList,
+ say where
+ data DList a where
+ MkT :: a -> DList a (Maybe a)
+ ...
+
+So the dataConTyCon of the data constructor, DList, differs from
+the "outside" type, D. So we can't straightforwardly decompose the
+"outside" type, and we end up in the "_" branch of the case.
+
+Then we match the dataConOrigResTy of the data constructor against the
+outside type, hoping to get a substitution that tells how to instantiate
+the *representation* type constructor. This looks a bit delicate to
+me, but it seems to work.
+-}
+
+-- Soundness checks
+--------------------
+{-
+This is not formalized anywhere, so hold to your seats!
+RTTI in the presence of newtypes can be a tricky and unsound business.
+
+Example:
+~~~~~~~~~
+Suppose we are doing RTTI for a partially evaluated
+closure t, the real type of which is t :: MkT Int, for
+
+ newtype MkT a = MkT [Maybe a]
+
+The table below shows the results of RTTI and the improvement
+calculated for different combinations of evaluatedness and :type t.
+Regard the two first columns as input and the next two as output.
+
+ # | t | :type t | rtti(t) | improv. | result
+ ------------------------------------------------------------
+ 1 | _ | t b | a | none | OK
+ 2 | _ | MkT b | a | none | OK
+ 3 | _ | t Int | a | none | OK
+
+ If t is not evaluated at *all*, we are safe.
+
+ 4 | (_ : _) | t b | [a] | t = [] | UNSOUND
+ 5 | (_ : _) | MkT b | MkT a | none | OK (compensating for the missing newtype)
+ 6 | (_ : _) | t Int | [Int] | t = [] | UNSOUND
+
+ If a is a minimal whnf, we run into trouble. Note that
+ row 5 above does newtype enrichment on the ty_rtty parameter.
+
+ 7 | (Just _:_)| t b |[Maybe a] | t = [], | UNSOUND
+ | | | b = Maybe a|
+
+ 8 | (Just _:_)| MkT b | MkT a | none | OK
+ 9 | (Just _:_)| t Int | FAIL | none | OK
+
+ And if t is any more evaluated than whnf, we are still in trouble.
+ Because constraints are solved in top-down order, when we reach the
+ Maybe subterm what we got is already unsound. This explains why the
+ row 9 fails to complete.
+
+ 10 | (Just _:_)| t Int | [Maybe a] | FAIL | OK
+ 11 | (Just 1:_)| t Int | [Maybe Int] | FAIL | OK
+
+ We can undo the failure in row 9 by leaving out the constraint
+ coming from the type signature of t (i.e., the 2nd column).
+ Note that this type information is still used
+ to calculate the improvement. But we fail
+ when trying to calculate the improvement, as there is no unifier for
+ t Int = [Maybe a] or t Int = [Maybe Int].
+
+
+ Another set of examples with t :: [MkT (Maybe Int)] \equiv [[Maybe (Maybe Int)]]
+
+ # | t | :type t | rtti(t) | improvement | result
+ ---------------------------------------------------------------------
+ 1 |(Just _:_) | [t (Maybe a)] | [[Maybe b]] | t = [] |
+ | | | | b = Maybe a |
+
+The checks:
+~~~~~~~~~~~
+Consider a function obtainType that takes a value and a type and produces
+the Term representation and a substitution (the improvement).
+Assume an auxiliar rtti' function which does the actual job if recovering
+the type, but which may produce a false type.
+
+In pseudocode:
+
+ rtti' :: a -> IO Type -- Does not use the static type information
+
+ obtainType :: a -> Type -> IO (Maybe (Term, Improvement))
+ obtainType v old_ty = do
+ rtti_ty <- rtti' v
+ if monomorphic rtti_ty || (check rtti_ty old_ty)
+ then ...
+ else return Nothing
+ where check rtti_ty old_ty = check1 rtti_ty &&
+ check2 rtti_ty old_ty
+
+ check1 :: Type -> Bool
+ check2 :: Type -> Type -> Bool
+
+Now, if rtti' returns a monomorphic type, we are safe.
+If that is not the case, then we consider two conditions.
+
+
+1. To prevent the class of unsoundness displayed by
+ rows 4 and 7 in the example: no higher kind tyvars
+ accepted.
+
+ check1 (t a) = NO
+ check1 (t Int) = NO
+ check1 ([] a) = YES
+
+2. To prevent the class of unsoundness shown by row 6,
+ the rtti type should be structurally more
+ defined than the old type we are comparing it to.
+ check2 :: NewType -> OldType -> Bool
+ check2 a _ = True
+ check2 [a] a = True
+ check2 [a] (t Int) = False
+ check2 [a] (t a) = False -- By check1 we never reach this equation
+ check2 [Int] a = True
+ check2 [Int] (t Int) = True
+ check2 [Maybe a] (t Int) = False
+ check2 [Maybe Int] (t Int) = True
+ check2 (Maybe [a]) (m [Int]) = False
+ check2 (Maybe [Int]) (m [Int]) = True
+
+-}
+
+check1 :: QuantifiedType -> Bool
+check1 (tvs, _) = not $ any isHigherKind (map tyVarKind tvs)
+ where
+ isHigherKind = not . null . fst . splitPiTys
+
+check2 :: QuantifiedType -> QuantifiedType -> Bool
+check2 (_, rtti_ty) (_, old_ty)
+ | Just (_, rttis) <- tcSplitTyConApp_maybe rtti_ty
+ = case () of
+ _ | Just (_,olds) <- tcSplitTyConApp_maybe old_ty
+ -> and$ zipWith check2 (map quantifyType rttis) (map quantifyType olds)
+ _ | Just _ <- splitAppTy_maybe old_ty
+ -> isMonomorphicOnNonPhantomArgs rtti_ty
+ _ -> True
+ | otherwise = True
+
+-- Dealing with newtypes
+--------------------------
+{-
+ congruenceNewtypes does a parallel fold over two Type values,
+ compensating for missing newtypes on both sides.
+ This is necessary because newtypes are not present
+ in runtime, but sometimes there is evidence available.
+ Evidence can come from DataCon signatures or
+ from compile-time type inference.
+ What we are doing here is an approximation
+ of unification modulo a set of equations derived
+ from newtype definitions. These equations should be the
+ same as the equality coercions generated for newtypes
+ in System Fc. The idea is to perform a sort of rewriting,
+ taking those equations as rules, before launching unification.
+
+ The caller must ensure the following.
+ The 1st type (lhs) comes from the heap structure of ptrs,nptrs.
+ The 2nd type (rhs) comes from a DataCon type signature.
+ Rewriting (i.e. adding/removing a newtype wrapper) can happen
+ in both types, but in the rhs it is restricted to the result type.
+
+ Note that it is very tricky to make this 'rewriting'
+ work with the unification implemented by TcM, where
+ substitutions are operationally inlined. The order in which
+ constraints are unified is vital as we cannot modify
+ anything that has been touched by a previous unification step.
+Therefore, congruenceNewtypes is sound only if the types
+recovered by the RTTI mechanism are unified Top-Down.
+-}
+congruenceNewtypes :: TcType -> TcType -> TR (TcType,TcType)
+congruenceNewtypes lhs rhs = go lhs rhs >>= \rhs' -> return (lhs,rhs')
+ where
+ go l r
+ -- TyVar lhs inductive case
+ | Just tv <- getTyVar_maybe l
+ , isTcTyVar tv
+ , isMetaTyVar tv
+ = recoverTR (return r) $ do
+ Indirect ty_v <- readMetaTyVar tv
+ traceTR $ fsep [text "(congruence) Following indirect tyvar:",
+ ppr tv, equals, ppr ty_v]
+ go ty_v r
+-- FunTy inductive case
+ | Just (l1,l2) <- splitFunTy_maybe l
+ , Just (r1,r2) <- splitFunTy_maybe r
+ = do r2' <- go l2 r2
+ r1' <- go l1 r1
+ return (mkFunTy r1' r2')
+-- TyconApp Inductive case; this is the interesting bit.
+ | Just (tycon_l, _) <- tcSplitTyConApp_maybe lhs
+ , Just (tycon_r, _) <- tcSplitTyConApp_maybe rhs
+ , tycon_l /= tycon_r
+ = upgrade tycon_l r
+
+ | otherwise = return r
+
+ where upgrade :: TyCon -> Type -> TR Type
+ upgrade new_tycon ty
+ | not (isNewTyCon new_tycon) = do
+ traceTR (text "(Upgrade) Not matching newtype evidence: " <>
+ ppr new_tycon <> text " for " <> ppr ty)
+ return ty
+ | otherwise = do
+ traceTR (text "(Upgrade) upgraded " <> ppr ty <>
+ text " in presence of newtype evidence " <> ppr new_tycon)
+ (_, vars) <- instTyVars (tyConTyVars new_tycon)
+ let ty' = mkTyConApp new_tycon (mkTyVarTys vars)
+ rep_ty = unwrapType ty'
+ _ <- liftTcM (unifyType noThing ty rep_ty)
+ -- assumes that reptype doesn't ^^^^ touch tyconApp args
+ return ty'
+
+
+zonkTerm :: Term -> TcM Term
+zonkTerm = foldTermM (TermFoldM
+ { fTermM = \ty dc v tt -> zonkRttiType ty >>= \ty' ->
+ return (Term ty' dc v tt)
+ , fSuspensionM = \ct ty v b -> zonkRttiType ty >>= \ty ->
+ return (Suspension ct ty v b)
+ , fNewtypeWrapM = \ty dc t -> zonkRttiType ty >>= \ty' ->
+ return$ NewtypeWrap ty' dc t
+ , fRefWrapM = \ty t -> return RefWrap `ap`
+ zonkRttiType ty `ap` return t
+ , fPrimM = (return.) . Prim })
+
+zonkRttiType :: TcType -> TcM Type
+-- Zonk the type, replacing any unbound Meta tyvars
+-- by skolems, safely out of Meta-tyvar-land
+zonkRttiType = zonkTcTypeToType (mkEmptyZonkEnv zonk_unbound_meta)
+ where
+ zonk_unbound_meta tv
+ = ASSERT( isTcTyVar tv )
+ do { tv' <- skolemiseRuntimeUnk tv
+ -- This is where RuntimeUnks are born:
+ -- otherwise-unconstrained unification variables are
+ -- turned into RuntimeUnks as they leave the
+ -- typechecker's monad
+ ; return (mkTyVarTy tv') }
+
+--------------------------------------------------------------------------------
+-- Restore Class predicates out of a representation type
+dictsView :: Type -> Type
+dictsView ty = ty
+
+
+-- Use only for RTTI types
+isMonomorphic :: RttiType -> Bool
+isMonomorphic ty = noExistentials && noUniversals
+ where (tvs, _, ty') = tcSplitSigmaTy ty
+ noExistentials = noFreeVarsOfType ty'
+ noUniversals = null tvs
+
+-- Use only for RTTI types
+isMonomorphicOnNonPhantomArgs :: RttiType -> Bool
+isMonomorphicOnNonPhantomArgs ty
+ | Just (tc, all_args) <- tcSplitTyConApp_maybe (unwrapType ty)
+ , phantom_vars <- tyConPhantomTyVars tc
+ , concrete_args <- [ arg | (tyv,arg) <- tyConTyVars tc `zip` all_args
+ , tyv `notElem` phantom_vars]
+ = all isMonomorphicOnNonPhantomArgs concrete_args
+ | Just (ty1, ty2) <- splitFunTy_maybe ty
+ = all isMonomorphicOnNonPhantomArgs [ty1,ty2]
+ | otherwise = isMonomorphic ty
+
+tyConPhantomTyVars :: TyCon -> [TyVar]
+tyConPhantomTyVars tc
+ | isAlgTyCon tc
+ , Just dcs <- tyConDataCons_maybe tc
+ , dc_vars <- concatMap dataConUnivTyVars dcs
+ = tyConTyVars tc \\ dc_vars
+tyConPhantomTyVars _ = []
+
+type QuantifiedType = ([TyVar], Type)
+ -- Make the free type variables explicit
+ -- The returned Type should have no top-level foralls (I believe)
+
+quantifyType :: Type -> QuantifiedType
+-- Generalize the type: find all free and forall'd tyvars
+-- and return them, together with the type inside, which
+-- should not be a forall type.
+--
+-- Thus (quantifyType (forall a. a->[b]))
+-- returns ([a,b], a -> [b])
+
+quantifyType ty = ( filter isTyVar $
+ tyCoVarsOfTypeWellScoped rho
+ , rho)
+ where
+ (_tvs, rho) = tcSplitForAllTys ty
+
+-- Strict application of f at index i
+appArr :: Ix i => (e -> a) -> Array i e -> Int -> a
+appArr f a@(Array _ _ _ ptrs#) i@(I# i#)
+ = ASSERT2(i < length(elems a), ppr(length$ elems a, i))
+ case indexArray# ptrs# i# of
+ (# e #) -> f e
+
+amap' :: (t -> b) -> Array Int t -> [b]
+amap' f (Array i0 i _ arr#) = map g [0 .. i - i0]
+ where g (I# i#) = case indexArray# arr# i# of
+ (# e #) -> f e
diff --git a/ghci/keepCAFsForGHCi.c b/ghci/keepCAFsForGHCi.c
new file mode 100644
--- /dev/null
+++ b/ghci/keepCAFsForGHCi.c
@@ -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;
+}
+
diff --git a/hsSyn/Convert.hs b/hsSyn/Convert.hs
new file mode 100644
--- /dev/null
+++ b/hsSyn/Convert.hs
@@ -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 =
+
+is of the form
+
+ forall univs. reqs => forall exis. provs => t1 -> t2 -> ... -> tn -> t
+
+with the following parts:
+
+ 1) the (possibly empty lists of) universally quantified type
+ variables `univs` and required constraints `reqs` on them.
+ 2) the (possibly empty lists of) existentially quantified type
+ variables `exis` and the provided constraints `provs` on them.
+ 3) the types `t1`, `t2`, .., `tn` of the pattern synonym's arguments x1,
+ x2, .., xn, respectively
+ 4) the type `t` of , mentioning only universals from `univs`.
+
+Due to the two forall quantifiers and constraint contexts (either of
+which might be empty), pattern synonym type signatures are treated
+specially in `deSugar/DsMeta.hs`, `hsSyn/Convert.hs`, and
+`typecheck/TcSplice.hs`:
+
+ (a) When desugaring a pattern synonym from HsSyn to TH.Dec in
+ `deSugar/DsMeta.hs`, we represent its *full* type signature in TH, i.e.:
+
+ ForallT univs reqs (ForallT exis provs ty)
+ (where ty is the AST representation of t1 -> t2 -> ... -> tn -> t)
+
+ (b) When converting pattern synonyms from TH.Dec to HsSyn in
+ `hsSyn/Convert.hs`, we convert their TH type signatures back to an
+ appropriate Haskell pattern synonym type of the form
+
+ forall univs. reqs => forall exis. provs => t1 -> t2 -> ... -> tn -> t
+
+ where initial empty `univs` type variables or an empty `reqs`
+ constraint context are represented *explicitly* as `() =>`.
+
+ (c) When reifying a pattern synonym in `typecheck/TcSplice.hs`, we always
+ return its *full* type, i.e.:
+
+ ForallT univs reqs (ForallT exis provs ty)
+ (where ty is the AST representation of t1 -> t2 -> ... -> tn -> t)
+
+The key point is to always represent a pattern synonym's *full* type
+in cases (a) and (c) to make it clear which of the two forall
+quantifiers and/or constraint contexts are specified, and which are
+not. See GHC's user's guide on pattern synonyms for more information
+about pattern synonym type signatures.
+
+-}
diff --git a/hsSyn/HsBinds.hs b/hsSyn/HsBinds.hs
new file mode 100644
--- /dev/null
+++ b/hsSyn/HsBinds.hs
@@ -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 ""
+pprTcSpecPrags (SpecPrags ps) = vcat (map (ppr . unLoc) ps)
+
+instance Outputable TcSpecPrag where
+ ppr (SpecPrag var _ inl)
+ = text "SPECIALIZE" <+> pprSpec var (text "") inl
+
+pprMinimalSig :: (OutputableBndr name)
+ => LBooleanFormula (Located name) -> SDoc
+pprMinimalSig (L _ bf) = ppr (fmap unLoc bf)
+
+{-
+************************************************************************
+* *
+\subsection[PatSynBind]{A pattern synonym definition}
+* *
+************************************************************************
+-}
+
+-- | Haskell Pattern Synonym Details
+data HsPatSynDetails a
+ = InfixPatSyn a a -- ^ Infix Pattern Synonym
+ | PrefixPatSyn [a] -- ^ Prefix Pattern Synonym
+ | RecordPatSyn [RecordPatSynField a] -- ^ Record Pattern Synonym
+ deriving Data
+
+
+-- See Note [Record PatSyn Fields]
+-- | Record Pattern Synonym Field
+data RecordPatSynField a
+ = RecordPatSynField {
+ recordPatSynSelectorId :: a -- Selector name visible in rest of the file
+ , recordPatSynPatVar :: a
+ -- Filled in by renamer, the name used internally
+ -- by the pattern
+ } deriving Data
+
+
+
+{-
+Note [Record PatSyn Fields]
+
+Consider the following two pattern synonyms.
+
+pattern P x y = ([x,True], [y,'v'])
+pattern Q{ x, y } =([x,True], [y,'v'])
+
+In P, we just have two local binders, x and y.
+
+In Q, we have local binders but also top-level record selectors
+x :: ([Bool], [Char]) -> Bool and similarly for y.
+
+It would make sense to support record-like syntax
+
+pattern Q{ x=x1, y=y1 } = ([x1,True], [y1,'v'])
+
+when we have a different name for the local and top-level binder
+the distinction between the two names clear
+
+-}
+instance Functor RecordPatSynField where
+ fmap f (RecordPatSynField { recordPatSynSelectorId = visible
+ , recordPatSynPatVar = hidden })
+ = RecordPatSynField { recordPatSynSelectorId = f visible
+ , recordPatSynPatVar = f hidden }
+
+instance Outputable a => Outputable (RecordPatSynField a) where
+ ppr (RecordPatSynField { recordPatSynSelectorId = v }) = ppr v
+
+instance Foldable RecordPatSynField where
+ foldMap f (RecordPatSynField { recordPatSynSelectorId = visible
+ , recordPatSynPatVar = hidden })
+ = f visible `mappend` f hidden
+
+instance Traversable RecordPatSynField where
+ traverse f (RecordPatSynField { recordPatSynSelectorId =visible
+ , recordPatSynPatVar = hidden })
+ = (\ sel_id pat_var -> RecordPatSynField { recordPatSynSelectorId = sel_id
+ , recordPatSynPatVar = pat_var })
+ <$> f visible <*> f hidden
+
+
+instance Functor HsPatSynDetails where
+ fmap f (InfixPatSyn left right) = InfixPatSyn (f left) (f right)
+ fmap f (PrefixPatSyn args) = PrefixPatSyn (fmap f args)
+ fmap f (RecordPatSyn args) = RecordPatSyn (map (fmap f) args)
+
+instance Foldable HsPatSynDetails where
+ foldMap f (InfixPatSyn left right) = f left `mappend` f right
+ foldMap f (PrefixPatSyn args) = foldMap f args
+ foldMap f (RecordPatSyn args) = foldMap (foldMap f) args
+
+ foldl1 f (InfixPatSyn left right) = left `f` right
+ foldl1 f (PrefixPatSyn args) = Data.List.foldl1 f args
+ foldl1 f (RecordPatSyn args) =
+ Data.List.foldl1 f (map (Data.Foldable.foldl1 f) args)
+
+ foldr1 f (InfixPatSyn left right) = left `f` right
+ foldr1 f (PrefixPatSyn args) = Data.List.foldr1 f args
+ foldr1 f (RecordPatSyn args) =
+ Data.List.foldr1 f (map (Data.Foldable.foldr1 f) args)
+
+ length (InfixPatSyn _ _) = 2
+ length (PrefixPatSyn args) = Data.List.length args
+ length (RecordPatSyn args) = Data.List.length args
+
+ null (InfixPatSyn _ _) = False
+ null (PrefixPatSyn args) = Data.List.null args
+ null (RecordPatSyn args) = Data.List.null args
+
+ toList (InfixPatSyn left right) = [left, right]
+ toList (PrefixPatSyn args) = args
+ toList (RecordPatSyn args) = foldMap toList args
+
+instance Traversable HsPatSynDetails where
+ traverse f (InfixPatSyn left right) = InfixPatSyn <$> f left <*> f right
+ traverse f (PrefixPatSyn args) = PrefixPatSyn <$> traverse f args
+ traverse f (RecordPatSyn args) = RecordPatSyn <$> traverse (traverse f) args
+
+-- | Haskell Pattern Synonym Direction
+data HsPatSynDir id
+ = Unidirectional
+ | ImplicitBidirectional
+ | ExplicitBidirectional (MatchGroup id (LHsExpr id))
+deriving instance (DataId id) => Data (HsPatSynDir id)
diff --git a/hsSyn/HsDecls.hs b/hsSyn/HsDecls.hs
new file mode 100644
--- /dev/null
+++ b/hsSyn/HsDecls.hs
@@ -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 ::
+ op2 ::
+ op1 = ...
+ We generate a binding for $dmop1 but not for $dmop2.
+ The Class for Foo has a Nothing for op2 and
+ a Just ($dm_op1, VanillaDM) for op1.
+ The Name for $dmop2 is simply discarded.
+
+In *interface-file* class declarations:
+ - When parsing, we see if there's an explicit programmer-supplied default method
+ because there's an '=' sign to indicate it:
+ class Foo a where
+ op1 = :: -- NB the '='
+ op2 ::
+ We use this info to generate a DefMeth with a suitable RdrName for op1,
+ and a NoDefMeth for op2
+ - The interface file has a separate definition for $dmop1, with unfolding etc.
+ - The renamer renames it to a Name.
+ - The renamer treats $dmop1 as a free variable of the declaration, so that
+ the binding for $dmop1 will be sucked in. (See RnHsSyn.tyClDeclFVs)
+ This doesn't happen for source code class decls, because they *bind* the default method.
+
+Dictionary functions
+~~~~~~~~~~~~~~~~~~~~
+Each instance declaration gives rise to one dictionary function binding.
+
+The type checker makes up new source-code instance declarations
+(e.g. from 'deriving' or generic default methods --- see
+TcInstDcls.tcInstDecls1). So we can't generate the names for
+dictionary functions in advance (we don't know how many we need).
+
+On the other hand for interface-file instance declarations, the decl
+specifies the name of the dictionary function, and it has a binding elsewhere
+in the interface file:
+ instance {Eq Int} = dEqInt
+ dEqInt :: {Eq Int}
+
+So again we treat source code and interface file code slightly differently.
+
+Source code:
+ - Source code instance decls have a Nothing in the (Maybe name) field
+ (see data InstDecl below)
+
+ - The typechecker makes up a Local name for the dict fun for any source-code
+ instance decl, whether it comes from a source-code instance decl, or whether
+ the instance decl is derived from some other construct (e.g. 'deriving').
+
+ - The occurrence name it chooses is derived from the instance decl (just for
+ documentation really) --- e.g. dNumInt. Two dict funs may share a common
+ occurrence name, but will have different uniques. E.g.
+ instance Foo [Int] where ...
+ instance Foo [Bool] where ...
+ These might both be dFooList
+
+ - The CoreTidy phase externalises the name, and ensures the occurrence name is
+ unique (this isn't special to dict funs). So we'd get dFooList and dFooList1.
+
+ - We can take this relaxed approach (changing the occurrence name later)
+ because dict fun Ids are not captured in a TyCon or Class (unlike default
+ methods, say). Instead, they are kept separately in the InstEnv. This
+ makes it easy to adjust them after compiling a module. (Once we've finished
+ compiling that module, they don't change any more.)
+
+
+Interface file code:
+ - The instance decl gives the dict fun name, so the InstDecl has a (Just name)
+ in the (Maybe name) field.
+
+ - RnHsSyn.instDeclFVs treats the dict fun name as free in the decl, so that we
+ suck in the dfun binding
+-}
+
+-- | Located Declaration of a Type or Class
+type LTyClDecl name = Located (TyClDecl name)
+
+-- | A type or class declaration.
+data TyClDecl name
+ = -- | @type/data family T :: *->*@
+ --
+ -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType',
+ -- 'ApiAnnotation.AnnData',
+ -- 'ApiAnnotation.AnnFamily','ApiAnnotation.AnnDcolon',
+ -- 'ApiAnnotation.AnnWhere','ApiAnnotation.AnnOpenP',
+ -- 'ApiAnnotation.AnnDcolon','ApiAnnotation.AnnCloseP',
+ -- 'ApiAnnotation.AnnEqual','ApiAnnotation.AnnRarrow',
+ -- 'ApiAnnotation.AnnVbar'
+
+ -- For details on above see note [Api annotations] in ApiAnnotation
+ FamDecl { tcdFam :: FamilyDecl name }
+
+ | -- | @type@ declaration
+ --
+ -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType',
+ -- 'ApiAnnotation.AnnEqual',
+
+ -- For details on above see note [Api annotations] in ApiAnnotation
+ SynDecl { tcdLName :: Located name -- ^ Type constructor
+ , tcdTyVars :: LHsQTyVars name -- ^ Type variables; for an associated type
+ -- these include outer binders
+ , tcdFixity :: LexicalFixity -- ^ Fixity used in the declaration
+ , tcdRhs :: LHsType name -- ^ RHS of type declaration
+ , tcdFVs :: PostRn name NameSet }
+
+ | -- | @data@ declaration
+ --
+ -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnData',
+ -- 'ApiAnnotation.AnnFamily',
+ -- 'ApiAnnotation.AnnNewType',
+ -- 'ApiAnnotation.AnnNewType','ApiAnnotation.AnnDcolon'
+ -- 'ApiAnnotation.AnnWhere',
+
+ -- For details on above see note [Api annotations] in ApiAnnotation
+ DataDecl { tcdLName :: Located name -- ^ Type constructor
+ , tcdTyVars :: LHsQTyVars name -- ^ Type variables; for an associated type
+ -- these include outer binders
+ -- Eg class T a where
+ -- type F a :: *
+ -- type F a = a -> a
+ -- Here the type decl for 'f' includes 'a'
+ -- in its tcdTyVars
+ , tcdFixity :: LexicalFixity -- ^ Fixity used in the declaration
+ , tcdDataDefn :: HsDataDefn name
+ , tcdDataCusk :: PostRn name Bool -- ^ does this have a CUSK?
+ , tcdFVs :: PostRn name NameSet }
+
+ | ClassDecl { tcdCtxt :: LHsContext name, -- ^ Context...
+ tcdLName :: Located name, -- ^ Name of the class
+ tcdTyVars :: LHsQTyVars name, -- ^ Class type variables
+ tcdFixity :: LexicalFixity, -- ^ Fixity used in the declaration
+ tcdFDs :: [Located (FunDep (Located name))],
+ -- ^ Functional deps
+ tcdSigs :: [LSig name], -- ^ Methods' signatures
+ tcdMeths :: LHsBinds name, -- ^ Default methods
+ tcdATs :: [LFamilyDecl name], -- ^ Associated types;
+ tcdATDefs :: [LTyFamDefltEqn name], -- ^ Associated type defaults
+ tcdDocs :: [LDocDecl], -- ^ Haddock docs
+ tcdFVs :: PostRn name NameSet
+ }
+ -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnClass',
+ -- 'ApiAnnotation.AnnWhere','ApiAnnotation.AnnOpen',
+ -- 'ApiAnnotation.AnnClose'
+ -- - The tcdFDs will have 'ApiAnnotation.AnnVbar',
+ -- 'ApiAnnotation.AnnComma'
+ -- 'ApiAnnotation.AnnRarrow'
+
+ -- For details on above see note [Api annotations] in ApiAnnotation
+
+deriving instance (DataId id) => Data (TyClDecl id)
+
+
+-- Simple classifiers for TyClDecl
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+-- | @True@ <=> argument is a @data@\/@newtype@
+-- declaration.
+isDataDecl :: TyClDecl name -> Bool
+isDataDecl (DataDecl {}) = True
+isDataDecl _other = False
+
+-- | type or type instance declaration
+isSynDecl :: TyClDecl name -> Bool
+isSynDecl (SynDecl {}) = True
+isSynDecl _other = False
+
+-- | type class
+isClassDecl :: TyClDecl name -> Bool
+isClassDecl (ClassDecl {}) = True
+isClassDecl _ = False
+
+-- | type/data family declaration
+isFamilyDecl :: TyClDecl name -> Bool
+isFamilyDecl (FamDecl {}) = True
+isFamilyDecl _other = False
+
+-- | type family declaration
+isTypeFamilyDecl :: TyClDecl name -> Bool
+isTypeFamilyDecl (FamDecl (FamilyDecl { fdInfo = info })) = case info of
+ OpenTypeFamily -> True
+ ClosedTypeFamily {} -> True
+ _ -> False
+isTypeFamilyDecl _ = False
+
+-- | open type family info
+isOpenTypeFamilyInfo :: FamilyInfo name -> Bool
+isOpenTypeFamilyInfo OpenTypeFamily = True
+isOpenTypeFamilyInfo _ = False
+
+-- | closed type family info
+isClosedTypeFamilyInfo :: FamilyInfo name -> Bool
+isClosedTypeFamilyInfo (ClosedTypeFamily {}) = True
+isClosedTypeFamilyInfo _ = False
+
+-- | data family declaration
+isDataFamilyDecl :: TyClDecl name -> Bool
+isDataFamilyDecl (FamDecl (FamilyDecl { fdInfo = DataFamily })) = True
+isDataFamilyDecl _other = False
+
+-- Dealing with names
+
+tyFamInstDeclName :: TyFamInstDecl name -> name
+tyFamInstDeclName = unLoc . tyFamInstDeclLName
+
+tyFamInstDeclLName :: TyFamInstDecl name -> Located name
+tyFamInstDeclLName (TyFamInstDecl { tfid_eqn =
+ (L _ (TyFamEqn { tfe_tycon = ln })) })
+ = ln
+
+tyClDeclLName :: TyClDecl name -> Located name
+tyClDeclLName (FamDecl { tcdFam = FamilyDecl { fdLName = ln } }) = ln
+tyClDeclLName decl = tcdLName decl
+
+tcdName :: TyClDecl name -> name
+tcdName = unLoc . tyClDeclLName
+
+tyClDeclTyVars :: TyClDecl name -> LHsQTyVars name
+tyClDeclTyVars (FamDecl { tcdFam = FamilyDecl { fdTyVars = tvs } }) = tvs
+tyClDeclTyVars d = tcdTyVars d
+
+countTyClDecls :: [TyClDecl name] -> (Int, Int, Int, Int, Int)
+ -- class, synonym decls, data, newtype, family decls
+countTyClDecls decls
+ = (count isClassDecl decls,
+ count isSynDecl decls, -- excluding...
+ count isDataTy decls, -- ...family...
+ count isNewTy decls, -- ...instances
+ count isFamilyDecl decls)
+ where
+ isDataTy DataDecl{ tcdDataDefn = HsDataDefn { dd_ND = DataType } } = True
+ isDataTy _ = False
+
+ isNewTy DataDecl{ tcdDataDefn = HsDataDefn { dd_ND = NewType } } = True
+ isNewTy _ = False
+
+-- | Does this declaration have a complete, user-supplied kind signature?
+-- See Note [Complete user-supplied kind signatures]
+hsDeclHasCusk :: TyClDecl Name -> Bool
+hsDeclHasCusk (FamDecl { tcdFam = fam_decl }) = famDeclHasCusk Nothing fam_decl
+hsDeclHasCusk (SynDecl { tcdTyVars = tyvars, tcdRhs = rhs })
+ -- NB: Keep this synchronized with 'getInitialKind'
+ = hsTvbAllKinded tyvars && rhs_annotated rhs
+ where
+ rhs_annotated (L _ ty) = case ty of
+ HsParTy lty -> rhs_annotated lty
+ HsKindSig {} -> True
+ _ -> False
+hsDeclHasCusk (DataDecl { tcdDataCusk = cusk }) = cusk
+hsDeclHasCusk (ClassDecl { tcdTyVars = tyvars }) = hsTvbAllKinded tyvars
+
+-- Pretty-printing TyClDecl
+-- ~~~~~~~~~~~~~~~~~~~~~~~~
+
+instance (OutputableBndrId name) => Outputable (TyClDecl name) where
+
+ ppr (FamDecl { tcdFam = decl }) = ppr decl
+ ppr (SynDecl { tcdLName = ltycon, tcdTyVars = tyvars, tcdFixity = fixity
+ , tcdRhs = rhs })
+ = hang (text "type" <+>
+ pp_vanilla_decl_head ltycon tyvars fixity [] <+> equals)
+ 4 (ppr rhs)
+
+ ppr (DataDecl { tcdLName = ltycon, tcdTyVars = tyvars, tcdFixity = fixity
+ , tcdDataDefn = defn })
+ = pp_data_defn (pp_vanilla_decl_head ltycon tyvars fixity) defn
+
+ ppr (ClassDecl {tcdCtxt = context, tcdLName = lclas, tcdTyVars = tyvars,
+ tcdFixity = fixity,
+ tcdFDs = fds,
+ tcdSigs = sigs, tcdMeths = methods,
+ tcdATs = ats, tcdATDefs = at_defs})
+ | null sigs && isEmptyBag methods && null ats && null at_defs -- No "where" part
+ = top_matter
+
+ | otherwise -- Laid out
+ = vcat [ top_matter <+> text "where"
+ , nest 2 $ pprDeclList (map (pprFamilyDecl NotTopLevel . unLoc) ats ++
+ map ppr_fam_deflt_eqn at_defs ++
+ pprLHsBindsForUser methods sigs) ]
+ where
+ top_matter = text "class"
+ <+> pp_vanilla_decl_head lclas tyvars fixity (unLoc context)
+ <+> pprFundeps (map unLoc fds)
+
+instance (OutputableBndrId name) => Outputable (TyClGroup name) where
+ ppr (TyClGroup { group_tyclds = tyclds
+ , group_roles = roles
+ , group_instds = instds
+ }
+ )
+ = ppr tyclds $$
+ ppr roles $$
+ ppr instds
+
+pp_vanilla_decl_head :: (OutputableBndrId name) => Located name
+ -> LHsQTyVars name
+ -> LexicalFixity
+ -> HsContext name
+ -> SDoc
+pp_vanilla_decl_head thing (HsQTvs { hsq_explicit = tyvars }) fixity context
+ = hsep [pprHsContext context, pp_tyvars tyvars]
+ where
+ pp_tyvars (varl:varsr)
+ | fixity == Infix
+ = hsep [ppr (unLoc varl), pprInfixOcc (unLoc thing)
+ , hsep (map (ppr.unLoc) varsr)]
+ | otherwise = hsep [ pprPrefixOcc (unLoc thing)
+ , hsep (map (ppr.unLoc) (varl:varsr))]
+ pp_tyvars [] = ppr thing
+
+pprTyClDeclFlavour :: TyClDecl a -> SDoc
+pprTyClDeclFlavour (ClassDecl {}) = text "class"
+pprTyClDeclFlavour (SynDecl {}) = text "type"
+pprTyClDeclFlavour (FamDecl { tcdFam = FamilyDecl { fdInfo = info }})
+ = pprFlavour info <+> text "family"
+pprTyClDeclFlavour (DataDecl { tcdDataDefn = HsDataDefn { dd_ND = nd } })
+ = ppr nd
+
+
+{- Note [Complete user-supplied kind signatures]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We kind-check declarations differently if they have a complete, user-supplied
+kind signature (CUSK). This is because we can safely generalise a CUSKed
+declaration before checking all of the others, supporting polymorphic recursion.
+See ghc.haskell.org/trac/ghc/wiki/GhcKinds/KindInference#Proposednewstrategy
+and #9200 for lots of discussion of how we got here.
+
+A declaration has a CUSK if we can know its complete kind without doing any
+inference, at all. Here are the rules:
+
+ - A class or datatype is said to have a CUSK if and only if all of its type
+variables are annotated. Its result kind is, by construction, Constraint or *
+respectively.
+
+ - A type synonym has a CUSK if and only if all of its type variables and its
+RHS are annotated with kinds.
+
+ - A closed type family is said to have a CUSK if and only if all of its type
+variables and its return type are annotated.
+
+ - An open type family always has a CUSK -- unannotated type variables (and
+return type) default to *.
+
+ - Additionally, if -XTypeInType is on, then a data definition with a top-level
+ :: must explicitly bind all kind variables to the right of the ::.
+ See test dependent/should_compile/KindLevels, which requires this case.
+ (Naturally, any kind variable mentioned before the :: should not be bound
+ after it.)
+-}
+
+
+{- *********************************************************************
+* *
+ TyClGroup
+ Strongly connected components of
+ type, class, instance, and role declarations
+* *
+********************************************************************* -}
+
+{- Note [TyClGroups and dependency analysis]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+A TyClGroup represents a strongly connected components of type/class/instance
+decls, together with the role annotations for the type/class declarations.
+
+The hs_tyclds :: [TyClGroup] field of a HsGroup is a dependency-order
+sequence of strongly-connected components.
+
+Invariants
+ * The type and class declarations, group_tyclds, may depend on each
+ other, or earlier TyClGroups, but not on later ones
+
+ * The role annotations, group_roles, are role-annotations for some or
+ all of the types and classes in group_tyclds (only).
+
+ * The instance declarations, group_instds, may (and usually will)
+ depend on group_tyclds, or on earlier TyClGroups, but not on later
+ ones.
+
+See Note [Dependency analsis of type, class, and instance decls]
+in RnSource for more info.
+-}
+
+-- | Type or Class Group
+data TyClGroup name -- See Note [TyClGroups and dependency analysis]
+ = TyClGroup { group_tyclds :: [LTyClDecl name]
+ , group_roles :: [LRoleAnnotDecl name]
+ , group_instds :: [LInstDecl name] }
+deriving instance (DataId id) => Data (TyClGroup id)
+
+emptyTyClGroup :: TyClGroup name
+emptyTyClGroup = TyClGroup [] [] []
+
+tyClGroupTyClDecls :: [TyClGroup name] -> [LTyClDecl name]
+tyClGroupTyClDecls = concatMap group_tyclds
+
+tyClGroupInstDecls :: [TyClGroup name] -> [LInstDecl name]
+tyClGroupInstDecls = concatMap group_instds
+
+tyClGroupRoleDecls :: [TyClGroup name] -> [LRoleAnnotDecl name]
+tyClGroupRoleDecls = concatMap group_roles
+
+mkTyClGroup :: [LTyClDecl name] -> [LInstDecl name] -> TyClGroup name
+mkTyClGroup decls instds = TyClGroup
+ { group_tyclds = decls
+ , group_roles = []
+ , group_instds = instds
+ }
+
+
+
+{- *********************************************************************
+* *
+ Data and type family declarations
+* *
+********************************************************************* -}
+
+{- Note [FamilyResultSig]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+
+This data type represents the return signature of a type family. Possible
+values are:
+
+ * NoSig - the user supplied no return signature:
+ type family Id a where ...
+
+ * KindSig - the user supplied the return kind:
+ type family Id a :: * where ...
+
+ * TyVarSig - user named the result with a type variable and possibly
+ provided a kind signature for that variable:
+ type family Id a = r where ...
+ type family Id a = (r :: *) where ...
+
+ Naming result of a type family is required if we want to provide
+ injectivity annotation for a type family:
+ type family Id a = r | r -> a where ...
+
+See also: Note [Injectivity annotation]
+
+Note [Injectivity annotation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+A user can declare a type family to be injective:
+
+ type family Id a = r | r -> a where ...
+
+ * The part after the "|" is called "injectivity annotation".
+ * "r -> a" part is called "injectivity condition"; at the moment terms
+ "injectivity annotation" and "injectivity condition" are synonymous
+ because we only allow a single injectivity condition.
+ * "r" is the "LHS of injectivity condition". LHS can only contain the
+ variable naming the result of a type family.
+
+ * "a" is the "RHS of injectivity condition". RHS contains space-separated
+ type and kind variables representing the arguments of a type
+ family. Variables can be omitted if a type family is not injective in
+ these arguments. Example:
+ type family Foo a b c = d | d -> a c where ...
+
+Note that:
+ (a) naming of type family result is required to provide injectivity
+ annotation
+ (b) for associated types if the result was named then injectivity annotation
+ is mandatory. Otherwise result type variable is indistinguishable from
+ associated type default.
+
+It is possible that in the future this syntax will be extended to support
+more complicated injectivity annotations. For example we could declare that
+if we know the result of Plus and one of its arguments we can determine the
+other argument:
+
+ type family Plus a b = (r :: Nat) | r a -> b, r b -> a where ...
+
+Here injectivity annotation would consist of two comma-separated injectivity
+conditions.
+
+See also Note [Injective type families] in TyCon
+-}
+
+-- | Located type Family Result Signature
+type LFamilyResultSig name = Located (FamilyResultSig name)
+
+-- | type Family Result Signature
+data FamilyResultSig name = -- see Note [FamilyResultSig]
+ NoSig
+ -- ^ - 'ApiAnnotation.AnnKeywordId' :
+
+ -- For details on above see note [Api annotations] in ApiAnnotation
+
+ | KindSig (LHsKind name)
+ -- ^ - 'ApiAnnotation.AnnKeywordId' :
+ -- 'ApiAnnotation.AnnOpenP','ApiAnnotation.AnnDcolon',
+ -- 'ApiAnnotation.AnnCloseP'
+
+ -- For details on above see note [Api annotations] in ApiAnnotation
+
+ | TyVarSig (LHsTyVarBndr name)
+ -- ^ - 'ApiAnnotation.AnnKeywordId' :
+ -- 'ApiAnnotation.AnnOpenP','ApiAnnotation.AnnDcolon',
+ -- 'ApiAnnotation.AnnCloseP', 'ApiAnnotation.AnnEqual'
+
+ -- For details on above see note [Api annotations] in ApiAnnotation
+
+deriving instance (DataId name) => Data (FamilyResultSig name)
+
+-- | Located type Family Declaration
+type LFamilyDecl name = Located (FamilyDecl name)
+
+-- | type Family Declaration
+data FamilyDecl name = FamilyDecl
+ { fdInfo :: FamilyInfo name -- type/data, closed/open
+ , fdLName :: Located name -- type constructor
+ , fdTyVars :: LHsQTyVars name -- type variables
+ , fdFixity :: LexicalFixity -- Fixity used in the declaration
+ , fdResultSig :: LFamilyResultSig name -- result signature
+ , fdInjectivityAnn :: Maybe (LInjectivityAnn name) -- optional injectivity ann
+ }
+ -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType',
+ -- 'ApiAnnotation.AnnData', 'ApiAnnotation.AnnFamily',
+ -- 'ApiAnnotation.AnnWhere', 'ApiAnnotation.AnnOpenP',
+ -- 'ApiAnnotation.AnnDcolon', 'ApiAnnotation.AnnCloseP',
+ -- 'ApiAnnotation.AnnEqual', 'ApiAnnotation.AnnRarrow',
+ -- 'ApiAnnotation.AnnVbar'
+
+ -- For details on above see note [Api annotations] in ApiAnnotation
+
+deriving instance (DataId id) => Data (FamilyDecl id)
+
+-- | Located Injectivity Annotation
+type LInjectivityAnn name = Located (InjectivityAnn name)
+
+-- | If the user supplied an injectivity annotation it is represented using
+-- InjectivityAnn. At the moment this is a single injectivity condition - see
+-- Note [Injectivity annotation]. `Located name` stores the LHS of injectivity
+-- condition. `[Located name]` stores the RHS of injectivity condition. Example:
+--
+-- type family Foo a b c = r | r -> a c where ...
+--
+-- This will be represented as "InjectivityAnn `r` [`a`, `c`]"
+data InjectivityAnn name
+ = InjectivityAnn (Located name) [Located name]
+ -- ^ - 'ApiAnnotation.AnnKeywordId' :
+ -- 'ApiAnnotation.AnnRarrow', 'ApiAnnotation.AnnVbar'
+
+ -- For details on above see note [Api annotations] in ApiAnnotation
+ deriving Data
+
+data FamilyInfo name
+ = DataFamily
+ | OpenTypeFamily
+ -- | 'Nothing' if we're in an hs-boot file and the user
+ -- said "type family Foo x where .."
+ | ClosedTypeFamily (Maybe [LTyFamInstEqn name])
+deriving instance (DataId name) => Data (FamilyInfo name)
+
+-- | Does this family declaration have a complete, user-supplied kind signature?
+famDeclHasCusk :: Maybe Bool
+ -- ^ if associated, does the enclosing class have a CUSK?
+ -> FamilyDecl name -> Bool
+famDeclHasCusk _ (FamilyDecl { fdInfo = ClosedTypeFamily _
+ , fdTyVars = tyvars
+ , fdResultSig = L _ resultSig })
+ = hsTvbAllKinded tyvars && hasReturnKindSignature resultSig
+famDeclHasCusk mb_class_cusk _ = mb_class_cusk `orElse` True
+ -- all un-associated open families have CUSKs!
+
+-- | Does this family declaration have user-supplied return kind signature?
+hasReturnKindSignature :: FamilyResultSig a -> Bool
+hasReturnKindSignature NoSig = False
+hasReturnKindSignature (TyVarSig (L _ (UserTyVar _))) = False
+hasReturnKindSignature _ = True
+
+-- | Maybe return name of the result type variable
+resultVariableName :: FamilyResultSig a -> Maybe a
+resultVariableName (TyVarSig sig) = Just $ hsLTyVarName sig
+resultVariableName _ = Nothing
+
+instance (OutputableBndrId name) => Outputable (FamilyDecl name) where
+ ppr = pprFamilyDecl TopLevel
+
+pprFamilyDecl :: (OutputableBndrId name)
+ => TopLevelFlag -> FamilyDecl name -> SDoc
+pprFamilyDecl top_level (FamilyDecl { fdInfo = info, fdLName = ltycon
+ , fdTyVars = tyvars
+ , fdFixity = fixity
+ , fdResultSig = L _ result
+ , fdInjectivityAnn = mb_inj })
+ = vcat [ pprFlavour info <+> pp_top_level <+>
+ pp_vanilla_decl_head ltycon tyvars fixity [] <+>
+ pp_kind <+> pp_inj <+> pp_where
+ , nest 2 $ pp_eqns ]
+ where
+ pp_top_level = case top_level of
+ TopLevel -> text "family"
+ NotTopLevel -> empty
+
+ pp_kind = case result of
+ NoSig -> empty
+ KindSig kind -> dcolon <+> ppr kind
+ TyVarSig tv_bndr -> text "=" <+> ppr tv_bndr
+ pp_inj = case mb_inj of
+ Just (L _ (InjectivityAnn lhs rhs)) ->
+ hsep [ vbar, ppr lhs, text "->", hsep (map ppr rhs) ]
+ Nothing -> empty
+ (pp_where, pp_eqns) = case info of
+ ClosedTypeFamily mb_eqns ->
+ ( text "where"
+ , case mb_eqns of
+ Nothing -> text ".."
+ Just eqns -> vcat $ map ppr_fam_inst_eqn eqns )
+ _ -> (empty, empty)
+
+pprFlavour :: FamilyInfo name -> SDoc
+pprFlavour DataFamily = text "data"
+pprFlavour OpenTypeFamily = text "type"
+pprFlavour (ClosedTypeFamily {}) = text "type"
+
+instance Outputable (FamilyInfo name) where
+ ppr info = pprFlavour info <+> text "family"
+
+
+
+{- *********************************************************************
+* *
+ Data types and data constructors
+* *
+********************************************************************* -}
+
+-- | Haskell Data type Definition
+data HsDataDefn name -- The payload of a data type defn
+ -- Used *both* for vanilla data declarations,
+ -- *and* for data family instances
+ = -- | Declares a data type or newtype, giving its constructors
+ -- @
+ -- data/newtype T a =
+ -- data/newtype instance T [a] =
+ -- @
+ HsDataDefn { dd_ND :: NewOrData,
+ dd_ctxt :: LHsContext name, -- ^ Context
+ dd_cType :: Maybe (Located CType),
+ dd_kindSig:: Maybe (LHsKind name),
+ -- ^ Optional kind signature.
+ --
+ -- @(Just k)@ for a GADT-style @data@,
+ -- or @data instance@ decl, with explicit kind sig
+ --
+ -- Always @Nothing@ for H98-syntax decls
+
+ dd_cons :: [LConDecl name],
+ -- ^ Data constructors
+ --
+ -- For @data T a = T1 | T2 a@
+ -- the 'LConDecl's all have 'ConDeclH98'.
+ -- For @data T a where { T1 :: T a }@
+ -- the 'LConDecls' all have 'ConDeclGADT'.
+
+ dd_derivs :: HsDeriving name -- ^ Optional 'deriving' claues
+
+ -- For details on above see note [Api annotations] in ApiAnnotation
+ }
+deriving instance (DataId id) => Data (HsDataDefn id)
+
+-- | Haskell Deriving clause
+type HsDeriving name = Located [LHsDerivingClause name]
+ -- ^ The optional @deriving@ clauses of a data declaration. "Clauses" is
+ -- plural because one can specify multiple deriving clauses using the
+ -- @-XDerivingStrategies@ language extension.
+ --
+ -- The list of 'LHsDerivingClause's corresponds to exactly what the user
+ -- requested to derive, in order. If no deriving clauses were specified,
+ -- the list is empty.
+
+type LHsDerivingClause name = Located (HsDerivingClause name)
+
+-- | A single @deriving@ clause of a data declaration.
+--
+-- - 'ApiAnnotation.AnnKeywordId' :
+-- 'ApiAnnotation.AnnDeriving', 'ApiAnnotation.AnnStock',
+-- 'ApiAnnotation.AnnAnyClass', 'Api.AnnNewtype',
+-- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose'
+data HsDerivingClause name
+ -- See Note [Deriving strategies] in TcDeriv
+ = HsDerivingClause
+ { deriv_clause_strategy :: Maybe (Located DerivStrategy)
+ -- ^ The user-specified strategy (if any) to use when deriving
+ -- 'deriv_clause_tys'.
+ , deriv_clause_tys :: Located [LHsSigType name]
+ -- ^ The types to derive.
+ --
+ -- It uses 'LHsSigType's because, with @-XGeneralizedNewtypeDeriving@,
+ -- we can mention type variables that aren't bound by the datatype, e.g.
+ --
+ -- > data T b = ... deriving (C [a])
+ --
+ -- should produce a derived instance for @C [a] (T b)@.
+ }
+deriving instance (DataId id) => Data (HsDerivingClause id)
+
+instance (OutputableBndrId name)
+ => Outputable (HsDerivingClause name) where
+ ppr (HsDerivingClause { deriv_clause_strategy = dcs
+ , deriv_clause_tys = L _ dct })
+ = hsep [ text "deriving"
+ , ppDerivStrategy dcs
+ , pp_dct dct ]
+ where
+ -- This complexity is to distinguish between
+ -- deriving Show
+ -- deriving (Show)
+ pp_dct [a@(HsIB { hsib_body = L _ HsAppsTy{} })] = parens (ppr a)
+ pp_dct [a] = ppr a
+ pp_dct _ = parens (interpp'SP dct)
+
+data NewOrData
+ = NewType -- ^ @newtype Blah ...@
+ | DataType -- ^ @data Blah ...@
+ deriving( Eq, Data ) -- Needed because Demand derives Eq
+
+-- | Located data Constructor Declaration
+type LConDecl name = Located (ConDecl name)
+ -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi' when
+ -- in a GADT constructor list
+
+ -- For details on above see note [Api annotations] in ApiAnnotation
+
+-- |
+--
+-- @
+-- data T b = forall a. Eq a => MkT a b
+-- MkT :: forall b a. Eq a => MkT a b
+--
+-- data T b where
+-- MkT1 :: Int -> T Int
+--
+-- data T = Int `MkT` Int
+-- | MkT2
+--
+-- data T a where
+-- Int `MkT` Int :: T Int
+-- @
+--
+-- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnOpen',
+-- 'ApiAnnotation.AnnDotdot','ApiAnnotation.AnnCLose',
+-- 'ApiAnnotation.AnnEqual','ApiAnnotation.AnnVbar',
+-- 'ApiAnnotation.AnnDarrow','ApiAnnotation.AnnDarrow',
+-- 'ApiAnnotation.AnnForall','ApiAnnotation.AnnDot'
+
+-- For details on above see note [Api annotations] in ApiAnnotation
+
+-- | data Constructor Declaration
+data ConDecl name
+ = ConDeclGADT
+ { con_names :: [Located name]
+ , con_type :: LHsSigType name
+ -- ^ The type after the ‘::’
+ , con_doc :: Maybe LHsDocString
+ -- ^ A possible Haddock comment.
+ }
+
+ | ConDeclH98
+ { con_name :: Located name
+
+ , con_qvars :: Maybe (LHsQTyVars name)
+ -- User-written forall (if any), and its implicit
+ -- kind variables
+ -- Non-Nothing needs -XExistentialQuantification
+ -- e.g. data T a = forall b. MkT b (b->a)
+ -- con_qvars = {b}
+
+ , con_cxt :: Maybe (LHsContext name)
+ -- ^ User-written context (if any)
+
+ , con_details :: HsConDeclDetails name
+ -- ^ Arguments
+
+ , con_doc :: Maybe LHsDocString
+ -- ^ A possible Haddock comment.
+ }
+deriving instance (DataId name) => Data (ConDecl name)
+
+-- | Haskell data Constructor Declaration Details
+type HsConDeclDetails name
+ = HsConDetails (LBangType name) (Located [LConDeclField name])
+
+getConNames :: ConDecl name -> [Located name]
+getConNames ConDeclH98 {con_name = name} = [name]
+getConNames ConDeclGADT {con_names = names} = names
+
+-- don't call with RdrNames, because it can't deal with HsAppsTy
+getConDetails :: ConDecl name -> HsConDeclDetails name
+getConDetails ConDeclH98 {con_details = details} = details
+getConDetails ConDeclGADT {con_type = ty } = details
+ where
+ (details,_,_,_) = gadtDeclDetails ty
+
+-- don't call with RdrNames, because it can't deal with HsAppsTy
+gadtDeclDetails :: LHsSigType name
+ -> ( HsConDeclDetails name
+ , LHsType name
+ , LHsContext name
+ , [LHsTyVarBndr name] )
+gadtDeclDetails HsIB {hsib_body = lbody_ty} = (details,res_ty,cxt,tvs)
+ where
+ (tvs, cxt, tau) = splitLHsSigmaTy lbody_ty
+ (details, res_ty) -- See Note [Sorting out the result type]
+ = case tau of
+ L _ (HsFunTy (L l (HsRecTy flds)) res_ty')
+ -> (RecCon (L l flds), res_ty')
+ _other -> (PrefixCon [], tau)
+
+hsConDeclArgTys :: HsConDeclDetails name -> [LBangType name]
+hsConDeclArgTys (PrefixCon tys) = tys
+hsConDeclArgTys (InfixCon ty1 ty2) = [ty1,ty2]
+hsConDeclArgTys (RecCon flds) = map (cd_fld_type . unLoc) (unLoc flds)
+
+pp_data_defn :: (OutputableBndrId name)
+ => (HsContext name -> SDoc) -- Printing the header
+ -> HsDataDefn name
+ -> SDoc
+pp_data_defn pp_hdr (HsDataDefn { dd_ND = new_or_data, dd_ctxt = L _ context
+ , dd_cType = mb_ct
+ , dd_kindSig = mb_sig
+ , dd_cons = condecls, dd_derivs = derivings })
+ | null condecls
+ = ppr new_or_data <+> pp_ct <+> pp_hdr context <+> pp_sig
+ <+> pp_derivings derivings
+
+ | otherwise
+ = hang (ppr new_or_data <+> pp_ct <+> pp_hdr context <+> pp_sig)
+ 2 (pp_condecls condecls $$ pp_derivings derivings)
+ where
+ pp_ct = case mb_ct of
+ Nothing -> empty
+ Just ct -> ppr ct
+ pp_sig = case mb_sig of
+ Nothing -> empty
+ Just kind -> dcolon <+> ppr kind
+ pp_derivings (L _ ds) = vcat (map ppr ds)
+
+instance (OutputableBndrId name) => Outputable (HsDataDefn name) where
+ ppr d = pp_data_defn (\_ -> text "Naked HsDataDefn") d
+
+instance Outputable NewOrData where
+ ppr NewType = text "newtype"
+ ppr DataType = text "data"
+
+pp_condecls :: (OutputableBndrId name) => [LConDecl name] -> SDoc
+pp_condecls cs@(L _ ConDeclGADT{} : _) -- In GADT syntax
+ = hang (text "where") 2 (vcat (map ppr cs))
+pp_condecls cs -- In H98 syntax
+ = equals <+> sep (punctuate (text " |") (map ppr cs))
+
+instance (OutputableBndrId name) => Outputable (ConDecl name) where
+ ppr = pprConDecl
+
+pprConDecl :: (OutputableBndrId name) => ConDecl name -> SDoc
+pprConDecl (ConDeclH98 { con_name = L _ con
+ , con_qvars = mtvs
+ , con_cxt = mcxt
+ , con_details = details
+ , con_doc = doc })
+ = sep [ppr_mbDoc doc, pprHsForAll tvs cxt, ppr_details details]
+ where
+ ppr_details (InfixCon t1 t2) = hsep [ppr t1, pprInfixOcc con, ppr t2]
+ ppr_details (PrefixCon tys) = hsep (pprPrefixOcc con
+ : map (pprParendHsType . unLoc) tys)
+ ppr_details (RecCon fields) = pprPrefixOcc con
+ <+> pprConDeclFields (unLoc fields)
+ tvs = case mtvs of
+ Nothing -> []
+ Just (HsQTvs { hsq_explicit = tvs }) -> tvs
+
+ cxt = fromMaybe (noLoc []) mcxt
+
+pprConDecl (ConDeclGADT { con_names = cons, con_type = res_ty, con_doc = doc })
+ = sep [ppr_mbDoc doc <+> ppr_con_names cons <+> dcolon
+ <+> ppr res_ty]
+
+ppr_con_names :: (OutputableBndr name) => [Located name] -> SDoc
+ppr_con_names = pprWithCommas (pprPrefixOcc . unLoc)
+
+{-
+************************************************************************
+* *
+ Instance declarations
+* *
+************************************************************************
+
+Note [Type family instance declarations in HsSyn]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The data type TyFamEqn represents one equation of a type family instance.
+It is parameterised over its tfe_pats field:
+
+ * An ordinary type family instance declaration looks like this in source Haskell
+ type instance T [a] Int = a -> a
+ (or something similar for a closed family)
+ It is represented by a TyFamInstEqn, with *type* in the tfe_pats field.
+
+ * On the other hand, the *default instance* of an associated type looks like
+ this in source Haskell
+ class C a where
+ type T a b
+ type T a b = a -> b -- The default instance
+ It is represented by a TyFamDefltEqn, with *type variables* in the tfe_pats
+ field.
+-}
+
+----------------- Type synonym family instances -------------
+
+-- | Located Type Family Instance Equation
+type LTyFamInstEqn name = Located (TyFamInstEqn name)
+ -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi'
+ -- when in a list
+
+-- For details on above see note [Api annotations] in ApiAnnotation
+
+-- | Located Type Family Default Equation
+type LTyFamDefltEqn name = Located (TyFamDefltEqn name)
+
+-- | Haskell Type Patterns
+type HsTyPats name = HsImplicitBndrs name [LHsType name]
+ -- ^ Type patterns (with kind and type bndrs)
+ -- See Note [Family instance declaration binders]
+
+{- Note [Family instance declaration binders]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The HsTyPats field is LHS patterns or a type/data family instance.
+
+The hsib_vars of the HsImplicitBndrs are the template variables of the
+type patterns, i.e. fv(pat_tys). Note in particular
+
+* The hsib_vars *includes* any anonymous wildcards. For example
+ type instance F a _ = a
+ The hsib_vars will be {a, _}. Remember that each separate wildcard
+ '_' gets its own unique. In this context wildcards behave just like
+ an ordinary type variable, only anonymous.
+
+* The hsib_vars *including* type variables that are already in scope
+
+ Eg class C s t where
+ type F t p :: *
+ instance C w (a,b) where
+ type F (a,b) x = x->a
+ The hsib_vars of the F decl are {a,b,x}, even though the F decl
+ is nested inside the 'instance' decl.
+
+ However after the renamer, the uniques will match up:
+ instance C w7 (a8,b9) where
+ type F (a8,b9) x10 = x10->a8
+ so that we can compare the type pattern in the 'instance' decl and
+ in the associated 'type' decl
+-}
+
+-- | Type Family Instance Equation
+type TyFamInstEqn name = TyFamEqn name (HsTyPats name)
+
+-- | Type Family Default Equation
+type TyFamDefltEqn name = TyFamEqn name (LHsQTyVars name)
+ -- See Note [Type family instance declarations in HsSyn]
+
+-- | Type Family Equation
+--
+-- One equation in a type family instance declaration
+-- See Note [Type family instance declarations in HsSyn]
+data TyFamEqn name pats
+ = TyFamEqn
+ { tfe_tycon :: Located name
+ , tfe_pats :: pats
+ , tfe_fixity :: LexicalFixity -- ^ Fixity used in the declaration
+ , tfe_rhs :: LHsType name }
+ -- ^
+ -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnEqual'
+
+ -- For details on above see note [Api annotations] in ApiAnnotation
+deriving instance (DataId name, Data pats) => Data (TyFamEqn name pats)
+
+-- | Located Type Family Instance Declaration
+type LTyFamInstDecl name = Located (TyFamInstDecl name)
+
+-- | Type Family Instance Declaration
+data TyFamInstDecl name
+ = TyFamInstDecl
+ { tfid_eqn :: LTyFamInstEqn name
+ , tfid_fvs :: PostRn name NameSet }
+ -- ^
+ -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType',
+ -- 'ApiAnnotation.AnnInstance',
+
+ -- For details on above see note [Api annotations] in ApiAnnotation
+deriving instance (DataId name) => Data (TyFamInstDecl name)
+
+----------------- Data family instances -------------
+
+-- | Located Data Family Instance Declaration
+type LDataFamInstDecl name = Located (DataFamInstDecl name)
+
+-- | Data Family Instance Declaration
+data DataFamInstDecl name
+ = DataFamInstDecl
+ { dfid_tycon :: Located name
+ , dfid_pats :: HsTyPats name -- LHS
+ , dfid_fixity :: LexicalFixity -- ^ Fixity used in the declaration
+ , dfid_defn :: HsDataDefn name -- RHS
+ , dfid_fvs :: PostRn name NameSet } -- Free vars for dependency analysis
+ -- ^
+ -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnData',
+ -- 'ApiAnnotation.AnnNewType','ApiAnnotation.AnnInstance',
+ -- 'ApiAnnotation.AnnDcolon'
+ -- 'ApiAnnotation.AnnWhere','ApiAnnotation.AnnOpen',
+ -- 'ApiAnnotation.AnnClose'
+
+ -- For details on above see note [Api annotations] in ApiAnnotation
+deriving instance (DataId name) => Data (DataFamInstDecl name)
+
+
+----------------- Class instances -------------
+
+-- | Located Class Instance Declaration
+type LClsInstDecl name = Located (ClsInstDecl name)
+
+-- | Class Instance Declaration
+data ClsInstDecl name
+ = ClsInstDecl
+ { cid_poly_ty :: LHsSigType name -- Context => Class Instance-type
+ -- Using a polytype means that the renamer conveniently
+ -- figures out the quantified type variables for us.
+ , cid_binds :: LHsBinds name -- Class methods
+ , cid_sigs :: [LSig name] -- User-supplied pragmatic info
+ , cid_tyfam_insts :: [LTyFamInstDecl name] -- Type family instances
+ , cid_datafam_insts :: [LDataFamInstDecl name] -- Data family instances
+ , cid_overlap_mode :: Maybe (Located OverlapMode)
+ -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
+ -- 'ApiAnnotation.AnnClose',
+
+ -- For details on above see note [Api annotations] in ApiAnnotation
+ }
+ -- ^
+ -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnInstance',
+ -- 'ApiAnnotation.AnnWhere',
+ -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose',
+
+ -- For details on above see note [Api annotations] in ApiAnnotation
+deriving instance (DataId id) => Data (ClsInstDecl id)
+
+
+----------------- Instances of all kinds -------------
+
+-- | Located Instance Declaration
+type LInstDecl name = Located (InstDecl name)
+
+-- | Instance Declaration
+data InstDecl name -- Both class and family instances
+ = ClsInstD
+ { cid_inst :: ClsInstDecl name }
+ | DataFamInstD -- data family instance
+ { dfid_inst :: DataFamInstDecl name }
+ | TyFamInstD -- type family instance
+ { tfid_inst :: TyFamInstDecl name }
+deriving instance (DataId id) => Data (InstDecl id)
+
+instance (OutputableBndrId name) => Outputable (TyFamInstDecl name) where
+ ppr = pprTyFamInstDecl TopLevel
+
+pprTyFamInstDecl :: (OutputableBndrId name)
+ => TopLevelFlag -> TyFamInstDecl name -> SDoc
+pprTyFamInstDecl top_lvl (TyFamInstDecl { tfid_eqn = eqn })
+ = text "type" <+> ppr_instance_keyword top_lvl <+> ppr_fam_inst_eqn eqn
+
+ppr_instance_keyword :: TopLevelFlag -> SDoc
+ppr_instance_keyword TopLevel = text "instance"
+ppr_instance_keyword NotTopLevel = empty
+
+ppr_fam_inst_eqn :: (OutputableBndrId name) => LTyFamInstEqn name -> SDoc
+ppr_fam_inst_eqn (L _ (TyFamEqn { tfe_tycon = tycon
+ , tfe_pats = pats
+ , tfe_fixity = fixity
+ , tfe_rhs = rhs }))
+ = pp_fam_inst_lhs tycon pats fixity [] <+> equals <+> ppr rhs
+
+ppr_fam_deflt_eqn :: (OutputableBndrId name) => LTyFamDefltEqn name -> SDoc
+ppr_fam_deflt_eqn (L _ (TyFamEqn { tfe_tycon = tycon
+ , tfe_pats = tvs
+ , tfe_fixity = fixity
+ , tfe_rhs = rhs }))
+ = text "type" <+> pp_vanilla_decl_head tycon tvs fixity []
+ <+> equals <+> ppr rhs
+
+instance (OutputableBndrId name) => Outputable (DataFamInstDecl name) where
+ ppr = pprDataFamInstDecl TopLevel
+
+pprDataFamInstDecl :: (OutputableBndrId name)
+ => TopLevelFlag -> DataFamInstDecl name -> SDoc
+pprDataFamInstDecl top_lvl (DataFamInstDecl { dfid_tycon = tycon
+ , dfid_pats = pats
+ , dfid_fixity = fixity
+ , dfid_defn = defn })
+ = pp_data_defn pp_hdr defn
+ where
+ pp_hdr ctxt = ppr_instance_keyword top_lvl
+ <+> pp_fam_inst_lhs tycon pats fixity ctxt
+
+pprDataFamInstFlavour :: DataFamInstDecl name -> SDoc
+pprDataFamInstFlavour (DataFamInstDecl { dfid_defn = (HsDataDefn { dd_ND = nd }) })
+ = ppr nd
+
+pp_fam_inst_lhs :: (OutputableBndrId name) => Located name
+ -> HsTyPats name
+ -> LexicalFixity
+ -> HsContext name
+ -> SDoc
+pp_fam_inst_lhs thing (HsIB { hsib_body = typats }) fixity context
+ -- explicit type patterns
+ = hsep [ pprHsContext context, pp_pats typats]
+ where
+ pp_pats (patl:patsr)
+ | fixity == Infix
+ = hsep [pprParendHsType (unLoc patl), pprInfixOcc (unLoc thing)
+ , hsep (map (pprParendHsType.unLoc) patsr)]
+ | otherwise = hsep [ pprPrefixOcc (unLoc thing)
+ , hsep (map (pprParendHsType.unLoc) (patl:patsr))]
+ pp_pats [] = empty
+
+instance (OutputableBndrId name) => Outputable (ClsInstDecl name) where
+ ppr (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = binds
+ , cid_sigs = sigs, cid_tyfam_insts = ats
+ , cid_overlap_mode = mbOverlap
+ , cid_datafam_insts = adts })
+ | null sigs, null ats, null adts, isEmptyBag binds -- No "where" part
+ = top_matter
+
+ | otherwise -- Laid out
+ = vcat [ top_matter <+> text "where"
+ , nest 2 $ pprDeclList $
+ map (pprTyFamInstDecl NotTopLevel . unLoc) ats ++
+ map (pprDataFamInstDecl NotTopLevel . unLoc) adts ++
+ pprLHsBindsForUser binds sigs ]
+ where
+ top_matter = text "instance" <+> ppOverlapPragma mbOverlap
+ <+> ppr inst_ty
+
+ppDerivStrategy :: Maybe (Located DerivStrategy) -> SDoc
+ppDerivStrategy mb =
+ case mb of
+ Nothing -> empty
+ Just (L _ ds) -> ppr ds
+
+ppOverlapPragma :: Maybe (Located OverlapMode) -> SDoc
+ppOverlapPragma mb =
+ case mb of
+ Nothing -> empty
+ Just (L _ (NoOverlap s)) -> maybe_stext s "{-# NO_OVERLAP #-}"
+ Just (L _ (Overlappable s)) -> maybe_stext s "{-# OVERLAPPABLE #-}"
+ Just (L _ (Overlapping s)) -> maybe_stext s "{-# OVERLAPPING #-}"
+ Just (L _ (Overlaps s)) -> maybe_stext s "{-# OVERLAPS #-}"
+ Just (L _ (Incoherent s)) -> maybe_stext s "{-# INCOHERENT #-}"
+ where
+ maybe_stext NoSourceText alt = text alt
+ maybe_stext (SourceText src) _ = text src <+> text "#-}"
+
+
+instance (OutputableBndrId name) => Outputable (InstDecl name) where
+ ppr (ClsInstD { cid_inst = decl }) = ppr decl
+ ppr (TyFamInstD { tfid_inst = decl }) = ppr decl
+ ppr (DataFamInstD { dfid_inst = decl }) = ppr decl
+
+-- Extract the declarations of associated data types from an instance
+
+instDeclDataFamInsts :: [LInstDecl name] -> [DataFamInstDecl name]
+instDeclDataFamInsts inst_decls
+ = concatMap do_one inst_decls
+ where
+ do_one (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = fam_insts } }))
+ = map unLoc fam_insts
+ do_one (L _ (DataFamInstD { dfid_inst = fam_inst })) = [fam_inst]
+ do_one (L _ (TyFamInstD {})) = []
+
+{-
+************************************************************************
+* *
+\subsection[DerivDecl]{A stand-alone instance deriving declaration}
+* *
+************************************************************************
+-}
+
+-- | Located Deriving Declaration
+type LDerivDecl name = Located (DerivDecl name)
+
+-- | Deriving Declaration
+data DerivDecl name = DerivDecl
+ { deriv_type :: LHsSigType name
+ , deriv_strategy :: Maybe (Located DerivStrategy)
+ , deriv_overlap_mode :: Maybe (Located OverlapMode)
+ -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDeriving',
+ -- 'ApiAnnotation.AnnInstance', 'ApiAnnotation.AnnStock',
+ -- 'ApiAnnotation.AnnAnyClass', 'Api.AnnNewtype',
+ -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose'
+
+ -- For details on above see note [Api annotations] in ApiAnnotation
+ }
+deriving instance (DataId name) => Data (DerivDecl name)
+
+instance (OutputableBndrId name) => Outputable (DerivDecl name) where
+ ppr (DerivDecl { deriv_type = ty
+ , deriv_strategy = ds
+ , deriv_overlap_mode = o })
+ = hsep [ text "deriving"
+ , ppDerivStrategy ds
+ , text "instance"
+ , ppOverlapPragma o
+ , ppr ty ]
+
+{-
+************************************************************************
+* *
+\subsection[DefaultDecl]{A @default@ declaration}
+* *
+************************************************************************
+
+There can only be one default declaration per module, but it is hard
+for the parser to check that; we pass them all through in the abstract
+syntax, and that restriction must be checked in the front end.
+-}
+
+-- | Located Default Declaration
+type LDefaultDecl name = Located (DefaultDecl name)
+
+-- | Default Declaration
+data DefaultDecl name
+ = DefaultDecl [LHsType name]
+ -- ^ - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnDefault',
+ -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose'
+
+ -- For details on above see note [Api annotations] in ApiAnnotation
+deriving instance (DataId name) => Data (DefaultDecl name)
+
+instance (OutputableBndrId name) => Outputable (DefaultDecl name) where
+
+ ppr (DefaultDecl tys)
+ = text "default" <+> parens (interpp'SP tys)
+
+{-
+************************************************************************
+* *
+\subsection{Foreign function interface declaration}
+* *
+************************************************************************
+-}
+
+-- foreign declarations are distinguished as to whether they define or use a
+-- Haskell name
+--
+-- * the Boolean value indicates whether the pre-standard deprecated syntax
+-- has been used
+
+-- | Located Foreign Declaration
+type LForeignDecl name = Located (ForeignDecl name)
+
+-- | Foreign Declaration
+data ForeignDecl name
+ = ForeignImport
+ { fd_name :: Located name -- defines this name
+ , fd_sig_ty :: LHsSigType name -- sig_ty
+ , fd_co :: PostTc name Coercion -- rep_ty ~ sig_ty
+ , fd_fi :: ForeignImport }
+
+ | ForeignExport
+ { fd_name :: Located name -- uses this name
+ , fd_sig_ty :: LHsSigType name -- sig_ty
+ , fd_co :: PostTc name Coercion -- rep_ty ~ sig_ty
+ , fd_fe :: ForeignExport }
+ -- ^
+ -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnForeign',
+ -- 'ApiAnnotation.AnnImport','ApiAnnotation.AnnExport',
+ -- 'ApiAnnotation.AnnDcolon'
+
+ -- For details on above see note [Api annotations] in ApiAnnotation
+
+deriving instance (DataId name) => Data (ForeignDecl name)
+{-
+ In both ForeignImport and ForeignExport:
+ sig_ty is the type given in the Haskell code
+ rep_ty is the representation for this type, i.e. with newtypes
+ coerced away and type functions evaluated.
+ Thus if the declaration is valid, then rep_ty will only use types
+ such as Int and IO that we know how to make foreign calls with.
+-}
+
+noForeignImportCoercionYet :: PlaceHolder
+noForeignImportCoercionYet = PlaceHolder
+
+noForeignExportCoercionYet :: PlaceHolder
+noForeignExportCoercionYet = PlaceHolder
+
+-- Specification Of an imported external entity in dependence on the calling
+-- convention
+--
+data ForeignImport = -- import of a C entity
+ --
+ -- * the two strings specifying a header file or library
+ -- may be empty, which indicates the absence of a
+ -- header or object specification (both are not used
+ -- in the case of `CWrapper' and when `CFunction'
+ -- has a dynamic target)
+ --
+ -- * the calling convention is irrelevant for code
+ -- generation in the case of `CLabel', but is needed
+ -- for pretty printing
+ --
+ -- * `Safety' is irrelevant for `CLabel' and `CWrapper'
+ --
+ CImport (Located CCallConv) -- ccall or stdcall
+ (Located Safety) -- interruptible, safe or unsafe
+ (Maybe Header) -- name of C header
+ CImportSpec -- details of the C entity
+ (Located SourceText) -- original source text for
+ -- the C entity
+ deriving Data
+
+-- details of an external C entity
+--
+data CImportSpec = CLabel CLabelString -- import address of a C label
+ | CFunction CCallTarget -- static or dynamic function
+ | CWrapper -- wrapper to expose closures
+ -- (former f.e.d.)
+ deriving Data
+
+-- specification of an externally exported entity in dependence on the calling
+-- convention
+--
+data ForeignExport = CExport (Located CExportSpec) -- contains the calling
+ -- convention
+ (Located SourceText) -- original source text for
+ -- the C entity
+ deriving Data
+
+-- pretty printing of foreign declarations
+--
+
+instance (OutputableBndrId name) => Outputable (ForeignDecl name) where
+ ppr (ForeignImport { fd_name = n, fd_sig_ty = ty, fd_fi = fimport })
+ = hang (text "foreign import" <+> ppr fimport <+> ppr n)
+ 2 (dcolon <+> ppr ty)
+ ppr (ForeignExport { fd_name = n, fd_sig_ty = ty, fd_fe = fexport }) =
+ hang (text "foreign export" <+> ppr fexport <+> ppr n)
+ 2 (dcolon <+> ppr ty)
+
+instance Outputable ForeignImport where
+ ppr (CImport cconv safety mHeader spec (L _ srcText)) =
+ ppr cconv <+> ppr safety
+ <+> pprWithSourceText srcText (pprCEntity spec "")
+ where
+ pp_hdr = case mHeader of
+ Nothing -> empty
+ Just (Header _ header) -> ftext header
+
+ pprCEntity (CLabel lbl) _ =
+ doubleQuotes $ text "static" <+> pp_hdr <+> char '&' <> ppr lbl
+ pprCEntity (CFunction (StaticTarget st _lbl _ isFun)) src =
+ if dqNeeded then doubleQuotes ce else empty
+ where
+ dqNeeded = (take 6 src == "static")
+ || isJust mHeader
+ || not isFun
+ || st /= NoSourceText
+ ce =
+ -- We may need to drop leading spaces first
+ (if take 6 src == "static" then text "static" else empty)
+ <+> pp_hdr
+ <+> (if isFun then empty else text "value")
+ <+> (pprWithSourceText st empty)
+ pprCEntity (CFunction DynamicTarget) _ =
+ doubleQuotes $ text "dynamic"
+ pprCEntity CWrapper _ = doubleQuotes $ text "wrapper"
+
+instance Outputable ForeignExport where
+ ppr (CExport (L _ (CExportStatic _ lbl cconv)) _) =
+ ppr cconv <+> char '"' <> ppr lbl <> char '"'
+
+{-
+************************************************************************
+* *
+\subsection{Transformation rules}
+* *
+************************************************************************
+-}
+
+-- | Located Rule Declarations
+type LRuleDecls name = Located (RuleDecls name)
+
+ -- Note [Pragma source text] in BasicTypes
+-- | Rule Declarations
+data RuleDecls name = HsRules { rds_src :: SourceText
+ , rds_rules :: [LRuleDecl name] }
+deriving instance (DataId name) => Data (RuleDecls name)
+
+-- | Located Rule Declaration
+type LRuleDecl name = Located (RuleDecl name)
+
+-- | Rule Declaration
+data RuleDecl name
+ = HsRule -- Source rule
+ (Located (SourceText,RuleName)) -- Rule name
+ -- Note [Pragma source text] in BasicTypes
+ Activation
+ [LRuleBndr name] -- Forall'd vars; after typechecking this
+ -- includes tyvars
+ (Located (HsExpr name)) -- LHS
+ (PostRn name NameSet) -- Free-vars from the LHS
+ (Located (HsExpr name)) -- RHS
+ (PostRn name NameSet) -- Free-vars from the RHS
+ -- ^
+ -- - 'ApiAnnotation.AnnKeywordId' :
+ -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnTilde',
+ -- 'ApiAnnotation.AnnVal',
+ -- 'ApiAnnotation.AnnClose',
+ -- 'ApiAnnotation.AnnForall','ApiAnnotation.AnnDot',
+ -- 'ApiAnnotation.AnnEqual',
+
+ -- For details on above see note [Api annotations] in ApiAnnotation
+deriving instance (DataId name) => Data (RuleDecl name)
+
+flattenRuleDecls :: [LRuleDecls name] -> [LRuleDecl name]
+flattenRuleDecls decls = concatMap (rds_rules . unLoc) decls
+
+-- | Located Rule Binder
+type LRuleBndr name = Located (RuleBndr name)
+
+-- | Rule Binder
+data RuleBndr name
+ = RuleBndr (Located name)
+ | RuleBndrSig (Located name) (LHsSigWcType name)
+ -- ^
+ -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
+ -- 'ApiAnnotation.AnnDcolon','ApiAnnotation.AnnClose'
+
+ -- For details on above see note [Api annotations] in ApiAnnotation
+deriving instance (DataId name) => Data (RuleBndr name)
+
+collectRuleBndrSigTys :: [RuleBndr name] -> [LHsSigWcType name]
+collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ ty <- bndrs]
+
+pprFullRuleName :: Located (SourceText, RuleName) -> SDoc
+pprFullRuleName (L _ (st, n)) = pprWithSourceText st (doubleQuotes $ ftext n)
+
+instance (OutputableBndrId name) => Outputable (RuleDecls name) where
+ ppr (HsRules st rules)
+ = pprWithSourceText st (text "{-# RULES")
+ <+> vcat (punctuate semi (map ppr rules)) <+> text "#-}"
+
+instance (OutputableBndrId name) => Outputable (RuleDecl name) where
+ ppr (HsRule name act ns lhs _fv_lhs rhs _fv_rhs)
+ = sep [pprFullRuleName name <+> ppr act,
+ nest 4 (pp_forall <+> pprExpr (unLoc lhs)),
+ nest 6 (equals <+> pprExpr (unLoc rhs)) ]
+ where
+ pp_forall | null ns = empty
+ | otherwise = forAllLit <+> fsep (map ppr ns) <> dot
+
+instance (OutputableBndrId name) => Outputable (RuleBndr name) where
+ ppr (RuleBndr name) = ppr name
+ ppr (RuleBndrSig name ty) = parens (ppr name <> dcolon <> ppr ty)
+
+{-
+************************************************************************
+* *
+\subsection{Vectorisation declarations}
+* *
+************************************************************************
+
+A vectorisation pragma, one of
+
+ {-# VECTORISE f = closure1 g (scalar_map g) #-}
+ {-# VECTORISE SCALAR f #-}
+ {-# NOVECTORISE f #-}
+
+ {-# VECTORISE type T = ty #-}
+ {-# VECTORISE SCALAR type T #-}
+-}
+
+-- | Located Vectorise Declaration
+type LVectDecl name = Located (VectDecl name)
+
+-- | Vectorise Declaration
+data VectDecl name
+ = HsVect
+ SourceText -- Note [Pragma source text] in BasicTypes
+ (Located name)
+ (LHsExpr name)
+ -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
+ -- 'ApiAnnotation.AnnEqual','ApiAnnotation.AnnClose'
+
+ -- For details on above see note [Api annotations] in ApiAnnotation
+ | HsNoVect
+ SourceText -- Note [Pragma source text] in BasicTypes
+ (Located name)
+ -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
+ -- 'ApiAnnotation.AnnClose'
+
+ -- For details on above see note [Api annotations] in ApiAnnotation
+ | HsVectTypeIn -- pre type-checking
+ SourceText -- Note [Pragma source text] in BasicTypes
+ Bool -- 'TRUE' => SCALAR declaration
+ (Located name)
+ (Maybe (Located name)) -- 'Nothing' => no right-hand side
+ -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
+ -- 'ApiAnnotation.AnnType','ApiAnnotation.AnnClose',
+ -- 'ApiAnnotation.AnnEqual'
+
+ -- For details on above see note [Api annotations] in ApiAnnotation
+ | HsVectTypeOut -- post type-checking
+ Bool -- 'TRUE' => SCALAR declaration
+ TyCon
+ (Maybe TyCon) -- 'Nothing' => no right-hand side
+ | HsVectClassIn -- pre type-checking
+ SourceText -- Note [Pragma source text] in BasicTypes
+ (Located name)
+ -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
+ -- 'ApiAnnotation.AnnClass','ApiAnnotation.AnnClose',
+
+ -- For details on above see note [Api annotations] in ApiAnnotation
+ | HsVectClassOut -- post type-checking
+ Class
+ | HsVectInstIn -- pre type-checking (always SCALAR) !!!FIXME: should be superfluous now
+ (LHsSigType name)
+ | HsVectInstOut -- post type-checking (always SCALAR) !!!FIXME: should be superfluous now
+ ClsInst
+deriving instance (DataId name) => Data (VectDecl name)
+
+lvectDeclName :: NamedThing name => LVectDecl name -> Name
+lvectDeclName (L _ (HsVect _ (L _ name) _)) = getName name
+lvectDeclName (L _ (HsNoVect _ (L _ name))) = getName name
+lvectDeclName (L _ (HsVectTypeIn _ _ (L _ name) _)) = getName name
+lvectDeclName (L _ (HsVectTypeOut _ tycon _)) = getName tycon
+lvectDeclName (L _ (HsVectClassIn _ (L _ name))) = getName name
+lvectDeclName (L _ (HsVectClassOut cls)) = getName cls
+lvectDeclName (L _ (HsVectInstIn _))
+ = panic "HsDecls.lvectDeclName: HsVectInstIn"
+lvectDeclName (L _ (HsVectInstOut _))
+ = panic "HsDecls.lvectDeclName: HsVectInstOut"
+
+lvectInstDecl :: LVectDecl name -> Bool
+lvectInstDecl (L _ (HsVectInstIn _)) = True
+lvectInstDecl (L _ (HsVectInstOut _)) = True
+lvectInstDecl _ = False
+
+instance (OutputableBndrId name) => Outputable (VectDecl name) where
+ ppr (HsVect _ v rhs)
+ = sep [text "{-# VECTORISE" <+> ppr v,
+ nest 4 $
+ pprExpr (unLoc rhs) <+> text "#-}" ]
+ ppr (HsNoVect _ v)
+ = sep [text "{-# NOVECTORISE" <+> ppr v <+> text "#-}" ]
+ ppr (HsVectTypeIn _ False t Nothing)
+ = sep [text "{-# VECTORISE type" <+> ppr t <+> text "#-}" ]
+ ppr (HsVectTypeIn _ False t (Just t'))
+ = sep [text "{-# VECTORISE type" <+> ppr t, text "=", ppr t', text "#-}" ]
+ ppr (HsVectTypeIn _ True t Nothing)
+ = sep [text "{-# VECTORISE SCALAR type" <+> ppr t <+> text "#-}" ]
+ ppr (HsVectTypeIn _ True t (Just t'))
+ = sep [text "{-# VECTORISE SCALAR type" <+> ppr t, text "=", ppr t', text "#-}" ]
+ ppr (HsVectTypeOut False t Nothing)
+ = sep [text "{-# VECTORISE type" <+> ppr t <+> text "#-}" ]
+ ppr (HsVectTypeOut False t (Just t'))
+ = sep [text "{-# VECTORISE type" <+> ppr t, text "=", ppr t', text "#-}" ]
+ ppr (HsVectTypeOut True t Nothing)
+ = sep [text "{-# VECTORISE SCALAR type" <+> ppr t <+> text "#-}" ]
+ ppr (HsVectTypeOut True t (Just t'))
+ = sep [text "{-# VECTORISE SCALAR type" <+> ppr t, text "=", ppr t', text "#-}" ]
+ ppr (HsVectClassIn _ c)
+ = sep [text "{-# VECTORISE class" <+> ppr c <+> text "#-}" ]
+ ppr (HsVectClassOut c)
+ = sep [text "{-# VECTORISE class" <+> ppr c <+> text "#-}" ]
+ ppr (HsVectInstIn ty)
+ = sep [text "{-# VECTORISE SCALAR instance" <+> ppr ty <+> text "#-}" ]
+ ppr (HsVectInstOut i)
+ = sep [text "{-# VECTORISE SCALAR instance" <+> ppr i <+> text "#-}" ]
+
+{-
+************************************************************************
+* *
+\subsection[DocDecl]{Document comments}
+* *
+************************************************************************
+-}
+
+-- | Located Documentation comment Declaration
+type LDocDecl = Located (DocDecl)
+
+-- | Documentation comment Declaration
+data DocDecl
+ = DocCommentNext HsDocString
+ | DocCommentPrev HsDocString
+ | DocCommentNamed String HsDocString
+ | DocGroup Int HsDocString
+ deriving Data
+
+-- Okay, I need to reconstruct the document comments, but for now:
+instance Outputable DocDecl where
+ ppr _ = text ""
+
+docDeclDoc :: DocDecl -> HsDocString
+docDeclDoc (DocCommentNext d) = d
+docDeclDoc (DocCommentPrev d) = d
+docDeclDoc (DocCommentNamed _ d) = d
+docDeclDoc (DocGroup _ d) = d
+
+{-
+************************************************************************
+* *
+\subsection[DeprecDecl]{Deprecations}
+* *
+************************************************************************
+
+We use exported entities for things to deprecate.
+-}
+
+-- | Located Warning Declarations
+type LWarnDecls name = Located (WarnDecls name)
+
+ -- Note [Pragma source text] in BasicTypes
+-- | Warning pragma Declarations
+data WarnDecls name = Warnings { wd_src :: SourceText
+ , wd_warnings :: [LWarnDecl name]
+ }
+ deriving Data
+
+-- | Located Warning pragma Declaration
+type LWarnDecl name = Located (WarnDecl name)
+
+-- | Warning pragma Declaration
+data WarnDecl name = Warning [Located name] WarningTxt
+ deriving Data
+
+instance OutputableBndr name => Outputable (WarnDecls name) where
+ ppr (Warnings (SourceText src) decls)
+ = text src <+> vcat (punctuate comma (map ppr decls)) <+> text "#-}"
+ ppr (Warnings NoSourceText _decls) = panic "WarnDecls"
+
+instance OutputableBndr name => Outputable (WarnDecl name) where
+ ppr (Warning thing txt)
+ = hsep ( punctuate comma (map ppr thing))
+ <+> ppr txt
+
+{-
+************************************************************************
+* *
+\subsection[AnnDecl]{Annotations}
+* *
+************************************************************************
+-}
+
+-- | Located Annotation Declaration
+type LAnnDecl name = Located (AnnDecl name)
+
+-- | Annotation Declaration
+data AnnDecl name = HsAnnotation
+ SourceText -- Note [Pragma source text] in BasicTypes
+ (AnnProvenance name) (Located (HsExpr name))
+ -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
+ -- 'ApiAnnotation.AnnType'
+ -- 'ApiAnnotation.AnnModule'
+ -- 'ApiAnnotation.AnnClose'
+
+ -- For details on above see note [Api annotations] in ApiAnnotation
+deriving instance (DataId name) => Data (AnnDecl name)
+
+instance (OutputableBndrId name) => Outputable (AnnDecl name) where
+ ppr (HsAnnotation _ provenance expr)
+ = hsep [text "{-#", pprAnnProvenance provenance, pprExpr (unLoc expr), text "#-}"]
+
+-- | Annotation Provenance
+data AnnProvenance name = ValueAnnProvenance (Located name)
+ | TypeAnnProvenance (Located name)
+ | ModuleAnnProvenance
+ deriving (Data, Functor)
+deriving instance Foldable AnnProvenance
+deriving instance Traversable AnnProvenance
+
+annProvenanceName_maybe :: AnnProvenance name -> Maybe name
+annProvenanceName_maybe (ValueAnnProvenance (L _ name)) = Just name
+annProvenanceName_maybe (TypeAnnProvenance (L _ name)) = Just name
+annProvenanceName_maybe ModuleAnnProvenance = Nothing
+
+pprAnnProvenance :: OutputableBndr name => AnnProvenance name -> SDoc
+pprAnnProvenance ModuleAnnProvenance = text "ANN module"
+pprAnnProvenance (ValueAnnProvenance (L _ name))
+ = text "ANN" <+> ppr name
+pprAnnProvenance (TypeAnnProvenance (L _ name))
+ = text "ANN type" <+> ppr name
+
+{-
+************************************************************************
+* *
+\subsection[RoleAnnot]{Role annotations}
+* *
+************************************************************************
+-}
+
+-- | Located Role Annotation Declaration
+type LRoleAnnotDecl name = Located (RoleAnnotDecl name)
+
+-- See #8185 for more info about why role annotations are
+-- top-level declarations
+-- | Role Annotation Declaration
+data RoleAnnotDecl name
+ = RoleAnnotDecl (Located name) -- type constructor
+ [Located (Maybe Role)] -- optional annotations
+ -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType',
+ -- 'ApiAnnotation.AnnRole'
+
+ -- For details on above see note [Api annotations] in ApiAnnotation
+ deriving Data
+
+instance OutputableBndr name => Outputable (RoleAnnotDecl name) where
+ ppr (RoleAnnotDecl ltycon roles)
+ = text "type role" <+> ppr ltycon <+>
+ hsep (map (pp_role . unLoc) roles)
+ where
+ pp_role Nothing = underscore
+ pp_role (Just r) = ppr r
+
+roleAnnotDeclName :: RoleAnnotDecl name -> name
+roleAnnotDeclName (RoleAnnotDecl (L _ name) _) = name
diff --git a/hsSyn/HsDoc.hs b/hsSyn/HsDoc.hs
new file mode 100644
--- /dev/null
+++ b/hsSyn/HsDoc.hs
@@ -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
+
diff --git a/hsSyn/HsDumpAst.hs b/hsSyn/HsDumpAst.hs
new file mode 100644
--- /dev/null
+++ b/hsSyn/HsDumpAst.hs
@@ -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)
diff --git a/hsSyn/HsExpr.hs b/hsSyn/HsExpr.hs
new file mode 100644
--- /dev/null
+++ b/hsSyn/HsExpr.hs
@@ -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, )]
+ where is the evidence for the method. This evidence is
+ instantiated with the class, but is still polymorphic in everything
+ else. For example, in the case of 'arr', the evidence has type
+ forall b c. (b->c) -> a b c
+ where 'a' is the ambient type of the arrow. This polymorphism is
+ important because the desugarer uses the same evidence at multiple
+ different types.
+
+This is Less Cool than what we normally do for rebindable syntax, which is to
+make fully-instantiated piece of evidence at every use site. The Cmd way
+is Less Cool because
+ * The renamer has to predict which methods are needed.
+ See the tedious RnExpr.methodNamesCmd.
+
+ * The desugarer has to know the polymorphic type of the instantiated
+ method. This is checked by Inst.tcSyntaxName, but is less flexible
+ than the rest of rebindable syntax, where the type is less
+ pre-ordained. (And this flexibility is useful; for example we can
+ typecheck do-notation with (>>=) :: m1 a -> (a -> m2 b) -> m2 b.)
+-}
+
+-- | An unbound variable; used for treating out-of-scope variables as
+-- expression holes
+data UnboundVar
+ = OutOfScope OccName GlobalRdrEnv -- ^ An (unqualified) out-of-scope
+ -- variable, together with the GlobalRdrEnv
+ -- with respect to which it is unbound
+
+ -- See Note [OutOfScope and GlobalRdrEnv]
+
+ | TrueExprHole OccName -- ^ A "true" expression hole (_ or _x)
+
+ deriving Data
+
+instance Outputable UnboundVar where
+ ppr = ppr . unboundVarOcc
+
+unboundVarOcc :: UnboundVar -> OccName
+unboundVarOcc (OutOfScope occ _) = occ
+unboundVarOcc (TrueExprHole occ) = occ
+
+{-
+Note [OutOfScope and GlobalRdrEnv]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+To understand why we bundle a GlobalRdrEnv with an out-of-scope variable,
+consider the following module:
+
+ module A where
+
+ foo :: ()
+ foo = bar
+
+ bat :: [Double]
+ bat = [1.2, 3.4]
+
+ $(return [])
+
+ bar = ()
+ bad = False
+
+When A is compiled, the renamer determines that `bar` is not in scope in the
+declaration of `foo` (since `bar` is declared in the following inter-splice
+group). Once it has finished typechecking the entire module, the typechecker
+then generates the associated error message, which specifies both the type of
+`bar` and a list of possible in-scope alternatives:
+
+ A.hs:6:7: error:
+ • Variable not in scope: bar :: ()
+ • ‘bar’ (line 13) is not in scope before the splice on line 11
+ Perhaps you meant ‘bat’ (line 9)
+
+When it calls RnEnv.unknownNameSuggestions to identify these alternatives, the
+typechecker must provide a GlobalRdrEnv. If it provided the current one, which
+contains top-level declarations for the entire module, the error message would
+incorrectly suggest the out-of-scope `bar` and `bad` as possible alternatives
+for `bar` (see Trac #11680). Instead, the typechecker must use the same
+GlobalRdrEnv the renamer used when it determined that `bar` is out-of-scope.
+
+To obtain this GlobalRdrEnv, can the typechecker simply use the out-of-scope
+`bar`'s location to either reconstruct it (from the current GlobalRdrEnv) or to
+look it up in some global store? Unfortunately, no. The problem is that
+location information is not always sufficient for this task. This is most
+apparent when dealing with the TH function addTopDecls, which adds its
+declarations to the FOLLOWING inter-splice group. Consider these declarations:
+
+ ex9 = cat -- cat is NOT in scope here
+
+ $(do -------------------------------------------------------------
+ ds <- [d| f = cab -- cat and cap are both in scope here
+ cat = ()
+ |]
+ addTopDecls ds
+ [d| g = cab -- only cap is in scope here
+ cap = True
+ |])
+
+ ex10 = cat -- cat is NOT in scope here
+
+ $(return []) -----------------------------------------------------
+
+ ex11 = cat -- cat is in scope
+
+Here, both occurrences of `cab` are out-of-scope, and so the typechecker needs
+the GlobalRdrEnvs which were used when they were renamed. These GlobalRdrEnvs
+are different (`cat` is present only in the GlobalRdrEnv for f's `cab'), but the
+locations of the two `cab`s are the same (they are both created in the same
+splice). Thus, we must include some additional information with each `cab` to
+allow the typechecker to obtain the correct GlobalRdrEnv. Clearly, the simplest
+information to use is the GlobalRdrEnv itself.
+-}
+
+-- | A Haskell expression.
+data HsExpr id
+ = HsVar (Located id) -- ^ Variable
+
+ -- See Note [Located RdrNames]
+
+ | HsUnboundVar UnboundVar -- ^ Unbound variable; also used for "holes"
+ -- (_ or _x).
+ -- Turned from HsVar to HsUnboundVar by the
+ -- renamer, when it finds an out-of-scope
+ -- variable or hole.
+ -- Turned into HsVar by type checker, to support
+ -- deferred type errors.
+
+ | HsConLikeOut ConLike -- ^ After typechecker only; must be different
+ -- HsVar for pretty printing
+
+ | HsRecFld (AmbiguousFieldOcc id) -- ^ Variable pointing to record selector
+ -- Not in use after typechecking
+
+ | HsOverLabel (Maybe id) FastString
+ -- ^ Overloaded label (Note [Overloaded labels] in GHC.OverloadedLabels)
+ -- @Just id@ means @RebindableSyntax@ is in use, and gives the id of the
+ -- in-scope 'fromLabel'.
+ -- NB: Not in use after typechecking
+
+ | HsIPVar HsIPName -- ^ Implicit parameter (not in use after typechecking)
+ | HsOverLit (HsOverLit id) -- ^ Overloaded literals
+
+ | HsLit HsLit -- ^ Simple (non-overloaded) literals
+
+ | HsLam (MatchGroup id (LHsExpr id)) -- ^ Lambda abstraction. Currently always a single match
+ --
+ -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLam',
+ -- 'ApiAnnotation.AnnRarrow',
+
+ -- For details on above see note [Api annotations] in ApiAnnotation
+
+ | HsLamCase (MatchGroup id (LHsExpr id)) -- ^ Lambda-case
+ --
+ -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLam',
+ -- 'ApiAnnotation.AnnCase','ApiAnnotation.AnnOpen',
+ -- 'ApiAnnotation.AnnClose'
+
+ -- For details on above see note [Api annotations] in ApiAnnotation
+
+ | HsApp (LHsExpr id) (LHsExpr id) -- ^ Application
+
+ | HsAppType (LHsExpr id) (LHsWcType id) -- ^ Visible type application
+ --
+ -- Explicit type argument; e.g f @Int x y
+ -- NB: Has wildcards, but no implicit quantification
+ --
+ -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnAt',
+
+ | HsAppTypeOut (LHsExpr id) (LHsWcType Name) -- just for pretty-printing
+
+
+ -- | Operator applications:
+ -- NB Bracketed ops such as (+) come out as Vars.
+
+ -- NB We need an expr for the operator in an OpApp/Section since
+ -- the typechecker may need to apply the operator to a few types.
+
+ | OpApp (LHsExpr id) -- left operand
+ (LHsExpr id) -- operator
+ (PostRn id Fixity) -- Renamer adds fixity; bottom until then
+ (LHsExpr id) -- right operand
+
+ -- | Negation operator. Contains the negated expression and the name
+ -- of 'negate'
+ --
+ -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnMinus'
+
+ -- For details on above see note [Api annotations] in ApiAnnotation
+ | NegApp (LHsExpr id)
+ (SyntaxExpr id)
+
+ -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@,
+ -- 'ApiAnnotation.AnnClose' @')'@
+
+ -- For details on above see note [Api annotations] in ApiAnnotation
+ | HsPar (LHsExpr id) -- ^ Parenthesised expr; see Note [Parens in HsSyn]
+
+ | SectionL (LHsExpr id) -- operand; see Note [Sections in HsSyn]
+ (LHsExpr id) -- operator
+ | SectionR (LHsExpr id) -- operator; see Note [Sections in HsSyn]
+ (LHsExpr id) -- operand
+
+ -- | Used for explicit tuples and sections thereof
+ --
+ -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
+ -- 'ApiAnnotation.AnnClose'
+
+ -- For details on above see note [Api annotations] in ApiAnnotation
+ | ExplicitTuple
+ [LHsTupArg id]
+ Boxity
+
+ -- | Used for unboxed sum types
+ --
+ -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'(#'@,
+ -- 'ApiAnnotation.AnnVbar', 'ApiAnnotation.AnnClose' @'#)'@,
+ --
+ -- There will be multiple 'ApiAnnotation.AnnVbar', (1 - alternative) before
+ -- the expression, (arity - alternative) after it
+ | ExplicitSum
+ ConTag -- Alternative (one-based)
+ Arity -- Sum arity
+ (LHsExpr id)
+ (PostTc id [Type]) -- the type arguments
+
+ -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnCase',
+ -- 'ApiAnnotation.AnnOf','ApiAnnotation.AnnOpen' @'{'@,
+ -- 'ApiAnnotation.AnnClose' @'}'@
+
+ -- For details on above see note [Api annotations] in ApiAnnotation
+ | HsCase (LHsExpr id)
+ (MatchGroup id (LHsExpr id))
+
+ -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnIf',
+ -- 'ApiAnnotation.AnnSemi',
+ -- 'ApiAnnotation.AnnThen','ApiAnnotation.AnnSemi',
+ -- 'ApiAnnotation.AnnElse',
+
+ -- For details on above see note [Api annotations] in ApiAnnotation
+ | HsIf (Maybe (SyntaxExpr id)) -- cond function
+ -- Nothing => use the built-in 'if'
+ -- See Note [Rebindable if]
+ (LHsExpr id) -- predicate
+ (LHsExpr id) -- then part
+ (LHsExpr id) -- else part
+
+ -- | Multi-way if
+ --
+ -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnIf'
+ -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose',
+
+ -- For details on above see note [Api annotations] in ApiAnnotation
+ | HsMultiIf (PostTc id Type) [LGRHS id (LHsExpr id)]
+
+ -- | let(rec)
+ --
+ -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLet',
+ -- 'ApiAnnotation.AnnOpen' @'{'@,
+ -- 'ApiAnnotation.AnnClose' @'}'@,'ApiAnnotation.AnnIn'
+
+ -- For details on above see note [Api annotations] in ApiAnnotation
+ | HsLet (LHsLocalBinds id)
+ (LHsExpr id)
+
+ -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDo',
+ -- 'ApiAnnotation.AnnOpen', 'ApiAnnotation.AnnSemi',
+ -- 'ApiAnnotation.AnnVbar',
+ -- 'ApiAnnotation.AnnClose'
+
+ -- For details on above see note [Api annotations] in ApiAnnotation
+ | HsDo (HsStmtContext Name) -- The parameterisation is unimportant
+ -- because in this context we never use
+ -- the PatGuard or ParStmt variant
+ (Located [ExprLStmt id]) -- "do":one or more stmts
+ (PostTc id Type) -- Type of the whole expression
+
+ -- | Syntactic list: [a,b,c,...]
+ --
+ -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'['@,
+ -- 'ApiAnnotation.AnnClose' @']'@
+
+ -- For details on above see note [Api annotations] in ApiAnnotation
+ | ExplicitList
+ (PostTc id Type) -- Gives type of components of list
+ (Maybe (SyntaxExpr id)) -- For OverloadedLists, the fromListN witness
+ [LHsExpr id]
+
+ -- | Syntactic parallel array: [:e1, ..., en:]
+ --
+ -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'[:'@,
+ -- 'ApiAnnotation.AnnDotdot','ApiAnnotation.AnnComma',
+ -- 'ApiAnnotation.AnnVbar'
+ -- 'ApiAnnotation.AnnClose' @':]'@
+
+ -- For details on above see note [Api annotations] in ApiAnnotation
+ | ExplicitPArr
+ (PostTc id Type) -- type of elements of the parallel array
+ [LHsExpr id]
+
+ -- | Record construction
+ --
+ -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{'@,
+ -- 'ApiAnnotation.AnnDotdot','ApiAnnotation.AnnClose' @'}'@
+
+ -- For details on above see note [Api annotations] in ApiAnnotation
+ | RecordCon
+ { rcon_con_name :: Located id -- The constructor name;
+ -- not used after type checking
+ , rcon_con_like :: PostTc id ConLike -- The data constructor or pattern synonym
+ , rcon_con_expr :: PostTcExpr -- Instantiated constructor function
+ , rcon_flds :: HsRecordBinds id } -- The fields
+
+ -- | Record update
+ --
+ -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{'@,
+ -- 'ApiAnnotation.AnnDotdot','ApiAnnotation.AnnClose' @'}'@
+
+ -- For details on above see note [Api annotations] in ApiAnnotation
+ | RecordUpd
+ { rupd_expr :: LHsExpr id
+ , rupd_flds :: [LHsRecUpdField id]
+ , rupd_cons :: PostTc id [ConLike]
+ -- Filled in by the type checker to the
+ -- _non-empty_ list of DataCons that have
+ -- all the upd'd fields
+
+ , rupd_in_tys :: PostTc id [Type] -- Argument types of *input* record type
+ , rupd_out_tys :: PostTc id [Type] -- and *output* record type
+ -- The original type can be reconstructed
+ -- with conLikeResTy
+ , rupd_wrap :: PostTc id HsWrapper -- See note [Record Update HsWrapper]
+ }
+ -- For a type family, the arg types are of the *instance* tycon,
+ -- not the family tycon
+
+ -- | Expression with an explicit type signature. @e :: type@
+ --
+ -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon'
+
+ -- For details on above see note [Api annotations] in ApiAnnotation
+ | ExprWithTySig
+ (LHsExpr id)
+ (LHsSigWcType id)
+
+ | ExprWithTySigOut -- Post typechecking
+ (LHsExpr id)
+ (LHsSigWcType Name) -- Retain the signature,
+ -- as HsSigType Name, for
+ -- round-tripping purposes
+
+ -- | Arithmetic sequence
+ --
+ -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'['@,
+ -- 'ApiAnnotation.AnnComma','ApiAnnotation.AnnDotdot',
+ -- 'ApiAnnotation.AnnClose' @']'@
+
+ -- For details on above see note [Api annotations] in ApiAnnotation
+ | ArithSeq
+ PostTcExpr
+ (Maybe (SyntaxExpr id)) -- For OverloadedLists, the fromList witness
+ (ArithSeqInfo id)
+
+ -- | Arithmetic sequence for parallel array
+ --
+ -- > [:e1..e2:] or [:e1, e2..e3:]
+ --
+ -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'[:'@,
+ -- 'ApiAnnotation.AnnComma','ApiAnnotation.AnnDotdot',
+ -- 'ApiAnnotation.AnnVbar',
+ -- 'ApiAnnotation.AnnClose' @':]'@
+
+ -- For details on above see note [Api annotations] in ApiAnnotation
+ | PArrSeq
+ PostTcExpr
+ (ArithSeqInfo id)
+
+ -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{-\# SCC'@,
+ -- 'ApiAnnotation.AnnVal' or 'ApiAnnotation.AnnValStr',
+ -- 'ApiAnnotation.AnnClose' @'\#-}'@
+
+ -- For details on above see note [Api annotations] in ApiAnnotation
+ | HsSCC SourceText -- Note [Pragma source text] in BasicTypes
+ StringLiteral -- "set cost centre" SCC pragma
+ (LHsExpr id) -- expr whose cost is to be measured
+
+ -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{-\# CORE'@,
+ -- 'ApiAnnotation.AnnVal', 'ApiAnnotation.AnnClose' @'\#-}'@
+
+ -- For details on above see note [Api annotations] in ApiAnnotation
+ | HsCoreAnn SourceText -- Note [Pragma source text] in BasicTypes
+ StringLiteral -- hdaume: core annotation
+ (LHsExpr id)
+
+ -----------------------------------------------------------
+ -- MetaHaskell Extensions
+
+ -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
+ -- 'ApiAnnotation.AnnOpenE','ApiAnnotation.AnnOpenEQ',
+ -- 'ApiAnnotation.AnnClose','ApiAnnotation.AnnCloseQ'
+
+ -- For details on above see note [Api annotations] in ApiAnnotation
+ | HsBracket (HsBracket id)
+
+ -- See Note [Pending Splices]
+ | HsRnBracketOut
+ (HsBracket Name) -- Output of the renamer is the *original* renamed
+ -- expression, plus
+ [PendingRnSplice] -- _renamed_ splices to be type checked
+
+ | HsTcBracketOut
+ (HsBracket Name) -- Output of the type checker is the *original*
+ -- renamed expression, plus
+ [PendingTcSplice] -- _typechecked_ splices to be
+ -- pasted back in by the desugarer
+
+ -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
+ -- 'ApiAnnotation.AnnClose'
+
+ -- For details on above see note [Api annotations] in ApiAnnotation
+ | HsSpliceE (HsSplice id)
+
+ -----------------------------------------------------------
+ -- Arrow notation extension
+
+ -- | @proc@ notation for Arrows
+ --
+ -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnProc',
+ -- 'ApiAnnotation.AnnRarrow'
+
+ -- For details on above see note [Api annotations] in ApiAnnotation
+ | HsProc (LPat id) -- arrow abstraction, proc
+ (LHsCmdTop id) -- body of the abstraction
+ -- always has an empty stack
+
+ ---------------------------------------
+ -- static pointers extension
+ -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnStatic',
+
+ -- For details on above see note [Api annotations] in ApiAnnotation
+ | HsStatic (PostRn id NameSet) -- Free variables of the body
+ (LHsExpr id) -- Body
+
+ ---------------------------------------
+ -- The following are commands, not expressions proper
+ -- They are only used in the parsing stage and are removed
+ -- immediately in parser.RdrHsSyn.checkCommand
+
+ -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.Annlarrowtail',
+ -- 'ApiAnnotation.Annrarrowtail','ApiAnnotation.AnnLarrowtail',
+ -- 'ApiAnnotation.AnnRarrowtail'
+
+ -- For details on above see note [Api annotations] in ApiAnnotation
+ | HsArrApp -- Arrow tail, or arrow application (f -< arg)
+ (LHsExpr id) -- arrow expression, f
+ (LHsExpr id) -- input expression, arg
+ (PostTc id Type) -- type of the arrow expressions f,
+ -- of the form a t t', where arg :: t
+ HsArrAppType -- higher-order (-<<) or first-order (-<)
+ Bool -- True => right-to-left (f -< arg)
+ -- False => left-to-right (arg >- f)
+
+ -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpenB' @'(|'@,
+ -- 'ApiAnnotation.AnnCloseB' @'|)'@
+
+ -- For details on above see note [Api annotations] in ApiAnnotation
+ | HsArrForm -- Command formation, (| e cmd1 .. cmdn |)
+ (LHsExpr id) -- the operator
+ -- after type-checking, a type abstraction to be
+ -- applied to the type of the local environment tuple
+ (Maybe Fixity) -- fixity (filled in by the renamer), for forms that
+ -- were converted from OpApp's by the renamer
+ [LHsCmdTop id] -- argument commands
+
+ ---------------------------------------
+ -- Haskell program coverage (Hpc) Support
+
+ | HsTick
+ (Tickish id)
+ (LHsExpr id) -- sub-expression
+
+ | HsBinTick
+ Int -- module-local tick number for True
+ Int -- module-local tick number for False
+ (LHsExpr id) -- sub-expression
+
+ -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
+ -- 'ApiAnnotation.AnnOpen' @'{-\# GENERATED'@,
+ -- 'ApiAnnotation.AnnVal','ApiAnnotation.AnnVal',
+ -- 'ApiAnnotation.AnnColon','ApiAnnotation.AnnVal',
+ -- 'ApiAnnotation.AnnMinus',
+ -- 'ApiAnnotation.AnnVal','ApiAnnotation.AnnColon',
+ -- 'ApiAnnotation.AnnVal',
+ -- 'ApiAnnotation.AnnClose' @'\#-}'@
+
+ -- For details on above see note [Api annotations] in ApiAnnotation
+ | HsTickPragma -- A pragma introduced tick
+ SourceText -- Note [Pragma source text] in BasicTypes
+ (StringLiteral,(Int,Int),(Int,Int))
+ -- external span for this tick
+ ((SourceText,SourceText),(SourceText,SourceText))
+ -- Source text for the four integers used in the span.
+ -- See note [Pragma source text] in BasicTypes
+ (LHsExpr id)
+
+ ---------------------------------------
+ -- These constructors only appear temporarily in the parser.
+ -- The renamer translates them into the Right Thing.
+
+ | EWildPat -- wildcard
+
+ -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnAt'
+
+ -- For details on above see note [Api annotations] in ApiAnnotation
+ | EAsPat (Located id) -- as pattern
+ (LHsExpr id)
+
+ -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow'
+
+ -- For details on above see note [Api annotations] in ApiAnnotation
+ | EViewPat (LHsExpr id) -- view pattern
+ (LHsExpr id)
+
+ -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnTilde'
+
+ -- For details on above see note [Api annotations] in ApiAnnotation
+ | ELazyPat (LHsExpr id) -- ~ pattern
+
+
+ ---------------------------------------
+ -- Finally, HsWrap appears only in typechecker output
+
+ | HsWrap HsWrapper -- TRANSLATION
+ (HsExpr id)
+
+deriving instance (DataId id) => Data (HsExpr id)
+
+-- | Located Haskell Tuple Argument
+--
+-- 'HsTupArg' is used for tuple sections
+-- @(,a,)@ is represented by
+-- @ExplicitTuple [Missing ty1, Present a, Missing ty3]@
+-- Which in turn stands for @(\x:ty1 \y:ty2. (x,a,y))@
+type LHsTupArg id = Located (HsTupArg id)
+-- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnComma'
+
+-- For details on above see note [Api annotations] in ApiAnnotation
+
+-- | Haskell Tuple Argument
+data HsTupArg id
+ = Present (LHsExpr id) -- ^ The argument
+ | Missing (PostTc id Type) -- ^ The argument is missing, but this is its type
+deriving instance (DataId id) => Data (HsTupArg id)
+
+tupArgPresent :: LHsTupArg id -> Bool
+tupArgPresent (L _ (Present {})) = True
+tupArgPresent (L _ (Missing {})) = False
+
+{-
+Note [Parens in HsSyn]
+~~~~~~~~~~~~~~~~~~~~~~
+HsPar (and ParPat in patterns, HsParTy in types) is used as follows
+
+ * HsPar is required; the pretty printer does not add parens.
+
+ * HsPars are respected when rearranging operator fixities.
+ So a * (b + c) means what it says (where the parens are an HsPar)
+
+ * For ParPat and HsParTy the pretty printer does add parens but this should be
+ a no-op for ParsedSource, based on the pretty printer round trip feature
+ introduced in
+ https://phabricator.haskell.org/rGHC499e43824bda967546ebf95ee33ec1f84a114a7c
+
+ * ParPat and HsParTy are pretty printed as '( .. )' regardless of whether or
+ not they are strictly necssary. This should be addressed when #13238 is
+ completed, to be treated the same as HsPar.
+
+
+Note [Sections in HsSyn]
+~~~~~~~~~~~~~~~~~~~~~~~~
+Sections should always appear wrapped in an HsPar, thus
+ HsPar (SectionR ...)
+The parser parses sections in a wider variety of situations
+(See Note [Parsing sections]), but the renamer checks for those
+parens. This invariant makes pretty-printing easier; we don't need
+a special case for adding the parens round sections.
+
+Note [Rebindable if]
+~~~~~~~~~~~~~~~~~~~~
+The rebindable syntax for 'if' is a bit special, because when
+rebindable syntax is *off* we do not want to treat
+ (if c then t else e)
+as if it was an application (ifThenElse c t e). Why not?
+Because we allow an 'if' to return *unboxed* results, thus
+ if blah then 3# else 4#
+whereas that would not be possible using a all to a polymorphic function
+(because you can't call a polymorphic function at an unboxed type).
+
+So we use Nothing to mean "use the old built-in typing rule".
+
+Note [Record Update HsWrapper]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+There is a wrapper in RecordUpd which is used for the *required*
+constraints for pattern synonyms. This wrapper is created in the
+typechecking and is then directly used in the desugaring without
+modification.
+
+For example, if we have the record pattern synonym P,
+ pattern P :: (Show a) => a -> Maybe a
+ pattern P{x} = Just x
+
+ foo = (Just True) { x = False }
+then `foo` desugars to something like
+ foo = case Just True of
+ P x -> P False
+hence we need to provide the correct dictionaries to P's matcher on
+the RHS so that we can build the expression.
+
+Note [Located RdrNames]
+~~~~~~~~~~~~~~~~~~~~~~~
+A number of syntax elements have seemingly redundant locations attached to them.
+This is deliberate, to allow transformations making use of the API Annotations
+to easily correlate a Located Name in the RenamedSource with a Located RdrName
+in the ParsedSource.
+
+There are unfortunately enough differences between the ParsedSource and the
+RenamedSource that the API Annotations cannot be used directly with
+RenamedSource, so this allows a simple mapping to be used based on the location.
+-}
+
+instance (OutputableBndrId id) => Outputable (HsExpr id) where
+ ppr expr = pprExpr expr
+
+-----------------------
+-- pprExpr, pprLExpr, pprBinds call pprDeeper;
+-- the underscore versions do not
+pprLExpr :: (OutputableBndrId id) => LHsExpr id -> SDoc
+pprLExpr (L _ e) = pprExpr e
+
+pprExpr :: (OutputableBndrId id) => HsExpr id -> SDoc
+pprExpr e | isAtomicHsExpr e || isQuietHsExpr e = ppr_expr e
+ | otherwise = pprDeeper (ppr_expr e)
+
+isQuietHsExpr :: HsExpr id -> Bool
+-- Parentheses do display something, but it gives little info and
+-- if we go deeper when we go inside them then we get ugly things
+-- like (...)
+isQuietHsExpr (HsPar _) = True
+-- applications don't display anything themselves
+isQuietHsExpr (HsApp _ _) = True
+isQuietHsExpr (HsAppType _ _) = True
+isQuietHsExpr (HsAppTypeOut _ _) = True
+isQuietHsExpr (OpApp _ _ _ _) = True
+isQuietHsExpr _ = False
+
+pprBinds :: (OutputableBndrId idL, OutputableBndrId idR)
+ => HsLocalBindsLR idL idR -> SDoc
+pprBinds b = pprDeeper (ppr b)
+
+-----------------------
+ppr_lexpr :: (OutputableBndrId id) => LHsExpr id -> SDoc
+ppr_lexpr e = ppr_expr (unLoc e)
+
+ppr_expr :: forall id. (OutputableBndrId id) => HsExpr id -> SDoc
+ppr_expr (HsVar (L _ v)) = pprPrefixOcc v
+ppr_expr (HsUnboundVar uv)= pprPrefixOcc (unboundVarOcc uv)
+ppr_expr (HsConLikeOut c) = pprPrefixOcc c
+ppr_expr (HsIPVar v) = ppr v
+ppr_expr (HsOverLabel _ l)= char '#' <> ppr l
+ppr_expr (HsLit lit) = ppr lit
+ppr_expr (HsOverLit lit) = ppr lit
+ppr_expr (HsPar e) = parens (ppr_lexpr e)
+
+ppr_expr (HsCoreAnn stc (StringLiteral sta s) e)
+ = vcat [pprWithSourceText stc (text "{-# CORE")
+ <+> pprWithSourceText sta (doubleQuotes $ ftext s) <+> text "#-}"
+ , ppr_lexpr e]
+
+ppr_expr e@(HsApp {}) = ppr_apps e []
+ppr_expr e@(HsAppType {}) = ppr_apps e []
+ppr_expr e@(HsAppTypeOut {}) = ppr_apps e []
+
+ppr_expr (OpApp e1 op _ e2)
+ | Just pp_op <- should_print_infix (unLoc op)
+ = pp_infixly pp_op
+ | otherwise
+ = pp_prefixly
+
+ where
+ should_print_infix (HsVar (L _ v)) = Just (pprInfixOcc v)
+ should_print_infix (HsConLikeOut c)= Just (pprInfixOcc (conLikeName c))
+ should_print_infix (HsRecFld f) = Just (pprInfixOcc f)
+ should_print_infix (HsUnboundVar h@TrueExprHole{})
+ = Just (pprInfixOcc (unboundVarOcc h))
+ should_print_infix EWildPat = Just (text "`_`")
+ should_print_infix (HsWrap _ e) = should_print_infix e
+ should_print_infix _ = Nothing
+
+ pp_e1 = pprDebugParendExpr e1 -- In debug mode, add parens
+ pp_e2 = pprDebugParendExpr e2 -- to make precedence clear
+
+ pp_prefixly
+ = hang (ppr op) 2 (sep [pp_e1, pp_e2])
+
+ pp_infixly pp_op
+ = hang pp_e1 2 (sep [pp_op, nest 2 pp_e2])
+
+ppr_expr (NegApp e _) = char '-' <+> pprDebugParendExpr e
+
+ppr_expr (SectionL expr op)
+ = case unLoc op of
+ HsVar (L _ v) -> pp_infixly v
+ HsConLikeOut c -> pp_infixly (conLikeName c)
+ _ -> pp_prefixly
+ where
+ pp_expr = pprDebugParendExpr expr
+
+ pp_prefixly = hang (hsep [text " \\ x_ ->", ppr op])
+ 4 (hsep [pp_expr, text "x_ )"])
+ pp_infixly v = (sep [pp_expr, pprInfixOcc v])
+
+ppr_expr (SectionR op expr)
+ = case unLoc op of
+ HsVar (L _ v) -> pp_infixly v
+ HsConLikeOut c -> pp_infixly (conLikeName c)
+ _ -> pp_prefixly
+ where
+ pp_expr = pprDebugParendExpr expr
+
+ pp_prefixly = hang (hsep [text "( \\ x_ ->", ppr op, text "x_"])
+ 4 (pp_expr <> rparen)
+ pp_infixly v = sep [pprInfixOcc v, pp_expr]
+
+ppr_expr (ExplicitTuple exprs boxity)
+ = tupleParens (boxityTupleSort boxity) (fcat (ppr_tup_args $ map unLoc exprs))
+ where
+ ppr_tup_args [] = []
+ ppr_tup_args (Present e : es) = (ppr_lexpr e <> punc es) : ppr_tup_args es
+ ppr_tup_args (Missing _ : es) = punc es : ppr_tup_args es
+
+ punc (Present {} : _) = comma <> space
+ punc (Missing {} : _) = comma
+ punc [] = empty
+
+ppr_expr (ExplicitSum alt arity expr _)
+ = text "(#" <+> ppr_bars (alt - 1) <+> ppr expr <+> ppr_bars (arity - alt) <+> text "#)"
+ where
+ ppr_bars n = hsep (replicate n (char '|'))
+
+ppr_expr (HsLam matches)
+ = pprMatches matches
+
+ppr_expr (HsLamCase matches)
+ = sep [ sep [text "\\case"],
+ nest 2 (pprMatches matches) ]
+
+ppr_expr (HsCase expr matches@(MG { mg_alts = L _ [_] }))
+ = sep [ sep [text "case", nest 4 (ppr expr), ptext (sLit "of {")],
+ nest 2 (pprMatches matches) <+> char '}']
+ppr_expr (HsCase expr matches)
+ = sep [ sep [text "case", nest 4 (ppr expr), ptext (sLit "of")],
+ nest 2 (pprMatches matches) ]
+
+ppr_expr (HsIf _ e1 e2 e3)
+ = sep [hsep [text "if", nest 2 (ppr e1), ptext (sLit "then")],
+ nest 4 (ppr e2),
+ text "else",
+ nest 4 (ppr e3)]
+
+ppr_expr (HsMultiIf _ alts)
+ = hang (text "if") 3 (vcat (map ppr_alt alts))
+ where ppr_alt (L _ (GRHS guards expr)) =
+ hang vbar 2 (ppr_one one_alt)
+ where
+ ppr_one [] = panic "ppr_exp HsMultiIf"
+ ppr_one (h:t) = hang h 2 (sep t)
+ one_alt = [ interpp'SP guards
+ , text "->" <+> pprDeeper (ppr expr) ]
+
+-- special case: let ... in let ...
+ppr_expr (HsLet (L _ binds) expr@(L _ (HsLet _ _)))
+ = sep [hang (text "let") 2 (hsep [pprBinds binds, ptext (sLit "in")]),
+ ppr_lexpr expr]
+
+ppr_expr (HsLet (L _ binds) expr)
+ = sep [hang (text "let") 2 (pprBinds binds),
+ hang (text "in") 2 (ppr expr)]
+
+ppr_expr (HsDo do_or_list_comp (L _ stmts) _) = pprDo do_or_list_comp stmts
+
+ppr_expr (ExplicitList _ _ exprs)
+ = brackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs)))
+
+ppr_expr (ExplicitPArr _ exprs)
+ = paBrackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs)))
+
+ppr_expr (RecordCon { rcon_con_name = con_id, rcon_flds = rbinds })
+ = hang (ppr con_id) 2 (ppr rbinds)
+
+ppr_expr (RecordUpd { rupd_expr = L _ aexp, rupd_flds = rbinds })
+ = hang (ppr aexp) 2 (braces (fsep (punctuate comma (map ppr rbinds))))
+
+ppr_expr (ExprWithTySig expr sig)
+ = hang (nest 2 (ppr_lexpr expr) <+> dcolon)
+ 4 (ppr sig)
+ppr_expr (ExprWithTySigOut expr sig)
+ = hang (nest 2 (ppr_lexpr expr) <+> dcolon)
+ 4 (ppr sig)
+
+ppr_expr (ArithSeq _ _ info) = brackets (ppr info)
+ppr_expr (PArrSeq _ info) = paBrackets (ppr info)
+
+ppr_expr EWildPat = char '_'
+ppr_expr (ELazyPat e) = char '~' <> ppr e
+ppr_expr (EAsPat v e) = ppr v <> char '@' <> ppr e
+ppr_expr (EViewPat p e) = ppr p <+> text "->" <+> ppr e
+
+ppr_expr (HsSCC st (StringLiteral stl lbl) expr)
+ = sep [ pprWithSourceText st (text "{-# SCC")
+ -- no doublequotes if stl empty, for the case where the SCC was written
+ -- without quotes.
+ <+> pprWithSourceText stl (ftext lbl) <+> text "#-}",
+ ppr expr ]
+
+ppr_expr (HsWrap co_fn e)
+ = pprHsWrapper co_fn (\parens -> if parens then pprExpr e
+ else pprExpr e)
+
+ppr_expr (HsSpliceE s) = pprSplice s
+ppr_expr (HsBracket b) = pprHsBracket b
+ppr_expr (HsRnBracketOut e []) = ppr e
+ppr_expr (HsRnBracketOut e ps) = ppr e $$ text "pending(rn)" <+> ppr ps
+ppr_expr (HsTcBracketOut e []) = ppr e
+ppr_expr (HsTcBracketOut e ps) = ppr e $$ text "pending(tc)" <+> ppr ps
+
+ppr_expr (HsProc pat (L _ (HsCmdTop cmd _ _ _)))
+ = hsep [text "proc", ppr pat, ptext (sLit "->"), ppr cmd]
+
+ppr_expr (HsStatic _ e)
+ = hsep [text "static", ppr e]
+
+ppr_expr (HsTick tickish exp)
+ = pprTicks (ppr exp) $
+ ppr tickish <+> ppr_lexpr exp
+ppr_expr (HsBinTick tickIdTrue tickIdFalse exp)
+ = pprTicks (ppr exp) $
+ hcat [text "bintick<",
+ ppr tickIdTrue,
+ text ",",
+ ppr tickIdFalse,
+ text ">(",
+ ppr exp, text ")"]
+ppr_expr (HsTickPragma _ externalSrcLoc _ exp)
+ = pprTicks (ppr exp) $
+ hcat [text "tickpragma<",
+ pprExternalSrcLoc externalSrcLoc,
+ text ">(",
+ ppr exp,
+ text ")"]
+
+ppr_expr (HsArrApp arrow arg _ HsFirstOrderApp True)
+ = hsep [ppr_lexpr arrow, larrowt, ppr_lexpr arg]
+ppr_expr (HsArrApp arrow arg _ HsFirstOrderApp False)
+ = hsep [ppr_lexpr arg, arrowt, ppr_lexpr arrow]
+ppr_expr (HsArrApp arrow arg _ HsHigherOrderApp True)
+ = hsep [ppr_lexpr arrow, larrowtt, ppr_lexpr arg]
+ppr_expr (HsArrApp arrow arg _ HsHigherOrderApp False)
+ = hsep [ppr_lexpr arg, arrowtt, ppr_lexpr arrow]
+
+ppr_expr (HsArrForm (L _ (HsVar (L _ v))) (Just _) [arg1, arg2])
+ = sep [pprCmdArg (unLoc arg1), hsep [pprInfixOcc v, pprCmdArg (unLoc arg2)]]
+ppr_expr (HsArrForm (L _ (HsConLikeOut c)) (Just _) [arg1, arg2])
+ = sep [pprCmdArg (unLoc arg1), hsep [pprInfixOcc (conLikeName c), pprCmdArg (unLoc arg2)]]
+ppr_expr (HsArrForm op _ args)
+ = hang (text "(|" <+> ppr_lexpr op)
+ 4 (sep (map (pprCmdArg.unLoc) args) <+> text "|)")
+ppr_expr (HsRecFld f) = ppr f
+
+-- We must tiresomely make the "id" parameter to the LHsWcType existential
+-- because it's different in the HsAppType case and the HsAppTypeOut case
+-- | Located Haskell Wildcard Type Expression
+data LHsWcTypeX = forall id. (OutputableBndrId id) => LHsWcTypeX (LHsWcType id)
+
+ppr_apps :: (OutputableBndrId id) => HsExpr id
+ -> [Either (LHsExpr id) LHsWcTypeX]
+ -> SDoc
+ppr_apps (HsApp (L _ fun) arg) args
+ = ppr_apps fun (Left arg : args)
+ppr_apps (HsAppType (L _ fun) arg) args
+ = ppr_apps fun (Right (LHsWcTypeX arg) : args)
+ppr_apps (HsAppTypeOut (L _ fun) arg) args
+ = ppr_apps fun (Right (LHsWcTypeX arg) : args)
+ppr_apps fun args = hang (ppr_expr fun) 2 (sep (map pp args))
+ where
+ pp (Left arg) = ppr arg
+ pp (Right (LHsWcTypeX (HsWC { hswc_body = L _ arg })))
+ = char '@' <> pprParendHsType arg
+
+pprExternalSrcLoc :: (StringLiteral,(Int,Int),(Int,Int)) -> SDoc
+pprExternalSrcLoc (StringLiteral _ src,(n1,n2),(n3,n4))
+ = ppr (src,(n1,n2),(n3,n4))
+
+{-
+HsSyn records exactly where the user put parens, with HsPar.
+So generally speaking we print without adding any parens.
+However, some code is internally generated, and in some places
+parens are absolutely required; so for these places we use
+pprParendLExpr (but don't print double parens of course).
+
+For operator applications we don't add parens, because the operator
+fixities should do the job, except in debug mode (-dppr-debug) so we
+can see the structure of the parse tree.
+-}
+
+pprDebugParendExpr :: (OutputableBndrId id) => LHsExpr id -> SDoc
+pprDebugParendExpr expr
+ = getPprStyle (\sty ->
+ if debugStyle sty then pprParendLExpr expr
+ else pprLExpr expr)
+
+pprParendLExpr :: (OutputableBndrId id) => LHsExpr id -> SDoc
+pprParendLExpr (L _ e) = pprParendExpr e
+
+pprParendExpr :: (OutputableBndrId id) => HsExpr id -> SDoc
+pprParendExpr expr
+ | hsExprNeedsParens expr = parens (pprExpr expr)
+ | otherwise = pprExpr expr
+ -- Using pprLExpr makes sure that we go 'deeper'
+ -- I think that is usually (always?) right
+
+hsExprNeedsParens :: HsExpr id -> Bool
+-- True of expressions for which '(e)' and 'e'
+-- mean the same thing
+hsExprNeedsParens (ArithSeq {}) = False
+hsExprNeedsParens (PArrSeq {}) = False
+hsExprNeedsParens (HsLit {}) = False
+hsExprNeedsParens (HsOverLit {}) = False
+hsExprNeedsParens (HsVar {}) = False
+hsExprNeedsParens (HsUnboundVar {}) = False
+hsExprNeedsParens (HsConLikeOut {}) = False
+hsExprNeedsParens (HsIPVar {}) = False
+hsExprNeedsParens (HsOverLabel {}) = False
+hsExprNeedsParens (ExplicitTuple {}) = False
+hsExprNeedsParens (ExplicitList {}) = False
+hsExprNeedsParens (ExplicitPArr {}) = False
+hsExprNeedsParens (HsPar {}) = False
+hsExprNeedsParens (HsBracket {}) = False
+hsExprNeedsParens (HsRnBracketOut {}) = False
+hsExprNeedsParens (HsTcBracketOut {}) = False
+hsExprNeedsParens (HsDo sc _ _)
+ | isListCompExpr sc = False
+hsExprNeedsParens (HsRecFld{}) = False
+hsExprNeedsParens (RecordCon{}) = False
+hsExprNeedsParens (HsSpliceE{}) = False
+hsExprNeedsParens (RecordUpd{}) = False
+hsExprNeedsParens (HsWrap _ e) = hsExprNeedsParens e
+hsExprNeedsParens _ = True
+
+
+isAtomicHsExpr :: HsExpr id -> Bool
+-- True of a single token
+isAtomicHsExpr (HsVar {}) = True
+isAtomicHsExpr (HsConLikeOut {}) = True
+isAtomicHsExpr (HsLit {}) = True
+isAtomicHsExpr (HsOverLit {}) = True
+isAtomicHsExpr (HsIPVar {}) = True
+isAtomicHsExpr (HsOverLabel {}) = True
+isAtomicHsExpr (HsUnboundVar {}) = True
+isAtomicHsExpr (HsWrap _ e) = isAtomicHsExpr e
+isAtomicHsExpr (HsPar e) = isAtomicHsExpr (unLoc e)
+isAtomicHsExpr (HsRecFld{}) = True
+isAtomicHsExpr _ = False
+
+{-
+************************************************************************
+* *
+\subsection{Commands (in arrow abstractions)}
+* *
+************************************************************************
+
+We re-use HsExpr to represent these.
+-}
+
+-- | Located Haskell Command (for arrow syntax)
+type LHsCmd id = Located (HsCmd id)
+
+-- | Haskell Command (e.g. a "statement" in an Arrow proc block)
+data HsCmd id
+ -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.Annlarrowtail',
+ -- 'ApiAnnotation.Annrarrowtail','ApiAnnotation.AnnLarrowtail',
+ -- 'ApiAnnotation.AnnRarrowtail'
+
+ -- For details on above see note [Api annotations] in ApiAnnotation
+ = HsCmdArrApp -- Arrow tail, or arrow application (f -< arg)
+ (LHsExpr id) -- arrow expression, f
+ (LHsExpr id) -- input expression, arg
+ (PostTc id Type) -- type of the arrow expressions f,
+ -- of the form a t t', where arg :: t
+ HsArrAppType -- higher-order (-<<) or first-order (-<)
+ Bool -- True => right-to-left (f -< arg)
+ -- False => left-to-right (arg >- f)
+
+ -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpenB' @'(|'@,
+ -- 'ApiAnnotation.AnnCloseB' @'|)'@
+
+ -- For details on above see note [Api annotations] in ApiAnnotation
+ | HsCmdArrForm -- Command formation, (| e cmd1 .. cmdn |)
+ (LHsExpr id) -- The operator.
+ -- After type-checking, a type abstraction to be
+ -- applied to the type of the local environment tuple
+ LexicalFixity -- Whether the operator appeared prefix or infix when
+ -- parsed.
+ (Maybe Fixity) -- fixity (filled in by the renamer), for forms that
+ -- were converted from OpApp's by the renamer
+ [LHsCmdTop id] -- argument commands
+
+ | HsCmdApp (LHsCmd id)
+ (LHsExpr id)
+
+ | HsCmdLam (MatchGroup id (LHsCmd id)) -- kappa
+ -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLam',
+ -- 'ApiAnnotation.AnnRarrow',
+
+ -- For details on above see note [Api annotations] in ApiAnnotation
+
+ | HsCmdPar (LHsCmd id) -- parenthesised command
+ -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@,
+ -- 'ApiAnnotation.AnnClose' @')'@
+
+ -- For details on above see note [Api annotations] in ApiAnnotation
+
+ | HsCmdCase (LHsExpr id)
+ (MatchGroup id (LHsCmd id)) -- bodies are HsCmd's
+ -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnCase',
+ -- 'ApiAnnotation.AnnOf','ApiAnnotation.AnnOpen' @'{'@,
+ -- 'ApiAnnotation.AnnClose' @'}'@
+
+ -- For details on above see note [Api annotations] in ApiAnnotation
+
+ | HsCmdIf (Maybe (SyntaxExpr id)) -- cond function
+ (LHsExpr id) -- predicate
+ (LHsCmd id) -- then part
+ (LHsCmd id) -- else part
+ -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnIf',
+ -- 'ApiAnnotation.AnnSemi',
+ -- 'ApiAnnotation.AnnThen','ApiAnnotation.AnnSemi',
+ -- 'ApiAnnotation.AnnElse',
+
+ -- For details on above see note [Api annotations] in ApiAnnotation
+
+ | HsCmdLet (LHsLocalBinds id) -- let(rec)
+ (LHsCmd id)
+ -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLet',
+ -- 'ApiAnnotation.AnnOpen' @'{'@,
+ -- 'ApiAnnotation.AnnClose' @'}'@,'ApiAnnotation.AnnIn'
+
+ -- For details on above see note [Api annotations] in ApiAnnotation
+
+ | HsCmdDo (Located [CmdLStmt id])
+ (PostTc id Type) -- Type of the whole expression
+ -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDo',
+ -- 'ApiAnnotation.AnnOpen', 'ApiAnnotation.AnnSemi',
+ -- 'ApiAnnotation.AnnVbar',
+ -- 'ApiAnnotation.AnnClose'
+
+ -- For details on above see note [Api annotations] in ApiAnnotation
+
+ | HsCmdWrap HsWrapper
+ (HsCmd id) -- If cmd :: arg1 --> res
+ -- wrap :: arg1 "->" arg2
+ -- Then (HsCmdWrap wrap cmd) :: arg2 --> res
+deriving instance (DataId id) => Data (HsCmd id)
+
+-- | Haskell Array Application Type
+data HsArrAppType = HsHigherOrderApp | HsFirstOrderApp
+ deriving Data
+
+
+{- | Top-level command, introducing a new arrow.
+This may occur inside a proc (where the stack is empty) or as an
+argument of a command-forming operator.
+-}
+
+-- | Located Haskell Top-level Command
+type LHsCmdTop id = Located (HsCmdTop id)
+
+-- | Haskell Top-level Command
+data HsCmdTop id
+ = HsCmdTop (LHsCmd id)
+ (PostTc id Type) -- Nested tuple of inputs on the command's stack
+ (PostTc id Type) -- return type of the command
+ (CmdSyntaxTable id) -- See Note [CmdSyntaxTable]
+deriving instance (DataId id) => Data (HsCmdTop id)
+
+instance (OutputableBndrId id) => Outputable (HsCmd id) where
+ ppr cmd = pprCmd cmd
+
+-----------------------
+-- pprCmd and pprLCmd call pprDeeper;
+-- the underscore versions do not
+pprLCmd :: (OutputableBndrId id) => LHsCmd id -> SDoc
+pprLCmd (L _ c) = pprCmd c
+
+pprCmd :: (OutputableBndrId id) => HsCmd id -> SDoc
+pprCmd c | isQuietHsCmd c = ppr_cmd c
+ | otherwise = pprDeeper (ppr_cmd c)
+
+isQuietHsCmd :: HsCmd id -> Bool
+-- Parentheses do display something, but it gives little info and
+-- if we go deeper when we go inside them then we get ugly things
+-- like (...)
+isQuietHsCmd (HsCmdPar _) = True
+-- applications don't display anything themselves
+isQuietHsCmd (HsCmdApp _ _) = True
+isQuietHsCmd _ = False
+
+-----------------------
+ppr_lcmd :: (OutputableBndrId id) => LHsCmd id -> SDoc
+ppr_lcmd c = ppr_cmd (unLoc c)
+
+ppr_cmd :: forall id. (OutputableBndrId id) => HsCmd id -> SDoc
+ppr_cmd (HsCmdPar c) = parens (ppr_lcmd c)
+
+ppr_cmd (HsCmdApp c e)
+ = let (fun, args) = collect_args c [e] in
+ hang (ppr_lcmd fun) 2 (sep (map ppr args))
+ where
+ collect_args (L _ (HsCmdApp fun arg)) args = collect_args fun (arg:args)
+ collect_args fun args = (fun, args)
+
+ppr_cmd (HsCmdLam matches)
+ = pprMatches matches
+
+ppr_cmd (HsCmdCase expr matches)
+ = sep [ sep [text "case", nest 4 (ppr expr), ptext (sLit "of")],
+ nest 2 (pprMatches matches) ]
+
+ppr_cmd (HsCmdIf _ e ct ce)
+ = sep [hsep [text "if", nest 2 (ppr e), ptext (sLit "then")],
+ nest 4 (ppr ct),
+ text "else",
+ nest 4 (ppr ce)]
+
+-- special case: let ... in let ...
+ppr_cmd (HsCmdLet (L _ binds) cmd@(L _ (HsCmdLet _ _)))
+ = sep [hang (text "let") 2 (hsep [pprBinds binds, ptext (sLit "in")]),
+ ppr_lcmd cmd]
+
+ppr_cmd (HsCmdLet (L _ binds) cmd)
+ = sep [hang (text "let") 2 (pprBinds binds),
+ hang (text "in") 2 (ppr cmd)]
+
+ppr_cmd (HsCmdDo (L _ stmts) _) = pprDo ArrowExpr stmts
+
+ppr_cmd (HsCmdWrap w cmd)
+ = pprHsWrapper w (\_ -> parens (ppr_cmd cmd))
+ppr_cmd (HsCmdArrApp arrow arg _ HsFirstOrderApp True)
+ = hsep [ppr_lexpr arrow, larrowt, ppr_lexpr arg]
+ppr_cmd (HsCmdArrApp arrow arg _ HsFirstOrderApp False)
+ = hsep [ppr_lexpr arg, arrowt, ppr_lexpr arrow]
+ppr_cmd (HsCmdArrApp arrow arg _ HsHigherOrderApp True)
+ = hsep [ppr_lexpr arrow, larrowtt, ppr_lexpr arg]
+ppr_cmd (HsCmdArrApp arrow arg _ HsHigherOrderApp False)
+ = hsep [ppr_lexpr arg, arrowtt, ppr_lexpr arrow]
+
+ppr_cmd (HsCmdArrForm (L _ (HsVar (L _ v))) _ (Just _) [arg1, arg2])
+ = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc v
+ , pprCmdArg (unLoc arg2)])
+ppr_cmd (HsCmdArrForm (L _ (HsVar (L _ v))) Infix _ [arg1, arg2])
+ = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc v
+ , pprCmdArg (unLoc arg2)])
+ppr_cmd (HsCmdArrForm (L _ (HsConLikeOut c)) _ (Just _) [arg1, arg2])
+ = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc (conLikeName c)
+ , pprCmdArg (unLoc arg2)])
+ppr_cmd (HsCmdArrForm (L _ (HsConLikeOut c)) Infix _ [arg1, arg2])
+ = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc (conLikeName c)
+ , pprCmdArg (unLoc arg2)])
+ppr_cmd (HsCmdArrForm op _ _ args)
+ = hang (text "(|" <> ppr_lexpr op)
+ 4 (sep (map (pprCmdArg.unLoc) args) <> text "|)")
+
+pprCmdArg :: (OutputableBndrId id) => HsCmdTop id -> SDoc
+pprCmdArg (HsCmdTop cmd _ _ _)
+ = ppr_lcmd cmd
+
+instance (OutputableBndrId id) => Outputable (HsCmdTop id) where
+ ppr = pprCmdArg
+
+{-
+************************************************************************
+* *
+\subsection{Record binds}
+* *
+************************************************************************
+-}
+
+-- | Haskell Record Bindings
+type HsRecordBinds id = HsRecFields id (LHsExpr id)
+
+{-
+************************************************************************
+* *
+\subsection{@Match@, @GRHSs@, and @GRHS@ datatypes}
+* *
+************************************************************************
+
+@Match@es are sets of pattern bindings and right hand sides for
+functions, patterns or case branches. For example, if a function @g@
+is defined as:
+\begin{verbatim}
+g (x,y) = y
+g ((x:ys),y) = y+1,
+\end{verbatim}
+then \tr{g} has two @Match@es: @(x,y) = y@ and @((x:ys),y) = y+1@.
+
+It is always the case that each element of an @[Match]@ list has the
+same number of @pats@s inside it. This corresponds to saying that
+a function defined by pattern matching must have the same number of
+patterns in each equation.
+-}
+
+data MatchGroup id body
+ = MG { mg_alts :: Located [LMatch id body] -- The alternatives
+ , mg_arg_tys :: [PostTc id Type] -- Types of the arguments, t1..tn
+ , mg_res_ty :: PostTc id Type -- Type of the result, tr
+ , mg_origin :: Origin }
+ -- The type is the type of the entire group
+ -- t1 -> ... -> tn -> tr
+ -- where there are n patterns
+deriving instance (Data body,DataId id) => Data (MatchGroup id body)
+
+-- | Located Match
+type LMatch id body = Located (Match id body)
+-- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi' when in a
+-- list
+
+-- For details on above see note [Api annotations] in ApiAnnotation
+data Match id body
+ = Match {
+ m_ctxt :: HsMatchContext (NameOrRdrName id),
+ -- See note [m_ctxt in Match]
+ m_pats :: [LPat id], -- The patterns
+ m_type :: (Maybe (LHsType id)),
+ -- A type signature for the result of the match
+ -- Nothing after typechecking
+ -- NB: No longer supported
+ m_grhss :: (GRHSs id body)
+ }
+deriving instance (Data body,DataId id) => Data (Match id body)
+
+instance (OutputableBndrId idR, Outputable body)
+ => Outputable (Match idR body) where
+ ppr = pprMatch
+
+{-
+Note [m_ctxt in Match]
+~~~~~~~~~~~~~~~~~~~~~~
+
+A Match can occur in a number of contexts, such as a FunBind, HsCase, HsLam and
+so on.
+
+In order to simplify tooling processing and pretty print output, the provenance
+is captured in an HsMatchContext.
+
+This is particularly important for the API Annotations for a multi-equation
+FunBind.
+
+The parser initially creates a FunBind with a single Match in it for
+every function definition it sees.
+
+These are then grouped together by getMonoBind into a single FunBind,
+where all the Matches are combined.
+
+In the process, all the original FunBind fun_id's bar one are
+discarded, including the locations.
+
+This causes a problem for source to source conversions via API
+Annotations, so the original fun_ids and infix flags are preserved in
+the Match, when it originates from a FunBind.
+
+Example infix function definition requiring individual API Annotations
+
+ (&&& ) [] [] = []
+ xs &&& [] = xs
+ ( &&& ) [] ys = ys
+
+
+
+-}
+
+
+isInfixMatch :: Match id body -> Bool
+isInfixMatch match = case m_ctxt match of
+ FunRhs {mc_fixity = Infix} -> True
+ _ -> False
+
+isEmptyMatchGroup :: MatchGroup id body -> Bool
+isEmptyMatchGroup (MG { mg_alts = ms }) = null $ unLoc ms
+
+-- | Is there only one RHS in this list of matches?
+isSingletonMatchGroup :: [LMatch id body] -> Bool
+isSingletonMatchGroup matches
+ | [L _ match] <- matches
+ , Match { m_grhss = GRHSs { grhssGRHSs = [_] } } <- match
+ = True
+ | otherwise
+ = False
+
+matchGroupArity :: MatchGroup id body -> Arity
+-- Precondition: MatchGroup is non-empty
+-- This is called before type checking, when mg_arg_tys is not set
+matchGroupArity (MG { mg_alts = alts })
+ | L _ (alt1:_) <- alts = length (hsLMatchPats alt1)
+ | otherwise = panic "matchGroupArity"
+
+hsLMatchPats :: LMatch id body -> [LPat id]
+hsLMatchPats (L _ (Match _ pats _ _)) = pats
+
+-- | Guarded Right-Hand Sides
+--
+-- GRHSs are used both for pattern bindings and for Matches
+--
+-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnVbar',
+-- 'ApiAnnotation.AnnEqual','ApiAnnotation.AnnWhere',
+-- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose'
+-- 'ApiAnnotation.AnnRarrow','ApiAnnotation.AnnSemi'
+
+-- For details on above see note [Api annotations] in ApiAnnotation
+data GRHSs id body
+ = GRHSs {
+ grhssGRHSs :: [LGRHS id body], -- ^ Guarded RHSs
+ grhssLocalBinds :: LHsLocalBinds id -- ^ The where clause
+ }
+deriving instance (Data body,DataId id) => Data (GRHSs id body)
+
+-- | Located Guarded Right-Hand Side
+type LGRHS id body = Located (GRHS id body)
+
+-- | Guarded Right Hand Side.
+data GRHS id body = GRHS [GuardLStmt id] -- Guards
+ body -- Right hand side
+deriving instance (Data body,DataId id) => Data (GRHS id body)
+
+-- We know the list must have at least one @Match@ in it.
+
+pprMatches :: (OutputableBndrId idR, Outputable body)
+ => MatchGroup idR body -> SDoc
+pprMatches MG { mg_alts = matches }
+ = vcat (map pprMatch (map unLoc (unLoc matches)))
+ -- Don't print the type; it's only a place-holder before typechecking
+
+-- Exported to HsBinds, which can't see the defn of HsMatchContext
+pprFunBind :: (OutputableBndrId idR, Outputable body)
+ => MatchGroup idR body -> SDoc
+pprFunBind matches = pprMatches matches
+
+-- Exported to HsBinds, which can't see the defn of HsMatchContext
+pprPatBind :: forall bndr id body. (OutputableBndrId bndr,
+ OutputableBndrId id,
+ Outputable body)
+ => LPat bndr -> GRHSs id body -> SDoc
+pprPatBind pat (grhss)
+ = sep [ppr pat, nest 2 (pprGRHSs (PatBindRhs :: HsMatchContext id) grhss)]
+
+pprMatch :: (OutputableBndrId idR, Outputable body) => Match idR body -> SDoc
+pprMatch match
+ = sep [ sep (herald : map (nest 2 . pprParendLPat) other_pats)
+ , nest 2 ppr_maybe_ty
+ , nest 2 (pprGRHSs ctxt (m_grhss match)) ]
+ where
+ ctxt = m_ctxt match
+ (herald, other_pats)
+ = case ctxt of
+ FunRhs {mc_fun=L _ fun, mc_fixity=fixity, mc_strictness=strictness}
+ | strictness == SrcStrict -> ASSERT(null $ m_pats match)
+ (char '!'<>pprPrefixOcc fun, m_pats match)
+ -- a strict variable binding
+ | fixity == Prefix -> (pprPrefixOcc fun, m_pats match)
+ -- f x y z = e
+ -- Not pprBndr; the AbsBinds will
+ -- have printed the signature
+
+ | null pats2 -> (pp_infix, [])
+ -- x &&& y = e
+
+ | otherwise -> (parens pp_infix, pats2)
+ -- (x &&& y) z = e
+ where
+ pp_infix = pprParendLPat pat1 <+> pprInfixOcc fun <+> pprParendLPat pat2
+
+ LambdaExpr -> (char '\\', m_pats match)
+
+ _ -> ASSERT2( null pats1, ppr ctxt $$ ppr pat1 $$ ppr pats1 )
+ (ppr pat1, []) -- No parens around the single pat
+
+ (pat1:pats1) = m_pats match
+ (pat2:pats2) = pats1
+ ppr_maybe_ty = case m_type match of
+ Just ty -> dcolon <+> ppr ty
+ Nothing -> empty
+
+
+pprGRHSs :: (OutputableBndrId idR, Outputable body)
+ => HsMatchContext idL -> GRHSs idR body -> SDoc
+pprGRHSs ctxt (GRHSs grhss (L _ binds))
+ = vcat (map (pprGRHS ctxt . unLoc) grhss)
+ -- Print the "where" even if the contents of the binds is empty. Only
+ -- EmptyLocalBinds means no "where" keyword
+ $$ ppUnless (eqEmptyLocalBinds binds)
+ (text "where" $$ nest 4 (pprBinds binds))
+
+pprGRHS :: (OutputableBndrId idR, Outputable body)
+ => HsMatchContext idL -> GRHS idR body -> SDoc
+pprGRHS ctxt (GRHS [] body)
+ = pp_rhs ctxt body
+
+pprGRHS ctxt (GRHS guards body)
+ = sep [vbar <+> interpp'SP guards, pp_rhs ctxt body]
+
+pp_rhs :: Outputable body => HsMatchContext idL -> body -> SDoc
+pp_rhs ctxt rhs = matchSeparator ctxt <+> pprDeeper (ppr rhs)
+
+{-
+************************************************************************
+* *
+\subsection{Do stmts and list comprehensions}
+* *
+************************************************************************
+-}
+
+-- | Located @do@ block Statement
+type LStmt id body = Located (StmtLR id id body)
+
+-- | Located Statement with separate Left and Right id's
+type LStmtLR idL idR body = Located (StmtLR idL idR body)
+
+-- | @do@ block Statement
+type Stmt id body = StmtLR id id body
+
+-- | Command Located Statement
+type CmdLStmt id = LStmt id (LHsCmd id)
+
+-- | Command Statement
+type CmdStmt id = Stmt id (LHsCmd id)
+
+-- | Expression Located Statement
+type ExprLStmt id = LStmt id (LHsExpr id)
+
+-- | Expression Statement
+type ExprStmt id = Stmt id (LHsExpr id)
+
+-- | Guard Located Statement
+type GuardLStmt id = LStmt id (LHsExpr id)
+
+-- | Guard Statement
+type GuardStmt id = Stmt id (LHsExpr id)
+
+-- | Ghci Located Statemnt
+type GhciLStmt id = LStmt id (LHsExpr id)
+
+-- | Ghci Statement
+type GhciStmt id = Stmt id (LHsExpr id)
+
+-- The SyntaxExprs in here are used *only* for do-notation and monad
+-- comprehensions, which have rebindable syntax. Otherwise they are unused.
+-- | API Annotations when in qualifier lists or guards
+-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnVbar',
+-- 'ApiAnnotation.AnnComma','ApiAnnotation.AnnThen',
+-- 'ApiAnnotation.AnnBy','ApiAnnotation.AnnBy',
+-- 'ApiAnnotation.AnnGroup','ApiAnnotation.AnnUsing'
+
+-- For details on above see note [Api annotations] in ApiAnnotation
+data StmtLR idL idR body -- body should always be (LHs**** idR)
+ = LastStmt -- Always the last Stmt in ListComp, MonadComp, PArrComp,
+ -- and (after the renamer) DoExpr, MDoExpr
+ -- Not used for GhciStmtCtxt, PatGuard, which scope over other stuff
+ body
+ Bool -- True <=> return was stripped by ApplicativeDo
+ (SyntaxExpr idR) -- The return operator, used only for
+ -- MonadComp For ListComp, PArrComp, we
+ -- use the baked-in 'return' For DoExpr,
+ -- MDoExpr, we don't apply a 'return' at
+ -- all See Note [Monad Comprehensions] |
+ -- - 'ApiAnnotation.AnnKeywordId' :
+ -- 'ApiAnnotation.AnnLarrow'
+
+ -- For details on above see note [Api annotations] in ApiAnnotation
+ | BindStmt (LPat idL)
+ body
+ (SyntaxExpr idR) -- The (>>=) operator; see Note [The type of bind in Stmts]
+ (SyntaxExpr idR) -- The fail operator
+ -- The fail operator is noSyntaxExpr
+ -- if the pattern match can't fail
+
+ (PostTc idR Type) -- result type of the function passed to bind;
+ -- that is, S in (>>=) :: Q -> (R -> S) -> T
+
+ -- | 'ApplicativeStmt' represents an applicative expression built with
+ -- <$> and <*>. It is generated by the renamer, and is desugared into the
+ -- appropriate applicative expression by the desugarer, but it is intended
+ -- to be invisible in error messages.
+ --
+ -- For full details, see Note [ApplicativeDo] in RnExpr
+ --
+ | ApplicativeStmt
+ [ ( SyntaxExpr idR
+ , ApplicativeArg idL idR) ]
+ -- [(<$>, e1), (<*>, e2), ..., (<*>, en)]
+ (Maybe (SyntaxExpr idR)) -- 'join', if necessary
+ (PostTc idR Type) -- Type of the body
+
+ | BodyStmt body -- See Note [BodyStmt]
+ (SyntaxExpr idR) -- The (>>) operator
+ (SyntaxExpr idR) -- The `guard` operator; used only in MonadComp
+ -- See notes [Monad Comprehensions]
+ (PostTc idR Type) -- Element type of the RHS (used for arrows)
+
+ -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLet'
+ -- 'ApiAnnotation.AnnOpen' @'{'@,'ApiAnnotation.AnnClose' @'}'@,
+
+ -- For details on above see note [Api annotations] in ApiAnnotation
+ | LetStmt (LHsLocalBindsLR idL idR)
+
+ -- ParStmts only occur in a list/monad comprehension
+ | ParStmt [ParStmtBlock idL idR]
+ (HsExpr idR) -- Polymorphic `mzip` for monad comprehensions
+ (SyntaxExpr idR) -- The `>>=` operator
+ -- See notes [Monad Comprehensions]
+ (PostTc idR Type) -- S in (>>=) :: Q -> (R -> S) -> T
+ -- After renaming, the ids are the binders
+ -- bound by the stmts and used after themp
+
+ | TransStmt {
+ trS_form :: TransForm,
+ trS_stmts :: [ExprLStmt idL], -- Stmts to the *left* of the 'group'
+ -- which generates the tuples to be grouped
+
+ trS_bndrs :: [(idR, idR)], -- See Note [TransStmt binder map]
+
+ trS_using :: LHsExpr idR,
+ trS_by :: Maybe (LHsExpr idR), -- "by e" (optional)
+ -- Invariant: if trS_form = GroupBy, then grp_by = Just e
+
+ trS_ret :: SyntaxExpr idR, -- The monomorphic 'return' function for
+ -- the inner monad comprehensions
+ trS_bind :: SyntaxExpr idR, -- The '(>>=)' operator
+ trS_bind_arg_ty :: PostTc idR Type, -- R in (>>=) :: Q -> (R -> S) -> T
+ trS_fmap :: HsExpr idR -- The polymorphic 'fmap' function for desugaring
+ -- Only for 'group' forms
+ -- Just a simple HsExpr, because it's
+ -- too polymorphic for tcSyntaxOp
+ } -- See Note [Monad Comprehensions]
+
+ -- Recursive statement (see Note [How RecStmt works] below)
+ -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRec'
+
+ -- For details on above see note [Api annotations] in ApiAnnotation
+ | RecStmt
+ { recS_stmts :: [LStmtLR idL idR body]
+
+ -- The next two fields are only valid after renaming
+ , recS_later_ids :: [idR] -- The ids are a subset of the variables bound by the
+ -- stmts that are used in stmts that follow the RecStmt
+
+ , recS_rec_ids :: [idR] -- Ditto, but these variables are the "recursive" ones,
+ -- that are used before they are bound in the stmts of
+ -- the RecStmt.
+ -- An Id can be in both groups
+ -- Both sets of Ids are (now) treated monomorphically
+ -- See Note [How RecStmt works] for why they are separate
+
+ -- Rebindable syntax
+ , recS_bind_fn :: SyntaxExpr idR -- The bind function
+ , recS_ret_fn :: SyntaxExpr idR -- The return function
+ , recS_mfix_fn :: SyntaxExpr idR -- The mfix function
+ , recS_bind_ty :: PostTc idR Type -- S in (>>=) :: Q -> (R -> S) -> T
+
+ -- These fields are only valid after typechecking
+ , recS_later_rets :: [PostTcExpr] -- (only used in the arrow version)
+ , recS_rec_rets :: [PostTcExpr] -- These expressions correspond 1-to-1
+ -- with recS_later_ids and recS_rec_ids,
+ -- and are the expressions that should be
+ -- returned by the recursion.
+ -- They may not quite be the Ids themselves,
+ -- because the Id may be *polymorphic*, but
+ -- the returned thing has to be *monomorphic*,
+ -- so they may be type applications
+
+ , recS_ret_ty :: PostTc idR Type -- The type of
+ -- do { stmts; return (a,b,c) }
+ -- With rebindable syntax the type might not
+ -- be quite as simple as (m (tya, tyb, tyc)).
+ }
+deriving instance (Data body, DataId idL, DataId idR)
+ => Data (StmtLR idL idR body)
+
+data TransForm -- The 'f' below is the 'using' function, 'e' is the by function
+ = ThenForm -- then f or then f by e (depending on trS_by)
+ | GroupForm -- then group using f or then group by e using f (depending on trS_by)
+ deriving Data
+
+-- | Parenthesised Statement Block
+data ParStmtBlock idL idR
+ = ParStmtBlock
+ [ExprLStmt idL]
+ [idR] -- The variables to be returned
+ (SyntaxExpr idR) -- The return operator
+deriving instance (DataId idL, DataId idR) => Data (ParStmtBlock idL idR)
+
+-- | Applicative Argument
+data ApplicativeArg idL idR
+ = ApplicativeArgOne -- pat <- expr (pat must be irrefutable)
+ (LPat idL)
+ (LHsExpr idL)
+ | ApplicativeArgMany -- do { stmts; return vars }
+ [ExprLStmt idL] -- stmts
+ (HsExpr idL) -- return (v1,..,vn), or just (v1,..,vn)
+ (LPat idL) -- (v1,...,vn)
+deriving instance (DataId idL, DataId idR) => Data (ApplicativeArg idL idR)
+
+{-
+Note [The type of bind in Stmts]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Some Stmts, notably BindStmt, keep the (>>=) bind operator.
+We do NOT assume that it has type
+ (>>=) :: m a -> (a -> m b) -> m b
+In some cases (see Trac #303, #1537) it might have a more
+exotic type, such as
+ (>>=) :: m i j a -> (a -> m j k b) -> m i k b
+So we must be careful not to make assumptions about the type.
+In particular, the monad may not be uniform throughout.
+
+Note [TransStmt binder map]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The [(idR,idR)] in a TransStmt behaves as follows:
+
+ * Before renaming: []
+
+ * After renaming:
+ [ (x27,x27), ..., (z35,z35) ]
+ These are the variables
+ bound by the stmts to the left of the 'group'
+ and used either in the 'by' clause,
+ or in the stmts following the 'group'
+ Each item is a pair of identical variables.
+
+ * After typechecking:
+ [ (x27:Int, x27:[Int]), ..., (z35:Bool, z35:[Bool]) ]
+ Each pair has the same unique, but different *types*.
+
+Note [BodyStmt]
+~~~~~~~~~~~~~~~
+BodyStmts are a bit tricky, because what they mean
+depends on the context. Consider the following contexts:
+
+ A do expression of type (m res_ty)
+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ * BodyStmt E any_ty: do { ....; E; ... }
+ E :: m any_ty
+ Translation: E >> ...
+
+ A list comprehensions of type [elt_ty]
+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ * BodyStmt E Bool: [ .. | .... E ]
+ [ .. | ..., E, ... ]
+ [ .. | .... | ..., E | ... ]
+ E :: Bool
+ Translation: if E then fail else ...
+
+ A guard list, guarding a RHS of type rhs_ty
+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ * BodyStmt E BooParStmtBlockl: f x | ..., E, ... = ...rhs...
+ E :: Bool
+ Translation: if E then fail else ...
+
+ A monad comprehension of type (m res_ty)
+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ * BodyStmt E Bool: [ .. | .... E ]
+ E :: Bool
+ Translation: guard E >> ...
+
+Array comprehensions are handled like list comprehensions.
+
+Note [How RecStmt works]
+~~~~~~~~~~~~~~~~~~~~~~~~
+Example:
+ HsDo [ BindStmt x ex
+
+ , RecStmt { recS_rec_ids = [a, c]
+ , recS_stmts = [ BindStmt b (return (a,c))
+ , LetStmt a = ...b...
+ , BindStmt c ec ]
+ , recS_later_ids = [a, b]
+
+ , return (a b) ]
+
+Here, the RecStmt binds a,b,c; but
+ - Only a,b are used in the stmts *following* the RecStmt,
+ - Only a,c are used in the stmts *inside* the RecStmt
+ *before* their bindings
+
+Why do we need *both* rec_ids and later_ids? For monads they could be
+combined into a single set of variables, but not for arrows. That
+follows from the types of the respective feedback operators:
+
+ mfix :: MonadFix m => (a -> m a) -> m a
+ loop :: ArrowLoop a => a (b,d) (c,d) -> a b c
+
+* For mfix, the 'a' covers the union of the later_ids and the rec_ids
+* For 'loop', 'c' is the later_ids and 'd' is the rec_ids
+
+Note [Typing a RecStmt]
+~~~~~~~~~~~~~~~~~~~~~~~
+A (RecStmt stmts) types as if you had written
+
+ (v1,..,vn, _, ..., _) <- mfix (\~(_, ..., _, r1, ..., rm) ->
+ do { stmts
+ ; return (v1,..vn, r1, ..., rm) })
+
+where v1..vn are the later_ids
+ r1..rm are the rec_ids
+
+Note [Monad Comprehensions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Monad comprehensions require separate functions like 'return' and
+'>>=' for desugaring. These functions are stored in the statements
+used in monad comprehensions. For example, the 'return' of the 'LastStmt'
+expression is used to lift the body of the monad comprehension:
+
+ [ body | stmts ]
+ =>
+ stmts >>= \bndrs -> return body
+
+In transform and grouping statements ('then ..' and 'then group ..') the
+'return' function is required for nested monad comprehensions, for example:
+
+ [ body | stmts, then f, rest ]
+ =>
+ f [ env | stmts ] >>= \bndrs -> [ body | rest ]
+
+BodyStmts require the 'Control.Monad.guard' function for boolean
+expressions:
+
+ [ body | exp, stmts ]
+ =>
+ guard exp >> [ body | stmts ]
+
+Parallel statements require the 'Control.Monad.Zip.mzip' function:
+
+ [ body | stmts1 | stmts2 | .. ]
+ =>
+ mzip stmts1 (mzip stmts2 (..)) >>= \(bndrs1, (bndrs2, ..)) -> return body
+
+In any other context than 'MonadComp', the fields for most of these
+'SyntaxExpr's stay bottom.
+-}
+
+instance (OutputableBndrId idL) => Outputable (ParStmtBlock idL idR) where
+ ppr (ParStmtBlock stmts _ _) = interpp'SP stmts
+
+instance (OutputableBndrId idL, OutputableBndrId idR, Outputable body)
+ => Outputable (StmtLR idL idR body) where
+ ppr stmt = pprStmt stmt
+
+pprStmt :: forall idL idR body . (OutputableBndrId idL, OutputableBndrId idR,
+ Outputable body)
+ => (StmtLR idL idR body) -> SDoc
+pprStmt (LastStmt expr ret_stripped _)
+ = ifPprDebug (text "[last]") <+>
+ (if ret_stripped then text "return" else empty) <+>
+ ppr expr
+pprStmt (BindStmt pat expr _ _ _) = hsep [ppr pat, larrow, ppr expr]
+pprStmt (LetStmt (L _ binds)) = hsep [text "let", pprBinds binds]
+pprStmt (BodyStmt expr _ _ _) = ppr expr
+pprStmt (ParStmt stmtss _ _ _) = sep (punctuate (text " | ") (map ppr stmtss))
+
+pprStmt (TransStmt { trS_stmts = stmts, trS_by = by, trS_using = using, trS_form = form })
+ = sep $ punctuate comma (map ppr stmts ++ [pprTransStmt by using form])
+
+pprStmt (RecStmt { recS_stmts = segment, recS_rec_ids = rec_ids
+ , recS_later_ids = later_ids })
+ = text "rec" <+>
+ vcat [ ppr_do_stmts segment
+ , ifPprDebug (vcat [ text "rec_ids=" <> ppr rec_ids
+ , text "later_ids=" <> ppr later_ids])]
+
+pprStmt (ApplicativeStmt args mb_join _)
+ = getPprStyle $ \style ->
+ if userStyle style
+ then pp_for_user
+ else pp_debug
+ where
+ -- make all the Applicative stuff invisible in error messages by
+ -- flattening the whole ApplicativeStmt nest back to a sequence
+ -- of statements.
+ pp_for_user = vcat $ concatMap flattenArg args
+
+ -- ppr directly rather than transforming here, because we need to
+ -- inject a "return" which is hard when we're polymorphic in the id
+ -- type.
+ flattenStmt :: ExprLStmt idL -> [SDoc]
+ flattenStmt (L _ (ApplicativeStmt args _ _)) = concatMap flattenArg args
+ flattenStmt stmt = [ppr stmt]
+
+ flattenArg (_, ApplicativeArgOne pat expr) =
+ [ppr (BindStmt pat expr noSyntaxExpr noSyntaxExpr (panic "pprStmt")
+ :: ExprStmt idL)]
+ flattenArg (_, ApplicativeArgMany stmts _ _) =
+ concatMap flattenStmt stmts
+
+ pp_debug =
+ let
+ ap_expr = sep (punctuate (text " |") (map pp_arg args))
+ in
+ if isNothing mb_join
+ then ap_expr
+ else text "join" <+> parens ap_expr
+
+ pp_arg (_, ApplicativeArgOne pat expr) =
+ ppr (BindStmt pat expr noSyntaxExpr noSyntaxExpr (panic "pprStmt")
+ :: ExprStmt idL)
+ pp_arg (_, ApplicativeArgMany stmts return pat) =
+ ppr pat <+>
+ text "<-" <+>
+ ppr (HsDo DoExpr (noLoc
+ (stmts ++ [noLoc (LastStmt (noLoc return) False noSyntaxExpr)]))
+ (error "pprStmt"))
+
+pprTransformStmt :: (OutputableBndrId id)
+ => [id] -> LHsExpr id -> Maybe (LHsExpr id) -> SDoc
+pprTransformStmt bndrs using by
+ = sep [ text "then" <+> ifPprDebug (braces (ppr bndrs))
+ , nest 2 (ppr using)
+ , nest 2 (pprBy by)]
+
+pprTransStmt :: Outputable body => Maybe body -> body -> TransForm -> SDoc
+pprTransStmt by using ThenForm
+ = sep [ text "then", nest 2 (ppr using), nest 2 (pprBy by)]
+pprTransStmt by using GroupForm
+ = sep [ text "then group", nest 2 (pprBy by), nest 2 (ptext (sLit "using") <+> ppr using)]
+
+pprBy :: Outputable body => Maybe body -> SDoc
+pprBy Nothing = empty
+pprBy (Just e) = text "by" <+> ppr e
+
+pprDo :: (OutputableBndrId id, Outputable body)
+ => HsStmtContext any -> [LStmt id body] -> SDoc
+pprDo DoExpr stmts = text "do" <+> ppr_do_stmts stmts
+pprDo GhciStmtCtxt stmts = text "do" <+> ppr_do_stmts stmts
+pprDo ArrowExpr stmts = text "do" <+> ppr_do_stmts stmts
+pprDo MDoExpr stmts = text "mdo" <+> ppr_do_stmts stmts
+pprDo ListComp stmts = brackets $ pprComp stmts
+pprDo PArrComp stmts = paBrackets $ pprComp stmts
+pprDo MonadComp stmts = brackets $ pprComp stmts
+pprDo _ _ = panic "pprDo" -- PatGuard, ParStmtCxt
+
+ppr_do_stmts :: (OutputableBndrId idL, OutputableBndrId idR, Outputable body)
+ => [LStmtLR idL idR body] -> SDoc
+-- Print a bunch of do stmts
+ppr_do_stmts stmts = pprDeeperList vcat (map ppr stmts)
+
+pprComp :: (OutputableBndrId id, Outputable body) => [LStmt id body] -> SDoc
+pprComp quals -- Prints: body | qual1, ..., qualn
+ | Just (initStmts, L _ (LastStmt body _ _)) <- snocView quals
+ = if null initStmts
+ -- If there are no statements in a list comprehension besides the last
+ -- one, we simply treat it like a normal list. This does arise
+ -- occasionally in code that GHC generates, e.g., in implementations of
+ -- 'range' for derived 'Ix' instances for product datatypes with exactly
+ -- one constructor (e.g., see Trac #12583).
+ then ppr body
+ else hang (ppr body <+> vbar) 2 (pprQuals initStmts)
+ | otherwise
+ = pprPanic "pprComp" (pprQuals quals)
+
+pprQuals :: (OutputableBndrId id, Outputable body) => [LStmt id body] -> SDoc
+-- Show list comprehension qualifiers separated by commas
+pprQuals quals = interpp'SP quals
+
+{-
+************************************************************************
+* *
+ Template Haskell quotation brackets
+* *
+************************************************************************
+-}
+
+-- | Haskell Splice
+data HsSplice id
+ = HsTypedSplice -- $$z or $$(f 4)
+ SpliceDecoration -- Whether $$( ) variant found, for pretty printing
+ id -- A unique name to identify this splice point
+ (LHsExpr id) -- See Note [Pending Splices]
+
+ | HsUntypedSplice -- $z or $(f 4)
+ SpliceDecoration -- Whether $( ) variant found, for pretty printing
+ id -- A unique name to identify this splice point
+ (LHsExpr id) -- See Note [Pending Splices]
+
+ | HsQuasiQuote -- See Note [Quasi-quote overview] in TcSplice
+ id -- Splice point
+ id -- Quoter
+ SrcSpan -- The span of the enclosed string
+ FastString -- The enclosed string
+
+ | HsSpliced -- See Note [Delaying modFinalizers in untyped splices] in
+ -- RnSplice.
+ -- This is the result of splicing a splice. It is produced by
+ -- the renamer and consumed by the typechecker. It lives only
+ -- between the two.
+ ThModFinalizers -- TH finalizers produced by the splice.
+ (HsSplicedThing id) -- The result of splicing
+ deriving Typeable
+deriving instance (DataId id) => Data (HsSplice id)
+
+-- | A splice can appear with various decorations wrapped around it. This data
+-- type captures explicitly how it was originally written, for use in the pretty
+-- printer.
+data SpliceDecoration
+ = HasParens -- ^ $( splice ) or $$( splice )
+ | HasDollar -- ^ $splice or $$splice
+ | NoParens -- ^ bare splice
+ deriving (Data, Eq, Show)
+
+instance Outputable SpliceDecoration where
+ ppr x = text $ show x
+
+
+isTypedSplice :: HsSplice id -> Bool
+isTypedSplice (HsTypedSplice {}) = True
+isTypedSplice _ = False -- Quasi-quotes are untyped splices
+
+-- | Finalizers produced by a splice with
+-- 'Language.Haskell.TH.Syntax.addModFinalizer'
+--
+-- See Note [Delaying modFinalizers in untyped splices] in RnSplice. For how
+-- this is used.
+--
+newtype ThModFinalizers = ThModFinalizers [ForeignRef (TH.Q ())]
+
+-- A Data instance which ignores the argument of 'ThModFinalizers'.
+instance Data ThModFinalizers where
+ gunfold _ z _ = z $ ThModFinalizers []
+ toConstr a = mkConstr (dataTypeOf a) "ThModFinalizers" [] Data.Prefix
+ dataTypeOf a = mkDataType "HsExpr.ThModFinalizers" [toConstr a]
+
+-- | Haskell Spliced Thing
+--
+-- Values that can result from running a splice.
+data HsSplicedThing id
+ = HsSplicedExpr (HsExpr id) -- ^ Haskell Spliced Expression
+ | HsSplicedTy (HsType id) -- ^ Haskell Spliced Type
+ | HsSplicedPat (Pat id) -- ^ Haskell Spliced Pattern
+ deriving Typeable
+
+deriving instance (DataId id) => Data (HsSplicedThing id)
+
+-- See Note [Pending Splices]
+type SplicePointName = Name
+
+-- | Pending Renamer Splice
+data PendingRnSplice
+ = PendingRnSplice UntypedSpliceFlavour SplicePointName (LHsExpr Name)
+ deriving Data
+
+data UntypedSpliceFlavour
+ = UntypedExpSplice
+ | UntypedPatSplice
+ | UntypedTypeSplice
+ | UntypedDeclSplice
+ deriving Data
+
+-- | Pending Type-checker Splice
+data PendingTcSplice
+ = PendingTcSplice SplicePointName (LHsExpr Id)
+ deriving Data
+
+
+{-
+Note [Pending Splices]
+~~~~~~~~~~~~~~~~~~~~~~
+When we rename an untyped bracket, we name and lift out all the nested
+splices, so that when the typechecker hits the bracket, it can
+typecheck those nested splices without having to walk over the untyped
+bracket code. So for example
+ [| f $(g x) |]
+looks like
+
+ HsBracket (HsApp (HsVar "f") (HsSpliceE _ (g x)))
+
+which the renamer rewrites to
+
+ HsRnBracketOut (HsApp (HsVar f) (HsSpliceE sn (g x)))
+ [PendingRnSplice UntypedExpSplice sn (g x)]
+
+* The 'sn' is the Name of the splice point, the SplicePointName
+
+* The PendingRnExpSplice gives the splice that splice-point name maps to;
+ and the typechecker can now conveniently find these sub-expressions
+
+* The other copy of the splice, in the second argument of HsSpliceE
+ in the renamed first arg of HsRnBracketOut
+ is used only for pretty printing
+
+There are four varieties of pending splices generated by the renamer,
+distinguished by their UntypedSpliceFlavour
+
+ * Pending expression splices (UntypedExpSplice), e.g.,
+ [|$(f x) + 2|]
+
+ UntypedExpSplice is also used for
+ * quasi-quotes, where the pending expression expands to
+ $(quoter "...blah...")
+ (see RnSplice.makePending, HsQuasiQuote case)
+
+ * cross-stage lifting, where the pending expression expands to
+ $(lift x)
+ (see RnSplice.checkCrossStageLifting)
+
+ * Pending pattern splices (UntypedPatSplice), e.g.,
+ [| \$(f x) -> x |]
+
+ * Pending type splices (UntypedTypeSplice), e.g.,
+ [| f :: $(g x) |]
+
+ * Pending declaration (UntypedDeclSplice), e.g.,
+ [| let $(f x) in ... |]
+
+There is a fifth variety of pending splice, which is generated by the type
+checker:
+
+ * Pending *typed* expression splices, (PendingTcSplice), e.g.,
+ [||1 + $$(f 2)||]
+
+It would be possible to eliminate HsRnBracketOut and use HsBracketOut for the
+output of the renamer. However, when pretty printing the output of the renamer,
+e.g., in a type error message, we *do not* want to print out the pending
+splices. In contrast, when pretty printing the output of the type checker, we
+*do* want to print the pending splices. So splitting them up seems to make
+sense, although I hate to add another constructor to HsExpr.
+-}
+
+instance (OutputableBndrId id) => Outputable (HsSplicedThing id) where
+ ppr (HsSplicedExpr e) = ppr_expr e
+ ppr (HsSplicedTy t) = ppr t
+ ppr (HsSplicedPat p) = ppr p
+
+instance (OutputableBndrId id) => Outputable (HsSplice id) where
+ ppr s = pprSplice s
+
+pprPendingSplice :: (OutputableBndrId id)
+ => SplicePointName -> LHsExpr id -> SDoc
+pprPendingSplice n e = angleBrackets (ppr n <> comma <+> ppr e)
+
+pprSpliceDecl :: (OutputableBndrId id)
+ => HsSplice id -> SpliceExplicitFlag -> SDoc
+pprSpliceDecl e@HsQuasiQuote{} _ = pprSplice e
+pprSpliceDecl e ExplicitSplice = text "$(" <> ppr_splice_decl e <> text ")"
+pprSpliceDecl e ImplicitSplice = ppr_splice_decl e
+
+ppr_splice_decl :: (OutputableBndrId id) => HsSplice id -> SDoc
+ppr_splice_decl (HsUntypedSplice _ n e) = ppr_splice empty n e empty
+ppr_splice_decl e = pprSplice e
+
+pprSplice :: (OutputableBndrId id) => HsSplice id -> SDoc
+pprSplice (HsTypedSplice HasParens n e)
+ = ppr_splice (text "$$(") n e (text ")")
+pprSplice (HsTypedSplice HasDollar n e)
+ = ppr_splice (text "$$") n e empty
+pprSplice (HsTypedSplice NoParens n e)
+ = ppr_splice empty n e empty
+pprSplice (HsUntypedSplice HasParens n e)
+ = ppr_splice (text "$(") n e (text ")")
+pprSplice (HsUntypedSplice HasDollar n e)
+ = ppr_splice (text "$") n e empty
+pprSplice (HsUntypedSplice NoParens n e)
+ = ppr_splice empty n e empty
+pprSplice (HsQuasiQuote n q _ s) = ppr_quasi n q s
+pprSplice (HsSpliced _ thing) = ppr thing
+
+ppr_quasi :: OutputableBndr id => id -> id -> FastString -> SDoc
+ppr_quasi n quoter quote = ifPprDebug (brackets (ppr n)) <>
+ char '[' <> ppr quoter <> vbar <>
+ ppr quote <> text "|]"
+
+ppr_splice :: (OutputableBndrId id)
+ => SDoc -> id -> LHsExpr id -> SDoc -> SDoc
+ppr_splice herald n e trail
+ = herald <> ifPprDebug (brackets (ppr n)) <> ppr e <> trail
+
+-- | Haskell Bracket
+data HsBracket id = ExpBr (LHsExpr id) -- [| expr |]
+ | PatBr (LPat id) -- [p| pat |]
+ | DecBrL [LHsDecl id] -- [d| decls |]; result of parser
+ | DecBrG (HsGroup id) -- [d| decls |]; result of renamer
+ | TypBr (LHsType id) -- [t| type |]
+ | VarBr Bool id -- True: 'x, False: ''T
+ -- (The Bool flag is used only in pprHsBracket)
+ | TExpBr (LHsExpr id) -- [|| expr ||]
+deriving instance (DataId id) => Data (HsBracket id)
+
+isTypedBracket :: HsBracket id -> Bool
+isTypedBracket (TExpBr {}) = True
+isTypedBracket _ = False
+
+instance (OutputableBndrId id) => Outputable (HsBracket id) where
+ ppr = pprHsBracket
+
+
+pprHsBracket :: (OutputableBndrId id) => HsBracket id -> SDoc
+pprHsBracket (ExpBr e) = thBrackets empty (ppr e)
+pprHsBracket (PatBr p) = thBrackets (char 'p') (ppr p)
+pprHsBracket (DecBrG gp) = thBrackets (char 'd') (ppr gp)
+pprHsBracket (DecBrL ds) = thBrackets (char 'd') (vcat (map ppr ds))
+pprHsBracket (TypBr t) = thBrackets (char 't') (ppr t)
+pprHsBracket (VarBr True n)
+ = char '\'' <> pprPrefixOcc n
+pprHsBracket (VarBr False n)
+ = text "''" <> pprPrefixOcc n
+pprHsBracket (TExpBr e) = thTyBrackets (ppr e)
+
+thBrackets :: SDoc -> SDoc -> SDoc
+thBrackets pp_kind pp_body = char '[' <> pp_kind <> vbar <+>
+ pp_body <+> text "|]"
+
+thTyBrackets :: SDoc -> SDoc
+thTyBrackets pp_body = text "[||" <+> pp_body <+> ptext (sLit "||]")
+
+instance Outputable PendingRnSplice where
+ ppr (PendingRnSplice _ n e) = pprPendingSplice n e
+
+instance Outputable PendingTcSplice where
+ ppr (PendingTcSplice n e) = pprPendingSplice n e
+
+{-
+************************************************************************
+* *
+\subsection{Enumerations and list comprehensions}
+* *
+************************************************************************
+-}
+
+-- | Arithmetic Sequence Information
+data ArithSeqInfo id
+ = From (LHsExpr id)
+ | FromThen (LHsExpr id)
+ (LHsExpr id)
+ | FromTo (LHsExpr id)
+ (LHsExpr id)
+ | FromThenTo (LHsExpr id)
+ (LHsExpr id)
+ (LHsExpr id)
+deriving instance (DataId id) => Data (ArithSeqInfo id)
+
+instance (OutputableBndrId id)
+ => Outputable (ArithSeqInfo id) where
+ ppr (From e1) = hcat [ppr e1, pp_dotdot]
+ ppr (FromThen e1 e2) = hcat [ppr e1, comma, space, ppr e2, pp_dotdot]
+ ppr (FromTo e1 e3) = hcat [ppr e1, pp_dotdot, ppr e3]
+ ppr (FromThenTo e1 e2 e3)
+ = hcat [ppr e1, comma, space, ppr e2, pp_dotdot, ppr e3]
+
+pp_dotdot :: SDoc
+pp_dotdot = text " .. "
+
+{-
+************************************************************************
+* *
+\subsection{HsMatchCtxt}
+* *
+************************************************************************
+-}
+
+-- | Haskell Match Context
+--
+-- Context of a pattern match. This is more subtle than it would seem. See Note
+-- [Varieties of pattern matches].
+data HsMatchContext id -- Not an extensible tag
+ = FunRhs { mc_fun :: Located id -- ^ function binder of @f@
+ , mc_fixity :: LexicalFixity -- ^ fixing of @f@
+ , mc_strictness :: SrcStrictness
+ -- ^ was the pattern banged? See
+ -- Note [Varieties of binding pattern matches]
+ }
+ -- ^A pattern matching on an argument of a
+ -- function binding
+ | LambdaExpr -- ^Patterns of a lambda
+ | CaseAlt -- ^Patterns and guards on a case alternative
+ | IfAlt -- ^Guards of a multi-way if alternative
+ | ProcExpr -- ^Patterns of a proc
+ | PatBindRhs -- ^A pattern binding eg [y] <- e = e
+
+ | RecUpd -- ^Record update [used only in DsExpr to
+ -- tell matchWrapper what sort of
+ -- runtime error message to generate]
+
+ | StmtCtxt (HsStmtContext id) -- ^Pattern of a do-stmt, list comprehension,
+ -- pattern guard, etc
+
+ | ThPatSplice -- ^A Template Haskell pattern splice
+ | ThPatQuote -- ^A Template Haskell pattern quotation [p| (a,b) |]
+ | PatSyn -- ^A pattern synonym declaration
+ deriving Functor
+deriving instance (DataIdPost id) => Data (HsMatchContext id)
+
+instance OutputableBndr id => Outputable (HsMatchContext id) where
+ ppr m@(FunRhs{}) = text "FunRhs" <+> ppr (mc_fun m) <+> ppr (mc_fixity m)
+ ppr LambdaExpr = text "LambdaExpr"
+ ppr CaseAlt = text "CaseAlt"
+ ppr IfAlt = text "IfAlt"
+ ppr ProcExpr = text "ProcExpr"
+ ppr PatBindRhs = text "PatBindRhs"
+ ppr RecUpd = text "RecUpd"
+ ppr (StmtCtxt _) = text "StmtCtxt _"
+ ppr ThPatSplice = text "ThPatSplice"
+ ppr ThPatQuote = text "ThPatQuote"
+ ppr PatSyn = text "PatSyn"
+
+isPatSynCtxt :: HsMatchContext id -> Bool
+isPatSynCtxt ctxt =
+ case ctxt of
+ PatSyn -> True
+ _ -> False
+
+-- | Haskell Statement Context
+data HsStmtContext id
+ = ListComp
+ | MonadComp
+ | PArrComp -- ^Parallel array comprehension
+
+ | DoExpr -- ^do { ... }
+ | MDoExpr -- ^mdo { ... } ie recursive do-expression
+ | ArrowExpr -- ^do-notation in an arrow-command context
+
+ | GhciStmtCtxt -- ^A command-line Stmt in GHCi pat <- rhs
+ | PatGuard (HsMatchContext id) -- ^Pattern guard for specified thing
+ | ParStmtCtxt (HsStmtContext id) -- ^A branch of a parallel stmt
+ | TransStmtCtxt (HsStmtContext id) -- ^A branch of a transform stmt
+ deriving Functor
+deriving instance (DataIdPost id) => Data (HsStmtContext id)
+
+isListCompExpr :: HsStmtContext id -> Bool
+-- Uses syntax [ e | quals ]
+isListCompExpr ListComp = True
+isListCompExpr PArrComp = True
+isListCompExpr MonadComp = True
+isListCompExpr (ParStmtCtxt c) = isListCompExpr c
+isListCompExpr (TransStmtCtxt c) = isListCompExpr c
+isListCompExpr _ = False
+
+isMonadCompExpr :: HsStmtContext id -> Bool
+isMonadCompExpr MonadComp = True
+isMonadCompExpr (ParStmtCtxt ctxt) = isMonadCompExpr ctxt
+isMonadCompExpr (TransStmtCtxt ctxt) = isMonadCompExpr ctxt
+isMonadCompExpr _ = False
+
+-- | Should pattern match failure in a 'HsStmtContext' be desugared using
+-- 'MonadFail'?
+isMonadFailStmtContext :: HsStmtContext id -> Bool
+isMonadFailStmtContext MonadComp = True
+isMonadFailStmtContext DoExpr = True
+isMonadFailStmtContext MDoExpr = True
+isMonadFailStmtContext GhciStmtCtxt = True
+isMonadFailStmtContext _ = False
+
+matchSeparator :: HsMatchContext id -> SDoc
+matchSeparator (FunRhs {}) = text "="
+matchSeparator CaseAlt = text "->"
+matchSeparator IfAlt = text "->"
+matchSeparator LambdaExpr = text "->"
+matchSeparator ProcExpr = text "->"
+matchSeparator PatBindRhs = text "="
+matchSeparator (StmtCtxt _) = text "<-"
+matchSeparator RecUpd = text "=" -- This can be printed by the pattern
+ -- match checker trace
+matchSeparator ThPatSplice = panic "unused"
+matchSeparator ThPatQuote = panic "unused"
+matchSeparator PatSyn = panic "unused"
+
+pprMatchContext :: (Outputable (NameOrRdrName id),Outputable id)
+ => HsMatchContext id -> SDoc
+pprMatchContext ctxt
+ | want_an ctxt = text "an" <+> pprMatchContextNoun ctxt
+ | otherwise = text "a" <+> pprMatchContextNoun ctxt
+ where
+ want_an (FunRhs {}) = True -- Use "an" in front
+ want_an ProcExpr = True
+ want_an _ = False
+
+pprMatchContextNoun :: (Outputable (NameOrRdrName id),Outputable id)
+ => HsMatchContext id -> SDoc
+pprMatchContextNoun (FunRhs {mc_fun=L _ fun})
+ = text "equation for"
+ <+> quotes (ppr fun)
+pprMatchContextNoun CaseAlt = text "case alternative"
+pprMatchContextNoun IfAlt = text "multi-way if alternative"
+pprMatchContextNoun RecUpd = text "record-update construct"
+pprMatchContextNoun ThPatSplice = text "Template Haskell pattern splice"
+pprMatchContextNoun ThPatQuote = text "Template Haskell pattern quotation"
+pprMatchContextNoun PatBindRhs = text "pattern binding"
+pprMatchContextNoun LambdaExpr = text "lambda abstraction"
+pprMatchContextNoun ProcExpr = text "arrow abstraction"
+pprMatchContextNoun (StmtCtxt ctxt) = text "pattern binding in"
+ $$ pprStmtContext ctxt
+pprMatchContextNoun PatSyn = text "pattern synonym declaration"
+
+-----------------
+pprAStmtContext, pprStmtContext :: (Outputable id,
+ Outputable (NameOrRdrName id))
+ => HsStmtContext id -> SDoc
+pprAStmtContext ctxt = article <+> pprStmtContext ctxt
+ where
+ pp_an = text "an"
+ pp_a = text "a"
+ article = case ctxt of
+ MDoExpr -> pp_an
+ PArrComp -> pp_an
+ GhciStmtCtxt -> pp_an
+ _ -> pp_a
+
+
+-----------------
+pprStmtContext GhciStmtCtxt = text "interactive GHCi command"
+pprStmtContext DoExpr = text "'do' block"
+pprStmtContext MDoExpr = text "'mdo' block"
+pprStmtContext ArrowExpr = text "'do' block in an arrow command"
+pprStmtContext ListComp = text "list comprehension"
+pprStmtContext MonadComp = text "monad comprehension"
+pprStmtContext PArrComp = text "array comprehension"
+pprStmtContext (PatGuard ctxt) = text "pattern guard for" $$ pprMatchContext ctxt
+
+-- Drop the inner contexts when reporting errors, else we get
+-- Unexpected transform statement
+-- in a transformed branch of
+-- transformed branch of
+-- transformed branch of monad comprehension
+pprStmtContext (ParStmtCtxt c) =
+ sdocWithPprDebug $ \dbg -> if dbg
+ then sep [text "parallel branch of", pprAStmtContext c]
+ else pprStmtContext c
+pprStmtContext (TransStmtCtxt c) =
+ sdocWithPprDebug $ \dbg -> if dbg
+ then sep [text "transformed branch of", pprAStmtContext c]
+ else pprStmtContext c
+
+instance (Outputable id, Outputable (NameOrRdrName id))
+ => Outputable (HsStmtContext id) where
+ ppr = pprStmtContext
+
+-- Used to generate the string for a *runtime* error message
+matchContextErrString :: Outputable id
+ => HsMatchContext id -> SDoc
+matchContextErrString (FunRhs{mc_fun=L _ fun}) = text "function" <+> ppr fun
+matchContextErrString CaseAlt = text "case"
+matchContextErrString IfAlt = text "multi-way if"
+matchContextErrString PatBindRhs = text "pattern binding"
+matchContextErrString RecUpd = text "record update"
+matchContextErrString LambdaExpr = text "lambda"
+matchContextErrString ProcExpr = text "proc"
+matchContextErrString ThPatSplice = panic "matchContextErrString" -- Not used at runtime
+matchContextErrString ThPatQuote = panic "matchContextErrString" -- Not used at runtime
+matchContextErrString PatSyn = panic "matchContextErrString" -- Not used at runtime
+matchContextErrString (StmtCtxt (ParStmtCtxt c)) = matchContextErrString (StmtCtxt c)
+matchContextErrString (StmtCtxt (TransStmtCtxt c)) = matchContextErrString (StmtCtxt c)
+matchContextErrString (StmtCtxt (PatGuard _)) = text "pattern guard"
+matchContextErrString (StmtCtxt GhciStmtCtxt) = text "interactive GHCi command"
+matchContextErrString (StmtCtxt DoExpr) = text "'do' block"
+matchContextErrString (StmtCtxt ArrowExpr) = text "'do' block"
+matchContextErrString (StmtCtxt MDoExpr) = text "'mdo' block"
+matchContextErrString (StmtCtxt ListComp) = text "list comprehension"
+matchContextErrString (StmtCtxt MonadComp) = text "monad comprehension"
+matchContextErrString (StmtCtxt PArrComp) = text "array comprehension"
+
+pprMatchInCtxt :: (OutputableBndrId idR,
+ Outputable (NameOrRdrName (NameOrRdrName idR)),
+ Outputable body)
+ => Match idR body -> SDoc
+pprMatchInCtxt match = hang (text "In" <+> pprMatchContext (m_ctxt match)
+ <> colon)
+ 4 (pprMatch match)
+
+pprStmtInCtxt :: (OutputableBndrId idL, OutputableBndrId idR,
+ Outputable body)
+ => HsStmtContext idL -> StmtLR idL idR body -> SDoc
+pprStmtInCtxt ctxt (LastStmt e _ _)
+ | isListCompExpr ctxt -- For [ e | .. ], do not mutter about "stmts"
+ = hang (text "In the expression:") 2 (ppr e)
+
+pprStmtInCtxt ctxt stmt
+ = hang (text "In a stmt of" <+> pprAStmtContext ctxt <> colon)
+ 2 (ppr_stmt stmt)
+ where
+ -- For Group and Transform Stmts, don't print the nested stmts!
+ ppr_stmt (TransStmt { trS_by = by, trS_using = using
+ , trS_form = form }) = pprTransStmt by using form
+ ppr_stmt stmt = pprStmt stmt
diff --git a/hsSyn/HsExpr.hs-boot b/hsSyn/HsExpr.hs-boot
new file mode 100644
--- /dev/null
+++ b/hsSyn/HsExpr.hs-boot
@@ -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
diff --git a/hsSyn/HsImpExp.hs b/hsSyn/HsImpExp.hs
new file mode 100644
--- /dev/null
+++ b/hsSyn/HsImpExp.hs
@@ -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 ("")
+ ppr (IEDoc doc) = ppr doc
+ ppr (IEDocNamed string) = text ("")
+
+instance (HasOccName name) => HasOccName (IEWrappedName name) where
+ occName w = occName (ieWrappedName w)
+
+instance (OutputableBndr name, HasOccName name)
+ => OutputableBndr (IEWrappedName name) where
+ pprBndr bs w = pprBndr bs (ieWrappedName w)
+ pprPrefixOcc w = pprPrefixOcc (ieWrappedName w)
+ pprInfixOcc w = pprInfixOcc (ieWrappedName w)
+
+instance (HasOccName name, OutputableBndr name)
+ => Outputable (IEWrappedName name) where
+ ppr (IEName n) = pprPrefixOcc (unLoc n)
+ ppr (IEPattern n) = text "pattern" <+> pprPrefixOcc (unLoc n)
+ ppr (IEType n) = text "type" <+> pprPrefixOcc (unLoc n)
+
+pprImpExp :: (HasOccName name, OutputableBndr name) => name -> SDoc
+pprImpExp name = type_pref <+> pprPrefixOcc name
+ where
+ occ = occName name
+ type_pref | isTcOcc occ && isSymOcc occ = text "type"
+ | otherwise = empty
diff --git a/hsSyn/HsLit.hs b/hsSyn/HsLit.hs
new file mode 100644
--- /dev/null
+++ b/hsSyn/HsLit.hs
@@ -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
diff --git a/hsSyn/HsPat.hs b/hsSyn/HsPat.hs
new file mode 100644
--- /dev/null
+++ b/hsSyn/HsPat.hs
@@ -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
diff --git a/hsSyn/HsPat.hs-boot b/hsSyn/HsPat.hs-boot
new file mode 100644
--- /dev/null
+++ b/hsSyn/HsPat.hs-boot
@@ -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)
diff --git a/hsSyn/HsSyn.hs b/hsSyn/HsSyn.hs
new file mode 100644
--- /dev/null
+++ b/hsSyn/HsSyn.hs
@@ -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)
diff --git a/hsSyn/HsTypes.hs b/hsSyn/HsTypes.hs
new file mode 100644
--- /dev/null
+++ b/hsSyn/HsTypes.hs
@@ -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)
diff --git a/hsSyn/HsUtils.hs b/hsSyn/HsUtils.hs
new file mode 100644
--- /dev/null
+++ b/hsSyn/HsUtils.hs
@@ -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
diff --git a/hsSyn/PlaceHolder.hs b/hsSyn/PlaceHolder.hs
new file mode 100644
--- /dev/null
+++ b/hsSyn/PlaceHolder.hs
@@ -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)
+ )
diff --git a/iface/BinFingerprint.hs b/iface/BinFingerprint.hs
new file mode 100644
--- /dev/null
+++ b/iface/BinFingerprint.hs
@@ -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
diff --git a/iface/BinIface.hs b/iface/BinIface.hs
new file mode 100644
--- /dev/null
+++ b/iface/BinIface.hs
@@ -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.
diff --git a/iface/BuildTyCl.hs b/iface/BuildTyCl.hs
new file mode 100644
--- /dev/null
+++ b/iface/BuildTyCl.hs
@@ -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. -> T tvs
+ -- Note that we *can't* use dataConInstOrigArgTys here because
+ -- the newtype arising from class Foo a => Bar a where {}
+ -- has a single argument (Foo a) that is a *type class*, so
+ -- dataConInstOrigArgTys returns [].
+
+ etad_tvs :: [TyVar] -- Matched lazily, so that mkNewTypeCo can
+ etad_roles :: [Role] -- return a TyCon without pulling on rhs_ty
+ etad_rhs :: Type -- See Note [Tricky iface loop] in LoadIface
+ (etad_tvs, etad_roles, etad_rhs) = eta_reduce (reverse tvs) (reverse roles) rhs_ty
+
+ eta_reduce :: [TyVar] -- Reversed
+ -> [Role] -- also reversed
+ -> Type -- Rhs type
+ -> ([TyVar], [Role], Type) -- Eta-reduced version
+ -- (tyvars in normal order)
+ eta_reduce (a:as) (_:rs) ty | Just (fun, arg) <- splitAppTy_maybe ty,
+ Just tv <- getTyVar_maybe arg,
+ tv == a,
+ not (a `elemVarSet` tyCoVarsOfType fun)
+ = eta_reduce as rs fun
+ eta_reduce tvs rs ty = (reverse tvs, reverse rs, ty)
+
+------------------------------------------------------
+buildDataCon :: FamInstEnvs
+ -> Name
+ -> Bool -- Declared infix
+ -> TyConRepName
+ -> [HsSrcBang]
+ -> Maybe [HsImplBang]
+ -- See Note [Bangs on imported data constructors] in MkId
+ -> [FieldLabel] -- Field labels
+ -> [TyVarBinder] -- Universals
+ -> [TyVarBinder] -- Existentials
+ -> [EqSpec] -- Equality spec
+ -> ThetaType -- Does not include the "stupid theta"
+ -- or the GADT equalities
+ -> [Type] -> Type -- Argument and result types
+ -> TyCon -- Rep tycon
+ -> TcRnIf m n DataCon
+-- A wrapper for DataCon.mkDataCon that
+-- a) makes the worker Id
+-- b) makes the wrapper Id if necessary, including
+-- allocating its unique (hence monadic)
+-- c) Sorts out the TyVarBinders. See mkDataConUnivTyBinders
+buildDataCon fam_envs src_name declared_infix prom_info src_bangs impl_bangs field_lbls
+ univ_tvs ex_tvs eq_spec ctxt arg_tys res_ty rep_tycon
+ = do { wrap_name <- newImplicitBinder src_name mkDataConWrapperOcc
+ ; work_name <- newImplicitBinder src_name mkDataConWorkerOcc
+ -- This last one takes the name of the data constructor in the source
+ -- code, which (for Haskell source anyway) will be in the DataName name
+ -- space, and puts it into the VarName name space
+
+ ; traceIf (text "buildDataCon 1" <+> ppr src_name)
+ ; us <- newUniqueSupply
+ ; dflags <- getDynFlags
+ ; let stupid_ctxt = mkDataConStupidTheta rep_tycon arg_tys univ_tvs
+ data_con = mkDataCon src_name declared_infix prom_info
+ src_bangs field_lbls
+ univ_tvs ex_tvs eq_spec ctxt
+ arg_tys res_ty NoRRI rep_tycon
+ stupid_ctxt dc_wrk dc_rep
+ dc_wrk = mkDataConWorkId work_name data_con
+ dc_rep = initUs_ us (mkDataConRep dflags fam_envs wrap_name
+ impl_bangs data_con)
+
+ ; traceIf (text "buildDataCon 2" <+> ppr src_name)
+ ; return data_con }
+
+
+-- The stupid context for a data constructor should be limited to
+-- the type variables mentioned in the arg_tys
+-- ToDo: Or functionally dependent on?
+-- This whole stupid theta thing is, well, stupid.
+mkDataConStupidTheta :: TyCon -> [Type] -> [TyVarBinder] -> [PredType]
+mkDataConStupidTheta tycon arg_tys univ_tvs
+ | null stupid_theta = [] -- The common case
+ | otherwise = filter in_arg_tys stupid_theta
+ where
+ tc_subst = zipTvSubst (tyConTyVars tycon)
+ (mkTyVarTys (binderVars univ_tvs))
+ stupid_theta = substTheta tc_subst (tyConStupidTheta tycon)
+ -- Start by instantiating the master copy of the
+ -- stupid theta, taken from the TyCon
+
+ arg_tyvars = tyCoVarsOfTypes arg_tys
+ in_arg_tys pred = not $ isEmptyVarSet $
+ tyCoVarsOfType pred `intersectVarSet` arg_tyvars
+
+
+mkDataConUnivTyVarBinders :: [TyConBinder] -- From the TyCon
+ -> [TyVarBinder] -- For the DataCon
+-- See Note [Building the TyBinders for a DataCon]
+mkDataConUnivTyVarBinders tc_bndrs
+ = map mk_binder tc_bndrs
+ where
+ mk_binder (TvBndr tv tc_vis) = mkTyVarBinder vis tv
+ where
+ vis = case tc_vis of
+ AnonTCB -> Specified
+ NamedTCB Required -> Specified
+ NamedTCB vis -> vis
+
+{- Note [Building the TyBinders for a DataCon]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+A DataCon needs to keep track of the visibility of its universals and
+existentials, so that visible type application can work properly. This
+is done by storing the universal and existential TyVarBinders.
+See Note [TyVarBinders in DataCons] in DataCon.
+
+During construction of a DataCon, we often start from the TyBinders of
+the parent TyCon. For example
+ data Maybe a = Nothing | Just a
+The DataCons start from the TyBinders of the parent TyCon.
+
+But the ultimate TyBinders for the DataCon are *different* than those
+of the DataCon. Here is an example:
+
+ data App a b = MkApp (a b) -- App :: forall {k}. (k->*) -> k -> *
+
+The TyCon has
+
+ tyConTyVars = [ k:*, a:k->*, b:k]
+ tyConTyBinders = [ Named (TvBndr (k :: *) Inferred), Anon (k->*), Anon k ]
+
+The TyBinders for App line up with App's kind, given above.
+
+But the DataCon MkApp has the type
+ MkApp :: forall {k} (a:k->*) (b:k). a b -> App k a b
+
+That is, its TyBinders should be
+
+ dataConUnivTyVarBinders = [ TvBndr (k:*) Inferred
+ , TvBndr (a:k->*) Specified
+ , TvBndr (b:k) Specified ]
+
+So we want to take the TyCon's TyBinders and the TyCon's TyVars and
+merge them, pulling
+ - variable names from the TyVars
+ - visibilities from the TyBinders
+ - but changing Anon/Required to Specified
+
+The last part about Required->Specified comes from this:
+ data T k (a:k) b = MkT (a b)
+Here k is Required in T's kind, but we don't have Required binders in
+the TyBinders for a term (see Note [No Required TyBinder in terms]
+in TyCoRep), so we change it to Specified when making MkT's TyBinders
+
+This merging operation is done by mkDataConUnivTyBinders. In contrast,
+the TyBinders passed to mkDataCon are the final TyBinders stored in the
+DataCon (mkDataCon does no further work).
+-}
+
+------------------------------------------------------
+buildPatSyn :: Name -> Bool
+ -> (Id,Bool) -> Maybe (Id, Bool)
+ -> ([TyVarBinder], ThetaType) -- ^ Univ and req
+ -> ([TyVarBinder], ThetaType) -- ^ Ex and prov
+ -> [Type] -- ^ Argument types
+ -> Type -- ^ Result type
+ -> [FieldLabel] -- ^ Field labels for
+ -- a record pattern synonym
+ -> PatSyn
+buildPatSyn src_name declared_infix matcher@(matcher_id,_) builder
+ (univ_tvs, req_theta) (ex_tvs, prov_theta) arg_tys
+ pat_ty field_labels
+ = -- The assertion checks that the matcher is
+ -- compatible with the pattern synonym
+ ASSERT2((and [ univ_tvs `equalLength` univ_tvs1
+ , ex_tvs `equalLength` ex_tvs1
+ , pat_ty `eqType` substTy subst pat_ty1
+ , prov_theta `eqTypes` substTys subst prov_theta1
+ , req_theta `eqTypes` substTys subst req_theta1
+ , compareArgTys arg_tys (substTys subst arg_tys1)
+ ])
+ , (vcat [ ppr univ_tvs <+> twiddle <+> ppr univ_tvs1
+ , ppr ex_tvs <+> twiddle <+> ppr ex_tvs1
+ , ppr pat_ty <+> twiddle <+> ppr pat_ty1
+ , ppr prov_theta <+> twiddle <+> ppr prov_theta1
+ , ppr req_theta <+> twiddle <+> ppr req_theta1
+ , ppr arg_tys <+> twiddle <+> ppr arg_tys1]))
+ mkPatSyn src_name declared_infix
+ (univ_tvs, req_theta) (ex_tvs, prov_theta)
+ arg_tys pat_ty
+ matcher builder field_labels
+ where
+ ((_:_:univ_tvs1), req_theta1, tau) = tcSplitSigmaTy $ idType matcher_id
+ ([pat_ty1, cont_sigma, _], _) = tcSplitFunTys tau
+ (ex_tvs1, prov_theta1, cont_tau) = tcSplitSigmaTy cont_sigma
+ (arg_tys1, _) = (tcSplitFunTys cont_tau)
+ twiddle = char '~'
+ subst = zipTvSubst (univ_tvs1 ++ ex_tvs1)
+ (mkTyVarTys (binderVars (univ_tvs ++ ex_tvs)))
+
+ -- For a nullary pattern synonym we add a single void argument to the
+ -- matcher to preserve laziness in the case of unlifted types.
+ -- See #12746
+ compareArgTys :: [Type] -> [Type] -> Bool
+ compareArgTys [] [x] = x `eqType` voidPrimTy
+ compareArgTys arg_tys matcher_arg_tys = arg_tys `eqTypes` matcher_arg_tys
+
+
+------------------------------------------------------
+type TcMethInfo -- A temporary intermediate, to communicate
+ -- between tcClassSigs and buildClass.
+ = ( Name -- Name of the class op
+ , Type -- Type of the class op
+ , Maybe (DefMethSpec (SrcSpan, Type)))
+ -- Nothing => no default method
+ --
+ -- Just VanillaDM => There is an ordinary
+ -- polymorphic default method
+ --
+ -- Just (GenericDM (loc, ty)) => There is a generic default metho
+ -- Here is its type, and the location
+ -- of the type signature
+ -- We need that location /only/ to attach it to the
+ -- generic default method's Name; and we need /that/
+ -- only to give the right location of an ambiguity error
+ -- for the generic default method, spat out by checkValidClass
+
+buildClass :: Name -- Name of the class/tycon (they have the same Name)
+ -> [TyConBinder] -- Of the tycon
+ -> [Role]
+ -> [FunDep TyVar] -- Functional dependencies
+ -- Super classes, associated types, method info, minimal complete def.
+ -- This is Nothing if the class is abstract.
+ -> Maybe (ThetaType, [ClassATItem], [TcMethInfo], ClassMinimalDef)
+ -> TcRnIf m n Class
+
+buildClass tycon_name binders roles fds Nothing
+ = fixM $ \ rec_clas -> -- Only name generation inside loop
+ do { traceIf (text "buildClass")
+
+ ; tc_rep_name <- newTyConRepName tycon_name
+ ; let univ_bndrs = mkDataConUnivTyVarBinders binders
+ univ_tvs = binderVars univ_bndrs
+ tycon = mkClassTyCon tycon_name binders roles
+ AbstractTyCon rec_clas tc_rep_name
+ result = mkAbstractClass tycon_name univ_tvs fds tycon
+ ; traceIf (text "buildClass" <+> ppr tycon)
+ ; return result }
+
+buildClass tycon_name binders roles fds
+ (Just (sc_theta, at_items, sig_stuff, mindef))
+ = fixM $ \ rec_clas -> -- Only name generation inside loop
+ do { traceIf (text "buildClass")
+
+ ; datacon_name <- newImplicitBinder tycon_name mkClassDataConOcc
+ ; tc_rep_name <- newTyConRepName tycon_name
+
+ ; op_items <- mapM (mk_op_item rec_clas) sig_stuff
+ -- Build the selector id and default method id
+
+ -- Make selectors for the superclasses
+ ; sc_sel_names <- mapM (newImplicitBinder tycon_name . mkSuperDictSelOcc)
+ (takeList sc_theta [fIRST_TAG..])
+ ; let sc_sel_ids = [ mkDictSelId sc_name rec_clas
+ | sc_name <- sc_sel_names]
+ -- We number off the Dict superclass selectors, 1, 2, 3 etc so that we
+ -- can construct names for the selectors. Thus
+ -- class (C a, C b) => D a b where ...
+ -- gives superclass selectors
+ -- D_sc1, D_sc2
+ -- (We used to call them D_C, but now we can have two different
+ -- superclasses both called C!)
+
+ ; let use_newtype = isSingleton arg_tys
+ -- Use a newtype if the data constructor
+ -- (a) has exactly one value field
+ -- i.e. exactly one operation or superclass taken together
+ -- (b) that value is of lifted type (which they always are, because
+ -- we box equality superclasses)
+ -- See note [Class newtypes and equality predicates]
+
+ -- We treat the dictionary superclasses as ordinary arguments.
+ -- That means that in the case of
+ -- class C a => D a
+ -- we don't get a newtype with no arguments!
+ args = sc_sel_names ++ op_names
+ op_tys = [ty | (_,ty,_) <- sig_stuff]
+ op_names = [op | (op,_,_) <- sig_stuff]
+ arg_tys = sc_theta ++ op_tys
+ rec_tycon = classTyCon rec_clas
+ univ_bndrs = mkDataConUnivTyVarBinders binders
+ univ_tvs = binderVars univ_bndrs
+
+ ; rep_nm <- newTyConRepName datacon_name
+ ; dict_con <- buildDataCon (panic "buildClass: FamInstEnvs")
+ datacon_name
+ False -- Not declared infix
+ rep_nm
+ (map (const no_bang) args)
+ (Just (map (const HsLazy) args))
+ [{- No fields -}]
+ univ_bndrs
+ [{- no existentials -}]
+ [{- No GADT equalities -}]
+ [{- No theta -}]
+ arg_tys
+ (mkTyConApp rec_tycon (mkTyVarTys univ_tvs))
+ rec_tycon
+
+ ; rhs <- case () of
+ _ | use_newtype
+ -> mkNewTyConRhs tycon_name rec_tycon dict_con
+ | isCTupleTyConName tycon_name
+ -> return (TupleTyCon { data_con = dict_con
+ , tup_sort = ConstraintTuple })
+ | otherwise
+ -> return (mkDataTyConRhs [dict_con])
+
+ ; let { tycon = mkClassTyCon tycon_name binders roles
+ rhs rec_clas tc_rep_name
+ -- A class can be recursive, and in the case of newtypes
+ -- this matters. For example
+ -- class C a where { op :: C b => a -> b -> Int }
+ -- Because C has only one operation, it is represented by
+ -- a newtype, and it should be a *recursive* newtype.
+ -- [If we don't make it a recursive newtype, we'll expand the
+ -- newtype like a synonym, but that will lead to an infinite
+ -- type]
+
+ ; result = mkClass tycon_name univ_tvs fds
+ sc_theta sc_sel_ids at_items
+ op_items mindef tycon
+ }
+ ; traceIf (text "buildClass" <+> ppr tycon)
+ ; return result }
+ where
+ no_bang = HsSrcBang NoSourceText NoSrcUnpack NoSrcStrict
+
+ mk_op_item :: Class -> TcMethInfo -> TcRnIf n m ClassOpItem
+ mk_op_item rec_clas (op_name, _, dm_spec)
+ = do { dm_info <- mk_dm_info op_name dm_spec
+ ; return (mkDictSelId op_name rec_clas, dm_info) }
+
+ mk_dm_info :: Name -> Maybe (DefMethSpec (SrcSpan, Type))
+ -> TcRnIf n m (Maybe (Name, DefMethSpec Type))
+ mk_dm_info _ Nothing
+ = return Nothing
+ mk_dm_info op_name (Just VanillaDM)
+ = do { dm_name <- newImplicitBinder op_name mkDefaultMethodOcc
+ ; return (Just (dm_name, VanillaDM)) }
+ mk_dm_info op_name (Just (GenericDM (loc, dm_ty)))
+ = do { dm_name <- newImplicitBinderLoc op_name mkDefaultMethodOcc loc
+ ; return (Just (dm_name, GenericDM dm_ty)) }
+
+{-
+Note [Class newtypes and equality predicates]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+ class (a ~ F b) => C a b where
+ op :: a -> b
+
+We cannot represent this by a newtype, even though it's not
+existential, because there are two value fields (the equality
+predicate and op. See Trac #2238
+
+Moreover,
+ class (a ~ F b) => C a b where {}
+Here we can't use a newtype either, even though there is only
+one field, because equality predicates are unboxed, and classes
+are boxed.
+-}
+
+newImplicitBinder :: Name -- Base name
+ -> (OccName -> OccName) -- Occurrence name modifier
+ -> TcRnIf m n Name -- Implicit name
+-- Called in BuildTyCl to allocate the implicit binders of type/class decls
+-- For source type/class decls, this is the first occurrence
+-- For iface ones, the LoadIface has already allocated a suitable name in the cache
+newImplicitBinder base_name mk_sys_occ
+ = newImplicitBinderLoc base_name mk_sys_occ (nameSrcSpan base_name)
+
+newImplicitBinderLoc :: Name -- Base name
+ -> (OccName -> OccName) -- Occurrence name modifier
+ -> SrcSpan
+ -> TcRnIf m n Name -- Implicit name
+-- Just the same, but lets you specify the SrcSpan
+newImplicitBinderLoc base_name mk_sys_occ loc
+ | Just mod <- nameModule_maybe base_name
+ = newGlobalBinder mod occ loc
+ | otherwise -- When typechecking a [d| decl bracket |],
+ -- TH generates types, classes etc with Internal names,
+ -- so we follow suit for the implicit binders
+ = do { uniq <- newUnique
+ ; return (mkInternalName uniq occ loc) }
+ where
+ occ = mk_sys_occ (nameOccName base_name)
+
+-- | Make the 'TyConRepName' for this 'TyCon'
+newTyConRepName :: Name -> TcRnIf gbl lcl TyConRepName
+newTyConRepName tc_name
+ | Just mod <- nameModule_maybe tc_name
+ , (mod, occ) <- tyConRepModOcc mod (nameOccName tc_name)
+ = newGlobalBinder mod occ noSrcSpan
+ | otherwise
+ = newImplicitBinder tc_name mkTyConRepOcc
diff --git a/iface/FlagChecker.hs b/iface/FlagChecker.hs
new file mode 100644
--- /dev/null
+++ b/iface/FlagChecker.hs
@@ -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.
+-}
diff --git a/iface/IfaceEnv.hs b/iface/IfaceEnv.hs
new file mode 100644
--- /dev/null
+++ b/iface/IfaceEnv.hs
@@ -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] }
diff --git a/iface/IfaceEnv.hs-boot b/iface/IfaceEnv.hs-boot
new file mode 100644
--- /dev/null
+++ b/iface/IfaceEnv.hs-boot
@@ -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
diff --git a/iface/IfaceSyn.hs b/iface/IfaceSyn.hs
new file mode 100644
--- /dev/null
+++ b/iface/IfaceSyn.hs
@@ -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 ""
+ else Outputable.empty
+ ppr IfDFunId = text "DFunId"
+
+instance Outputable IfaceIdInfo where
+ ppr NoInfo = Outputable.empty
+ ppr (HasInfo is) = text "{-" <+> pprWithCommas ppr is
+ <+> text "-}"
+
+instance Outputable IfaceInfoItem where
+ ppr (HsUnfold lb unf) = text "Unfolding"
+ <> ppWhen lb (text "(loop-breaker)")
+ <> colon <+> ppr unf
+ ppr (HsInline prag) = text "Inline:" <+> ppr prag
+ ppr (HsArity arity) = text "Arity:" <+> int arity
+ ppr (HsStrictness str) = text "Strictness:" <+> pprIfaceStrictSig str
+ ppr HsNoCafRefs = text "HasNoCafRefs"
+ ppr HsLevity = text "Never levity-polymorphic"
+
+instance Outputable IfaceJoinInfo where
+ ppr IfaceNotJoinPoint = empty
+ ppr (IfaceJoinPoint ar) = angleBrackets (text "join" <+> ppr ar)
+
+instance Outputable IfaceUnfolding where
+ ppr (IfCompulsory e) = text "" <+> parens (ppr e)
+ ppr (IfCoreUnfold s e) = (if s
+ then text ""
+ else Outputable.empty)
+ <+> parens (ppr e)
+ ppr (IfInlineRule a uok bok e) = sep [text "InlineRule"
+ <+> ppr (a,uok,bok),
+ pprParendIfaceExpr e]
+ ppr (IfDFunUnfold bs es) = hang (text "DFun:" <+> sep (map ppr bs) <> dot)
+ 2 (sep (map pprParendIfaceExpr es))
+
+{-
+************************************************************************
+* *
+ Finding the Names in IfaceSyn
+* *
+************************************************************************
+
+This is used for dependency analysis in MkIface, so that we
+fingerprint a declaration before the things that depend on it. It
+is specific to interface-file fingerprinting in the sense that we
+don't collect *all* Names: for example, the DFun of an instance is
+recorded textually rather than by its fingerprint when
+fingerprinting the instance, so DFuns are not dependencies.
+-}
+
+freeNamesIfDecl :: IfaceDecl -> NameSet
+freeNamesIfDecl (IfaceId _s t d i) =
+ freeNamesIfType t &&&
+ freeNamesIfIdInfo i &&&
+ freeNamesIfIdDetails d
+freeNamesIfDecl d@IfaceData{} =
+ freeNamesIfTyVarBndrs (ifBinders d) &&&
+ freeNamesIfType (ifResKind d) &&&
+ freeNamesIfaceTyConParent (ifParent d) &&&
+ freeNamesIfContext (ifCtxt d) &&&
+ freeNamesIfConDecls (ifCons d)
+freeNamesIfDecl d@IfaceSynonym{} =
+ freeNamesIfType (ifSynRhs d) &&&
+ freeNamesIfTyVarBndrs (ifBinders d) &&&
+ freeNamesIfKind (ifResKind d)
+freeNamesIfDecl d@IfaceFamily{} =
+ freeNamesIfFamFlav (ifFamFlav d) &&&
+ freeNamesIfTyVarBndrs (ifBinders d) &&&
+ freeNamesIfKind (ifResKind d)
+freeNamesIfDecl d@IfaceClass{ ifBody = IfAbstractClass } =
+ freeNamesIfTyVarBndrs (ifBinders d)
+freeNamesIfDecl d@IfaceClass{ ifBody = d'@IfConcreteClass{} } =
+ freeNamesIfTyVarBndrs (ifBinders d) &&&
+ freeNamesIfContext (ifClassCtxt d') &&&
+ fnList freeNamesIfAT (ifATs d') &&&
+ fnList freeNamesIfClsSig (ifSigs d')
+freeNamesIfDecl d@IfaceAxiom{} =
+ freeNamesIfTc (ifTyCon d) &&&
+ fnList freeNamesIfAxBranch (ifAxBranches d)
+freeNamesIfDecl d@IfacePatSyn{} =
+ unitNameSet (fst (ifPatMatcher d)) &&&
+ maybe emptyNameSet (unitNameSet . fst) (ifPatBuilder d) &&&
+ freeNamesIfTyVarBndrs (ifPatUnivBndrs d) &&&
+ freeNamesIfTyVarBndrs (ifPatExBndrs d) &&&
+ freeNamesIfContext (ifPatProvCtxt d) &&&
+ freeNamesIfContext (ifPatReqCtxt d) &&&
+ fnList freeNamesIfType (ifPatArgs d) &&&
+ freeNamesIfType (ifPatTy d) &&&
+ mkNameSet (map flSelector (ifFieldLabels d))
+
+freeNamesIfAxBranch :: IfaceAxBranch -> NameSet
+freeNamesIfAxBranch (IfaceAxBranch { ifaxbTyVars = tyvars
+ , ifaxbCoVars = covars
+ , ifaxbLHS = lhs
+ , ifaxbRHS = rhs })
+ = fnList freeNamesIfTvBndr tyvars &&&
+ fnList freeNamesIfIdBndr covars &&&
+ freeNamesIfTcArgs lhs &&&
+ freeNamesIfType rhs
+
+freeNamesIfIdDetails :: IfaceIdDetails -> NameSet
+freeNamesIfIdDetails (IfRecSelId tc _) =
+ either freeNamesIfTc freeNamesIfDecl tc
+freeNamesIfIdDetails _ = emptyNameSet
+
+-- All other changes are handled via the version info on the tycon
+freeNamesIfFamFlav :: IfaceFamTyConFlav -> NameSet
+freeNamesIfFamFlav IfaceOpenSynFamilyTyCon = emptyNameSet
+freeNamesIfFamFlav IfaceDataFamilyTyCon = emptyNameSet
+freeNamesIfFamFlav (IfaceClosedSynFamilyTyCon (Just (ax, br)))
+ = unitNameSet ax &&& fnList freeNamesIfAxBranch br
+freeNamesIfFamFlav (IfaceClosedSynFamilyTyCon Nothing) = emptyNameSet
+freeNamesIfFamFlav IfaceAbstractClosedSynFamilyTyCon = emptyNameSet
+freeNamesIfFamFlav IfaceBuiltInSynFamTyCon = emptyNameSet
+
+freeNamesIfContext :: IfaceContext -> NameSet
+freeNamesIfContext = fnList freeNamesIfType
+
+freeNamesIfAT :: IfaceAT -> NameSet
+freeNamesIfAT (IfaceAT decl mb_def)
+ = freeNamesIfDecl decl &&&
+ case mb_def of
+ Nothing -> emptyNameSet
+ Just rhs -> freeNamesIfType rhs
+
+freeNamesIfClsSig :: IfaceClassOp -> NameSet
+freeNamesIfClsSig (IfaceClassOp _n ty dm) = freeNamesIfType ty &&& freeNamesDM dm
+
+freeNamesDM :: Maybe (DefMethSpec IfaceType) -> NameSet
+freeNamesDM (Just (GenericDM ty)) = freeNamesIfType ty
+freeNamesDM _ = emptyNameSet
+
+freeNamesIfConDecls :: IfaceConDecls -> NameSet
+freeNamesIfConDecls (IfDataTyCon c) = fnList freeNamesIfConDecl c
+freeNamesIfConDecls (IfNewTyCon c) = freeNamesIfConDecl c
+freeNamesIfConDecls _ = emptyNameSet
+
+freeNamesIfConDecl :: IfaceConDecl -> NameSet
+freeNamesIfConDecl (IfCon { ifConExTvs = ex_tvs, ifConCtxt = ctxt
+ , ifConArgTys = arg_tys
+ , ifConFields = flds
+ , ifConEqSpec = eq_spec
+ , ifConStricts = bangs })
+ = freeNamesIfTyVarBndrs ex_tvs &&&
+ freeNamesIfContext ctxt &&&
+ fnList freeNamesIfType arg_tys &&&
+ mkNameSet (map flSelector flds) &&&
+ fnList freeNamesIfType (map snd eq_spec) &&& -- equality constraints
+ fnList freeNamesIfBang bangs
+
+freeNamesIfBang :: IfaceBang -> NameSet
+freeNamesIfBang (IfUnpackCo co) = freeNamesIfCoercion co
+freeNamesIfBang _ = emptyNameSet
+
+freeNamesIfKind :: IfaceType -> NameSet
+freeNamesIfKind = freeNamesIfType
+
+freeNamesIfTcArgs :: IfaceTcArgs -> NameSet
+freeNamesIfTcArgs (ITC_Vis t ts) = freeNamesIfType t &&& freeNamesIfTcArgs ts
+freeNamesIfTcArgs (ITC_Invis k ks) = freeNamesIfKind k &&& freeNamesIfTcArgs ks
+freeNamesIfTcArgs ITC_Nil = emptyNameSet
+
+freeNamesIfType :: IfaceType -> NameSet
+freeNamesIfType (IfaceFreeTyVar _) = emptyNameSet
+freeNamesIfType (IfaceTyVar _) = emptyNameSet
+freeNamesIfType (IfaceAppTy s t) = freeNamesIfType s &&& freeNamesIfType t
+freeNamesIfType (IfaceTyConApp tc ts) = freeNamesIfTc tc &&& freeNamesIfTcArgs ts
+freeNamesIfType (IfaceTupleTy _ _ ts) = freeNamesIfTcArgs ts
+freeNamesIfType (IfaceLitTy _) = emptyNameSet
+freeNamesIfType (IfaceForAllTy tv t) = freeNamesIfTyVarBndr tv &&& freeNamesIfType t
+freeNamesIfType (IfaceFunTy s t) = freeNamesIfType s &&& freeNamesIfType t
+freeNamesIfType (IfaceDFunTy s t) = freeNamesIfType s &&& freeNamesIfType t
+freeNamesIfType (IfaceCastTy t c) = freeNamesIfType t &&& freeNamesIfCoercion c
+freeNamesIfType (IfaceCoercionTy c) = freeNamesIfCoercion c
+
+freeNamesIfCoercion :: IfaceCoercion -> NameSet
+freeNamesIfCoercion (IfaceReflCo _ t) = freeNamesIfType t
+freeNamesIfCoercion (IfaceFunCo _ c1 c2)
+ = freeNamesIfCoercion c1 &&& freeNamesIfCoercion c2
+freeNamesIfCoercion (IfaceTyConAppCo _ tc cos)
+ = freeNamesIfTc tc &&& fnList freeNamesIfCoercion cos
+freeNamesIfCoercion (IfaceAppCo c1 c2)
+ = freeNamesIfCoercion c1 &&& freeNamesIfCoercion c2
+freeNamesIfCoercion (IfaceForAllCo _ kind_co co)
+ = freeNamesIfCoercion kind_co &&& freeNamesIfCoercion co
+freeNamesIfCoercion (IfaceCoVarCo _)
+ = emptyNameSet
+freeNamesIfCoercion (IfaceAxiomInstCo ax _ cos)
+ = unitNameSet ax &&& fnList freeNamesIfCoercion cos
+freeNamesIfCoercion (IfaceUnivCo p _ t1 t2)
+ = freeNamesIfProv p &&& freeNamesIfType t1 &&& freeNamesIfType t2
+freeNamesIfCoercion (IfaceSymCo c)
+ = freeNamesIfCoercion c
+freeNamesIfCoercion (IfaceTransCo c1 c2)
+ = freeNamesIfCoercion c1 &&& freeNamesIfCoercion c2
+freeNamesIfCoercion (IfaceNthCo _ co)
+ = freeNamesIfCoercion co
+freeNamesIfCoercion (IfaceLRCo _ co)
+ = freeNamesIfCoercion co
+freeNamesIfCoercion (IfaceInstCo co co2)
+ = freeNamesIfCoercion co &&& freeNamesIfCoercion co2
+freeNamesIfCoercion (IfaceCoherenceCo c1 c2)
+ = freeNamesIfCoercion c1 &&& freeNamesIfCoercion c2
+freeNamesIfCoercion (IfaceKindCo c)
+ = freeNamesIfCoercion c
+freeNamesIfCoercion (IfaceSubCo co)
+ = freeNamesIfCoercion co
+freeNamesIfCoercion (IfaceAxiomRuleCo _ax cos)
+ -- the axiom is just a string, so we don't count it as a name.
+ = fnList freeNamesIfCoercion cos
+
+freeNamesIfProv :: IfaceUnivCoProv -> NameSet
+freeNamesIfProv IfaceUnsafeCoerceProv = emptyNameSet
+freeNamesIfProv (IfacePhantomProv co) = freeNamesIfCoercion co
+freeNamesIfProv (IfaceProofIrrelProv co) = freeNamesIfCoercion co
+freeNamesIfProv (IfacePluginProv _) = emptyNameSet
+freeNamesIfProv (IfaceHoleProv _) = emptyNameSet
+
+freeNamesIfTyVarBndr :: TyVarBndr IfaceTvBndr vis -> NameSet
+freeNamesIfTyVarBndr (TvBndr tv _) = freeNamesIfTvBndr tv
+
+freeNamesIfTyVarBndrs :: [TyVarBndr IfaceTvBndr vis] -> NameSet
+freeNamesIfTyVarBndrs = fnList freeNamesIfTyVarBndr
+
+freeNamesIfBndr :: IfaceBndr -> NameSet
+freeNamesIfBndr (IfaceIdBndr b) = freeNamesIfIdBndr b
+freeNamesIfBndr (IfaceTvBndr b) = freeNamesIfTvBndr b
+
+freeNamesIfBndrs :: [IfaceBndr] -> NameSet
+freeNamesIfBndrs = fnList freeNamesIfBndr
+
+freeNamesIfLetBndr :: IfaceLetBndr -> NameSet
+-- Remember IfaceLetBndr is used only for *nested* bindings
+-- The IdInfo can contain an unfolding (in the case of
+-- local INLINE pragmas), so look there too
+freeNamesIfLetBndr (IfLetBndr _name ty info _ji) = freeNamesIfType ty
+ &&& freeNamesIfIdInfo info
+
+freeNamesIfTvBndr :: IfaceTvBndr -> NameSet
+freeNamesIfTvBndr (_fs,k) = freeNamesIfKind k
+ -- kinds can have Names inside, because of promotion
+
+freeNamesIfIdBndr :: IfaceIdBndr -> NameSet
+freeNamesIfIdBndr (_fs,k) = freeNamesIfKind k
+
+freeNamesIfIdInfo :: IfaceIdInfo -> NameSet
+freeNamesIfIdInfo NoInfo = emptyNameSet
+freeNamesIfIdInfo (HasInfo i) = fnList freeNamesItem i
+
+freeNamesItem :: IfaceInfoItem -> NameSet
+freeNamesItem (HsUnfold _ u) = freeNamesIfUnfold u
+freeNamesItem _ = emptyNameSet
+
+freeNamesIfUnfold :: IfaceUnfolding -> NameSet
+freeNamesIfUnfold (IfCoreUnfold _ e) = freeNamesIfExpr e
+freeNamesIfUnfold (IfCompulsory e) = freeNamesIfExpr e
+freeNamesIfUnfold (IfInlineRule _ _ _ e) = freeNamesIfExpr e
+freeNamesIfUnfold (IfDFunUnfold bs es) = freeNamesIfBndrs bs &&& fnList freeNamesIfExpr es
+
+freeNamesIfExpr :: IfaceExpr -> NameSet
+freeNamesIfExpr (IfaceExt v) = unitNameSet v
+freeNamesIfExpr (IfaceFCall _ ty) = freeNamesIfType ty
+freeNamesIfExpr (IfaceType ty) = freeNamesIfType ty
+freeNamesIfExpr (IfaceCo co) = freeNamesIfCoercion co
+freeNamesIfExpr (IfaceTuple _ as) = fnList freeNamesIfExpr as
+freeNamesIfExpr (IfaceLam (b,_) body) = freeNamesIfBndr b &&& freeNamesIfExpr body
+freeNamesIfExpr (IfaceApp f a) = freeNamesIfExpr f &&& freeNamesIfExpr a
+freeNamesIfExpr (IfaceCast e co) = freeNamesIfExpr e &&& freeNamesIfCoercion co
+freeNamesIfExpr (IfaceTick _ e) = freeNamesIfExpr e
+freeNamesIfExpr (IfaceECase e ty) = freeNamesIfExpr e &&& freeNamesIfType ty
+freeNamesIfExpr (IfaceCase s _ alts)
+ = freeNamesIfExpr s &&& fnList fn_alt alts &&& fn_cons alts
+ where
+ fn_alt (_con,_bs,r) = freeNamesIfExpr r
+
+ -- Depend on the data constructors. Just one will do!
+ -- Note [Tracking data constructors]
+ fn_cons [] = emptyNameSet
+ fn_cons ((IfaceDefault ,_,_) : xs) = fn_cons xs
+ fn_cons ((IfaceDataAlt con,_,_) : _ ) = unitNameSet con
+ fn_cons (_ : _ ) = emptyNameSet
+
+freeNamesIfExpr (IfaceLet (IfaceNonRec bndr rhs) body)
+ = freeNamesIfLetBndr bndr &&& freeNamesIfExpr rhs &&& freeNamesIfExpr body
+
+freeNamesIfExpr (IfaceLet (IfaceRec as) x)
+ = fnList fn_pair as &&& freeNamesIfExpr x
+ where
+ fn_pair (bndr, rhs) = freeNamesIfLetBndr bndr &&& freeNamesIfExpr rhs
+
+freeNamesIfExpr _ = emptyNameSet
+
+freeNamesIfTc :: IfaceTyCon -> NameSet
+freeNamesIfTc tc = unitNameSet (ifaceTyConName tc)
+-- ToDo: shouldn't we include IfaceIntTc & co.?
+
+freeNamesIfRule :: IfaceRule -> NameSet
+freeNamesIfRule (IfaceRule { ifRuleBndrs = bs, ifRuleHead = f
+ , ifRuleArgs = es, ifRuleRhs = rhs })
+ = unitNameSet f &&&
+ fnList freeNamesIfBndr bs &&&
+ fnList freeNamesIfExpr es &&&
+ freeNamesIfExpr rhs
+
+freeNamesIfFamInst :: IfaceFamInst -> NameSet
+freeNamesIfFamInst (IfaceFamInst { ifFamInstFam = famName
+ , ifFamInstAxiom = axName })
+ = unitNameSet famName &&&
+ unitNameSet axName
+
+freeNamesIfaceTyConParent :: IfaceTyConParent -> NameSet
+freeNamesIfaceTyConParent IfNoParent = emptyNameSet
+freeNamesIfaceTyConParent (IfDataInstance ax tc tys)
+ = unitNameSet ax &&& freeNamesIfTc tc &&& freeNamesIfTcArgs tys
+
+-- helpers
+(&&&) :: NameSet -> NameSet -> NameSet
+(&&&) = unionNameSet
+
+fnList :: (a -> NameSet) -> [a] -> NameSet
+fnList f = foldr (&&&) emptyNameSet . map f
+
+{-
+Note [Tracking data constructors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In a case expression
+ case e of { C a -> ...; ... }
+You might think that we don't need to include the datacon C
+in the free names, because its type will probably show up in
+the free names of 'e'. But in rare circumstances this may
+not happen. Here's the one that bit me:
+
+ module DynFlags where
+ import {-# SOURCE #-} Packages( PackageState )
+ data DynFlags = DF ... PackageState ...
+
+ module Packages where
+ import DynFlags
+ data PackageState = PS ...
+ lookupModule (df :: DynFlags)
+ = case df of
+ DF ...p... -> case p of
+ PS ... -> ...
+
+Now, lookupModule depends on DynFlags, but the transitive dependency
+on the *locally-defined* type PackageState is not visible. We need
+to take account of the use of the data constructor PS in the pattern match.
+
+
+************************************************************************
+* *
+ Binary instances
+* *
+************************************************************************
+
+Note that there is a bit of subtlety here when we encode names. While
+IfaceTopBndrs is really just a synonym for Name, we need to take care to
+encode them with {get,put}IfaceTopBndr. The difference becomes important when
+we go to fingerprint an IfaceDecl. See Note [Fingerprinting IfaceDecls] for
+details.
+
+-}
+
+instance Binary IfaceDecl where
+ put_ bh (IfaceId name ty details idinfo) = do
+ putByte bh 0
+ putIfaceTopBndr bh name
+ lazyPut bh (ty, details, idinfo)
+ -- See Note [Lazy deserialization of IfaceId]
+
+ put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7 a8 a9) = do
+ putByte bh 2
+ putIfaceTopBndr bh a1
+ put_ bh a2
+ put_ bh a3
+ put_ bh a4
+ put_ bh a5
+ put_ bh a6
+ put_ bh a7
+ put_ bh a8
+ put_ bh a9
+
+ put_ bh (IfaceSynonym a1 a2 a3 a4 a5) = do
+ putByte bh 3
+ putIfaceTopBndr bh a1
+ put_ bh a2
+ put_ bh a3
+ put_ bh a4
+ put_ bh a5
+
+ put_ bh (IfaceFamily a1 a2 a3 a4 a5 a6) = do
+ putByte bh 4
+ putIfaceTopBndr bh a1
+ put_ bh a2
+ put_ bh a3
+ put_ bh a4
+ put_ bh a5
+ put_ bh a6
+
+ -- NB: Written in a funny way to avoid an interface change
+ put_ bh (IfaceClass {
+ ifName = a2,
+ ifRoles = a3,
+ ifBinders = a4,
+ ifFDs = a5,
+ ifBody = IfConcreteClass {
+ ifClassCtxt = a1,
+ ifATs = a6,
+ ifSigs = a7,
+ ifMinDef = a8
+ }}) = do
+ putByte bh 5
+ put_ bh a1
+ putIfaceTopBndr bh a2
+ put_ bh a3
+ put_ bh a4
+ put_ bh a5
+ put_ bh a6
+ put_ bh a7
+ put_ bh a8
+
+ put_ bh (IfaceAxiom a1 a2 a3 a4) = do
+ putByte bh 6
+ putIfaceTopBndr bh a1
+ put_ bh a2
+ put_ bh a3
+ put_ bh a4
+
+ put_ bh (IfacePatSyn a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11) = do
+ putByte bh 7
+ putIfaceTopBndr bh a1
+ put_ bh a2
+ put_ bh a3
+ put_ bh a4
+ put_ bh a5
+ put_ bh a6
+ put_ bh a7
+ put_ bh a8
+ put_ bh a9
+ put_ bh a10
+ put_ bh a11
+
+ put_ bh (IfaceClass {
+ ifName = a1,
+ ifRoles = a2,
+ ifBinders = a3,
+ ifFDs = a4,
+ ifBody = IfAbstractClass }) = do
+ putByte bh 8
+ putIfaceTopBndr bh a1
+ put_ bh a2
+ put_ bh a3
+ put_ bh a4
+
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> do name <- get bh
+ ~(ty, details, idinfo) <- lazyGet bh
+ -- See Note [Lazy deserialization of IfaceId]
+ return (IfaceId name ty details idinfo)
+ 1 -> error "Binary.get(TyClDecl): ForeignType"
+ 2 -> do a1 <- getIfaceTopBndr bh
+ a2 <- get bh
+ a3 <- get bh
+ a4 <- get bh
+ a5 <- get bh
+ a6 <- get bh
+ a7 <- get bh
+ a8 <- get bh
+ a9 <- get bh
+ return (IfaceData a1 a2 a3 a4 a5 a6 a7 a8 a9)
+ 3 -> do a1 <- getIfaceTopBndr bh
+ a2 <- get bh
+ a3 <- get bh
+ a4 <- get bh
+ a5 <- get bh
+ return (IfaceSynonym a1 a2 a3 a4 a5)
+ 4 -> do a1 <- getIfaceTopBndr bh
+ a2 <- get bh
+ a3 <- get bh
+ a4 <- get bh
+ a5 <- get bh
+ a6 <- get bh
+ return (IfaceFamily a1 a2 a3 a4 a5 a6)
+ 5 -> do a1 <- get bh
+ a2 <- getIfaceTopBndr bh
+ a3 <- get bh
+ a4 <- get bh
+ a5 <- get bh
+ a6 <- get bh
+ a7 <- get bh
+ a8 <- get bh
+ return (IfaceClass {
+ ifName = a2,
+ ifRoles = a3,
+ ifBinders = a4,
+ ifFDs = a5,
+ ifBody = IfConcreteClass {
+ ifClassCtxt = a1,
+ ifATs = a6,
+ ifSigs = a7,
+ ifMinDef = a8
+ }})
+ 6 -> do a1 <- getIfaceTopBndr bh
+ a2 <- get bh
+ a3 <- get bh
+ a4 <- get bh
+ return (IfaceAxiom a1 a2 a3 a4)
+ 7 -> do a1 <- getIfaceTopBndr bh
+ a2 <- get bh
+ a3 <- get bh
+ a4 <- get bh
+ a5 <- get bh
+ a6 <- get bh
+ a7 <- get bh
+ a8 <- get bh
+ a9 <- get bh
+ a10 <- get bh
+ a11 <- get bh
+ return (IfacePatSyn a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11)
+ 8 -> do a1 <- getIfaceTopBndr bh
+ a2 <- get bh
+ a3 <- get bh
+ a4 <- get bh
+ return (IfaceClass {
+ ifName = a1,
+ ifRoles = a2,
+ ifBinders = a3,
+ ifFDs = a4,
+ ifBody = IfAbstractClass })
+ _ -> panic (unwords ["Unknown IfaceDecl tag:", show h])
+
+{- Note [Lazy deserialization of IfaceId]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The use of lazyPut and lazyGet in the IfaceId Binary instance is
+purely for performance reasons, to avoid deserializing details about
+identifiers that will never be used. It's not involved in tying the
+knot in the type checker. It saved ~1% of the total build time of GHC.
+
+When we read an interface file, we extend the PTE, a mapping of Names
+to TyThings, with the declarations we have read. The extension of the
+PTE is strict in the Names, but not in the TyThings themselves.
+LoadIface.loadDecl calculates the list of (Name, TyThing) bindings to
+add to the PTE. For an IfaceId, there's just one binding to add; and
+the ty, details, and idinfo fields of an IfaceId are used only in the
+TyThing. So by reading those fields lazily we may be able to save the
+work of ever having to deserialize them (into IfaceType, etc.).
+
+For IfaceData and IfaceClass, loadDecl creates extra implicit bindings
+(the constructors and field selectors of the data declaration, or the
+methods of the class), whose Names depend on more than just the Name
+of the type constructor or class itself. So deserializing them lazily
+would be more involved. Similar comments apply to the other
+constructors of IfaceDecl with the additional point that they probably
+represent a small proportion of all declarations.
+-}
+
+instance Binary IfaceFamTyConFlav where
+ put_ bh IfaceDataFamilyTyCon = putByte bh 0
+ put_ bh IfaceOpenSynFamilyTyCon = putByte bh 1
+ put_ bh (IfaceClosedSynFamilyTyCon mb) = putByte bh 2 >> put_ bh mb
+ put_ bh IfaceAbstractClosedSynFamilyTyCon = putByte bh 3
+ put_ _ IfaceBuiltInSynFamTyCon
+ = pprPanic "Cannot serialize IfaceBuiltInSynFamTyCon, used for pretty-printing only" Outputable.empty
+
+ get bh = do { h <- getByte bh
+ ; case h of
+ 0 -> return IfaceDataFamilyTyCon
+ 1 -> return IfaceOpenSynFamilyTyCon
+ 2 -> do { mb <- get bh
+ ; return (IfaceClosedSynFamilyTyCon mb) }
+ 3 -> return IfaceAbstractClosedSynFamilyTyCon
+ _ -> pprPanic "Binary.get(IfaceFamTyConFlav): Invalid tag"
+ (ppr (fromIntegral h :: Int)) }
+
+instance Binary IfaceClassOp where
+ put_ bh (IfaceClassOp n ty def) = do
+ putIfaceTopBndr bh n
+ put_ bh ty
+ put_ bh def
+ get bh = do
+ n <- getIfaceTopBndr bh
+ ty <- get bh
+ def <- get bh
+ return (IfaceClassOp n ty def)
+
+instance Binary IfaceAT where
+ put_ bh (IfaceAT dec defs) = do
+ put_ bh dec
+ put_ bh defs
+ get bh = do
+ dec <- get bh
+ defs <- get bh
+ return (IfaceAT dec defs)
+
+instance Binary IfaceAxBranch where
+ put_ bh (IfaceAxBranch a1 a2 a3 a4 a5 a6) = do
+ put_ bh a1
+ put_ bh a2
+ put_ bh a3
+ put_ bh a4
+ put_ bh a5
+ put_ bh a6
+ get bh = do
+ a1 <- get bh
+ a2 <- get bh
+ a3 <- get bh
+ a4 <- get bh
+ a5 <- get bh
+ a6 <- get bh
+ return (IfaceAxBranch a1 a2 a3 a4 a5 a6)
+
+instance Binary IfaceConDecls where
+ put_ bh IfAbstractTyCon = putByte bh 0
+ put_ bh (IfDataTyCon cs) = putByte bh 1 >> put_ bh cs
+ put_ bh (IfNewTyCon c) = putByte bh 2 >> put_ bh c
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> return IfAbstractTyCon
+ 1 -> liftM IfDataTyCon (get bh)
+ 2 -> liftM IfNewTyCon (get bh)
+ _ -> error "Binary(IfaceConDecls).get: Invalid IfaceConDecls"
+
+instance Binary IfaceConDecl where
+ put_ bh (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) = do
+ putIfaceTopBndr bh a1
+ put_ bh a2
+ put_ bh a3
+ put_ bh a4
+ put_ bh a5
+ put_ bh a6
+ put_ bh a7
+ put_ bh (length a8)
+ mapM_ (put_ bh) a8
+ put_ bh a9
+ put_ bh a10
+ get bh = do
+ a1 <- getIfaceTopBndr bh
+ a2 <- get bh
+ a3 <- get bh
+ a4 <- get bh
+ a5 <- get bh
+ a6 <- get bh
+ a7 <- get bh
+ n_fields <- get bh
+ a8 <- replicateM n_fields (get bh)
+ a9 <- get bh
+ a10 <- get bh
+ return (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10)
+
+instance Binary IfaceBang where
+ put_ bh IfNoBang = putByte bh 0
+ put_ bh IfStrict = putByte bh 1
+ put_ bh IfUnpack = putByte bh 2
+ put_ bh (IfUnpackCo co) = putByte bh 3 >> put_ bh co
+
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> do return IfNoBang
+ 1 -> do return IfStrict
+ 2 -> do return IfUnpack
+ _ -> do { a <- get bh; return (IfUnpackCo a) }
+
+instance Binary IfaceSrcBang where
+ put_ bh (IfSrcBang a1 a2) =
+ do put_ bh a1
+ put_ bh a2
+
+ get bh =
+ do a1 <- get bh
+ a2 <- get bh
+ return (IfSrcBang a1 a2)
+
+instance Binary IfaceClsInst where
+ put_ bh (IfaceClsInst cls tys dfun flag orph) = do
+ put_ bh cls
+ put_ bh tys
+ put_ bh dfun
+ put_ bh flag
+ put_ bh orph
+ get bh = do
+ cls <- get bh
+ tys <- get bh
+ dfun <- get bh
+ flag <- get bh
+ orph <- get bh
+ return (IfaceClsInst cls tys dfun flag orph)
+
+instance Binary IfaceFamInst where
+ put_ bh (IfaceFamInst fam tys name orph) = do
+ put_ bh fam
+ put_ bh tys
+ put_ bh name
+ put_ bh orph
+ get bh = do
+ fam <- get bh
+ tys <- get bh
+ name <- get bh
+ orph <- get bh
+ return (IfaceFamInst fam tys name orph)
+
+instance Binary IfaceRule where
+ put_ bh (IfaceRule a1 a2 a3 a4 a5 a6 a7 a8) = do
+ put_ bh a1
+ put_ bh a2
+ put_ bh a3
+ put_ bh a4
+ put_ bh a5
+ put_ bh a6
+ put_ bh a7
+ put_ bh a8
+ get bh = do
+ a1 <- get bh
+ a2 <- get bh
+ a3 <- get bh
+ a4 <- get bh
+ a5 <- get bh
+ a6 <- get bh
+ a7 <- get bh
+ a8 <- get bh
+ return (IfaceRule a1 a2 a3 a4 a5 a6 a7 a8)
+
+instance Binary IfaceAnnotation where
+ put_ bh (IfaceAnnotation a1 a2) = do
+ put_ bh a1
+ put_ bh a2
+ get bh = do
+ a1 <- get bh
+ a2 <- get bh
+ return (IfaceAnnotation a1 a2)
+
+instance Binary IfaceIdDetails where
+ put_ bh IfVanillaId = putByte bh 0
+ put_ bh (IfRecSelId a b) = putByte bh 1 >> put_ bh a >> put_ bh b
+ put_ bh IfDFunId = putByte bh 2
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> return IfVanillaId
+ 1 -> do { a <- get bh; b <- get bh; return (IfRecSelId a b) }
+ _ -> return IfDFunId
+
+instance Binary IfaceIdInfo where
+ put_ bh NoInfo = putByte bh 0
+ put_ bh (HasInfo i) = putByte bh 1 >> lazyPut bh i -- NB lazyPut
+
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> return NoInfo
+ _ -> liftM HasInfo $ lazyGet bh -- NB lazyGet
+
+instance Binary IfaceInfoItem where
+ put_ bh (HsArity aa) = putByte bh 0 >> put_ bh aa
+ put_ bh (HsStrictness ab) = putByte bh 1 >> put_ bh ab
+ put_ bh (HsUnfold lb ad) = putByte bh 2 >> put_ bh lb >> put_ bh ad
+ put_ bh (HsInline ad) = putByte bh 3 >> put_ bh ad
+ put_ bh HsNoCafRefs = putByte bh 4
+ put_ bh HsLevity = putByte bh 5
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> liftM HsArity $ get bh
+ 1 -> liftM HsStrictness $ get bh
+ 2 -> do lb <- get bh
+ ad <- get bh
+ return (HsUnfold lb ad)
+ 3 -> liftM HsInline $ get bh
+ 4 -> return HsNoCafRefs
+ _ -> return HsLevity
+
+instance Binary IfaceUnfolding where
+ put_ bh (IfCoreUnfold s e) = do
+ putByte bh 0
+ put_ bh s
+ put_ bh e
+ put_ bh (IfInlineRule a b c d) = do
+ putByte bh 1
+ put_ bh a
+ put_ bh b
+ put_ bh c
+ put_ bh d
+ put_ bh (IfDFunUnfold as bs) = do
+ putByte bh 2
+ put_ bh as
+ put_ bh bs
+ put_ bh (IfCompulsory e) = do
+ putByte bh 3
+ put_ bh e
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> do s <- get bh
+ e <- get bh
+ return (IfCoreUnfold s e)
+ 1 -> do a <- get bh
+ b <- get bh
+ c <- get bh
+ d <- get bh
+ return (IfInlineRule a b c d)
+ 2 -> do as <- get bh
+ bs <- get bh
+ return (IfDFunUnfold as bs)
+ _ -> do e <- get bh
+ return (IfCompulsory e)
+
+
+instance Binary IfaceExpr where
+ put_ bh (IfaceLcl aa) = do
+ putByte bh 0
+ put_ bh aa
+ put_ bh (IfaceType ab) = do
+ putByte bh 1
+ put_ bh ab
+ put_ bh (IfaceCo ab) = do
+ putByte bh 2
+ put_ bh ab
+ put_ bh (IfaceTuple ac ad) = do
+ putByte bh 3
+ put_ bh ac
+ put_ bh ad
+ put_ bh (IfaceLam (ae, os) af) = do
+ putByte bh 4
+ put_ bh ae
+ put_ bh os
+ put_ bh af
+ put_ bh (IfaceApp ag ah) = do
+ putByte bh 5
+ put_ bh ag
+ put_ bh ah
+ put_ bh (IfaceCase ai aj ak) = do
+ putByte bh 6
+ put_ bh ai
+ put_ bh aj
+ put_ bh ak
+ put_ bh (IfaceLet al am) = do
+ putByte bh 7
+ put_ bh al
+ put_ bh am
+ put_ bh (IfaceTick an ao) = do
+ putByte bh 8
+ put_ bh an
+ put_ bh ao
+ put_ bh (IfaceLit ap) = do
+ putByte bh 9
+ put_ bh ap
+ put_ bh (IfaceFCall as at) = do
+ putByte bh 10
+ put_ bh as
+ put_ bh at
+ put_ bh (IfaceExt aa) = do
+ putByte bh 11
+ put_ bh aa
+ put_ bh (IfaceCast ie ico) = do
+ putByte bh 12
+ put_ bh ie
+ put_ bh ico
+ put_ bh (IfaceECase a b) = do
+ putByte bh 13
+ put_ bh a
+ put_ bh b
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> do aa <- get bh
+ return (IfaceLcl aa)
+ 1 -> do ab <- get bh
+ return (IfaceType ab)
+ 2 -> do ab <- get bh
+ return (IfaceCo ab)
+ 3 -> do ac <- get bh
+ ad <- get bh
+ return (IfaceTuple ac ad)
+ 4 -> do ae <- get bh
+ os <- get bh
+ af <- get bh
+ return (IfaceLam (ae, os) af)
+ 5 -> do ag <- get bh
+ ah <- get bh
+ return (IfaceApp ag ah)
+ 6 -> do ai <- get bh
+ aj <- get bh
+ ak <- get bh
+ return (IfaceCase ai aj ak)
+ 7 -> do al <- get bh
+ am <- get bh
+ return (IfaceLet al am)
+ 8 -> do an <- get bh
+ ao <- get bh
+ return (IfaceTick an ao)
+ 9 -> do ap <- get bh
+ return (IfaceLit ap)
+ 10 -> do as <- get bh
+ at <- get bh
+ return (IfaceFCall as at)
+ 11 -> do aa <- get bh
+ return (IfaceExt aa)
+ 12 -> do ie <- get bh
+ ico <- get bh
+ return (IfaceCast ie ico)
+ 13 -> do a <- get bh
+ b <- get bh
+ return (IfaceECase a b)
+ _ -> panic ("get IfaceExpr " ++ show h)
+
+instance Binary IfaceTickish where
+ put_ bh (IfaceHpcTick m ix) = do
+ putByte bh 0
+ put_ bh m
+ put_ bh ix
+ put_ bh (IfaceSCC cc tick push) = do
+ putByte bh 1
+ put_ bh cc
+ put_ bh tick
+ put_ bh push
+ put_ bh (IfaceSource src name) = do
+ putByte bh 2
+ put_ bh (srcSpanFile src)
+ put_ bh (srcSpanStartLine src)
+ put_ bh (srcSpanStartCol src)
+ put_ bh (srcSpanEndLine src)
+ put_ bh (srcSpanEndCol src)
+ put_ bh name
+
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> do m <- get bh
+ ix <- get bh
+ return (IfaceHpcTick m ix)
+ 1 -> do cc <- get bh
+ tick <- get bh
+ push <- get bh
+ return (IfaceSCC cc tick push)
+ 2 -> do file <- get bh
+ sl <- get bh
+ sc <- get bh
+ el <- get bh
+ ec <- get bh
+ let start = mkRealSrcLoc file sl sc
+ end = mkRealSrcLoc file el ec
+ name <- get bh
+ return (IfaceSource (mkRealSrcSpan start end) name)
+ _ -> panic ("get IfaceTickish " ++ show h)
+
+instance Binary IfaceConAlt where
+ put_ bh IfaceDefault = putByte bh 0
+ put_ bh (IfaceDataAlt aa) = putByte bh 1 >> put_ bh aa
+ put_ bh (IfaceLitAlt ac) = putByte bh 2 >> put_ bh ac
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> return IfaceDefault
+ 1 -> liftM IfaceDataAlt $ get bh
+ _ -> liftM IfaceLitAlt $ get bh
+
+instance Binary IfaceBinding where
+ put_ bh (IfaceNonRec aa ab) = putByte bh 0 >> put_ bh aa >> put_ bh ab
+ put_ bh (IfaceRec ac) = putByte bh 1 >> put_ bh ac
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> do { aa <- get bh; ab <- get bh; return (IfaceNonRec aa ab) }
+ _ -> do { ac <- get bh; return (IfaceRec ac) }
+
+instance Binary IfaceLetBndr where
+ put_ bh (IfLetBndr a b c d) = do
+ put_ bh a
+ put_ bh b
+ put_ bh c
+ put_ bh d
+ get bh = do a <- get bh
+ b <- get bh
+ c <- get bh
+ d <- get bh
+ return (IfLetBndr a b c d)
+
+instance Binary IfaceJoinInfo where
+ put_ bh IfaceNotJoinPoint = putByte bh 0
+ put_ bh (IfaceJoinPoint ar) = do
+ putByte bh 1
+ put_ bh ar
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> return IfaceNotJoinPoint
+ _ -> liftM IfaceJoinPoint $ get bh
+
+instance Binary IfaceTyConParent where
+ put_ bh IfNoParent = putByte bh 0
+ put_ bh (IfDataInstance ax pr ty) = do
+ putByte bh 1
+ put_ bh ax
+ put_ bh pr
+ put_ bh ty
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> return IfNoParent
+ _ -> do
+ ax <- get bh
+ pr <- get bh
+ ty <- get bh
+ return $ IfDataInstance ax pr ty
+
+instance Binary IfaceCompleteMatch where
+ put_ bh (IfaceCompleteMatch cs ts) = put_ bh cs >> put_ bh ts
+ get bh = IfaceCompleteMatch <$> get bh <*> get bh
diff --git a/iface/IfaceType.hs b/iface/IfaceType.hs
new file mode 100644
--- /dev/null
+++ b/iface/IfaceType.hs
@@ -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) }
diff --git a/iface/IfaceType.hs-boot b/iface/IfaceType.hs-boot
new file mode 100644
--- /dev/null
+++ b/iface/IfaceType.hs-boot
@@ -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
diff --git a/iface/LoadIface.hs b/iface/LoadIface.hs
new file mode 100644
--- /dev/null
+++ b/iface/LoadIface.hs
@@ -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=]:M@ but we only
+-- have an interface for @p[A=]:M@ (the indefinite interface.
+-- If we are not trying to build code, we load the interface we have,
+-- *instantiating it* according to how the holes are specified.
+-- (Of course, if we're actually building code, this is a hard error.)
+--
+-- In the presence of holes, 'computeInterface' has an important invariant:
+-- to load module M, its set of transitively reachable requirements must
+-- have an up-to-date local hi file for that requirement. Note that if
+-- we are loading the interface of a requirement, this does not
+-- apply to the requirement itself; e.g., @p[A=]:A@ does not require
+-- A.hi to be up-to-date (and indeed, we MUST NOT attempt to read A.hi, unless
+-- we are actually typechecking p.)
+computeInterface ::
+ SDoc -> IsBootInterface -> Module
+ -> TcRnIf gbl lcl (MaybeErr MsgDoc (ModIface, FilePath))
+computeInterface doc_str hi_boot_file mod0 = do
+ MASSERT( not (isHoleModule mod0) )
+ dflags <- getDynFlags
+ case splitModuleInsts mod0 of
+ (imod, Just indef) | not (unitIdIsDefinite (thisPackage dflags)) -> do
+ r <- findAndReadIface doc_str imod mod0 hi_boot_file
+ case r of
+ Succeeded (iface0, path) -> do
+ hsc_env <- getTopEnv
+ r <- liftIO $
+ rnModIface hsc_env (indefUnitIdInsts (indefModuleUnitId indef))
+ Nothing iface0
+ case r of
+ Right x -> return (Succeeded (x, path))
+ Left errs -> liftIO . throwIO . mkSrcErr $ errs
+ Failed err -> return (Failed err)
+ (mod, _) ->
+ findAndReadIface doc_str mod mod0 hi_boot_file
+
+-- | Compute the signatures which must be compiled in order to
+-- load the interface for a 'Module'. The output of this function
+-- is always a subset of 'moduleFreeHoles'; it is more precise
+-- because in signature @p[A=,B=]:B@, although the free holes
+-- are A and B, B might not depend on A at all!
+--
+-- If this is invoked on a signature, this does NOT include the
+-- signature itself; e.g. precise free module holes of
+-- @p[A=,B=]:B@ never includes B.
+moduleFreeHolesPrecise
+ :: SDoc -> Module
+ -> TcRnIf gbl lcl (MaybeErr MsgDoc (UniqDSet ModuleName))
+moduleFreeHolesPrecise doc_str mod
+ | moduleIsDefinite mod = return (Succeeded emptyUniqDSet)
+ | otherwise =
+ case splitModuleInsts mod of
+ (imod, Just indef) -> do
+ let insts = indefUnitIdInsts (indefModuleUnitId indef)
+ traceIf (text "Considering whether to load" <+> ppr mod <+>
+ text "to compute precise free module holes")
+ (eps, hpt) <- getEpsAndHpt
+ dflags <- getDynFlags
+ case tryEpsAndHpt dflags eps hpt `firstJust` tryDepsCache eps imod insts of
+ Just r -> return (Succeeded r)
+ Nothing -> readAndCache imod insts
+ (_, Nothing) -> return (Succeeded emptyUniqDSet)
+ where
+ tryEpsAndHpt dflags eps hpt =
+ fmap mi_free_holes (lookupIfaceByModule dflags hpt (eps_PIT eps) mod)
+ tryDepsCache eps imod insts =
+ case lookupInstalledModuleEnv (eps_free_holes eps) imod of
+ Just ifhs -> Just (renameFreeHoles ifhs insts)
+ _otherwise -> Nothing
+ readAndCache imod insts = do
+ mb_iface <- findAndReadIface (text "moduleFreeHolesPrecise" <+> doc_str) imod mod False
+ case mb_iface of
+ Succeeded (iface, _) -> do
+ let ifhs = mi_free_holes iface
+ -- Cache it
+ updateEps_ (\eps ->
+ eps { eps_free_holes = extendInstalledModuleEnv (eps_free_holes eps) imod ifhs })
+ return (Succeeded (renameFreeHoles ifhs insts))
+ Failed err -> return (Failed err)
+
+wantHiBootFile :: DynFlags -> ExternalPackageState -> Module -> WhereFrom
+ -> MaybeErr MsgDoc IsBootInterface
+-- Figure out whether we want Foo.hi or Foo.hi-boot
+wantHiBootFile dflags eps mod from
+ = case from of
+ ImportByUser usr_boot
+ | usr_boot && not this_package
+ -> Failed (badSourceImport mod)
+ | otherwise -> Succeeded usr_boot
+
+ ImportByPlugin
+ -> Succeeded False
+
+ ImportBySystem
+ | not this_package -- If the module to be imported is not from this package
+ -> Succeeded False -- don't look it up in eps_is_boot, because that is keyed
+ -- on the ModuleName of *home-package* modules only.
+ -- We never import boot modules from other packages!
+
+ | otherwise
+ -> case lookupUFM (eps_is_boot eps) (moduleName mod) of
+ Just (_, is_boot) -> Succeeded is_boot
+ Nothing -> Succeeded False
+ -- The boot-ness of the requested interface,
+ -- based on the dependencies in directly-imported modules
+ where
+ this_package = thisPackage dflags == moduleUnitId mod
+
+badSourceImport :: Module -> SDoc
+badSourceImport mod
+ = hang (text "You cannot {-# SOURCE #-} import a module from another package")
+ 2 (text "but" <+> quotes (ppr mod) <+> ptext (sLit "is from package")
+ <+> quotes (ppr (moduleUnitId mod)))
+
+-----------------------------------------------------
+-- Loading type/class/value decls
+-- We pass the full Module name here, replete with
+-- its package info, so that we can build a Name for
+-- each binder with the right package info in it
+-- All subsequent lookups, including crucially lookups during typechecking
+-- the declaration itself, will find the fully-glorious Name
+--
+-- We handle ATs specially. They are not main declarations, but also not
+-- implicit things (in particular, adding them to `implicitTyThings' would mess
+-- things up in the renaming/type checking of source programs).
+-----------------------------------------------------
+
+addDeclsToPTE :: PackageTypeEnv -> [(Name,TyThing)] -> PackageTypeEnv
+addDeclsToPTE pte things = extendNameEnvList pte things
+
+loadDecls :: Bool
+ -> [(Fingerprint, IfaceDecl)]
+ -> IfL [(Name,TyThing)]
+loadDecls ignore_prags ver_decls
+ = do { thingss <- mapM (loadDecl ignore_prags) ver_decls
+ ; return (concat thingss)
+ }
+
+loadDecl :: Bool -- Don't load pragmas into the decl pool
+ -> (Fingerprint, IfaceDecl)
+ -> IfL [(Name,TyThing)] -- The list can be poked eagerly, but the
+ -- TyThings are forkM'd thunks
+loadDecl ignore_prags (_version, decl)
+ = do { -- Populate the name cache with final versions of all
+ -- the names associated with the decl
+ let main_name = ifName decl
+
+ -- Typecheck the thing, lazily
+ -- NB. Firstly, the laziness is there in case we never need the
+ -- declaration (in one-shot mode), and secondly it is there so that
+ -- we don't look up the occurrence of a name before calling mk_new_bndr
+ -- on the binder. This is important because we must get the right name
+ -- which includes its nameParent.
+
+ ; thing <- forkM doc $ do { bumpDeclStats main_name
+ ; tcIfaceDecl ignore_prags decl }
+
+ -- Populate the type environment with the implicitTyThings too.
+ --
+ -- Note [Tricky iface loop]
+ -- ~~~~~~~~~~~~~~~~~~~~~~~~
+ -- Summary: The delicate point here is that 'mini-env' must be
+ -- buildable from 'thing' without demanding any of the things
+ -- 'forkM'd by tcIfaceDecl.
+ --
+ -- In more detail: Consider the example
+ -- data T a = MkT { x :: T a }
+ -- The implicitTyThings of T are: [ , ]
+ -- (plus their workers, wrappers, coercions etc etc)
+ --
+ -- We want to return an environment
+ -- [ "MkT" -> , "x" -> , ... ]
+ -- (where the "MkT" is the *Name* associated with MkT, etc.)
+ --
+ -- We do this by mapping the implicit_names to the associated
+ -- TyThings. By the invariant on ifaceDeclImplicitBndrs and
+ -- implicitTyThings, we can use getOccName on the implicit
+ -- TyThings to make this association: each Name's OccName should
+ -- be the OccName of exactly one implicitTyThing. So the key is
+ -- to define a "mini-env"
+ --
+ -- [ 'MkT' -> , 'x' -> , ... ]
+ -- where the 'MkT' here is the *OccName* associated with MkT.
+ --
+ -- However, there is a subtlety: due to how type checking needs
+ -- to be staged, we can't poke on the forkM'd thunks inside the
+ -- implicitTyThings while building this mini-env.
+ -- If we poke these thunks too early, two problems could happen:
+ -- (1) When processing mutually recursive modules across
+ -- hs-boot boundaries, poking too early will do the
+ -- type-checking before the recursive knot has been tied,
+ -- so things will be type-checked in the wrong
+ -- environment, and necessary variables won't be in
+ -- scope.
+ --
+ -- (2) Looking up one OccName in the mini_env will cause
+ -- others to be looked up, which might cause that
+ -- original one to be looked up again, and hence loop.
+ --
+ -- The code below works because of the following invariant:
+ -- getOccName on a TyThing does not force the suspended type
+ -- checks in order to extract the name. For example, we don't
+ -- poke on the "T a" type of on the way to
+ -- extracting 's OccName. Of course, there is no
+ -- reason in principle why getting the OccName should force the
+ -- thunks, but this means we need to be careful in
+ -- implicitTyThings and its helper functions.
+ --
+ -- All a bit too finely-balanced for my liking.
+
+ -- This mini-env and lookup function mediates between the
+ --'Name's n and the map from 'OccName's to the implicit TyThings
+ ; let mini_env = mkOccEnv [(getOccName t, t) | t <- implicitTyThings thing]
+ lookup n = case lookupOccEnv mini_env (getOccName n) of
+ Just thing -> thing
+ Nothing ->
+ pprPanic "loadDecl" (ppr main_name <+> ppr n $$ ppr (decl))
+
+ ; implicit_names <- mapM lookupIfaceTop (ifaceDeclImplicitBndrs decl)
+
+-- ; traceIf (text "Loading decl for " <> ppr main_name $$ ppr implicit_names)
+ ; return $ (main_name, thing) :
+ -- uses the invariant that implicit_names and
+ -- implicitTyThings are bijective
+ [(n, lookup n) | n <- implicit_names]
+ }
+ where
+ doc = text "Declaration for" <+> ppr (ifName decl)
+
+bumpDeclStats :: Name -> IfL () -- Record that one more declaration has actually been used
+bumpDeclStats name
+ = do { traceIf (text "Loading decl for" <+> ppr name)
+ ; updateEps_ (\eps -> let stats = eps_stats eps
+ in eps { eps_stats = stats { n_decls_out = n_decls_out stats + 1 } })
+ }
+
+{-
+*********************************************************
+* *
+\subsection{Reading an interface file}
+* *
+*********************************************************
+
+Note [Home module load error]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If the sought-for interface is in the current package (as determined
+by -package-name flag) then it jolly well should already be in the HPT
+because we process home-package modules in dependency order. (Except
+in one-shot mode; see notes with hsc_HPT decl in HscTypes).
+
+It is possible (though hard) to get this error through user behaviour.
+ * Suppose package P (modules P1, P2) depends on package Q (modules Q1,
+ Q2, with Q2 importing Q1)
+ * We compile both packages.
+ * Now we edit package Q so that it somehow depends on P
+ * Now recompile Q with --make (without recompiling P).
+ * Then Q1 imports, say, P1, which in turn depends on Q2. So Q2
+ is a home-package module which is not yet in the HPT! Disaster.
+
+This actually happened with P=base, Q=ghc-prim, via the AMP warnings.
+See Trac #8320.
+-}
+
+findAndReadIface :: SDoc
+ -- The unique identifier of the on-disk module we're
+ -- looking for
+ -> InstalledModule
+ -- The *actual* module we're looking for. We use
+ -- this to check the consistency of the requirements
+ -- of the module we read out.
+ -> Module
+ -> IsBootInterface -- True <=> Look for a .hi-boot file
+ -- False <=> Look for .hi file
+ -> TcRnIf gbl lcl (MaybeErr MsgDoc (ModIface, FilePath))
+ -- Nothing <=> file not found, or unreadable, or illegible
+ -- Just x <=> successfully found and parsed
+
+ -- It *doesn't* add an error to the monad, because
+ -- sometimes it's ok to fail... see notes with loadInterface
+findAndReadIface doc_str mod wanted_mod_with_insts hi_boot_file
+ = do traceIf (sep [hsep [text "Reading",
+ if hi_boot_file
+ then text "[boot]"
+ else Outputable.empty,
+ text "interface for",
+ ppr mod <> semi],
+ nest 4 (text "reason:" <+> doc_str)])
+
+ -- Check for GHC.Prim, and return its static interface
+ -- TODO: make this check a function
+ if mod `installedModuleEq` gHC_PRIM
+ then do
+ iface <- getHooked ghcPrimIfaceHook ghcPrimIface
+ return (Succeeded (iface,
+ ""))
+ else do
+ dflags <- getDynFlags
+ -- Look for the file
+ hsc_env <- getTopEnv
+ mb_found <- liftIO (findExactModule hsc_env mod)
+ case mb_found of
+ InstalledFound loc mod -> do
+ -- Found file, so read it
+ let file_path = addBootSuffix_maybe hi_boot_file
+ (ml_hi_file loc)
+
+ -- See Note [Home module load error]
+ if installedModuleUnitId mod `installedUnitIdEq` thisPackage dflags &&
+ not (isOneShot (ghcMode dflags))
+ then return (Failed (homeModError mod loc))
+ else do r <- read_file file_path
+ checkBuildDynamicToo r
+ return r
+ err -> do
+ traceIf (text "...not found")
+ dflags <- getDynFlags
+ return (Failed (cannotFindInterface dflags
+ (installedModuleName mod) err))
+ where read_file file_path = do
+ traceIf (text "readIFace" <+> text file_path)
+ -- Figure out what is recorded in mi_module. If this is
+ -- a fully definite interface, it'll match exactly, but
+ -- if it's indefinite, the inside will be uninstantiated!
+ dflags <- getDynFlags
+ let wanted_mod =
+ case splitModuleInsts wanted_mod_with_insts of
+ (_, Nothing) -> wanted_mod_with_insts
+ (_, Just indef_mod) ->
+ indefModuleToModule dflags
+ (generalizeIndefModule indef_mod)
+ read_result <- readIface wanted_mod file_path
+ case read_result of
+ Failed err -> return (Failed (badIfaceFile file_path err))
+ Succeeded iface -> return (Succeeded (iface, file_path))
+ -- Don't forget to fill in the package name...
+ checkBuildDynamicToo (Succeeded (iface, filePath)) = do
+ dflags <- getDynFlags
+ -- Indefinite interfaces are ALWAYS non-dynamic, and
+ -- that's OK.
+ let is_definite_iface = moduleIsDefinite (mi_module iface)
+ when is_definite_iface $
+ whenGeneratingDynamicToo dflags $ withDoDynamicToo $ do
+ let ref = canGenerateDynamicToo dflags
+ dynFilePath = addBootSuffix_maybe hi_boot_file
+ $ replaceExtension filePath (dynHiSuf dflags)
+ r <- read_file dynFilePath
+ case r of
+ Succeeded (dynIface, _)
+ | mi_mod_hash iface == mi_mod_hash dynIface ->
+ return ()
+ | otherwise ->
+ do traceIf (text "Dynamic hash doesn't match")
+ liftIO $ writeIORef ref False
+ Failed err ->
+ do traceIf (text "Failed to load dynamic interface file:" $$ err)
+ liftIO $ writeIORef ref False
+ checkBuildDynamicToo _ = return ()
+
+-- @readIface@ tries just the one file.
+
+readIface :: Module -> FilePath
+ -> TcRnIf gbl lcl (MaybeErr MsgDoc ModIface)
+ -- Failed err <=> file not found, or unreadable, or illegible
+ -- Succeeded iface <=> successfully found and parsed
+
+readIface wanted_mod file_path
+ = do { res <- tryMostM $
+ readBinIface CheckHiWay QuietBinIFaceReading file_path
+ ; dflags <- getDynFlags
+ ; case res of
+ Right iface
+ -- NB: This check is NOT just a sanity check, it is
+ -- critical for correctness of recompilation checking
+ -- (it lets us tell when -this-unit-id has changed.)
+ | wanted_mod == actual_mod
+ -> return (Succeeded iface)
+ | otherwise -> return (Failed err)
+ where
+ actual_mod = mi_module iface
+ err = hiModuleNameMismatchWarn dflags wanted_mod actual_mod
+
+ Left exn -> return (Failed (text (showException exn)))
+ }
+
+{-
+*********************************************************
+* *
+ Wired-in interface for GHC.Prim
+* *
+*********************************************************
+-}
+
+initExternalPackageState :: ExternalPackageState
+initExternalPackageState
+ = EPS {
+ eps_is_boot = emptyUFM,
+ eps_PIT = emptyPackageIfaceTable,
+ eps_free_holes = emptyInstalledModuleEnv,
+ eps_PTE = emptyTypeEnv,
+ eps_inst_env = emptyInstEnv,
+ eps_fam_inst_env = emptyFamInstEnv,
+ eps_rule_base = mkRuleBase builtinRules,
+ -- Initialise the EPS rule pool with the built-in rules
+ eps_mod_fam_inst_env
+ = emptyModuleEnv,
+ eps_vect_info = noVectInfo,
+ eps_complete_matches = emptyUFM,
+ eps_ann_env = emptyAnnEnv,
+ eps_stats = EpsStats { n_ifaces_in = 0, n_decls_in = 0, n_decls_out = 0
+ , n_insts_in = 0, n_insts_out = 0
+ , n_rules_in = length builtinRules, n_rules_out = 0 }
+ }
+
+{-
+*********************************************************
+* *
+ Wired-in interface for GHC.Prim
+* *
+*********************************************************
+-}
+
+ghcPrimIface :: ModIface
+ghcPrimIface
+ = (emptyModIface gHC_PRIM) {
+ mi_exports = ghcPrimExports,
+ mi_decls = [],
+ mi_fixities = fixities,
+ mi_fix_fn = mkIfaceFixCache fixities
+ }
+ where
+ fixities = (getOccName seqId, Fixity NoSourceText 0 InfixR)
+ -- seq is infixr 0
+ : (occName funTyConName, funTyFixity) -- trac #10145
+ : mapMaybe mkFixity allThePrimOps
+ mkFixity op = (,) (primOpOcc op) <$> primOpFixity op
+
+{-
+*********************************************************
+* *
+\subsection{Statistics}
+* *
+*********************************************************
+-}
+
+ifaceStats :: ExternalPackageState -> SDoc
+ifaceStats eps
+ = hcat [text "Renamer stats: ", msg]
+ where
+ stats = eps_stats eps
+ msg = vcat
+ [int (n_ifaces_in stats) <+> text "interfaces read",
+ hsep [ int (n_decls_out stats), text "type/class/variable imported, out of",
+ int (n_decls_in stats), text "read"],
+ hsep [ int (n_insts_out stats), text "instance decls imported, out of",
+ int (n_insts_in stats), text "read"],
+ hsep [ int (n_rules_out stats), text "rule decls imported, out of",
+ int (n_rules_in stats), text "read"]
+ ]
+
+{-
+************************************************************************
+* *
+ Printing interfaces
+* *
+************************************************************************
+-}
+
+-- | Read binary interface, and print it out
+showIface :: HscEnv -> FilePath -> IO ()
+showIface hsc_env filename = do
+ -- skip the hi way check; we don't want to worry about profiled vs.
+ -- non-profiled interfaces, for example.
+ iface <- initTcRnIf 's' hsc_env () () $
+ readBinIface IgnoreHiWay TraceBinIFaceReading filename
+ let dflags = hsc_dflags hsc_env
+ putLogMsg dflags NoReason SevDump noSrcSpan
+ (defaultDumpStyle dflags) (pprModIface iface)
+
+-- Show a ModIface but don't display details; suitable for ModIfaces stored in
+-- the EPT.
+pprModIfaceSimple :: ModIface -> SDoc
+pprModIfaceSimple iface = ppr (mi_module iface) $$ pprDeps (mi_deps iface) $$ nest 2 (vcat (map pprExport (mi_exports iface)))
+
+pprModIface :: ModIface -> SDoc
+-- Show a ModIface
+pprModIface iface
+ = vcat [ text "interface"
+ <+> ppr (mi_module iface) <+> pp_hsc_src (mi_hsc_src iface)
+ <+> (if mi_orphan iface then text "[orphan module]" else Outputable.empty)
+ <+> (if mi_finsts iface then text "[family instance module]" else Outputable.empty)
+ <+> (if mi_hpc iface then text "[hpc]" else Outputable.empty)
+ <+> integer hiVersion
+ , nest 2 (text "interface hash:" <+> ppr (mi_iface_hash iface))
+ , nest 2 (text "ABI hash:" <+> ppr (mi_mod_hash iface))
+ , nest 2 (text "export-list hash:" <+> ppr (mi_exp_hash iface))
+ , nest 2 (text "orphan hash:" <+> ppr (mi_orphan_hash iface))
+ , nest 2 (text "flag hash:" <+> ppr (mi_flag_hash iface))
+ , nest 2 (text "sig of:" <+> ppr (mi_sig_of iface))
+ , nest 2 (text "used TH splices:" <+> ppr (mi_used_th iface))
+ , nest 2 (text "where")
+ , text "exports:"
+ , nest 2 (vcat (map pprExport (mi_exports iface)))
+ , pprDeps (mi_deps iface)
+ , vcat (map pprUsage (mi_usages iface))
+ , vcat (map pprIfaceAnnotation (mi_anns iface))
+ , pprFixities (mi_fixities iface)
+ , vcat [ppr ver $$ nest 2 (ppr decl) | (ver,decl) <- mi_decls iface]
+ , vcat (map ppr (mi_insts iface))
+ , vcat (map ppr (mi_fam_insts iface))
+ , vcat (map ppr (mi_rules iface))
+ , pprVectInfo (mi_vect_info iface)
+ , ppr (mi_warns iface)
+ , pprTrustInfo (mi_trust iface)
+ , pprTrustPkg (mi_trust_pkg iface)
+ , vcat (map ppr (mi_complete_sigs iface))
+ ]
+ where
+ pp_hsc_src HsBootFile = text "[boot]"
+ pp_hsc_src HsigFile = text "[hsig]"
+ pp_hsc_src HsSrcFile = Outputable.empty
+
+{-
+When printing export lists, we print like this:
+ Avail f f
+ AvailTC C [C, x, y] C(x,y)
+ AvailTC C [x, y] C!(x,y) -- Exporting x, y but not C
+-}
+
+pprExport :: IfaceExport -> SDoc
+pprExport (Avail n) = ppr n
+pprExport (AvailTC _ [] []) = Outputable.empty
+pprExport (AvailTC n ns0 fs)
+ = case ns0 of
+ (n':ns) | n==n' -> ppr n <> pp_export ns fs
+ _ -> ppr n <> vbar <> pp_export ns0 fs
+ where
+ pp_export [] [] = Outputable.empty
+ pp_export names fs = braces (hsep (map ppr names ++ map (ppr . flLabel) fs))
+
+pprUsage :: Usage -> SDoc
+pprUsage usage@UsagePackageModule{}
+ = pprUsageImport usage usg_mod
+pprUsage usage@UsageHomeModule{}
+ = pprUsageImport usage usg_mod_name $$
+ nest 2 (
+ maybe Outputable.empty (\v -> text "exports: " <> ppr v) (usg_exports usage) $$
+ vcat [ ppr n <+> ppr v | (n,v) <- usg_entities usage ]
+ )
+pprUsage usage@UsageFile{}
+ = hsep [text "addDependentFile",
+ doubleQuotes (text (usg_file_path usage))]
+pprUsage usage@UsageMergedRequirement{}
+ = hsep [text "merged", ppr (usg_mod usage), ppr (usg_mod_hash usage)]
+
+pprUsageImport :: Outputable a => Usage -> (Usage -> a) -> SDoc
+pprUsageImport usage usg_mod'
+ = hsep [text "import", safe, ppr (usg_mod' usage),
+ ppr (usg_mod_hash usage)]
+ where
+ safe | usg_safe usage = text "safe"
+ | otherwise = text " -/ "
+
+pprDeps :: Dependencies -> SDoc
+pprDeps (Deps { dep_mods = mods, dep_pkgs = pkgs, dep_orphs = orphs,
+ dep_finsts = finsts })
+ = vcat [text "module dependencies:" <+> fsep (map ppr_mod mods),
+ text "package dependencies:" <+> fsep (map ppr_pkg pkgs),
+ text "orphans:" <+> fsep (map ppr orphs),
+ text "family instance modules:" <+> fsep (map ppr finsts)
+ ]
+ where
+ ppr_mod (mod_name, boot) = ppr mod_name <+> ppr_boot boot
+ ppr_pkg (pkg,trust_req) = ppr pkg <>
+ (if trust_req then text "*" else Outputable.empty)
+ ppr_boot True = text "[boot]"
+ ppr_boot False = Outputable.empty
+
+pprFixities :: [(OccName, Fixity)] -> SDoc
+pprFixities [] = Outputable.empty
+pprFixities fixes = text "fixities" <+> pprWithCommas pprFix fixes
+ where
+ pprFix (occ,fix) = ppr fix <+> ppr occ
+
+pprVectInfo :: IfaceVectInfo -> SDoc
+pprVectInfo (IfaceVectInfo { ifaceVectInfoVar = vars
+ , ifaceVectInfoTyCon = tycons
+ , ifaceVectInfoTyConReuse = tyconsReuse
+ , ifaceVectInfoParallelVars = parallelVars
+ , ifaceVectInfoParallelTyCons = parallelTyCons
+ }) =
+ vcat
+ [ text "vectorised variables:" <+> hsep (map ppr vars)
+ , text "vectorised tycons:" <+> hsep (map ppr tycons)
+ , text "vectorised reused tycons:" <+> hsep (map ppr tyconsReuse)
+ , text "parallel variables:" <+> hsep (map ppr parallelVars)
+ , text "parallel tycons:" <+> hsep (map ppr parallelTyCons)
+ ]
+
+pprTrustInfo :: IfaceTrustInfo -> SDoc
+pprTrustInfo trust = text "trusted:" <+> ppr trust
+
+pprTrustPkg :: Bool -> SDoc
+pprTrustPkg tpkg = text "require own pkg trusted:" <+> ppr tpkg
+
+instance Outputable Warnings where
+ ppr = pprWarns
+
+pprWarns :: Warnings -> SDoc
+pprWarns NoWarnings = Outputable.empty
+pprWarns (WarnAll txt) = text "Warn all" <+> ppr txt
+pprWarns (WarnSome prs) = text "Warnings"
+ <+> vcat (map pprWarning prs)
+ where pprWarning (name, txt) = ppr name <+> ppr txt
+
+pprIfaceAnnotation :: IfaceAnnotation -> SDoc
+pprIfaceAnnotation (IfaceAnnotation { ifAnnotatedTarget = target, ifAnnotatedValue = serialized })
+ = ppr target <+> text "annotated by" <+> ppr serialized
+
+{-
+*********************************************************
+* *
+\subsection{Errors}
+* *
+*********************************************************
+-}
+
+badIfaceFile :: String -> SDoc -> SDoc
+badIfaceFile file err
+ = vcat [text "Bad interface file:" <+> text file,
+ nest 4 err]
+
+hiModuleNameMismatchWarn :: DynFlags -> Module -> Module -> MsgDoc
+hiModuleNameMismatchWarn dflags requested_mod read_mod
+ | moduleUnitId requested_mod == moduleUnitId read_mod =
+ sep [text "Interface file contains module" <+> quotes (ppr read_mod) <> comma,
+ text "but we were expecting module" <+> quotes (ppr requested_mod),
+ sep [text "Probable cause: the source code which generated interface file",
+ text "has an incompatible module name"
+ ]
+ ]
+ | otherwise =
+ -- ToDo: This will fail to have enough qualification when the package IDs
+ -- are the same
+ withPprStyle (mkUserStyle dflags alwaysQualify AllTheWay) $
+ -- we want the Modules below to be qualified with package names,
+ -- so reset the PrintUnqualified setting.
+ hsep [ text "Something is amiss; requested module "
+ , ppr requested_mod
+ , text "differs from name found in the interface file"
+ , ppr read_mod
+ , parens (text "if these names look the same, try again with -dppr-debug")
+ ]
+
+homeModError :: InstalledModule -> ModLocation -> SDoc
+-- See Note [Home module load error]
+homeModError mod location
+ = text "attempting to use module " <> quotes (ppr mod)
+ <> (case ml_hs_file location of
+ Just file -> space <> parens (text file)
+ Nothing -> Outputable.empty)
+ <+> text "which is not loaded"
diff --git a/iface/LoadIface.hs-boot b/iface/LoadIface.hs-boot
new file mode 100644
--- /dev/null
+++ b/iface/LoadIface.hs-boot
@@ -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
diff --git a/iface/MkIface.hs b/iface/MkIface.hs
new file mode 100644
--- /dev/null
+++ b/iface/MkIface.hs
@@ -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
+ -- are going to be for , not the former id!
+ -- See Note [Identity versus semantic module]
+
+ fixities = sortBy (comparing fst)
+ [(occ,fix) | FixItem occ fix <- nameEnvElts fix_env]
+ -- The order of fixities returned from nameEnvElts is not
+ -- deterministic, so we sort by OccName to canonicalize it.
+ -- See Note [Deterministic UniqFM] in UniqDFM for more details.
+ warns = src_warns
+ iface_rules = map coreRuleToIfaceRule rules
+ iface_insts = map instanceToIfaceInst $ fixSafeInstances safe_mode insts
+ iface_fam_insts = map famInstToIfaceFamInst fam_insts
+ iface_vect_info = flattenVectInfo vect_info
+ trust_info = setSafeMode safe_mode
+ annotations = map mkIfaceAnnotation anns
+ icomplete_sigs = map mkIfaceCompleteSig complete_sigs
+
+ intermediate_iface = ModIface {
+ mi_module = this_mod,
+ -- Need to record this because it depends on the -instantiated-with flag
+ -- which could change
+ mi_sig_of = if semantic_mod == this_mod
+ then Nothing
+ else Just semantic_mod,
+ mi_hsc_src = hsc_src,
+ mi_deps = deps,
+ mi_usages = usages,
+ mi_exports = mkIfaceExports exports,
+
+ -- Sort these lexicographically, so that
+ -- the result is stable across compilations
+ mi_insts = sortBy cmp_inst iface_insts,
+ mi_fam_insts = sortBy cmp_fam_inst iface_fam_insts,
+ mi_rules = sortBy cmp_rule iface_rules,
+
+ mi_vect_info = iface_vect_info,
+
+ mi_fixities = fixities,
+ mi_warns = warns,
+ mi_anns = annotations,
+ mi_globals = maybeGlobalRdrEnv rdr_env,
+
+ -- Left out deliberately: filled in by addFingerprints
+ mi_iface_hash = fingerprint0,
+ mi_mod_hash = fingerprint0,
+ mi_flag_hash = fingerprint0,
+ mi_exp_hash = fingerprint0,
+ mi_used_th = used_th,
+ mi_orphan_hash = fingerprint0,
+ mi_orphan = False, -- Always set by addFingerprints, but
+ -- it's a strict field, so we can't omit it.
+ mi_finsts = False, -- Ditto
+ mi_decls = deliberatelyOmitted "decls",
+ mi_hash_fn = deliberatelyOmitted "hash_fn",
+ mi_hpc = isHpcUsed hpc_info,
+ mi_trust = trust_info,
+ mi_trust_pkg = pkg_trust_req,
+
+ -- And build the cached values
+ mi_warn_fn = mkIfaceWarnCache warns,
+ mi_fix_fn = mkIfaceFixCache fixities,
+ mi_complete_sigs = icomplete_sigs }
+
+ (new_iface, no_change_at_all)
+ <- {-# SCC "versioninfo" #-}
+ addFingerprints hsc_env maybe_old_fingerprint
+ intermediate_iface decls
+
+ -- Debug printing
+ dumpIfSet_dyn dflags Opt_D_dump_hi "FINAL INTERFACE"
+ (pprModIface new_iface)
+
+ -- bug #1617: on reload we weren't updating the PrintUnqualified
+ -- correctly. This stems from the fact that the interface had
+ -- not changed, so addFingerprints returns the old ModIface
+ -- with the old GlobalRdrEnv (mi_globals).
+ let final_iface = new_iface{ mi_globals = maybeGlobalRdrEnv rdr_env }
+
+ return (final_iface, no_change_at_all)
+ where
+ cmp_rule = comparing ifRuleName
+ -- Compare these lexicographically by OccName, *not* by unique,
+ -- because the latter is not stable across compilations:
+ cmp_inst = comparing (nameOccName . ifDFun)
+ cmp_fam_inst = comparing (nameOccName . ifFamInstTcName)
+
+ dflags = hsc_dflags hsc_env
+
+ -- We only fill in mi_globals if the module was compiled to byte
+ -- code. Otherwise, the compiler may not have retained all the
+ -- top-level bindings and they won't be in the TypeEnv (see
+ -- Desugar.addExportFlagsAndRules). The mi_globals field is used
+ -- by GHCi to decide whether the module has its full top-level
+ -- scope available. (#5534)
+ maybeGlobalRdrEnv :: GlobalRdrEnv -> Maybe GlobalRdrEnv
+ maybeGlobalRdrEnv rdr_env
+ | targetRetainsAllBindings (hscTarget dflags) = Just rdr_env
+ | otherwise = Nothing
+
+ deliberatelyOmitted :: String -> a
+ deliberatelyOmitted x = panic ("Deliberately omitted: " ++ x)
+
+ ifFamInstTcName = ifFamInstFam
+
+ flattenVectInfo (VectInfo { vectInfoVar = vVar
+ , vectInfoTyCon = vTyCon
+ , vectInfoParallelVars = vParallelVars
+ , vectInfoParallelTyCons = vParallelTyCons
+ }) =
+ IfaceVectInfo
+ { ifaceVectInfoVar = [Var.varName v | (v, _ ) <- dVarEnvElts vVar]
+ , ifaceVectInfoTyCon = [tyConName t | (t, t_v) <- nameEnvElts vTyCon, t /= t_v]
+ , ifaceVectInfoTyConReuse = [tyConName t | (t, t_v) <- nameEnvElts vTyCon, t == t_v]
+ , ifaceVectInfoParallelVars = [Var.varName v | v <- dVarSetElems vParallelVars]
+ , ifaceVectInfoParallelTyCons = nameSetElemsStable vParallelTyCons
+ }
+
+-----------------------------
+writeIfaceFile :: DynFlags -> FilePath -> ModIface -> IO ()
+writeIfaceFile dflags hi_file_path new_iface
+ = do createDirectoryIfMissing True (takeDirectory hi_file_path)
+ writeBinIface dflags hi_file_path new_iface
+
+
+-- -----------------------------------------------------------------------------
+-- Look up parents and versions of Names
+
+-- This is like a global version of the mi_hash_fn field in each ModIface.
+-- Given a Name, it finds the ModIface, and then uses mi_hash_fn to get
+-- the parent and version info.
+
+mkHashFun
+ :: HscEnv -- needed to look up versions
+ -> ExternalPackageState -- ditto
+ -> (Name -> IO Fingerprint)
+mkHashFun hsc_env eps name
+ | isHoleModule orig_mod
+ = lookup (mkModule (thisPackage dflags) (moduleName orig_mod))
+ | otherwise
+ = lookup orig_mod
+ where
+ dflags = hsc_dflags hsc_env
+ hpt = hsc_HPT hsc_env
+ pit = eps_PIT eps
+ occ = nameOccName name
+ orig_mod = nameModule name
+ lookup mod = do
+ MASSERT2( isExternalName name, ppr name )
+ iface <- case lookupIfaceByModule dflags hpt pit mod of
+ Just iface -> return iface
+ Nothing -> do
+ -- This can occur when we're writing out ifaces for
+ -- requirements; we didn't do any /real/ typechecking
+ -- so there's no guarantee everything is loaded.
+ -- Kind of a heinous hack.
+ iface <- initIfaceLoad hsc_env . withException
+ $ loadInterface (text "lookupVers2") mod ImportBySystem
+ return iface
+ return $ snd (mi_hash_fn iface occ `orElse`
+ pprPanic "lookupVers1" (ppr mod <+> ppr occ))
+
+-- ---------------------------------------------------------------------------
+-- Compute fingerprints for the interface
+
+{-
+Note [Fingerprinting IfaceDecls]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+The general idea here is that we first examine the 'IfaceDecl's and determine
+the recursive groups of them. We then walk these groups in dependency order,
+serializing each contained 'IfaceDecl' to a "Binary" buffer which we then
+hash using MD5 to produce a fingerprint for the group.
+
+However, the serialization that we use is a bit funny: we override the @putName@
+operation with our own which serializes the hash of a 'Name' instead of the
+'Name' itself. This ensures that the fingerprint of a decl changes if anything
+in its transitive closure changes. This trick is why we must be careful about
+traversing in dependency order: we need to ensure that we have hashes for
+everything referenced by the decl which we are fingerprinting.
+
+Moreover, we need to be careful to distinguish between serialization of binding
+Names (e.g. the ifName field of a IfaceDecl) and non-binding (e.g. the ifInstCls
+field of a IfaceClsInst): only in the non-binding case should we include the
+fingerprint; in the binding case we shouldn't since it is merely the name of the
+thing that we are currently fingerprinting.
+-}
+
+-- | Add fingerprints for top-level declarations to a 'ModIface'.
+--
+-- See Note [Fingerprinting IfaceDecls]
+addFingerprints
+ :: HscEnv
+ -> Maybe Fingerprint -- the old fingerprint, if any
+ -> ModIface -- The new interface (lacking decls)
+ -> [IfaceDecl] -- The new decls
+ -> IO (ModIface, -- Updated interface
+ Bool) -- True <=> no changes at all;
+ -- no need to write Iface
+
+addFingerprints hsc_env mb_old_fingerprint iface0 new_decls
+ = do
+ eps <- hscEPS hsc_env
+ let
+ -- The ABI of a declaration represents everything that is made
+ -- visible about the declaration that a client can depend on.
+ -- see IfaceDeclABI below.
+ declABI :: IfaceDecl -> IfaceDeclABI
+ -- TODO: I'm not sure if this should be semantic_mod or this_mod.
+ -- See also Note [Identity versus semantic module]
+ declABI decl = (this_mod, decl, extras)
+ where extras = declExtras fix_fn ann_fn non_orph_rules non_orph_insts
+ non_orph_fis decl
+
+ edges :: [(IfaceDeclABI, Unique, [Unique])]
+ edges = [ (abi, getUnique (getOccName decl), out)
+ | decl <- new_decls
+ , let abi = declABI decl
+ , let out = localOccs $ freeNamesDeclABI abi
+ ]
+
+ name_module n = ASSERT2( isExternalName n, ppr n ) nameModule n
+ localOccs =
+ map (getUnique . getParent . getOccName)
+ -- NB: names always use semantic module, so
+ -- filtering must be on the semantic module!
+ -- See Note [Identity versus semantic module]
+ . filter ((== semantic_mod) . name_module)
+ . nonDetEltsUniqSet
+ -- It's OK to use nonDetEltsUFM as localOccs is only
+ -- used to construct the edges and
+ -- stronglyConnCompFromEdgedVertices is deterministic
+ -- even with non-deterministic order of edges as
+ -- explained in Note [Deterministic SCC] in Digraph.
+ where getParent :: OccName -> OccName
+ getParent occ = lookupOccEnv parent_map occ `orElse` occ
+
+ -- maps OccNames to their parents in the current module.
+ -- e.g. a reference to a constructor must be turned into a reference
+ -- to the TyCon for the purposes of calculating dependencies.
+ parent_map :: OccEnv OccName
+ parent_map = foldl' extend emptyOccEnv new_decls
+ where extend env d =
+ extendOccEnvList env [ (b,n) | b <- ifaceDeclImplicitBndrs d ]
+ where n = getOccName d
+
+ -- strongly-connected groups of declarations, in dependency order
+ groups :: [SCC IfaceDeclABI]
+ groups =
+ stronglyConnCompFromEdgedVerticesUniq edges
+
+ global_hash_fn = mkHashFun hsc_env eps
+
+ -- How to output Names when generating the data to fingerprint.
+ -- Here we want to output the fingerprint for each top-level
+ -- Name, whether it comes from the current module or another
+ -- module. In this way, the fingerprint for a declaration will
+ -- change if the fingerprint for anything it refers to (transitively)
+ -- changes.
+ mk_put_name :: OccEnv (OccName,Fingerprint)
+ -> BinHandle -> Name -> IO ()
+ mk_put_name local_env bh name
+ | isWiredInName name = putNameLiterally bh name
+ -- wired-in names don't have fingerprints
+ | otherwise
+ = ASSERT2( isExternalName name, ppr name )
+ let hash | nameModule name /= semantic_mod = global_hash_fn name
+ -- Get it from the REAL interface!!
+ -- This will trigger when we compile an hsig file
+ -- and we know a backing impl for it.
+ -- See Note [Identity versus semantic module]
+ | semantic_mod /= this_mod
+ , not (isHoleModule semantic_mod) = global_hash_fn name
+ | otherwise = return (snd (lookupOccEnv local_env (getOccName name)
+ `orElse` pprPanic "urk! lookup local fingerprint"
+ (ppr name $$ ppr local_env)))
+ -- This panic indicates that we got the dependency
+ -- analysis wrong, because we needed a fingerprint for
+ -- an entity that wasn't in the environment. To debug
+ -- it, turn the panic into a trace, uncomment the
+ -- pprTraces below, run the compile again, and inspect
+ -- the output and the generated .hi file with
+ -- --show-iface.
+ in hash >>= put_ bh
+
+ -- take a strongly-connected group of declarations and compute
+ -- its fingerprint.
+
+ fingerprint_group :: (OccEnv (OccName,Fingerprint),
+ [(Fingerprint,IfaceDecl)])
+ -> SCC IfaceDeclABI
+ -> IO (OccEnv (OccName,Fingerprint),
+ [(Fingerprint,IfaceDecl)])
+
+ fingerprint_group (local_env, decls_w_hashes) (AcyclicSCC abi)
+ = do let hash_fn = mk_put_name local_env
+ decl = abiDecl abi
+ --pprTrace "fingerprinting" (ppr (ifName decl) ) $ do
+ hash <- computeFingerprint hash_fn abi
+ env' <- extend_hash_env local_env (hash,decl)
+ return (env', (hash,decl) : decls_w_hashes)
+
+ fingerprint_group (local_env, decls_w_hashes) (CyclicSCC abis)
+ = do let decls = map abiDecl abis
+ local_env1 <- foldM extend_hash_env local_env
+ (zip (repeat fingerprint0) decls)
+ let hash_fn = mk_put_name local_env1
+ -- pprTrace "fingerprinting" (ppr (map ifName decls) ) $ do
+ let stable_abis = sortBy cmp_abiNames abis
+ -- put the cycle in a canonical order
+ hash <- computeFingerprint hash_fn stable_abis
+ let pairs = zip (repeat hash) decls
+ local_env2 <- foldM extend_hash_env local_env pairs
+ return (local_env2, pairs ++ decls_w_hashes)
+
+ -- we have fingerprinted the whole declaration, but we now need
+ -- to assign fingerprints to all the OccNames that it binds, to
+ -- use when referencing those OccNames in later declarations.
+ --
+ extend_hash_env :: OccEnv (OccName,Fingerprint)
+ -> (Fingerprint,IfaceDecl)
+ -> IO (OccEnv (OccName,Fingerprint))
+ extend_hash_env env0 (hash,d) = do
+ return (foldr (\(b,fp) env -> extendOccEnv env b (b,fp)) env0
+ (ifaceDeclFingerprints hash d))
+
+ --
+ (local_env, decls_w_hashes) <-
+ foldM fingerprint_group (emptyOccEnv, []) groups
+
+ -- when calculating fingerprints, we always need to use canonical
+ -- ordering for lists of things. In particular, the mi_deps has various
+ -- lists of modules and suchlike, so put these all in canonical order:
+ let sorted_deps = sortDependencies (mi_deps iface0)
+
+ -- The export hash of a module depends on the orphan hashes of the
+ -- orphan modules below us in the dependency tree. This is the way
+ -- that changes in orphans get propagated all the way up the
+ -- dependency tree.
+ --
+ -- Note [A bad dep_orphs optimization]
+ -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ -- In a previous version of this code, we filtered out orphan modules which
+ -- were not from the home package, justifying it by saying that "we'd
+ -- pick up the ABI hashes of the external module instead". This is wrong.
+ -- Suppose that we have:
+ --
+ -- module External where
+ -- instance Show (a -> b)
+ --
+ -- module Home1 where
+ -- import External
+ --
+ -- module Home2 where
+ -- import Home1
+ --
+ -- The export hash of Home1 needs to reflect the orphan instances of
+ -- External. It's true that Home1 will get rebuilt if the orphans
+ -- of External, but we also need to make sure Home2 gets rebuilt
+ -- as well. See #12733 for more details.
+ let orph_mods
+ = filter (/= this_mod) -- Note [Do not update EPS with your own hi-boot]
+ $ dep_orphs sorted_deps
+ dep_orphan_hashes <- getOrphanHashes hsc_env orph_mods
+
+ -- Note [Do not update EPS with your own hi-boot]
+ -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ -- (See also Trac #10182). When your hs-boot file includes an orphan
+ -- instance declaration, you may find that the dep_orphs of a module you
+ -- import contains reference to yourself. DO NOT actually load this module
+ -- or add it to the orphan hashes: you're going to provide the orphan
+ -- instances yourself, no need to consult hs-boot; if you do load the
+ -- interface into EPS, you will see a duplicate orphan instance.
+
+ orphan_hash <- computeFingerprint (mk_put_name local_env)
+ (map ifDFun orph_insts, orph_rules, orph_fis)
+
+ -- the export list hash doesn't depend on the fingerprints of
+ -- the Names it mentions, only the Names themselves, hence putNameLiterally.
+ export_hash <- computeFingerprint putNameLiterally
+ (mi_exports iface0,
+ orphan_hash,
+ dep_orphan_hashes,
+ dep_pkgs (mi_deps iface0),
+ -- See Note [Export hash depends on non-orphan family instances]
+ dep_finsts (mi_deps iface0),
+ -- dep_pkgs: see "Package Version Changes" on
+ -- wiki/Commentary/Compiler/RecompilationAvoidance
+ mi_trust iface0)
+ -- Make sure change of Safe Haskell mode causes recomp.
+
+ -- Note [Export hash depends on non-orphan family instances]
+ -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ --
+ -- Suppose we have:
+ --
+ -- module A where
+ -- type instance F Int = Bool
+ --
+ -- module B where
+ -- import A
+ --
+ -- module C where
+ -- import B
+ --
+ -- The family instance consistency check for C depends on the dep_finsts of
+ -- B. If we rename module A to A2, when the dep_finsts of B changes, we need
+ -- to make sure that C gets rebuilt. Effectively, the dep_finsts are part of
+ -- the exports of B, because C always considers them when checking
+ -- consistency.
+ --
+ -- A full discussion is in #12723.
+ --
+ -- We do NOT need to hash dep_orphs, because this is implied by
+ -- dep_orphan_hashes, and we do not need to hash ordinary class instances,
+ -- because there is no eager consistency check as there is with type families
+ -- (also we didn't store it anywhere!)
+ --
+
+ -- put the declarations in a canonical order, sorted by OccName
+ let sorted_decls = Map.elems $ Map.fromList $
+ [(getOccName d, e) | e@(_, d) <- decls_w_hashes]
+
+ -- the flag hash depends on:
+ -- - (some of) dflags
+ -- it returns two hashes, one that shouldn't change
+ -- the abi hash and one that should
+ flag_hash <- fingerprintDynFlags dflags this_mod putNameLiterally
+
+ -- the ABI hash depends on:
+ -- - decls
+ -- - export list
+ -- - orphans
+ -- - deprecations
+ -- - vect info
+ -- - flag abi hash
+ mod_hash <- computeFingerprint putNameLiterally
+ (map fst sorted_decls,
+ export_hash, -- includes orphan_hash
+ mi_warns iface0,
+ mi_vect_info iface0)
+
+ -- The interface hash depends on:
+ -- - the ABI hash, plus
+ -- - the module level annotations,
+ -- - usages
+ -- - deps (home and external packages, dependent files)
+ -- - hpc
+ iface_hash <- computeFingerprint putNameLiterally
+ (mod_hash,
+ ann_fn (mkVarOcc "module"), -- See mkIfaceAnnCache
+ mi_usages iface0,
+ sorted_deps,
+ mi_hpc iface0)
+
+ let
+ no_change_at_all = Just iface_hash == mb_old_fingerprint
+
+ final_iface = iface0 {
+ mi_mod_hash = mod_hash,
+ mi_iface_hash = iface_hash,
+ mi_exp_hash = export_hash,
+ mi_orphan_hash = orphan_hash,
+ mi_flag_hash = flag_hash,
+ mi_orphan = not ( all ifRuleAuto orph_rules
+ -- See Note [Orphans and auto-generated rules]
+ && null orph_insts
+ && null orph_fis
+ && isNoIfaceVectInfo (mi_vect_info iface0)),
+ mi_finsts = not . null $ mi_fam_insts iface0,
+ mi_decls = sorted_decls,
+ mi_hash_fn = lookupOccEnv local_env }
+ --
+ return (final_iface, no_change_at_all)
+
+ where
+ this_mod = mi_module iface0
+ semantic_mod = mi_semantic_module iface0
+ dflags = hsc_dflags hsc_env
+ (non_orph_insts, orph_insts) = mkOrphMap ifInstOrph (mi_insts iface0)
+ (non_orph_rules, orph_rules) = mkOrphMap ifRuleOrph (mi_rules iface0)
+ (non_orph_fis, orph_fis) = mkOrphMap ifFamInstOrph (mi_fam_insts iface0)
+ fix_fn = mi_fix_fn iface0
+ ann_fn = mkIfaceAnnCache (mi_anns iface0)
+
+-- | Retrieve the orphan hashes 'mi_orphan_hash' for a list of modules
+-- (in particular, the orphan modules which are transitively imported by the
+-- current module).
+--
+-- Q: Why do we need the hash at all, doesn't the list of transitively
+-- imported orphan modules suffice?
+--
+-- A: If one of our transitive imports adds a new orphan instance, our
+-- export hash must change so that modules which import us rebuild. If we just
+-- hashed the [Module], the hash would not change even when a new instance was
+-- added to a module that already had an orphan instance.
+--
+-- Q: Why don't we just hash the orphan hashes of our direct dependencies?
+-- Why the full transitive closure?
+--
+-- A: Suppose we have these modules:
+--
+-- module A where
+-- instance Show (a -> b) where
+-- module B where
+-- import A -- **
+-- module C where
+-- import A
+-- import B
+--
+-- Whether or not we add or remove the import to A in B affects the
+-- orphan hash of B. But it shouldn't really affect the orphan hash
+-- of C. If we hashed only direct dependencies, there would be no
+-- way to tell that the net effect was a wash, and we'd be forced
+-- to recompile C and everything else.
+getOrphanHashes :: HscEnv -> [Module] -> IO [Fingerprint]
+getOrphanHashes hsc_env mods = do
+ eps <- hscEPS hsc_env
+ let
+ hpt = hsc_HPT hsc_env
+ pit = eps_PIT eps
+ dflags = hsc_dflags hsc_env
+ get_orph_hash mod =
+ case lookupIfaceByModule dflags hpt pit mod of
+ Just iface -> return (mi_orphan_hash iface)
+ Nothing -> do -- similar to 'mkHashFun'
+ iface <- initIfaceLoad hsc_env . withException
+ $ loadInterface (text "getOrphanHashes") mod ImportBySystem
+ return (mi_orphan_hash iface)
+
+ --
+ mapM get_orph_hash mods
+
+
+sortDependencies :: Dependencies -> Dependencies
+sortDependencies d
+ = Deps { dep_mods = sortBy (compare `on` (moduleNameFS.fst)) (dep_mods d),
+ dep_pkgs = sortBy (compare `on` fst) (dep_pkgs d),
+ dep_orphs = sortBy stableModuleCmp (dep_orphs d),
+ dep_finsts = sortBy stableModuleCmp (dep_finsts d) }
+
+-- | Creates cached lookup for the 'mi_anns' field of ModIface
+-- Hackily, we use "module" as the OccName for any module-level annotations
+mkIfaceAnnCache :: [IfaceAnnotation] -> OccName -> [AnnPayload]
+mkIfaceAnnCache anns
+ = \n -> lookupOccEnv env n `orElse` []
+ where
+ pair (IfaceAnnotation target value) =
+ (case target of
+ NamedTarget occn -> occn
+ ModuleTarget _ -> mkVarOcc "module"
+ , [value])
+ -- flipping (++), so the first argument is always short
+ env = mkOccEnv_C (flip (++)) (map pair anns)
+
+{-
+************************************************************************
+* *
+ The ABI of an IfaceDecl
+* *
+************************************************************************
+
+Note [The ABI of an IfaceDecl]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The ABI of a declaration consists of:
+
+ (a) the full name of the identifier (inc. module and package,
+ because these are used to construct the symbol name by which
+ the identifier is known externally).
+
+ (b) the declaration itself, as exposed to clients. That is, the
+ definition of an Id is included in the fingerprint only if
+ it is made available as an unfolding in the interface.
+
+ (c) the fixity of the identifier (if it exists)
+ (d) for Ids: rules
+ (e) for classes: instances, fixity & rules for methods
+ (f) for datatypes: instances, fixity & rules for constrs
+
+Items (c)-(f) are not stored in the IfaceDecl, but instead appear
+elsewhere in the interface file. But they are *fingerprinted* with
+the declaration itself. This is done by grouping (c)-(f) in IfaceDeclExtras,
+and fingerprinting that as part of the declaration.
+-}
+
+type IfaceDeclABI = (Module, IfaceDecl, IfaceDeclExtras)
+
+data IfaceDeclExtras
+ = IfaceIdExtras IfaceIdExtras
+
+ | IfaceDataExtras
+ (Maybe Fixity) -- Fixity of the tycon itself (if it exists)
+ [IfaceInstABI] -- Local class and family instances of this tycon
+ -- See Note [Orphans] in InstEnv
+ [AnnPayload] -- Annotations of the type itself
+ [IfaceIdExtras] -- For each constructor: fixity, RULES and annotations
+
+ | IfaceClassExtras
+ (Maybe Fixity) -- Fixity of the class itself (if it exists)
+ [IfaceInstABI] -- Local instances of this class *or*
+ -- of its associated data types
+ -- See Note [Orphans] in InstEnv
+ [AnnPayload] -- Annotations of the type itself
+ [IfaceIdExtras] -- For each class method: fixity, RULES and annotations
+
+ | IfaceSynonymExtras (Maybe Fixity) [AnnPayload]
+
+ | IfaceFamilyExtras (Maybe Fixity) [IfaceInstABI] [AnnPayload]
+
+ | IfaceOtherDeclExtras
+
+data IfaceIdExtras
+ = IdExtras
+ (Maybe Fixity) -- Fixity of the Id (if it exists)
+ [IfaceRule] -- Rules for the Id
+ [AnnPayload] -- Annotations for the Id
+
+-- When hashing a class or family instance, we hash only the
+-- DFunId or CoAxiom, because that depends on all the
+-- information about the instance.
+--
+type IfaceInstABI = IfExtName -- Name of DFunId or CoAxiom that is evidence for the instance
+
+abiDecl :: IfaceDeclABI -> IfaceDecl
+abiDecl (_, decl, _) = decl
+
+cmp_abiNames :: IfaceDeclABI -> IfaceDeclABI -> Ordering
+cmp_abiNames abi1 abi2 = getOccName (abiDecl abi1) `compare`
+ getOccName (abiDecl abi2)
+
+freeNamesDeclABI :: IfaceDeclABI -> NameSet
+freeNamesDeclABI (_mod, decl, extras) =
+ freeNamesIfDecl decl `unionNameSet` freeNamesDeclExtras extras
+
+freeNamesDeclExtras :: IfaceDeclExtras -> NameSet
+freeNamesDeclExtras (IfaceIdExtras id_extras)
+ = freeNamesIdExtras id_extras
+freeNamesDeclExtras (IfaceDataExtras _ insts _ subs)
+ = unionNameSets (mkNameSet insts : map freeNamesIdExtras subs)
+freeNamesDeclExtras (IfaceClassExtras _ insts _ subs)
+ = unionNameSets (mkNameSet insts : map freeNamesIdExtras subs)
+freeNamesDeclExtras (IfaceSynonymExtras _ _)
+ = emptyNameSet
+freeNamesDeclExtras (IfaceFamilyExtras _ insts _)
+ = mkNameSet insts
+freeNamesDeclExtras IfaceOtherDeclExtras
+ = emptyNameSet
+
+freeNamesIdExtras :: IfaceIdExtras -> NameSet
+freeNamesIdExtras (IdExtras _ rules _) = unionNameSets (map freeNamesIfRule rules)
+
+instance Outputable IfaceDeclExtras where
+ ppr IfaceOtherDeclExtras = Outputable.empty
+ ppr (IfaceIdExtras extras) = ppr_id_extras extras
+ ppr (IfaceSynonymExtras fix anns) = vcat [ppr fix, ppr anns]
+ ppr (IfaceFamilyExtras fix finsts anns) = vcat [ppr fix, ppr finsts, ppr anns]
+ ppr (IfaceDataExtras fix insts anns stuff) = vcat [ppr fix, ppr_insts insts, ppr anns,
+ ppr_id_extras_s stuff]
+ ppr (IfaceClassExtras fix insts anns stuff) = vcat [ppr fix, ppr_insts insts, ppr anns,
+ ppr_id_extras_s stuff]
+
+ppr_insts :: [IfaceInstABI] -> SDoc
+ppr_insts _ = text ""
+
+ppr_id_extras_s :: [IfaceIdExtras] -> SDoc
+ppr_id_extras_s stuff = vcat (map ppr_id_extras stuff)
+
+ppr_id_extras :: IfaceIdExtras -> SDoc
+ppr_id_extras (IdExtras fix rules anns) = ppr fix $$ vcat (map ppr rules) $$ vcat (map ppr anns)
+
+-- This instance is used only to compute fingerprints
+instance Binary IfaceDeclExtras where
+ get _bh = panic "no get for IfaceDeclExtras"
+ put_ bh (IfaceIdExtras extras) = do
+ putByte bh 1; put_ bh extras
+ put_ bh (IfaceDataExtras fix insts anns cons) = do
+ putByte bh 2; put_ bh fix; put_ bh insts; put_ bh anns; put_ bh cons
+ put_ bh (IfaceClassExtras fix insts anns methods) = do
+ putByte bh 3; put_ bh fix; put_ bh insts; put_ bh anns; put_ bh methods
+ put_ bh (IfaceSynonymExtras fix anns) = do
+ putByte bh 4; put_ bh fix; put_ bh anns
+ put_ bh (IfaceFamilyExtras fix finsts anns) = do
+ putByte bh 5; put_ bh fix; put_ bh finsts; put_ bh anns
+ put_ bh IfaceOtherDeclExtras = putByte bh 6
+
+instance Binary IfaceIdExtras where
+ get _bh = panic "no get for IfaceIdExtras"
+ put_ bh (IdExtras fix rules anns)= do { put_ bh fix; put_ bh rules; put_ bh anns }
+
+declExtras :: (OccName -> Maybe Fixity)
+ -> (OccName -> [AnnPayload])
+ -> OccEnv [IfaceRule]
+ -> OccEnv [IfaceClsInst]
+ -> OccEnv [IfaceFamInst]
+ -> IfaceDecl
+ -> IfaceDeclExtras
+
+declExtras fix_fn ann_fn rule_env inst_env fi_env decl
+ = case decl of
+ IfaceId{} -> IfaceIdExtras (id_extras n)
+ IfaceData{ifCons=cons} ->
+ IfaceDataExtras (fix_fn n)
+ (map ifFamInstAxiom (lookupOccEnvL fi_env n) ++
+ map ifDFun (lookupOccEnvL inst_env n))
+ (ann_fn n)
+ (map (id_extras . occName . ifConName) (visibleIfConDecls cons))
+ IfaceClass{ifBody = IfConcreteClass { ifSigs=sigs, ifATs=ats }} ->
+ IfaceClassExtras (fix_fn n)
+ (map ifDFun $ (concatMap at_extras ats)
+ ++ lookupOccEnvL inst_env n)
+ -- Include instances of the associated types
+ -- as well as instances of the class (Trac #5147)
+ (ann_fn n)
+ [id_extras (getOccName op) | IfaceClassOp op _ _ <- sigs]
+ IfaceSynonym{} -> IfaceSynonymExtras (fix_fn n)
+ (ann_fn n)
+ IfaceFamily{} -> IfaceFamilyExtras (fix_fn n)
+ (map ifFamInstAxiom (lookupOccEnvL fi_env n))
+ (ann_fn n)
+ _other -> IfaceOtherDeclExtras
+ where
+ n = getOccName decl
+ id_extras occ = IdExtras (fix_fn occ) (lookupOccEnvL rule_env occ) (ann_fn occ)
+ at_extras (IfaceAT decl _) = lookupOccEnvL inst_env (getOccName decl)
+
+
+lookupOccEnvL :: OccEnv [v] -> OccName -> [v]
+lookupOccEnvL env k = lookupOccEnv env k `orElse` []
+
+{-
+-- for testing: use the md5sum command to generate fingerprints and
+-- compare the results against our built-in version.
+ fp' <- oldMD5 dflags bh
+ if fp /= fp' then pprPanic "computeFingerprint" (ppr fp <+> ppr fp')
+ else return fp
+
+oldMD5 dflags bh = do
+ tmp <- newTempName dflags "bin"
+ writeBinMem bh tmp
+ tmp2 <- newTempName dflags "md5"
+ let cmd = "md5sum " ++ tmp ++ " >" ++ tmp2
+ r <- system cmd
+ case r of
+ ExitFailure _ -> throwGhcExceptionIO (PhaseFailed cmd r)
+ ExitSuccess -> do
+ hash_str <- readFile tmp2
+ return $! readHexFingerprint hash_str
+-}
+
+----------------------
+-- mkOrphMap partitions instance decls or rules into
+-- (a) an OccEnv for ones that are not orphans,
+-- mapping the local OccName to a list of its decls
+-- (b) a list of orphan decls
+mkOrphMap :: (decl -> IsOrphan) -- Extract orphan status from decl
+ -> [decl] -- Sorted into canonical order
+ -> (OccEnv [decl], -- Non-orphan decls associated with their key;
+ -- each sublist in canonical order
+ [decl]) -- Orphan decls; in canonical order
+mkOrphMap get_key decls
+ = foldl go (emptyOccEnv, []) decls
+ where
+ go (non_orphs, orphs) d
+ | NotOrphan occ <- get_key d
+ = (extendOccEnv_Acc (:) singleton non_orphs occ d, orphs)
+ | otherwise = (non_orphs, d:orphs)
+
+{-
+************************************************************************
+* *
+ COMPLETE Pragmas
+* *
+************************************************************************
+-}
+
+mkIfaceCompleteSig :: CompleteMatch -> IfaceCompleteMatch
+mkIfaceCompleteSig (CompleteMatch cls tc) = IfaceCompleteMatch cls tc
+
+
+{-
+************************************************************************
+* *
+ Keeping track of what we've slurped, and fingerprints
+* *
+************************************************************************
+-}
+
+
+mkIfaceAnnotation :: Annotation -> IfaceAnnotation
+mkIfaceAnnotation (Annotation { ann_target = target, ann_value = payload })
+ = IfaceAnnotation {
+ ifAnnotatedTarget = fmap nameOccName target,
+ ifAnnotatedValue = payload
+ }
+
+mkIfaceExports :: [AvailInfo] -> [IfaceExport] -- Sort to make canonical
+mkIfaceExports exports
+ = sortBy stableAvailCmp (map sort_subs exports)
+ where
+ sort_subs :: AvailInfo -> AvailInfo
+ sort_subs (Avail n) = Avail n
+ sort_subs (AvailTC n [] fs) = AvailTC n [] (sort_flds fs)
+ sort_subs (AvailTC n (m:ms) fs)
+ | n==m = AvailTC n (m:sortBy stableNameCmp ms) (sort_flds fs)
+ | otherwise = AvailTC n (sortBy stableNameCmp (m:ms)) (sort_flds fs)
+ -- Maintain the AvailTC Invariant
+
+ sort_flds = sortBy (stableNameCmp `on` flSelector)
+
+{-
+Note [Original module]
+~~~~~~~~~~~~~~~~~~~~~
+Consider this:
+ module X where { data family T }
+ module Y( T(..) ) where { import X; data instance T Int = MkT Int }
+The exported Avail from Y will look like
+ X.T{X.T, Y.MkT}
+That is, in Y,
+ - only MkT is brought into scope by the data instance;
+ - but the parent (used for grouping and naming in T(..) exports) is X.T
+ - and in this case we export X.T too
+
+In the result of MkIfaceExports, the names are grouped by defining module,
+so we may need to split up a single Avail into multiple ones.
+
+Note [Internal used_names]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+Most of the used_names are External Names, but we can have Internal
+Names too: see Note [Binders in Template Haskell] in Convert, and
+Trac #5362 for an example. Such Names are always
+ - Such Names are always for locally-defined things, for which we
+ don't gather usage info, so we can just ignore them in ent_map
+ - They are always System Names, hence the assert, just as a double check.
+
+
+************************************************************************
+* *
+ Load the old interface file for this module (unless
+ we have it already), and check whether it is up to date
+* *
+************************************************************************
+-}
+
+data RecompileRequired
+ = UpToDate
+ -- ^ everything is up to date, recompilation is not required
+ | MustCompile
+ -- ^ The .hs file has been touched, or the .o/.hi file does not exist
+ | RecompBecause String
+ -- ^ The .o/.hi files are up to date, but something else has changed
+ -- to force recompilation; the String says what (one-line summary)
+ deriving Eq
+
+recompileRequired :: RecompileRequired -> Bool
+recompileRequired UpToDate = False
+recompileRequired _ = True
+
+
+
+-- | Top level function to check if the version of an old interface file
+-- is equivalent to the current source file the user asked us to compile.
+-- If the same, we can avoid recompilation. We return a tuple where the
+-- first element is a bool saying if we should recompile the object file
+-- and the second is maybe the interface file, where Nothng means to
+-- rebuild the interface file not use the exisitng one.
+checkOldIface
+ :: HscEnv
+ -> ModSummary
+ -> SourceModified
+ -> Maybe ModIface -- Old interface from compilation manager, if any
+ -> IO (RecompileRequired, Maybe ModIface)
+
+checkOldIface hsc_env mod_summary source_modified maybe_iface
+ = do let dflags = hsc_dflags hsc_env
+ showPass dflags $
+ "Checking old interface for " ++
+ (showPpr dflags $ ms_mod mod_summary) ++
+ " (use -ddump-hi-diffs for more details)"
+ initIfaceCheck (text "checkOldIface") hsc_env $
+ check_old_iface hsc_env mod_summary source_modified maybe_iface
+
+check_old_iface
+ :: HscEnv
+ -> ModSummary
+ -> SourceModified
+ -> Maybe ModIface
+ -> IfG (RecompileRequired, Maybe ModIface)
+
+check_old_iface hsc_env mod_summary src_modified maybe_iface
+ = let dflags = hsc_dflags hsc_env
+ getIface =
+ case maybe_iface of
+ Just _ -> do
+ traceIf (text "We already have the old interface for" <+>
+ ppr (ms_mod mod_summary))
+ return maybe_iface
+ Nothing -> loadIface
+
+ loadIface = do
+ let iface_path = msHiFilePath mod_summary
+ read_result <- readIface (ms_mod mod_summary) iface_path
+ case read_result of
+ Failed err -> do
+ traceIf (text "FYI: cannot read old interface file:" $$ nest 4 err)
+ traceHiDiffs (text "Old interface file was invalid:" $$ nest 4 err)
+ return Nothing
+ Succeeded iface -> do
+ traceIf (text "Read the interface file" <+> text iface_path)
+ return $ Just iface
+
+ src_changed
+ | gopt Opt_ForceRecomp (hsc_dflags hsc_env) = True
+ | SourceModified <- src_modified = True
+ | otherwise = False
+ in do
+ when src_changed $
+ traceHiDiffs (nest 4 $ text "Source file changed or recompilation check turned off")
+
+ case src_changed of
+ -- If the source has changed and we're in interactive mode,
+ -- avoid reading an interface; just return the one we might
+ -- have been supplied with.
+ True | not (isObjectTarget $ hscTarget dflags) ->
+ return (MustCompile, maybe_iface)
+
+ -- Try and read the old interface for the current module
+ -- from the .hi file left from the last time we compiled it
+ True -> do
+ maybe_iface' <- getIface
+ return (MustCompile, maybe_iface')
+
+ False -> do
+ maybe_iface' <- getIface
+ case maybe_iface' of
+ -- We can't retrieve the iface
+ Nothing -> return (MustCompile, Nothing)
+
+ -- We have got the old iface; check its versions
+ -- even in the SourceUnmodifiedAndStable case we
+ -- should check versions because some packages
+ -- might have changed or gone away.
+ Just iface -> checkVersions hsc_env mod_summary iface
+
+-- | Check if a module is still the same 'version'.
+--
+-- This function is called in the recompilation checker after we have
+-- determined that the module M being checked hasn't had any changes
+-- to its source file since we last compiled M. So at this point in general
+-- two things may have changed that mean we should recompile M:
+-- * The interface export by a dependency of M has changed.
+-- * The compiler flags specified this time for M have changed
+-- in a manner that is significant for recompilation.
+-- We return not just if we should recompile the object file but also
+-- if we should rebuild the interface file.
+checkVersions :: HscEnv
+ -> ModSummary
+ -> ModIface -- Old interface
+ -> IfG (RecompileRequired, Maybe ModIface)
+checkVersions hsc_env mod_summary iface
+ = do { traceHiDiffs (text "Considering whether compilation is required for" <+>
+ ppr (mi_module iface) <> colon)
+
+ -- readIface will have verified that the InstalledUnitId matches,
+ -- but we ALSO must make sure the instantiation matches up. See
+ -- test case bkpcabal04!
+ ; if moduleUnitId (mi_module iface) /= thisPackage (hsc_dflags hsc_env)
+ then return (RecompBecause "-this-unit-id changed", Nothing) else do {
+ ; recomp <- checkFlagHash hsc_env iface
+ ; if recompileRequired recomp then return (recomp, Nothing) else do {
+ ; recomp <- checkMergedSignatures mod_summary iface
+ ; if recompileRequired recomp then return (recomp, Nothing) else do {
+ ; recomp <- checkHsig mod_summary iface
+ ; if recompileRequired recomp then return (recomp, Nothing) else do {
+ ; recomp <- checkDependencies hsc_env mod_summary iface
+ ; if recompileRequired recomp then return (recomp, Just iface) else do {
+
+ -- Source code unchanged and no errors yet... carry on
+ --
+ -- First put the dependent-module info, read from the old
+ -- interface, into the envt, so that when we look for
+ -- interfaces we look for the right one (.hi or .hi-boot)
+ --
+ -- It's just temporary because either the usage check will succeed
+ -- (in which case we are done with this module) or it'll fail (in which
+ -- case we'll compile the module from scratch anyhow).
+ --
+ -- We do this regardless of compilation mode, although in --make mode
+ -- all the dependent modules should be in the HPT already, so it's
+ -- quite redundant
+ ; updateEps_ $ \eps -> eps { eps_is_boot = mod_deps }
+ ; recomp <- checkList [checkModUsage this_pkg u | u <- mi_usages iface]
+ ; return (recomp, Just iface)
+ }}}}}}
+ where
+ this_pkg = thisPackage (hsc_dflags hsc_env)
+ -- This is a bit of a hack really
+ mod_deps :: ModuleNameEnv (ModuleName, IsBootInterface)
+ mod_deps = mkModDeps (dep_mods (mi_deps iface))
+
+-- | Check if an hsig file needs recompilation because its
+-- implementing module has changed.
+checkHsig :: ModSummary -> ModIface -> IfG RecompileRequired
+checkHsig mod_summary iface = do
+ dflags <- getDynFlags
+ let outer_mod = ms_mod mod_summary
+ inner_mod = canonicalizeHomeModule dflags (moduleName outer_mod)
+ MASSERT( moduleUnitId outer_mod == thisPackage dflags )
+ case inner_mod == mi_semantic_module iface of
+ True -> up_to_date (text "implementing module unchanged")
+ False -> return (RecompBecause "implementing module changed")
+
+-- | Check the flags haven't changed
+checkFlagHash :: HscEnv -> ModIface -> IfG RecompileRequired
+checkFlagHash hsc_env iface = do
+ let old_hash = mi_flag_hash iface
+ new_hash <- liftIO $ fingerprintDynFlags (hsc_dflags hsc_env)
+ (mi_module iface)
+ putNameLiterally
+ case old_hash == new_hash of
+ True -> up_to_date (text "Module flags unchanged")
+ False -> out_of_date_hash "flags changed"
+ (text " Module flags have changed")
+ old_hash new_hash
+
+-- Check that the set of signatures we are merging in match.
+-- If the -unit-id flags change, this can change too.
+checkMergedSignatures :: ModSummary -> ModIface -> IfG RecompileRequired
+checkMergedSignatures mod_summary iface = do
+ dflags <- getDynFlags
+ let old_merged = sort [ mod | UsageMergedRequirement{ usg_mod = mod } <- mi_usages iface ]
+ new_merged = case Map.lookup (ms_mod_name mod_summary)
+ (requirementContext (pkgState dflags)) of
+ Nothing -> []
+ Just r -> sort $ map (indefModuleToModule dflags) r
+ if old_merged == new_merged
+ then up_to_date (text "signatures to merge in unchanged" $$ ppr new_merged)
+ else return (RecompBecause "signatures to merge in changed")
+
+-- If the direct imports of this module are resolved to targets that
+-- are not among the dependencies of the previous interface file,
+-- then we definitely need to recompile. This catches cases like
+-- - an exposed package has been upgraded
+-- - we are compiling with different package flags
+-- - a home module that was shadowing a package module has been removed
+-- - a new home module has been added that shadows a package module
+-- See bug #1372.
+--
+-- Returns (RecompBecause ) if recompilation is required.
+checkDependencies :: HscEnv -> ModSummary -> ModIface -> IfG RecompileRequired
+checkDependencies hsc_env summary iface
+ = checkList (map dep_missing (ms_imps summary ++ ms_srcimps summary))
+ where
+ prev_dep_mods = dep_mods (mi_deps iface)
+ prev_dep_pkgs = dep_pkgs (mi_deps iface)
+
+ this_pkg = thisPackage (hsc_dflags hsc_env)
+
+ dep_missing (mb_pkg, L _ mod) = do
+ find_res <- liftIO $ findImportedModule hsc_env mod (mb_pkg)
+ let reason = moduleNameString mod ++ " changed"
+ case find_res of
+ Found _ mod
+ | pkg == this_pkg
+ -> if moduleName mod `notElem` map fst prev_dep_mods
+ then do traceHiDiffs $
+ text "imported module " <> quotes (ppr mod) <>
+ text " not among previous dependencies"
+ return (RecompBecause reason)
+ else
+ return UpToDate
+ | otherwise
+ -> if toInstalledUnitId pkg `notElem` (map fst prev_dep_pkgs)
+ then do traceHiDiffs $
+ text "imported module " <> quotes (ppr mod) <>
+ text " is from package " <> quotes (ppr pkg) <>
+ text ", which is not among previous dependencies"
+ return (RecompBecause reason)
+ else
+ return UpToDate
+ where pkg = moduleUnitId mod
+ _otherwise -> return (RecompBecause reason)
+
+needInterface :: Module -> (ModIface -> IfG RecompileRequired)
+ -> IfG RecompileRequired
+needInterface mod continue
+ = do -- Load the imported interface if possible
+ let doc_str = sep [text "need version info for", ppr mod]
+ traceHiDiffs (text "Checking usages for module" <+> ppr mod)
+
+ mb_iface <- loadInterface doc_str mod ImportBySystem
+ -- Load the interface, but don't complain on failure;
+ -- Instead, get an Either back which we can test
+
+ case mb_iface of
+ Failed _ -> do
+ traceHiDiffs (sep [text "Couldn't load interface for module",
+ ppr mod])
+ return MustCompile
+ -- Couldn't find or parse a module mentioned in the
+ -- old interface file. Don't complain: it might
+ -- just be that the current module doesn't need that
+ -- import and it's been deleted
+ Succeeded iface -> continue iface
+
+-- | Given the usage information extracted from the old
+-- M.hi file for the module being compiled, figure out
+-- whether M needs to be recompiled.
+checkModUsage :: UnitId -> Usage -> IfG RecompileRequired
+checkModUsage _this_pkg UsagePackageModule{
+ usg_mod = mod,
+ usg_mod_hash = old_mod_hash }
+ = needInterface mod $ \iface -> do
+ let reason = moduleNameString (moduleName mod) ++ " changed"
+ checkModuleFingerprint reason old_mod_hash (mi_mod_hash iface)
+ -- We only track the ABI hash of package modules, rather than
+ -- individual entity usages, so if the ABI hash changes we must
+ -- recompile. This is safe but may entail more recompilation when
+ -- a dependent package has changed.
+
+checkModUsage _ UsageMergedRequirement{ usg_mod = mod, usg_mod_hash = old_mod_hash }
+ = needInterface mod $ \iface -> do
+ let reason = moduleNameString (moduleName mod) ++ " changed (raw)"
+ checkModuleFingerprint reason old_mod_hash (mi_mod_hash iface)
+
+checkModUsage this_pkg UsageHomeModule{
+ usg_mod_name = mod_name,
+ usg_mod_hash = old_mod_hash,
+ usg_exports = maybe_old_export_hash,
+ usg_entities = old_decl_hash }
+ = do
+ let mod = mkModule this_pkg mod_name
+ needInterface mod $ \iface -> do
+
+ let
+ new_mod_hash = mi_mod_hash iface
+ new_decl_hash = mi_hash_fn iface
+ new_export_hash = mi_exp_hash iface
+
+ reason = moduleNameString mod_name ++ " changed"
+
+ -- CHECK MODULE
+ recompile <- checkModuleFingerprint reason old_mod_hash new_mod_hash
+ if not (recompileRequired recompile)
+ then return UpToDate
+ else do
+
+ -- CHECK EXPORT LIST
+ checkMaybeHash reason maybe_old_export_hash new_export_hash
+ (text " Export list changed") $ do
+
+ -- CHECK ITEMS ONE BY ONE
+ recompile <- checkList [ checkEntityUsage reason new_decl_hash u
+ | u <- old_decl_hash]
+ if recompileRequired recompile
+ then return recompile -- This one failed, so just bail out now
+ else up_to_date (text " Great! The bits I use are up to date")
+
+
+checkModUsage _this_pkg UsageFile{ usg_file_path = file,
+ usg_file_hash = old_hash } =
+ liftIO $
+ handleIO handle $ do
+ new_hash <- getFileHash file
+ if (old_hash /= new_hash)
+ then return recomp
+ else return UpToDate
+ where
+ recomp = RecompBecause (file ++ " changed")
+ handle =
+#ifdef DEBUG
+ \e -> pprTrace "UsageFile" (text (show e)) $ return recomp
+#else
+ \_ -> return recomp -- if we can't find the file, just recompile, don't fail
+#endif
+
+------------------------
+checkModuleFingerprint :: String -> Fingerprint -> Fingerprint
+ -> IfG RecompileRequired
+checkModuleFingerprint reason old_mod_hash new_mod_hash
+ | new_mod_hash == old_mod_hash
+ = up_to_date (text "Module fingerprint unchanged")
+
+ | otherwise
+ = out_of_date_hash reason (text " Module fingerprint has changed")
+ old_mod_hash new_mod_hash
+
+------------------------
+checkMaybeHash :: String -> Maybe Fingerprint -> Fingerprint -> SDoc
+ -> IfG RecompileRequired -> IfG RecompileRequired
+checkMaybeHash reason maybe_old_hash new_hash doc continue
+ | Just hash <- maybe_old_hash, hash /= new_hash
+ = out_of_date_hash reason doc hash new_hash
+ | otherwise
+ = continue
+
+------------------------
+checkEntityUsage :: String
+ -> (OccName -> Maybe (OccName, Fingerprint))
+ -> (OccName, Fingerprint)
+ -> IfG RecompileRequired
+checkEntityUsage reason new_hash (name,old_hash)
+ = case new_hash name of
+
+ Nothing -> -- We used it before, but it ain't there now
+ out_of_date reason (sep [text "No longer exported:", ppr name])
+
+ Just (_, new_hash) -- It's there, but is it up to date?
+ | new_hash == old_hash -> do traceHiDiffs (text " Up to date" <+> ppr name <+> parens (ppr new_hash))
+ return UpToDate
+ | otherwise -> out_of_date_hash reason (text " Out of date:" <+> ppr name)
+ old_hash new_hash
+
+up_to_date :: SDoc -> IfG RecompileRequired
+up_to_date msg = traceHiDiffs msg >> return UpToDate
+
+out_of_date :: String -> SDoc -> IfG RecompileRequired
+out_of_date reason msg = traceHiDiffs msg >> return (RecompBecause reason)
+
+out_of_date_hash :: String -> SDoc -> Fingerprint -> Fingerprint -> IfG RecompileRequired
+out_of_date_hash reason msg old_hash new_hash
+ = out_of_date reason (hsep [msg, ppr old_hash, text "->", ppr new_hash])
+
+----------------------
+checkList :: [IfG RecompileRequired] -> IfG RecompileRequired
+-- This helper is used in two places
+checkList [] = return UpToDate
+checkList (check:checks) = do recompile <- check
+ if recompileRequired recompile
+ then return recompile
+ else checkList checks
+
+{-
+************************************************************************
+* *
+ Converting things to their Iface equivalents
+* *
+************************************************************************
+-}
+
+tyThingToIfaceDecl :: TyThing -> IfaceDecl
+tyThingToIfaceDecl (AnId id) = idToIfaceDecl id
+tyThingToIfaceDecl (ATyCon tycon) = snd (tyConToIfaceDecl emptyTidyEnv tycon)
+tyThingToIfaceDecl (ACoAxiom ax) = coAxiomToIfaceDecl ax
+tyThingToIfaceDecl (AConLike cl) = case cl of
+ RealDataCon dc -> dataConToIfaceDecl dc -- for ppr purposes only
+ PatSynCon ps -> patSynToIfaceDecl ps
+
+--------------------------
+idToIfaceDecl :: Id -> IfaceDecl
+-- The Id is already tidied, so that locally-bound names
+-- (lambdas, for-alls) already have non-clashing OccNames
+-- We can't tidy it here, locally, because it may have
+-- free variables in its type or IdInfo
+idToIfaceDecl id
+ = IfaceId { ifName = getName id,
+ ifType = toIfaceType (idType id),
+ ifIdDetails = toIfaceIdDetails (idDetails id),
+ ifIdInfo = toIfaceIdInfo (idInfo id) }
+
+--------------------------
+dataConToIfaceDecl :: DataCon -> IfaceDecl
+dataConToIfaceDecl dataCon
+ = IfaceId { ifName = getName dataCon,
+ ifType = toIfaceType (dataConUserType dataCon),
+ ifIdDetails = IfVanillaId,
+ ifIdInfo = NoInfo }
+
+--------------------------
+coAxiomToIfaceDecl :: CoAxiom br -> IfaceDecl
+-- We *do* tidy Axioms, because they are not (and cannot
+-- conveniently be) built in tidy form
+coAxiomToIfaceDecl ax@(CoAxiom { co_ax_tc = tycon, co_ax_branches = branches
+ , co_ax_role = role })
+ = IfaceAxiom { ifName = getName ax
+ , ifTyCon = toIfaceTyCon tycon
+ , ifRole = role
+ , ifAxBranches = map (coAxBranchToIfaceBranch tycon
+ (map coAxBranchLHS branch_list))
+ branch_list }
+ where
+ branch_list = fromBranches branches
+
+-- 2nd parameter is the list of branch LHSs, for conversion from incompatible branches
+-- to incompatible indices
+-- See Note [Storing compatibility] in CoAxiom
+coAxBranchToIfaceBranch :: TyCon -> [[Type]] -> CoAxBranch -> IfaceAxBranch
+coAxBranchToIfaceBranch tc lhs_s
+ branch@(CoAxBranch { cab_incomps = incomps })
+ = (coAxBranchToIfaceBranch' tc branch) { ifaxbIncomps = iface_incomps }
+ where
+ iface_incomps = map (expectJust "iface_incomps"
+ . (flip findIndex lhs_s
+ . eqTypes)
+ . coAxBranchLHS) incomps
+
+-- use this one for standalone branches without incompatibles
+coAxBranchToIfaceBranch' :: TyCon -> CoAxBranch -> IfaceAxBranch
+coAxBranchToIfaceBranch' tc (CoAxBranch { cab_tvs = tvs, cab_cvs = cvs
+ , cab_lhs = lhs
+ , cab_roles = roles, cab_rhs = rhs })
+ = IfaceAxBranch { ifaxbTyVars = toIfaceTvBndrs tidy_tvs
+ , ifaxbCoVars = map toIfaceIdBndr cvs
+ , ifaxbLHS = tidyToIfaceTcArgs env1 tc lhs
+ , ifaxbRoles = roles
+ , ifaxbRHS = tidyToIfaceType env1 rhs
+ , ifaxbIncomps = [] }
+ where
+ (env1, tidy_tvs) = tidyTyCoVarBndrs emptyTidyEnv tvs
+ -- Don't re-bind in-scope tyvars
+ -- See Note [CoAxBranch type variables] in CoAxiom
+
+-----------------
+tyConToIfaceDecl :: TidyEnv -> TyCon -> (TidyEnv, IfaceDecl)
+-- We *do* tidy TyCons, because they are not (and cannot
+-- conveniently be) built in tidy form
+-- The returned TidyEnv is the one after tidying the tyConTyVars
+tyConToIfaceDecl env tycon
+ | Just clas <- tyConClass_maybe tycon
+ = classToIfaceDecl env clas
+
+ | Just syn_rhs <- synTyConRhs_maybe tycon
+ = ( tc_env1
+ , IfaceSynonym { ifName = getName tycon,
+ ifRoles = tyConRoles tycon,
+ ifSynRhs = if_syn_type syn_rhs,
+ ifBinders = if_binders,
+ ifResKind = if_res_kind
+ })
+
+ | Just fam_flav <- famTyConFlav_maybe tycon
+ = ( tc_env1
+ , IfaceFamily { ifName = getName tycon,
+ ifResVar = if_res_var,
+ ifFamFlav = to_if_fam_flav fam_flav,
+ ifBinders = if_binders,
+ ifResKind = if_res_kind,
+ ifFamInj = familyTyConInjectivityInfo tycon
+ })
+
+ | isAlgTyCon tycon
+ = ( tc_env1
+ , IfaceData { ifName = getName tycon,
+ ifBinders = if_binders,
+ ifResKind = if_res_kind,
+ ifCType = tyConCType tycon,
+ ifRoles = tyConRoles tycon,
+ ifCtxt = tidyToIfaceContext tc_env1 (tyConStupidTheta tycon),
+ ifCons = ifaceConDecls (algTyConRhs tycon),
+ ifGadtSyntax = isGadtSyntaxTyCon tycon,
+ ifParent = parent })
+
+ | otherwise -- FunTyCon, PrimTyCon, promoted TyCon/DataCon
+ -- We only convert these TyCons to IfaceTyCons when we are
+ -- just about to pretty-print them, not because we are going
+ -- to put them into interface files
+ = ( env
+ , IfaceData { ifName = getName tycon,
+ ifBinders = if_binders,
+ ifResKind = if_res_kind,
+ ifCType = Nothing,
+ ifRoles = tyConRoles tycon,
+ ifCtxt = [],
+ ifCons = IfDataTyCon [],
+ ifGadtSyntax = False,
+ ifParent = IfNoParent })
+ where
+ -- NOTE: Not all TyCons have `tyConTyVars` field. Forcing this when `tycon`
+ -- is one of these TyCons (FunTyCon, PrimTyCon, PromotedDataCon) will cause
+ -- an error.
+ (tc_env1, tc_binders) = tidyTyConBinders env (tyConBinders tycon)
+ tc_tyvars = binderVars tc_binders
+ if_binders = toIfaceTyVarBinders tc_binders
+ if_res_kind = tidyToIfaceType tc_env1 (tyConResKind tycon)
+ if_syn_type ty = tidyToIfaceType tc_env1 ty
+ if_res_var = getOccFS `fmap` tyConFamilyResVar_maybe tycon
+
+ parent = case tyConFamInstSig_maybe tycon of
+ Just (tc, ty, ax) -> IfDataInstance (coAxiomName ax)
+ (toIfaceTyCon tc)
+ (tidyToIfaceTcArgs tc_env1 tc ty)
+ Nothing -> IfNoParent
+
+ to_if_fam_flav OpenSynFamilyTyCon = IfaceOpenSynFamilyTyCon
+ to_if_fam_flav (ClosedSynFamilyTyCon (Just ax))
+ = IfaceClosedSynFamilyTyCon (Just (axn, ibr))
+ where defs = fromBranches $ coAxiomBranches ax
+ ibr = map (coAxBranchToIfaceBranch' tycon) defs
+ axn = coAxiomName ax
+ to_if_fam_flav (ClosedSynFamilyTyCon Nothing)
+ = IfaceClosedSynFamilyTyCon Nothing
+ to_if_fam_flav AbstractClosedSynFamilyTyCon = IfaceAbstractClosedSynFamilyTyCon
+ to_if_fam_flav (DataFamilyTyCon {}) = IfaceDataFamilyTyCon
+ to_if_fam_flav (BuiltInSynFamTyCon {}) = IfaceBuiltInSynFamTyCon
+
+
+
+ ifaceConDecls (NewTyCon { data_con = con }) = IfNewTyCon (ifaceConDecl con)
+ ifaceConDecls (DataTyCon { data_cons = cons }) = IfDataTyCon (map ifaceConDecl cons)
+ ifaceConDecls (TupleTyCon { data_con = con }) = IfDataTyCon [ifaceConDecl con]
+ ifaceConDecls (SumTyCon { data_cons = cons }) = IfDataTyCon (map ifaceConDecl cons)
+ ifaceConDecls AbstractTyCon = IfAbstractTyCon
+ -- The AbstractTyCon case happens when a TyCon has been trimmed
+ -- during tidying.
+ -- Furthermore, tyThingToIfaceDecl is also used in TcRnDriver
+ -- for GHCi, when browsing a module, in which case the
+ -- AbstractTyCon and TupleTyCon cases are perfectly sensible.
+ -- (Tuple declarations are not serialised into interface files.)
+
+ ifaceConDecl data_con
+ = IfCon { ifConName = dataConName data_con,
+ ifConInfix = dataConIsInfix data_con,
+ ifConWrapper = isJust (dataConWrapId_maybe data_con),
+ ifConExTvs = map toIfaceForAllBndr ex_bndrs',
+ ifConEqSpec = map (to_eq_spec . eqSpecPair) eq_spec,
+ ifConCtxt = tidyToIfaceContext con_env2 theta,
+ ifConArgTys = map (tidyToIfaceType con_env2) arg_tys,
+ ifConFields = dataConFieldLabels data_con,
+ ifConStricts = map (toIfaceBang con_env2)
+ (dataConImplBangs data_con),
+ ifConSrcStricts = map toIfaceSrcBang
+ (dataConSrcBangs data_con)}
+ where
+ (univ_tvs, _ex_tvs, eq_spec, theta, arg_tys, _)
+ = dataConFullSig data_con
+ ex_bndrs = dataConExTyVarBinders data_con
+
+ -- Tidy the univ_tvs of the data constructor to be identical
+ -- to the tyConTyVars of the type constructor. This means
+ -- (a) we don't need to redundantly put them into the interface file
+ -- (b) when pretty-printing an Iface data declaration in H98-style syntax,
+ -- we know that the type variables will line up
+ -- The latter (b) is important because we pretty-print type constructors
+ -- by converting to IfaceSyn and pretty-printing that
+ con_env1 = (fst tc_env1, mkVarEnv (zipEqual "ifaceConDecl" univ_tvs tc_tyvars))
+ -- A bit grimy, perhaps, but it's simple!
+
+ (con_env2, ex_bndrs') = tidyTyVarBinders con_env1 ex_bndrs
+ to_eq_spec (tv,ty) = (tidyTyVar con_env2 tv, tidyToIfaceType con_env2 ty)
+
+classToIfaceDecl :: TidyEnv -> Class -> (TidyEnv, IfaceDecl)
+classToIfaceDecl env clas
+ = ( env1
+ , IfaceClass { ifName = getName tycon,
+ ifRoles = tyConRoles (classTyCon clas),
+ ifBinders = toIfaceTyVarBinders tc_binders,
+ ifBody = body,
+ ifFDs = map toIfaceFD clas_fds })
+ where
+ (_, clas_fds, sc_theta, _, clas_ats, op_stuff)
+ = classExtraBigSig clas
+ tycon = classTyCon clas
+
+ body | isAbstractTyCon tycon = IfAbstractClass
+ | otherwise
+ = IfConcreteClass {
+ ifClassCtxt = tidyToIfaceContext env1 sc_theta,
+ ifATs = map toIfaceAT clas_ats,
+ ifSigs = map toIfaceClassOp op_stuff,
+ ifMinDef = fmap getOccFS (classMinimalDef clas)
+ }
+
+ (env1, tc_binders) = tidyTyConBinders env (tyConBinders tycon)
+
+ toIfaceAT :: ClassATItem -> IfaceAT
+ toIfaceAT (ATI tc def)
+ = IfaceAT if_decl (fmap (tidyToIfaceType env2 . fst) def)
+ where
+ (env2, if_decl) = tyConToIfaceDecl env1 tc
+
+ toIfaceClassOp (sel_id, def_meth)
+ = ASSERT( sel_tyvars == binderVars tc_binders )
+ IfaceClassOp (getName sel_id)
+ (tidyToIfaceType env1 op_ty)
+ (fmap toDmSpec def_meth)
+ where
+ -- Be careful when splitting the type, because of things
+ -- like class Foo a where
+ -- op :: (?x :: String) => a -> a
+ -- and class Baz a where
+ -- op :: (Ord a) => a -> a
+ (sel_tyvars, rho_ty) = splitForAllTys (idType sel_id)
+ op_ty = funResultTy rho_ty
+
+ toDmSpec :: (Name, DefMethSpec Type) -> DefMethSpec IfaceType
+ toDmSpec (_, VanillaDM) = VanillaDM
+ toDmSpec (_, GenericDM dm_ty) = GenericDM (tidyToIfaceType env1 dm_ty)
+
+ toIfaceFD (tvs1, tvs2) = (map (tidyTyVar env1) tvs1
+ ,map (tidyTyVar env1) tvs2)
+
+--------------------------
+
+tidyTyConBinder :: TidyEnv -> TyConBinder -> (TidyEnv, TyConBinder)
+-- If the type variable "binder" is in scope, don't re-bind it
+-- In a class decl, for example, the ATD binders mention
+-- (amd must mention) the class tyvars
+tidyTyConBinder env@(_, subst) tvb@(TvBndr tv vis)
+ = case lookupVarEnv subst tv of
+ Just tv' -> (env, TvBndr tv' vis)
+ Nothing -> tidyTyVarBinder env tvb
+
+tidyTyConBinders :: TidyEnv -> [TyConBinder] -> (TidyEnv, [TyConBinder])
+tidyTyConBinders = mapAccumL tidyTyConBinder
+
+tidyTyVar :: TidyEnv -> TyVar -> FastString
+tidyTyVar (_, subst) tv = toIfaceTyVar (lookupVarEnv subst tv `orElse` tv)
+
+--------------------------
+instanceToIfaceInst :: ClsInst -> IfaceClsInst
+instanceToIfaceInst (ClsInst { is_dfun = dfun_id, is_flag = oflag
+ , is_cls_nm = cls_name, is_cls = cls
+ , is_tcs = mb_tcs
+ , is_orphan = orph })
+ = ASSERT( cls_name == className cls )
+ IfaceClsInst { ifDFun = dfun_name,
+ ifOFlag = oflag,
+ ifInstCls = cls_name,
+ ifInstTys = map do_rough mb_tcs,
+ ifInstOrph = orph }
+ where
+ do_rough Nothing = Nothing
+ do_rough (Just n) = Just (toIfaceTyCon_name n)
+
+ dfun_name = idName dfun_id
+
+
+--------------------------
+famInstToIfaceFamInst :: FamInst -> IfaceFamInst
+famInstToIfaceFamInst (FamInst { fi_axiom = axiom,
+ fi_fam = fam,
+ fi_tcs = roughs })
+ = IfaceFamInst { ifFamInstAxiom = coAxiomName axiom
+ , ifFamInstFam = fam
+ , ifFamInstTys = map do_rough roughs
+ , ifFamInstOrph = orph }
+ where
+ do_rough Nothing = Nothing
+ do_rough (Just n) = Just (toIfaceTyCon_name n)
+
+ fam_decl = tyConName $ coAxiomTyCon axiom
+ mod = ASSERT( isExternalName (coAxiomName axiom) )
+ nameModule (coAxiomName axiom)
+ is_local name = nameIsLocalOrFrom mod name
+
+ lhs_names = filterNameSet is_local (orphNamesOfCoCon axiom)
+
+ orph | is_local fam_decl
+ = NotOrphan (nameOccName fam_decl)
+ | otherwise
+ = chooseOrphanAnchor lhs_names
+
+--------------------------
+coreRuleToIfaceRule :: CoreRule -> IfaceRule
+coreRuleToIfaceRule (BuiltinRule { ru_fn = fn})
+ = pprTrace "toHsRule: builtin" (ppr fn) $
+ bogusIfaceRule fn
+
+coreRuleToIfaceRule (Rule { ru_name = name, ru_fn = fn,
+ ru_act = act, ru_bndrs = bndrs,
+ ru_args = args, ru_rhs = rhs,
+ ru_orphan = orph, ru_auto = auto })
+ = IfaceRule { ifRuleName = name, ifActivation = act,
+ ifRuleBndrs = map toIfaceBndr bndrs,
+ ifRuleHead = fn,
+ ifRuleArgs = map do_arg args,
+ ifRuleRhs = toIfaceExpr rhs,
+ ifRuleAuto = auto,
+ ifRuleOrph = orph }
+ where
+ -- For type args we must remove synonyms from the outermost
+ -- level. Reason: so that when we read it back in we'll
+ -- construct the same ru_rough field as we have right now;
+ -- see tcIfaceRule
+ do_arg (Type ty) = IfaceType (toIfaceType (deNoteType ty))
+ do_arg (Coercion co) = IfaceCo (toIfaceCoercion co)
+ do_arg arg = toIfaceExpr arg
+
+bogusIfaceRule :: Name -> IfaceRule
+bogusIfaceRule id_name
+ = IfaceRule { ifRuleName = fsLit "bogus", ifActivation = NeverActive,
+ ifRuleBndrs = [], ifRuleHead = id_name, ifRuleArgs = [],
+ ifRuleRhs = IfaceExt id_name, ifRuleOrph = IsOrphan,
+ ifRuleAuto = True }
diff --git a/iface/TcIface.hs b/iface/TcIface.hs
new file mode 100644
--- /dev/null
+++ b/iface/TcIface.hs
@@ -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 for the constructor arg tys
+ * we build a thunk for the extended type environment (depends on )
+ * we write the extended type envt into the global EPS mutvar
+
+Now we look something up in the type envt
+ * that pulls on
+ * which reads the global type envt out of the global EPS mutvar
+ * but that depends in turn on
+
+It's subtle, because, it'd work fine if we typechecked the constructor args
+eagerly -- they don't need the extended type envt. They just get the extended
+type envt by accident, because they look at it later.
+
+What this means is that the implicitTyThings MUST NOT DEPEND on any of
+the forkM stuff.
+-}
+
+tcIfaceDecl :: Bool -- ^ True <=> discard IdInfo on IfaceId bindings
+ -> IfaceDecl
+ -> IfL TyThing
+tcIfaceDecl = tc_iface_decl Nothing
+
+tc_iface_decl :: Maybe Class -- ^ For associated type/data family declarations
+ -> Bool -- ^ True <=> discard IdInfo on IfaceId bindings
+ -> IfaceDecl
+ -> IfL TyThing
+tc_iface_decl _ ignore_prags (IfaceId {ifName = name, ifType = iface_type,
+ ifIdDetails = details, ifIdInfo = info})
+ = do { ty <- tcIfaceType iface_type
+ ; details <- tcIdDetails ty details
+ ; info <- tcIdInfo ignore_prags name ty info
+ ; return (AnId (mkGlobalId details name ty info)) }
+
+tc_iface_decl _ _ (IfaceData {ifName = tc_name,
+ ifCType = cType,
+ ifBinders = binders,
+ ifResKind = res_kind,
+ ifRoles = roles,
+ ifCtxt = ctxt, ifGadtSyntax = gadt_syn,
+ ifCons = rdr_cons,
+ ifParent = mb_parent })
+ = bindIfaceTyConBinders_AT binders $ \ binders' -> do
+ { res_kind' <- tcIfaceType res_kind
+
+ ; tycon <- fixM $ \ tycon -> do
+ { stupid_theta <- tcIfaceCtxt ctxt
+ ; parent' <- tc_parent tc_name mb_parent
+ ; cons <- tcIfaceDataCons tc_name tycon binders' rdr_cons
+ ; return (mkAlgTyCon tc_name binders' res_kind'
+ roles cType stupid_theta
+ cons parent' gadt_syn) }
+ ; traceIf (text "tcIfaceDecl4" <+> ppr tycon)
+ ; return (ATyCon tycon) }
+ where
+ tc_parent :: Name -> IfaceTyConParent -> IfL AlgTyConFlav
+ tc_parent tc_name IfNoParent
+ = do { tc_rep_name <- newTyConRepName tc_name
+ ; return (VanillaAlgTyCon tc_rep_name) }
+ tc_parent _ (IfDataInstance ax_name _ arg_tys)
+ = do { ax <- tcIfaceCoAxiom ax_name
+ ; let fam_tc = coAxiomTyCon ax
+ ax_unbr = toUnbranchedAxiom ax
+ ; lhs_tys <- tcIfaceTcArgs arg_tys
+ ; return (DataFamInstTyCon ax_unbr fam_tc lhs_tys) }
+
+tc_iface_decl _ _ (IfaceSynonym {ifName = tc_name,
+ ifRoles = roles,
+ ifSynRhs = rhs_ty,
+ ifBinders = binders,
+ ifResKind = res_kind })
+ = bindIfaceTyConBinders_AT binders $ \ binders' -> do
+ { res_kind' <- tcIfaceType res_kind -- Note [Synonym kind loop]
+ ; rhs <- forkM (mk_doc tc_name) $
+ tcIfaceType rhs_ty
+ ; let tycon = buildSynTyCon tc_name binders' res_kind' roles rhs
+ ; return (ATyCon tycon) }
+ where
+ mk_doc n = text "Type synonym" <+> ppr n
+
+tc_iface_decl parent _ (IfaceFamily {ifName = tc_name,
+ ifFamFlav = fam_flav,
+ ifBinders = binders,
+ ifResKind = res_kind,
+ ifResVar = res, ifFamInj = inj })
+ = bindIfaceTyConBinders_AT binders $ \ binders' -> do
+ { res_kind' <- tcIfaceType res_kind -- Note [Synonym kind loop]
+ ; rhs <- forkM (mk_doc tc_name) $
+ tc_fam_flav tc_name fam_flav
+ ; res_name <- traverse (newIfaceName . mkTyVarOccFS) res
+ ; let tycon = mkFamilyTyCon tc_name binders' res_kind' res_name rhs parent inj
+ ; return (ATyCon tycon) }
+ where
+ mk_doc n = text "Type synonym" <+> ppr n
+
+ tc_fam_flav :: Name -> IfaceFamTyConFlav -> IfL FamTyConFlav
+ tc_fam_flav tc_name IfaceDataFamilyTyCon
+ = do { tc_rep_name <- newTyConRepName tc_name
+ ; return (DataFamilyTyCon tc_rep_name) }
+ tc_fam_flav _ IfaceOpenSynFamilyTyCon= return OpenSynFamilyTyCon
+ tc_fam_flav _ (IfaceClosedSynFamilyTyCon mb_ax_name_branches)
+ = do { ax <- traverse (tcIfaceCoAxiom . fst) mb_ax_name_branches
+ ; return (ClosedSynFamilyTyCon ax) }
+ tc_fam_flav _ IfaceAbstractClosedSynFamilyTyCon
+ = return AbstractClosedSynFamilyTyCon
+ tc_fam_flav _ IfaceBuiltInSynFamTyCon
+ = pprPanic "tc_iface_decl"
+ (text "IfaceBuiltInSynFamTyCon in interface file")
+
+tc_iface_decl _parent _ignore_prags
+ (IfaceClass {ifName = tc_name,
+ ifRoles = roles,
+ ifBinders = binders,
+ ifFDs = rdr_fds,
+ ifBody = IfAbstractClass})
+ = bindIfaceTyConBinders binders $ \ binders' -> do
+ { fds <- mapM tc_fd rdr_fds
+ ; cls <- buildClass tc_name binders' roles fds Nothing
+ ; return (ATyCon (classTyCon cls)) }
+
+tc_iface_decl _parent ignore_prags
+ (IfaceClass {ifName = tc_name,
+ ifRoles = roles,
+ ifBinders = binders,
+ ifFDs = rdr_fds,
+ ifBody = IfConcreteClass {
+ ifClassCtxt = rdr_ctxt,
+ ifATs = rdr_ats, ifSigs = rdr_sigs,
+ ifMinDef = mindef_occ
+ }})
+ = bindIfaceTyConBinders binders $ \ binders' -> do
+ { traceIf (text "tc-iface-class1" <+> ppr tc_name)
+ ; ctxt <- mapM tc_sc rdr_ctxt
+ ; traceIf (text "tc-iface-class2" <+> ppr tc_name)
+ ; sigs <- mapM tc_sig rdr_sigs
+ ; fds <- mapM tc_fd rdr_fds
+ ; traceIf (text "tc-iface-class3" <+> ppr tc_name)
+ ; mindef <- traverse (lookupIfaceTop . mkVarOccFS) mindef_occ
+ ; cls <- fixM $ \ cls -> do
+ { ats <- mapM (tc_at cls) rdr_ats
+ ; traceIf (text "tc-iface-class4" <+> ppr tc_name)
+ ; buildClass tc_name binders' roles fds (Just (ctxt, ats, sigs, mindef)) }
+ ; return (ATyCon (classTyCon cls)) }
+ where
+ tc_sc pred = forkM (mk_sc_doc pred) (tcIfaceType pred)
+ -- The *length* of the superclasses is used by buildClass, and hence must
+ -- not be inside the thunk. But the *content* maybe recursive and hence
+ -- must be lazy (via forkM). Example:
+ -- class C (T a) => D a where
+ -- data T a
+ -- Here the associated type T is knot-tied with the class, and
+ -- so we must not pull on T too eagerly. See Trac #5970
+
+ tc_sig :: IfaceClassOp -> IfL TcMethInfo
+ tc_sig (IfaceClassOp op_name rdr_ty dm)
+ = do { let doc = mk_op_doc op_name rdr_ty
+ ; op_ty <- forkM (doc <+> text "ty") $ tcIfaceType rdr_ty
+ -- Must be done lazily for just the same reason as the
+ -- type of a data con; to avoid sucking in types that
+ -- it mentions unless it's necessary to do so
+ ; dm' <- tc_dm doc dm
+ ; return (op_name, op_ty, dm') }
+
+ tc_dm :: SDoc
+ -> Maybe (DefMethSpec IfaceType)
+ -> IfL (Maybe (DefMethSpec (SrcSpan, Type)))
+ tc_dm _ Nothing = return Nothing
+ tc_dm _ (Just VanillaDM) = return (Just VanillaDM)
+ tc_dm doc (Just (GenericDM ty))
+ = do { -- Must be done lazily to avoid sucking in types
+ ; ty' <- forkM (doc <+> text "dm") $ tcIfaceType ty
+ ; return (Just (GenericDM (noSrcSpan, ty'))) }
+
+ tc_at cls (IfaceAT tc_decl if_def)
+ = do ATyCon tc <- tc_iface_decl (Just cls) ignore_prags tc_decl
+ mb_def <- case if_def of
+ Nothing -> return Nothing
+ Just def -> forkM (mk_at_doc tc) $
+ extendIfaceTyVarEnv (tyConTyVars tc) $
+ do { tc_def <- tcIfaceType def
+ ; return (Just (tc_def, noSrcSpan)) }
+ -- Must be done lazily in case the RHS of the defaults mention
+ -- the type constructor being defined here
+ -- e.g. type AT a; type AT b = AT [b] Trac #8002
+ return (ATI tc mb_def)
+
+ mk_sc_doc pred = text "Superclass" <+> ppr pred
+ mk_at_doc tc = text "Associated type" <+> ppr tc
+ mk_op_doc op_name op_ty = text "Class op" <+> sep [ppr op_name, ppr op_ty]
+
+tc_iface_decl _ _ (IfaceAxiom { ifName = tc_name, ifTyCon = tc
+ , ifAxBranches = branches, ifRole = role })
+ = do { tc_tycon <- tcIfaceTyCon tc
+ -- Must be done lazily, because axioms are forced when checking
+ -- for family instance consistency, and the RHS may mention
+ -- a hs-boot declared type constructor that is going to be
+ -- defined by this module.
+ -- e.g. type instance F Int = ToBeDefined
+ -- See Trac #13803
+ ; tc_branches <- forkM (text "Axiom branches" <+> ppr tc_name)
+ $ tc_ax_branches branches
+ ; let axiom = CoAxiom { co_ax_unique = nameUnique tc_name
+ , co_ax_name = tc_name
+ , co_ax_tc = tc_tycon
+ , co_ax_role = role
+ , co_ax_branches = manyBranches tc_branches
+ , co_ax_implicit = False }
+ ; return (ACoAxiom axiom) }
+
+tc_iface_decl _ _ (IfacePatSyn{ ifName = name
+ , ifPatMatcher = if_matcher
+ , ifPatBuilder = if_builder
+ , ifPatIsInfix = is_infix
+ , ifPatUnivBndrs = univ_bndrs
+ , ifPatExBndrs = ex_bndrs
+ , ifPatProvCtxt = prov_ctxt
+ , ifPatReqCtxt = req_ctxt
+ , ifPatArgs = args
+ , ifPatTy = pat_ty
+ , ifFieldLabels = field_labels })
+ = do { traceIf (text "tc_iface_decl" <+> ppr name)
+ ; matcher <- tc_pr if_matcher
+ ; builder <- fmapMaybeM tc_pr if_builder
+ ; bindIfaceForAllBndrs univ_bndrs $ \univ_tvs -> do
+ { bindIfaceForAllBndrs ex_bndrs $ \ex_tvs -> do
+ { patsyn <- forkM (mk_doc name) $
+ do { prov_theta <- tcIfaceCtxt prov_ctxt
+ ; req_theta <- tcIfaceCtxt req_ctxt
+ ; pat_ty <- tcIfaceType pat_ty
+ ; arg_tys <- mapM tcIfaceType args
+ ; return $ buildPatSyn name is_infix matcher builder
+ (univ_tvs, req_theta)
+ (ex_tvs, prov_theta)
+ arg_tys pat_ty field_labels }
+ ; return $ AConLike . PatSynCon $ patsyn }}}
+ where
+ mk_doc n = text "Pattern synonym" <+> ppr n
+ tc_pr :: (IfExtName, Bool) -> IfL (Id, Bool)
+ tc_pr (nm, b) = do { id <- forkM (ppr nm) (tcIfaceExtId nm)
+ ; return (id, b) }
+
+tc_fd :: FunDep IfLclName -> IfL (FunDep TyVar)
+tc_fd (tvs1, tvs2) = do { tvs1' <- mapM tcIfaceTyVar tvs1
+ ; tvs2' <- mapM tcIfaceTyVar tvs2
+ ; return (tvs1', tvs2') }
+
+tc_ax_branches :: [IfaceAxBranch] -> IfL [CoAxBranch]
+tc_ax_branches if_branches = foldlM tc_ax_branch [] if_branches
+
+tc_ax_branch :: [CoAxBranch] -> IfaceAxBranch -> IfL [CoAxBranch]
+tc_ax_branch prev_branches
+ (IfaceAxBranch { ifaxbTyVars = tv_bndrs, ifaxbCoVars = cv_bndrs
+ , ifaxbLHS = lhs, ifaxbRHS = rhs
+ , ifaxbRoles = roles, ifaxbIncomps = incomps })
+ = bindIfaceTyConBinders_AT
+ (map (\b -> TvBndr b (NamedTCB Inferred)) tv_bndrs) $ \ tvs ->
+ -- The _AT variant is needed here; see Note [CoAxBranch type variables] in CoAxiom
+ bindIfaceIds cv_bndrs $ \ cvs -> do
+ { tc_lhs <- tcIfaceTcArgs lhs
+ ; tc_rhs <- tcIfaceType rhs
+ ; let br = CoAxBranch { cab_loc = noSrcSpan
+ , cab_tvs = binderVars tvs
+ , cab_cvs = cvs
+ , cab_lhs = tc_lhs
+ , cab_roles = roles
+ , cab_rhs = tc_rhs
+ , cab_incomps = map (prev_branches `getNth`) incomps }
+ ; return (prev_branches ++ [br]) }
+
+tcIfaceDataCons :: Name -> TyCon -> [TyConBinder] -> IfaceConDecls -> IfL AlgTyConRhs
+tcIfaceDataCons tycon_name tycon tc_tybinders if_cons
+ = case if_cons of
+ IfAbstractTyCon -> return AbstractTyCon
+ IfDataTyCon cons -> do { data_cons <- mapM tc_con_decl cons
+ ; return (mkDataTyConRhs data_cons) }
+ IfNewTyCon con -> do { data_con <- tc_con_decl con
+ ; mkNewTyConRhs tycon_name tycon data_con }
+ where
+ univ_tv_bndrs :: [TyVarBinder]
+ univ_tv_bndrs = mkDataConUnivTyVarBinders tc_tybinders
+
+ tc_con_decl (IfCon { ifConInfix = is_infix,
+ ifConExTvs = ex_bndrs,
+ ifConName = dc_name,
+ ifConCtxt = ctxt, ifConEqSpec = spec,
+ ifConArgTys = args, ifConFields = lbl_names,
+ ifConStricts = if_stricts,
+ ifConSrcStricts = if_src_stricts})
+ = -- Universally-quantified tyvars are shared with
+ -- parent TyCon, and are already in scope
+ bindIfaceForAllBndrs ex_bndrs $ \ ex_tv_bndrs -> do
+ { traceIf (text "Start interface-file tc_con_decl" <+> ppr dc_name)
+
+ -- Read the context and argument types, but lazily for two reasons
+ -- (a) to avoid looking tugging on a recursive use of
+ -- the type itself, which is knot-tied
+ -- (b) to avoid faulting in the component types unless
+ -- they are really needed
+ ; ~(eq_spec, theta, arg_tys, stricts) <- forkM (mk_doc dc_name) $
+ do { eq_spec <- tcIfaceEqSpec spec
+ ; theta <- tcIfaceCtxt ctxt
+ ; arg_tys <- mapM tcIfaceType args
+ ; stricts <- mapM tc_strict if_stricts
+ -- The IfBang field can mention
+ -- the type itself; hence inside forkM
+ ; return (eq_spec, theta, arg_tys, stricts) }
+
+ -- Remember, tycon is the representation tycon
+ ; let orig_res_ty = mkFamilyTyConApp tycon
+ (substTyVars (mkTvSubstPrs (map eqSpecPair eq_spec))
+ (binderVars tc_tybinders))
+
+ ; prom_rep_name <- newTyConRepName dc_name
+
+ ; con <- buildDataCon (pprPanic "tcIfaceDataCons: FamInstEnvs" (ppr dc_name))
+ dc_name is_infix prom_rep_name
+ (map src_strict if_src_stricts)
+ (Just stricts)
+ -- Pass the HsImplBangs (i.e. final
+ -- decisions) to buildDataCon; it'll use
+ -- these to guide the construction of a
+ -- worker.
+ -- See Note [Bangs on imported data constructors] in MkId
+ lbl_names
+ univ_tv_bndrs ex_tv_bndrs
+ eq_spec theta
+ arg_tys orig_res_ty tycon
+ ; traceIf (text "Done interface-file tc_con_decl" <+> ppr dc_name)
+ ; return con }
+ mk_doc con_name = text "Constructor" <+> ppr con_name
+
+ tc_strict :: IfaceBang -> IfL HsImplBang
+ tc_strict IfNoBang = return (HsLazy)
+ tc_strict IfStrict = return (HsStrict)
+ tc_strict IfUnpack = return (HsUnpack Nothing)
+ tc_strict (IfUnpackCo if_co) = do { co <- tcIfaceCo if_co
+ ; return (HsUnpack (Just co)) }
+
+ src_strict :: IfaceSrcBang -> HsSrcBang
+ src_strict (IfSrcBang unpk bang) = HsSrcBang NoSourceText unpk bang
+
+tcIfaceEqSpec :: IfaceEqSpec -> IfL [EqSpec]
+tcIfaceEqSpec spec
+ = mapM do_item spec
+ where
+ do_item (occ, if_ty) = do { tv <- tcIfaceTyVar occ
+ ; ty <- tcIfaceType if_ty
+ ; return (mkEqSpec tv ty) }
+
+{-
+Note [Synonym kind loop]
+~~~~~~~~~~~~~~~~~~~~~~~~
+Notice that we eagerly grab the *kind* from the interface file, but
+build a forkM thunk for the *rhs* (and family stuff). To see why,
+consider this (Trac #2412)
+
+M.hs: module M where { import X; data T = MkT S }
+X.hs: module X where { import {-# SOURCE #-} M; type S = T }
+M.hs-boot: module M where { data T }
+
+When kind-checking M.hs we need S's kind. But we do not want to
+find S's kind from (typeKind S-rhs), because we don't want to look at
+S-rhs yet! Since S is imported from X.hi, S gets just one chance to
+be defined, and we must not do that until we've finished with M.T.
+
+Solution: record S's kind in the interface file; now we can safely
+look at it.
+
+************************************************************************
+* *
+ Instances
+* *
+************************************************************************
+-}
+
+tcIfaceInst :: IfaceClsInst -> IfL ClsInst
+tcIfaceInst (IfaceClsInst { ifDFun = dfun_name, ifOFlag = oflag
+ , ifInstCls = cls, ifInstTys = mb_tcs
+ , ifInstOrph = orph })
+ = do { dfun <- forkM (text "Dict fun" <+> ppr dfun_name) $
+ fmap tyThingId (tcIfaceImplicit dfun_name)
+ ; let mb_tcs' = map (fmap ifaceTyConName) mb_tcs
+ ; return (mkImportedInstance cls mb_tcs' dfun_name dfun oflag orph) }
+
+tcIfaceFamInst :: IfaceFamInst -> IfL FamInst
+tcIfaceFamInst (IfaceFamInst { ifFamInstFam = fam, ifFamInstTys = mb_tcs
+ , ifFamInstAxiom = axiom_name } )
+ = do { axiom' <- forkM (text "Axiom" <+> ppr axiom_name) $
+ tcIfaceCoAxiom axiom_name
+ -- will panic if branched, but that's OK
+ ; let axiom'' = toUnbranchedAxiom axiom'
+ mb_tcs' = map (fmap ifaceTyConName) mb_tcs
+ ; return (mkImportedFamInst fam mb_tcs' axiom'') }
+
+{-
+************************************************************************
+* *
+ Rules
+* *
+************************************************************************
+
+We move a IfaceRule from eps_rules to eps_rule_base when all its LHS free vars
+are in the type environment. However, remember that typechecking a Rule may
+(as a side effect) augment the type envt, and so we may need to iterate the process.
+-}
+
+tcIfaceRules :: Bool -- True <=> ignore rules
+ -> [IfaceRule]
+ -> IfL [CoreRule]
+tcIfaceRules ignore_prags if_rules
+ | ignore_prags = return []
+ | otherwise = mapM tcIfaceRule if_rules
+
+tcIfaceRule :: IfaceRule -> IfL CoreRule
+tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs,
+ ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs,
+ ifRuleAuto = auto, ifRuleOrph = orph })
+ = do { ~(bndrs', args', rhs') <-
+ -- Typecheck the payload lazily, in the hope it'll never be looked at
+ forkM (text "Rule" <+> pprRuleName name) $
+ bindIfaceBndrs bndrs $ \ bndrs' ->
+ do { args' <- mapM tcIfaceExpr args
+ ; rhs' <- tcIfaceExpr rhs
+ ; return (bndrs', args', rhs') }
+ ; let mb_tcs = map ifTopFreeName args
+ ; this_mod <- getIfModule
+ ; return (Rule { ru_name = name, ru_fn = fn, ru_act = act,
+ ru_bndrs = bndrs', ru_args = args',
+ ru_rhs = occurAnalyseExpr rhs',
+ ru_rough = mb_tcs,
+ ru_origin = this_mod,
+ ru_orphan = orph,
+ ru_auto = auto,
+ ru_local = False }) } -- An imported RULE is never for a local Id
+ -- or, even if it is (module loop, perhaps)
+ -- we'll just leave it in the non-local set
+ where
+ -- This function *must* mirror exactly what Rules.roughTopNames does
+ -- We could have stored the ru_rough field in the iface file
+ -- but that would be redundant, I think.
+ -- The only wrinkle is that we must not be deceived by
+ -- type synonyms at the top of a type arg. Since
+ -- we can't tell at this point, we are careful not
+ -- to write them out in coreRuleToIfaceRule
+ ifTopFreeName :: IfaceExpr -> Maybe Name
+ ifTopFreeName (IfaceType (IfaceTyConApp tc _ )) = Just (ifaceTyConName tc)
+ ifTopFreeName (IfaceType (IfaceTupleTy s _ ts)) = Just (tupleTyConName s (length (tcArgsIfaceTypes ts)))
+ ifTopFreeName (IfaceApp f _) = ifTopFreeName f
+ ifTopFreeName (IfaceExt n) = Just n
+ ifTopFreeName _ = Nothing
+
+{-
+************************************************************************
+* *
+ Annotations
+* *
+************************************************************************
+-}
+
+tcIfaceAnnotations :: [IfaceAnnotation] -> IfL [Annotation]
+tcIfaceAnnotations = mapM tcIfaceAnnotation
+
+tcIfaceAnnotation :: IfaceAnnotation -> IfL Annotation
+tcIfaceAnnotation (IfaceAnnotation target serialized) = do
+ target' <- tcIfaceAnnTarget target
+ return $ Annotation {
+ ann_target = target',
+ ann_value = serialized
+ }
+
+tcIfaceAnnTarget :: IfaceAnnTarget -> IfL (AnnTarget Name)
+tcIfaceAnnTarget (NamedTarget occ) = do
+ name <- lookupIfaceTop occ
+ return $ NamedTarget name
+tcIfaceAnnTarget (ModuleTarget mod) = do
+ return $ ModuleTarget mod
+
+{-
+************************************************************************
+* *
+ Complete Match Pragmas
+* *
+************************************************************************
+-}
+
+tcIfaceCompleteSigs :: [IfaceCompleteMatch] -> IfL [CompleteMatch]
+tcIfaceCompleteSigs = mapM tcIfaceCompleteSig
+
+tcIfaceCompleteSig :: IfaceCompleteMatch -> IfL CompleteMatch
+tcIfaceCompleteSig (IfaceCompleteMatch ms t) = return (CompleteMatch ms t)
+
+{-
+************************************************************************
+* *
+ Vectorisation information
+* *
+************************************************************************
+-}
+
+-- We need access to the type environment as we need to look up information about type constructors
+-- (i.e., their data constructors and whether they are class type constructors). If a vectorised
+-- type constructor or class is defined in the same module as where it is vectorised, we cannot
+-- look that information up from the type constructor that we obtained via a 'forkM'ed
+-- 'tcIfaceTyCon' without recursively loading the interface that we are already type checking again
+-- and again and again...
+--
+tcIfaceVectInfo :: Module -> TypeEnv -> IfaceVectInfo -> IfL VectInfo
+tcIfaceVectInfo mod typeEnv (IfaceVectInfo
+ { ifaceVectInfoVar = vars
+ , ifaceVectInfoTyCon = tycons
+ , ifaceVectInfoTyConReuse = tyconsReuse
+ , ifaceVectInfoParallelVars = parallelVars
+ , ifaceVectInfoParallelTyCons = parallelTyCons
+ })
+ = do { let parallelTyConsSet = mkNameSet parallelTyCons
+ ; vVars <- mapM vectVarMapping vars
+ ; let varsSet = mkVarSet (map fst vVars)
+ ; tyConRes1 <- mapM (vectTyConVectMapping varsSet) tycons
+ ; tyConRes2 <- mapM (vectTyConReuseMapping varsSet) tyconsReuse
+ ; vParallelVars <- mapM vectVar parallelVars
+ ; let (vTyCons, vDataCons, vScSels) = unzip3 (tyConRes1 ++ tyConRes2)
+ ; return $ VectInfo
+ { vectInfoVar = mkDVarEnv vVars `extendDVarEnvList` concat vScSels
+ , vectInfoTyCon = mkNameEnv vTyCons
+ , vectInfoDataCon = mkNameEnv (concat vDataCons)
+ , vectInfoParallelVars = mkDVarSet vParallelVars
+ , vectInfoParallelTyCons = parallelTyConsSet
+ }
+ }
+ where
+ vectVarMapping name
+ = do { vName <- lookupIfaceTop (mkLocalisedOccName mod mkVectOcc name)
+ ; var <- forkM (text "vect var" <+> ppr name) $
+ tcIfaceExtId name
+ ; vVar <- forkM (text "vect vVar [mod =" <+>
+ ppr mod <> text "; nameModule =" <+>
+ ppr (nameModule name) <> text "]" <+> ppr vName) $
+ tcIfaceExtId vName
+ ; return (var, (var, vVar))
+ }
+ -- where
+ -- lookupLocalOrExternalId name
+ -- = do { let mb_id = lookupTypeEnv typeEnv name
+ -- ; case mb_id of
+ -- -- id is local
+ -- Just (AnId id) -> return id
+ -- -- name is not an Id => internal inconsistency
+ -- Just _ -> notAnIdErr
+ -- -- Id is external
+ -- Nothing -> tcIfaceExtId name
+ -- }
+ --
+ -- notAnIdErr = pprPanic "TcIface.tcIfaceVectInfo: not an id" (ppr name)
+
+ vectVar name
+ = forkM (text "vect scalar var" <+> ppr name) $
+ tcIfaceExtId name
+
+ vectTyConVectMapping vars name
+ = do { vName <- lookupIfaceTop (mkLocalisedOccName mod mkVectTyConOcc name)
+ ; vectTyConMapping vars name vName
+ }
+
+ vectTyConReuseMapping vars name
+ = vectTyConMapping vars name name
+
+ vectTyConMapping vars name vName
+ = do { tycon <- lookupLocalOrExternalTyCon name
+ ; vTycon <- forkM (text "vTycon of" <+> ppr vName) $
+ lookupLocalOrExternalTyCon vName
+
+ -- Map the data constructors of the original type constructor to those of the
+ -- vectorised type constructor /unless/ the type constructor was vectorised
+ -- abstractly; if it was vectorised abstractly, the workers of its data constructors
+ -- do not appear in the set of vectorised variables.
+ --
+ -- NB: This is lazy! We don't pull at the type constructors before we actually use
+ -- the data constructor mapping.
+ ; let isAbstract | isClassTyCon tycon = False
+ | datacon:_ <- tyConDataCons tycon
+ = not $ dataConWrapId datacon `elemVarSet` vars
+ | otherwise = True
+ vDataCons | isAbstract = []
+ | otherwise = [ (dataConName datacon, (datacon, vDatacon))
+ | (datacon, vDatacon) <- zip (tyConDataCons tycon)
+ (tyConDataCons vTycon)
+ ]
+
+ -- Map the (implicit) superclass and methods selectors as they don't occur in
+ -- the var map.
+ vScSels | Just cls <- tyConClass_maybe tycon
+ , Just vCls <- tyConClass_maybe vTycon
+ = [ (sel, (sel, vSel))
+ | (sel, vSel) <- zip (classAllSelIds cls) (classAllSelIds vCls)
+ ]
+ | otherwise
+ = []
+
+ ; return ( (name, (tycon, vTycon)) -- (T, T_v)
+ , vDataCons -- list of (Ci, Ci_v)
+ , vScSels -- list of (seli, seli_v)
+ )
+ }
+ where
+ -- we need a fully defined version of the type constructor to be able to extract
+ -- its data constructors etc.
+ lookupLocalOrExternalTyCon name
+ = do { let mb_tycon = lookupTypeEnv typeEnv name
+ ; case mb_tycon of
+ -- tycon is local
+ Just (ATyCon tycon) -> return tycon
+ -- name is not a tycon => internal inconsistency
+ Just _ -> notATyConErr
+ -- tycon is external
+ Nothing -> tcIfaceTyConByName name
+ }
+
+ notATyConErr = pprPanic "TcIface.tcIfaceVectInfo: not a tycon" (ppr name)
+
+{-
+************************************************************************
+* *
+ Types
+* *
+************************************************************************
+-}
+
+tcIfaceType :: IfaceType -> IfL Type
+tcIfaceType = go
+ where
+ go (IfaceTyVar n) = TyVarTy <$> tcIfaceTyVar n
+ go (IfaceFreeTyVar n) = pprPanic "tcIfaceType:IfaceFreeTyVar" (ppr n)
+ go (IfaceAppTy t1 t2) = AppTy <$> go t1 <*> go t2
+ go (IfaceLitTy l) = LitTy <$> tcIfaceTyLit l
+ go (IfaceFunTy t1 t2) = FunTy <$> go t1 <*> go t2
+ go (IfaceDFunTy t1 t2) = FunTy <$> go t1 <*> go t2
+ go (IfaceTupleTy s i tks) = tcIfaceTupleTy s i tks
+ go (IfaceTyConApp tc tks)
+ = do { tc' <- tcIfaceTyCon tc
+ ; tks' <- mapM go (tcArgsIfaceTypes tks)
+ ; return (mkTyConApp tc' tks') }
+ go (IfaceForAllTy bndr t)
+ = bindIfaceForAllBndr bndr $ \ tv' vis ->
+ ForAllTy (TvBndr tv' vis) <$> go t
+ go (IfaceCastTy ty co) = CastTy <$> go ty <*> tcIfaceCo co
+ go (IfaceCoercionTy co) = CoercionTy <$> tcIfaceCo co
+
+tcIfaceTupleTy :: TupleSort -> IsPromoted -> IfaceTcArgs -> IfL Type
+tcIfaceTupleTy sort is_promoted args
+ = do { args' <- tcIfaceTcArgs args
+ ; let arity = length args'
+ ; base_tc <- tcTupleTyCon True sort arity
+ ; case is_promoted of
+ IsNotPromoted
+ -> return (mkTyConApp base_tc args')
+
+ IsPromoted
+ -> do { let tc = promoteDataCon (tyConSingleDataCon base_tc)
+ kind_args = map typeKind args'
+ ; return (mkTyConApp tc (kind_args ++ args')) } }
+
+-- See Note [Unboxed tuple RuntimeRep vars] in TyCon
+tcTupleTyCon :: Bool -- True <=> typechecking a *type* (vs. an expr)
+ -> TupleSort
+ -> Arity -- the number of args. *not* the tuple arity.
+ -> IfL TyCon
+tcTupleTyCon in_type sort arity
+ = case sort of
+ ConstraintTuple -> do { thing <- tcIfaceGlobal (cTupleTyConName arity)
+ ; return (tyThingTyCon thing) }
+ BoxedTuple -> return (tupleTyCon Boxed arity)
+ UnboxedTuple -> return (tupleTyCon Unboxed arity')
+ where arity' | in_type = arity `div` 2
+ | otherwise = arity
+ -- in expressions, we only have term args
+
+tcIfaceTcArgs :: IfaceTcArgs -> IfL [Type]
+tcIfaceTcArgs = mapM tcIfaceType . tcArgsIfaceTypes
+
+-----------------------------------------
+tcIfaceCtxt :: IfaceContext -> IfL ThetaType
+tcIfaceCtxt sts = mapM tcIfaceType sts
+
+-----------------------------------------
+tcIfaceTyLit :: IfaceTyLit -> IfL TyLit
+tcIfaceTyLit (IfaceNumTyLit n) = return (NumTyLit n)
+tcIfaceTyLit (IfaceStrTyLit n) = return (StrTyLit n)
+
+{-
+%************************************************************************
+%* *
+ Coercions
+* *
+************************************************************************
+-}
+
+tcIfaceCo :: IfaceCoercion -> IfL Coercion
+tcIfaceCo = go
+ where
+ go (IfaceReflCo r t) = Refl r <$> tcIfaceType t
+ go (IfaceFunCo r c1 c2) = mkFunCo r <$> go c1 <*> go c2
+ go (IfaceTyConAppCo r tc cs)
+ = TyConAppCo r <$> tcIfaceTyCon tc <*> mapM go cs
+ go (IfaceAppCo c1 c2) = AppCo <$> go c1 <*> go c2
+ go (IfaceForAllCo tv k c) = do { k' <- go k
+ ; bindIfaceTyVar tv $ \ tv' ->
+ ForAllCo tv' k' <$> go c }
+ go (IfaceCoVarCo n) = CoVarCo <$> go_var n
+ go (IfaceAxiomInstCo n i cs) = AxiomInstCo <$> tcIfaceCoAxiom n <*> pure i <*> mapM go cs
+ go (IfaceUnivCo p r t1 t2) = UnivCo <$> tcIfaceUnivCoProv p <*> pure r
+ <*> tcIfaceType t1 <*> tcIfaceType t2
+ go (IfaceSymCo c) = SymCo <$> go c
+ go (IfaceTransCo c1 c2) = TransCo <$> go c1
+ <*> go c2
+ go (IfaceInstCo c1 t2) = InstCo <$> go c1
+ <*> go t2
+ go (IfaceNthCo d c) = NthCo d <$> go c
+ go (IfaceLRCo lr c) = LRCo lr <$> go c
+ go (IfaceCoherenceCo c1 c2) = CoherenceCo <$> go c1
+ <*> go c2
+ go (IfaceKindCo c) = KindCo <$> go c
+ go (IfaceSubCo c) = SubCo <$> go c
+ go (IfaceAxiomRuleCo ax cos) = AxiomRuleCo <$> go_axiom_rule ax
+ <*> mapM go cos
+
+ go_var :: FastString -> IfL CoVar
+ go_var = tcIfaceLclId
+
+ go_axiom_rule :: FastString -> IfL CoAxiomRule
+ go_axiom_rule n =
+ case Map.lookup n typeNatCoAxiomRules of
+ Just ax -> return ax
+ _ -> pprPanic "go_axiom_rule" (ppr n)
+
+tcIfaceUnivCoProv :: IfaceUnivCoProv -> IfL UnivCoProvenance
+tcIfaceUnivCoProv IfaceUnsafeCoerceProv = return UnsafeCoerceProv
+tcIfaceUnivCoProv (IfacePhantomProv kco) = PhantomProv <$> tcIfaceCo kco
+tcIfaceUnivCoProv (IfaceProofIrrelProv kco) = ProofIrrelProv <$> tcIfaceCo kco
+tcIfaceUnivCoProv (IfacePluginProv str) = return $ PluginProv str
+tcIfaceUnivCoProv (IfaceHoleProv _) =
+ pprPanic "tcIfaceUnivCoProv" (text "holes can't occur in interface files")
+
+{-
+************************************************************************
+* *
+ Core
+* *
+************************************************************************
+-}
+
+tcIfaceExpr :: IfaceExpr -> IfL CoreExpr
+tcIfaceExpr (IfaceType ty)
+ = Type <$> tcIfaceType ty
+
+tcIfaceExpr (IfaceCo co)
+ = Coercion <$> tcIfaceCo co
+
+tcIfaceExpr (IfaceCast expr co)
+ = Cast <$> tcIfaceExpr expr <*> tcIfaceCo co
+
+tcIfaceExpr (IfaceLcl name)
+ = Var <$> tcIfaceLclId name
+
+tcIfaceExpr (IfaceExt gbl)
+ = Var <$> tcIfaceExtId gbl
+
+tcIfaceExpr (IfaceLit lit)
+ = do lit' <- tcIfaceLit lit
+ return (Lit lit')
+
+tcIfaceExpr (IfaceFCall cc ty) = do
+ ty' <- tcIfaceType ty
+ u <- newUnique
+ dflags <- getDynFlags
+ return (Var (mkFCallId dflags u cc ty'))
+
+tcIfaceExpr (IfaceTuple sort args)
+ = do { args' <- mapM tcIfaceExpr args
+ ; tc <- tcTupleTyCon False sort arity
+ ; let con_tys = map exprType args'
+ some_con_args = map Type con_tys ++ args'
+ con_args = case sort of
+ UnboxedTuple -> map (Type . getRuntimeRep "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 )
+-- so tcIfaceLit just fills in the type.
+-- See Note [Integer literals] in Literal
+tcIfaceLit (LitInteger i _)
+ = do t <- tcIfaceTyConByName integerTyConName
+ return (mkLitInteger i (mkTyConTy t))
+tcIfaceLit lit = return lit
+
+-------------------------
+tcIfaceAlt :: CoreExpr -> (TyCon, [Type])
+ -> (IfaceConAlt, [FastString], IfaceExpr)
+ -> IfL (AltCon, [TyVar], CoreExpr)
+tcIfaceAlt _ _ (IfaceDefault, names, rhs)
+ = ASSERT( null names ) do
+ rhs' <- tcIfaceExpr rhs
+ return (DEFAULT, [], rhs')
+
+tcIfaceAlt _ _ (IfaceLitAlt lit, names, rhs)
+ = ASSERT( null names ) do
+ lit' <- tcIfaceLit lit
+ rhs' <- tcIfaceExpr rhs
+ return (LitAlt lit', [], rhs')
+
+-- A case alternative is made quite a bit more complicated
+-- by the fact that we omit type annotations because we can
+-- work them out. True enough, but its not that easy!
+tcIfaceAlt scrut (tycon, inst_tys) (IfaceDataAlt data_occ, arg_strs, rhs)
+ = do { con <- tcIfaceDataCon data_occ
+ ; when (debugIsOn && not (con `elem` tyConDataCons tycon))
+ (failIfM (ppr scrut $$ ppr con $$ ppr tycon $$ ppr (tyConDataCons tycon)))
+ ; tcIfaceDataAlt con inst_tys arg_strs rhs }
+
+tcIfaceDataAlt :: DataCon -> [Type] -> [FastString] -> IfaceExpr
+ -> IfL (AltCon, [TyVar], CoreExpr)
+tcIfaceDataAlt con inst_tys arg_strs rhs
+ = do { us <- newUniqueSupply
+ ; let uniqs = uniqsFromSupply us
+ ; let (ex_tvs, arg_ids)
+ = dataConRepFSInstPat arg_strs uniqs con inst_tys
+
+ ; rhs' <- extendIfaceEnvs ex_tvs $
+ extendIfaceIdEnv arg_ids $
+ tcIfaceExpr rhs
+ ; return (DataAlt con, ex_tvs ++ arg_ids, rhs') }
+
+{-
+************************************************************************
+* *
+ IdInfo
+* *
+************************************************************************
+-}
+
+tcIdDetails :: Type -> IfaceIdDetails -> IfL IdDetails
+tcIdDetails _ IfVanillaId = return VanillaId
+tcIdDetails ty IfDFunId
+ = return (DFunId (isNewTyCon (classTyCon cls)))
+ where
+ (_, _, cls, _) = tcSplitDFunTy ty
+
+tcIdDetails _ (IfRecSelId tc naughty)
+ = do { tc' <- either (fmap RecSelData . tcIfaceTyCon)
+ (fmap (RecSelPatSyn . tyThingPatSyn) . tcIfaceDecl False)
+ tc
+ ; return (RecSelId { sel_tycon = tc', sel_naughty = naughty }) }
+ where
+ tyThingPatSyn (AConLike (PatSynCon ps)) = ps
+ tyThingPatSyn _ = panic "tcIdDetails: expecting patsyn"
+
+tcIdInfo :: Bool -> Name -> Type -> IfaceIdInfo -> IfL IdInfo
+tcIdInfo ignore_prags name ty info = do
+ lcl_env <- getLclEnv
+ -- Set the CgInfo to something sensible but uninformative before
+ -- we start; default assumption is that it has CAFs
+ let init_info | if_boot lcl_env = vanillaIdInfo `setUnfoldingInfo` BootUnfolding
+ | otherwise = vanillaIdInfo
+ if ignore_prags
+ then return init_info
+ else case info of
+ NoInfo -> return init_info
+ HasInfo info -> foldlM tcPrag init_info info
+ where
+ tcPrag :: IdInfo -> IfaceInfoItem -> IfL IdInfo
+ tcPrag info HsNoCafRefs = return (info `setCafInfo` NoCafRefs)
+ tcPrag info (HsArity arity) = return (info `setArityInfo` arity)
+ tcPrag info (HsStrictness str) = return (info `setStrictnessInfo` str)
+ tcPrag info (HsInline prag) = return (info `setInlinePragInfo` prag)
+ tcPrag info HsLevity = return (info `setNeverLevPoly` ty)
+
+ -- The next two are lazy, so they don't transitively suck stuff in
+ tcPrag info (HsUnfold lb if_unf)
+ = do { unf <- tcUnfolding name ty info if_unf
+ ; let info1 | lb = info `setOccInfo` strongLoopBreaker
+ | otherwise = info
+ ; return (info1 `setUnfoldingInfo` unf) }
+
+tcJoinInfo :: IfaceJoinInfo -> Maybe JoinArity
+tcJoinInfo (IfaceJoinPoint ar) = Just ar
+tcJoinInfo IfaceNotJoinPoint = Nothing
+
+tcUnfolding :: Name -> Type -> IdInfo -> IfaceUnfolding -> IfL Unfolding
+tcUnfolding name _ info (IfCoreUnfold stable if_expr)
+ = do { dflags <- getDynFlags
+ ; mb_expr <- tcPragExpr name if_expr
+ ; let unf_src | stable = InlineStable
+ | otherwise = InlineRhs
+ ; return $ case mb_expr of
+ Nothing -> NoUnfolding
+ Just expr -> mkUnfolding dflags unf_src
+ True {- Top level -}
+ (isBottomingSig strict_sig)
+ expr
+ }
+ where
+ -- Strictness should occur before unfolding!
+ strict_sig = strictnessInfo info
+tcUnfolding name _ _ (IfCompulsory if_expr)
+ = do { mb_expr <- tcPragExpr name if_expr
+ ; return (case mb_expr of
+ Nothing -> NoUnfolding
+ Just expr -> mkCompulsoryUnfolding expr) }
+
+tcUnfolding name _ _ (IfInlineRule arity unsat_ok boring_ok if_expr)
+ = do { mb_expr <- tcPragExpr name if_expr
+ ; return (case mb_expr of
+ Nothing -> NoUnfolding
+ Just expr -> mkCoreUnfolding InlineStable True expr guidance )}
+ where
+ guidance = UnfWhen { ug_arity = arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok }
+
+tcUnfolding name dfun_ty _ (IfDFunUnfold bs ops)
+ = bindIfaceBndrs bs $ \ bs' ->
+ do { mb_ops1 <- forkM_maybe doc $ mapM tcIfaceExpr ops
+ ; return (case mb_ops1 of
+ Nothing -> noUnfolding
+ Just ops1 -> mkDFunUnfolding bs' (classDataCon cls) ops1) }
+ where
+ doc = text "Class ops for dfun" <+> ppr name
+ (_, _, cls, _) = tcSplitDFunTy dfun_ty
+
+{-
+For unfoldings we try to do the job lazily, so that we never type check
+an unfolding that isn't going to be looked at.
+-}
+
+tcPragExpr :: Name -> IfaceExpr -> IfL (Maybe CoreExpr)
+tcPragExpr name expr
+ = forkM_maybe doc $ do
+ core_expr' <- tcIfaceExpr expr
+
+ -- Check for type consistency in the unfolding
+ whenGOptM Opt_DoCoreLinting $ do
+ in_scope <- get_in_scope
+ dflags <- getDynFlags
+ case lintUnfolding dflags noSrcLoc in_scope core_expr' of
+ Nothing -> return ()
+ Just fail_msg -> do { mod <- getIfModule
+ ; pprPanic "Iface Lint failure"
+ (vcat [ text "In interface for" <+> ppr mod
+ , hang doc 2 fail_msg
+ , ppr name <+> equals <+> ppr core_expr'
+ , text "Iface expr =" <+> ppr expr ]) }
+ return core_expr'
+ where
+ doc = text "Unfolding of" <+> ppr name
+
+ get_in_scope :: IfL VarSet -- Totally disgusting; but just for linting
+ get_in_scope
+ = do { (gbl_env, lcl_env) <- getEnvs
+ ; rec_ids <- case if_rec_types gbl_env of
+ Nothing -> return []
+ Just (_, get_env) -> do
+ { type_env <- setLclEnv () get_env
+ ; return (typeEnvIds type_env) }
+ ; return (bindingsVars (if_tv_env lcl_env) `unionVarSet`
+ bindingsVars (if_id_env lcl_env) `unionVarSet`
+ mkVarSet rec_ids) }
+
+ bindingsVars :: FastStringEnv Var -> VarSet
+ bindingsVars ufm = mkVarSet $ nonDetEltsUFM ufm
+ -- It's OK to use nonDetEltsUFM here because we immediately forget
+ -- the ordering by creating a set
+
+{-
+************************************************************************
+* *
+ Getting from Names to TyThings
+* *
+************************************************************************
+-}
+
+tcIfaceGlobal :: Name -> IfL TyThing
+tcIfaceGlobal name
+ | Just thing <- wiredInNameTyThing_maybe name
+ -- Wired-in things include TyCons, DataCons, and Ids
+ -- Even though we are in an interface file, we want to make
+ -- sure the instances and RULES of this thing (particularly TyCon) are loaded
+ -- Imagine: f :: Double -> Double
+ = do { ifCheckWiredInThing thing; return thing }
+
+ | otherwise
+ = do { env <- getGblEnv
+ ; case if_rec_types env of { -- Note [Tying the knot]
+ Just (mod, get_type_env)
+ | nameIsLocalOrFrom mod name
+ -> do -- It's defined in the module being compiled
+ { type_env <- setLclEnv () get_type_env -- yuk
+ ; case lookupNameEnv type_env name of
+ Just thing -> return thing
+ Nothing ->
+ pprPanic "tcIfaceGlobal (local): not found"
+ (ifKnotErr name (if_doc env) type_env)
+ }
+
+ ; _ -> do
+
+ { hsc_env <- getTopEnv
+ ; mb_thing <- liftIO (lookupTypeHscEnv hsc_env name)
+ ; case mb_thing of {
+ Just thing -> return thing ;
+ Nothing -> do
+
+ { mb_thing <- importDecl name -- It's imported; go get it
+ ; case mb_thing of
+ Failed err -> failIfM err
+ Succeeded thing -> return thing
+ }}}}}
+
+ifKnotErr :: Name -> SDoc -> TypeEnv -> SDoc
+ifKnotErr name env_doc type_env = vcat
+ [ text "You are in a maze of twisty little passages, all alike."
+ , text "While forcing the thunk for TyThing" <+> ppr name
+ , text "which was lazily initialized by" <+> env_doc <> text ","
+ , text "I tried to tie the knot, but I couldn't find" <+> ppr name
+ , text "in the current type environment."
+ , text "If you are developing GHC, please read Note [Tying the knot]"
+ , text "and Note [Type-checking inside the knot]."
+ , text "Consider rebuilding GHC with profiling for a better stack trace."
+ , hang (text "Contents of current type environment:")
+ 2 (ppr type_env)
+ ]
+
+-- Note [Tying the knot]
+-- ~~~~~~~~~~~~~~~~~~~~~
+-- The if_rec_types field is used when we are compiling M.hs, which indirectly
+-- imports Foo.hi, which mentions M.T Then we look up M.T in M's type
+-- environment, which is splatted into if_rec_types after we've built M's type
+-- envt.
+--
+-- This is a dark and complicated part of GHC type checking, with a lot
+-- of moving parts. Interested readers should also look at:
+--
+-- * Note [Knot-tying typecheckIface]
+-- * Note [DFun knot-tying]
+-- * Note [hsc_type_env_var hack]
+--
+-- There is also a wiki page on the subject, see:
+--
+-- https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/TyingTheKnot
+
+tcIfaceTyConByName :: IfExtName -> IfL TyCon
+tcIfaceTyConByName name
+ = do { thing <- tcIfaceGlobal name
+ ; return (tyThingTyCon thing) }
+
+tcIfaceTyCon :: IfaceTyCon -> IfL TyCon
+tcIfaceTyCon (IfaceTyCon name info)
+ = do { thing <- tcIfaceGlobal name
+ ; return $ case ifaceTyConIsPromoted info of
+ IsNotPromoted -> tyThingTyCon thing
+ IsPromoted -> promoteDataCon $ tyThingDataCon thing }
+
+tcIfaceCoAxiom :: Name -> IfL (CoAxiom Branched)
+tcIfaceCoAxiom name = do { thing <- tcIfaceImplicit name
+ ; return (tyThingCoAxiom thing) }
+
+tcIfaceDataCon :: Name -> IfL DataCon
+tcIfaceDataCon name = do { thing <- tcIfaceGlobal name
+ ; case thing of
+ AConLike (RealDataCon dc) -> return dc
+ _ -> pprPanic "tcIfaceExtDC" (ppr name$$ ppr thing) }
+
+tcIfaceExtId :: Name -> IfL Id
+tcIfaceExtId name = do { thing <- tcIfaceGlobal name
+ ; case thing of
+ AnId id -> return id
+ _ -> pprPanic "tcIfaceExtId" (ppr name$$ ppr thing) }
+
+-- See Note [Resolving never-exported Names in TcIface]
+tcIfaceImplicit :: Name -> IfL TyThing
+tcIfaceImplicit n = do
+ lcl_env <- getLclEnv
+ case if_implicits_env lcl_env of
+ Nothing -> tcIfaceGlobal n
+ Just tenv ->
+ case lookupTypeEnv tenv n of
+ Nothing -> pprPanic "tcIfaceInst" (ppr n $$ ppr tenv)
+ Just tything -> return tything
+
+{-
+************************************************************************
+* *
+ Bindings
+* *
+************************************************************************
+-}
+
+bindIfaceId :: IfaceIdBndr -> (Id -> IfL a) -> IfL a
+bindIfaceId (fs, ty) thing_inside
+ = do { name <- newIfaceName (mkVarOccFS fs)
+ ; ty' <- tcIfaceType ty
+ ; let id = mkLocalIdOrCoVar name ty'
+ ; extendIfaceIdEnv [id] (thing_inside id) }
+
+bindIfaceIds :: [IfaceIdBndr] -> ([Id] -> IfL a) -> IfL a
+bindIfaceIds [] thing_inside = thing_inside []
+bindIfaceIds (b:bs) thing_inside
+ = bindIfaceId b $ \b' ->
+ bindIfaceIds bs $ \bs' ->
+ thing_inside (b':bs')
+
+bindIfaceBndr :: IfaceBndr -> (CoreBndr -> IfL a) -> IfL a
+bindIfaceBndr (IfaceIdBndr bndr) thing_inside
+ = bindIfaceId bndr thing_inside
+bindIfaceBndr (IfaceTvBndr bndr) thing_inside
+ = bindIfaceTyVar bndr thing_inside
+
+bindIfaceBndrs :: [IfaceBndr] -> ([CoreBndr] -> IfL a) -> IfL a
+bindIfaceBndrs [] thing_inside = thing_inside []
+bindIfaceBndrs (b:bs) thing_inside
+ = bindIfaceBndr b $ \ b' ->
+ bindIfaceBndrs bs $ \ bs' ->
+ thing_inside (b':bs')
+
+-----------------------
+bindIfaceForAllBndrs :: [IfaceForAllBndr] -> ([TyVarBinder] -> IfL a) -> IfL a
+bindIfaceForAllBndrs [] thing_inside = thing_inside []
+bindIfaceForAllBndrs (bndr:bndrs) thing_inside
+ = bindIfaceForAllBndr bndr $ \tv vis ->
+ bindIfaceForAllBndrs bndrs $ \bndrs' ->
+ thing_inside (mkTyVarBinder vis tv : bndrs')
+
+bindIfaceForAllBndr :: IfaceForAllBndr -> (TyVar -> ArgFlag -> IfL a) -> IfL a
+bindIfaceForAllBndr (TvBndr tv vis) thing_inside
+ = bindIfaceTyVar tv $ \tv' -> thing_inside tv' vis
+
+bindIfaceTyVar :: IfaceTvBndr -> (TyVar -> IfL a) -> IfL a
+bindIfaceTyVar (occ,kind) thing_inside
+ = do { name <- newIfaceName (mkTyVarOccFS occ)
+ ; tyvar <- mk_iface_tyvar name kind
+ ; extendIfaceTyVarEnv [tyvar] (thing_inside tyvar) }
+
+mk_iface_tyvar :: Name -> IfaceKind -> IfL TyVar
+mk_iface_tyvar name ifKind
+ = do { kind <- tcIfaceType ifKind
+ ; return (Var.mkTyVar name kind) }
+
+bindIfaceTyConBinders :: [IfaceTyConBinder]
+ -> ([TyConBinder] -> IfL a) -> IfL a
+bindIfaceTyConBinders [] thing_inside = thing_inside []
+bindIfaceTyConBinders (b:bs) thing_inside
+ = bindIfaceTyConBinderX bindIfaceTyVar b $ \ b' ->
+ bindIfaceTyConBinders bs $ \ bs' ->
+ thing_inside (b':bs')
+
+bindIfaceTyConBinders_AT :: [IfaceTyConBinder]
+ -> ([TyConBinder] -> IfL a) -> IfL a
+-- Used for type variable in nested associated data/type declarations
+-- where some of the type variables are already in scope
+-- class C a where { data T a b }
+-- Here 'a' is in scope when we look at the 'data T'
+bindIfaceTyConBinders_AT [] thing_inside
+ = thing_inside []
+bindIfaceTyConBinders_AT (b : bs) thing_inside
+ = bindIfaceTyConBinderX bind_tv b $ \b' ->
+ bindIfaceTyConBinders_AT bs $ \bs' ->
+ thing_inside (b':bs')
+ where
+ bind_tv tv thing
+ = do { mb_tv <- lookupIfaceTyVar tv
+ ; case mb_tv of
+ Just b' -> thing b'
+ Nothing -> bindIfaceTyVar tv thing }
+
+bindIfaceTyConBinderX :: (IfaceTvBndr -> (TyVar -> IfL a) -> IfL a)
+ -> IfaceTyConBinder
+ -> (TyConBinder -> IfL a) -> IfL a
+bindIfaceTyConBinderX bind_tv (TvBndr tv vis) thing_inside
+ = bind_tv tv $ \tv' ->
+ thing_inside (TvBndr tv' vis)
diff --git a/iface/TcIface.hs-boot b/iface/TcIface.hs-boot
new file mode 100644
--- /dev/null
+++ b/iface/TcIface.hs-boot
@@ -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]
diff --git a/iface/ToIface.hs b/iface/ToIface.hs
new file mode 100644
--- /dev/null
+++ b/iface/ToIface.hs
@@ -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.
+
+-}
diff --git a/iface/ToIface.hs-boot b/iface/ToIface.hs-boot
new file mode 100644
--- /dev/null
+++ b/iface/ToIface.hs-boot
@@ -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
diff --git a/llvmGen/Llvm.hs b/llvmGen/Llvm.hs
new file mode 100644
--- /dev/null
+++ b/llvmGen/Llvm.hs
@@ -0,0 +1,64 @@
+-- ----------------------------------------------------------------------------
+-- | This module supplies bindings to generate Llvm IR from Haskell
+-- ().
+--
+-- Note: this module is developed in a demand driven way. It is no complete
+-- LLVM binding library in Haskell, but enough to generate code for GHC.
+--
+-- This code is derived from code taken from the Essential Haskell Compiler
+-- (EHC) project ().
+--
+
+module Llvm (
+
+ -- * Modules, Functions and Blocks
+ LlvmModule(..),
+
+ LlvmFunction(..), LlvmFunctionDecl(..),
+ LlvmFunctions, LlvmFunctionDecls,
+ LlvmStatement(..), LlvmExpression(..),
+ LlvmBlocks, LlvmBlock(..), LlvmBlockId,
+ LlvmParamAttr(..), LlvmParameter,
+
+ -- * Atomic operations
+ LlvmAtomicOp(..),
+
+ -- * Fence synchronization
+ LlvmSyncOrdering(..),
+
+ -- * Call Handling
+ LlvmCallConvention(..), LlvmCallType(..), LlvmParameterListType(..),
+ LlvmLinkageType(..), LlvmFuncAttr(..),
+
+ -- * Operations and Comparisons
+ LlvmCmpOp(..), LlvmMachOp(..), LlvmCastOp(..),
+
+ -- * Variables and Type System
+ LlvmVar(..), LlvmStatic(..), LlvmLit(..), LlvmType(..),
+ LlvmAlias, LMGlobal(..), LMString, LMSection, LMAlign,
+ LMConst(..),
+
+ -- ** Some basic types
+ i64, i32, i16, i8, i1, i8Ptr, llvmWord, llvmWordPtr,
+
+ -- ** Metadata types
+ MetaExpr(..), MetaAnnot(..), MetaDecl(..), MetaId(..),
+
+ -- ** Operations on the type system.
+ isGlobal, getLitType, getVarType,
+ getLink, getStatType, pVarLift, pVarLower,
+ pLift, pLower, isInt, isFloat, isPointer, isVector, llvmWidthInBits,
+
+ -- * Pretty Printing
+ ppLit, ppName, ppPlainName,
+ ppLlvmModule, ppLlvmComments, ppLlvmComment, ppLlvmGlobals,
+ ppLlvmGlobal, ppLlvmFunctionDecls, ppLlvmFunctionDecl, ppLlvmFunctions,
+ ppLlvmFunction, ppLlvmAlias, ppLlvmAliases, ppLlvmMetas, ppLlvmMeta,
+
+ ) where
+
+import Llvm.AbsSyn
+import Llvm.MetaData
+import Llvm.PpLlvm
+import Llvm.Types
+
diff --git a/llvmGen/Llvm/AbsSyn.hs b/llvmGen/Llvm/AbsSyn.hs
new file mode 100644
--- /dev/null
+++ b/llvmGen/Llvm/AbsSyn.hs
@@ -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)
+
diff --git a/llvmGen/Llvm/MetaData.hs b/llvmGen/Llvm/MetaData.hs
new file mode 100644
--- /dev/null
+++ b/llvmGen/Llvm/MetaData.hs
@@ -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 = !{ [] !}
+--
+-- * Named metadata -- global metadata variables that attach a metadata nodes
+-- to a name. Used ONLY to communicated module level information to LLVM
+-- through a meaningful name. For example:
+-- !llvm.module.linkage = !{ !0, !1 }
+--
+--
+-- # Using Metadata
+-- Using metadata depends on the form it is in:
+--
+-- * Attach to instructions -- metadata can be attached to LLVM instructions
+-- using a specific reference as follows:
+-- %l = load i32* @glob, !nontemporal !10
+-- %m = load i32* @glob, !nontemporal !{ i32 0, !{ i32 0 } }
+-- Only metadata nodes or expressions can be attached, named metadata cannot.
+-- Refer to LLVM documentation for which instructions take metadata and its
+-- meaning.
+--
+-- * As arguments -- llvm functions can take metadata as arguments, for
+-- example:
+-- call void @llvm.dbg.value(metadata !{ i32 0 }, i64 0, metadata !1)
+-- As with instructions, only metadata nodes or expressions can be attached.
+--
+-- * As a named metadata -- Here the metadata is simply declared in global
+-- scope using a specific name to communicate module level information to LLVM.
+-- For example:
+-- !llvm.module.linkage = !{ !0, !1 }
+--
+
+-- | A reference to an un-named metadata node.
+newtype MetaId = MetaId Int
+ deriving (Eq, Ord, Enum)
+
+instance Outputable MetaId where
+ ppr (MetaId n) = char '!' <> int n
+
+-- | LLVM metadata expressions
+data MetaExpr = MetaStr !LMString
+ | MetaNode !MetaId
+ | MetaVar !LlvmVar
+ | MetaStruct [MetaExpr]
+ deriving (Eq)
+
+instance Outputable MetaExpr where
+ ppr (MetaVar (LMLitVar (LMNullLit _))) = text "null"
+ ppr (MetaStr s ) = char '!' <> doubleQuotes (ftext s)
+ ppr (MetaNode n ) = ppr n
+ ppr (MetaVar v ) = ppr v
+ ppr (MetaStruct es) = char '!' <> braces (ppCommaJoin es)
+
+-- | Associates some metadata with a specific label for attaching to an
+-- instruction.
+data MetaAnnot = MetaAnnot LMString MetaExpr
+ deriving (Eq)
+
+-- | Metadata declarations. Metadata can only be declared in global scope.
+data MetaDecl
+ -- | Named metadata. Only used for communicating module information to
+ -- LLVM. ('!name = !{ [!] }' form).
+ = MetaNamed !LMString [MetaId]
+ -- | Metadata node declaration.
+ -- ('!0 = metadata !{ }' form).
+ | MetaUnnamed !MetaId !MetaExpr
diff --git a/llvmGen/Llvm/PpLlvm.hs b/llvmGen/Llvm/PpLlvm.hs
new file mode 100644
--- /dev/null
+++ b/llvmGen/Llvm/PpLlvm.hs
@@ -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 '!'
diff --git a/llvmGen/Llvm/Types.hs b/llvmGen/Llvm/Types.hs
new file mode 100644
--- /dev/null
+++ b/llvmGen/Llvm/Types.hs
@@ -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
+data LlvmFuncAttr
+ -- | This attribute indicates that the inliner should attempt to inline this
+ -- function into callers whenever possible, ignoring any active inlining
+ -- size threshold for this caller.
+ = AlwaysInline
+ -- | This attribute indicates that the source code contained a hint that
+ -- inlining this function is desirable (such as the \"inline\" keyword in
+ -- C/C++). It is just a hint; it imposes no requirements on the inliner.
+ | InlineHint
+ -- | This attribute indicates that the inliner should never inline this
+ -- function in any situation. This attribute may not be used together
+ -- with the alwaysinline attribute.
+ | NoInline
+ -- | This attribute suggests that optimization passes and code generator
+ -- passes make choices that keep the code size of this function low, and
+ -- otherwise do optimizations specifically to reduce code size.
+ | OptSize
+ -- | This function attribute indicates that the function never returns
+ -- normally. This produces undefined behavior at runtime if the function
+ -- ever does dynamically return.
+ | NoReturn
+ -- | This function attribute indicates that the function never returns with
+ -- an unwind or exceptional control flow. If the function does unwind, its
+ -- runtime behavior is undefined.
+ | NoUnwind
+ -- | This attribute indicates that the function computes its result (or
+ -- decides to unwind an exception) based strictly on its arguments, without
+ -- dereferencing any pointer arguments or otherwise accessing any mutable
+ -- state (e.g. memory, control registers, etc) visible to caller functions.
+ -- It does not write through any pointer arguments (including byval
+ -- arguments) and never changes any state visible to callers. This means
+ -- that it cannot unwind exceptions by calling the C++ exception throwing
+ -- methods, but could use the unwind instruction.
+ | ReadNone
+ -- | This attribute indicates that the function does not write through any
+ -- pointer arguments (including byval arguments) or otherwise modify any
+ -- state (e.g. memory, control registers, etc) visible to caller functions.
+ -- It may dereference pointer arguments and read state that may be set in
+ -- the caller. A readonly function always returns the same value (or unwinds
+ -- an exception identically) when called with the same set of arguments and
+ -- global state. It cannot unwind an exception by calling the C++ exception
+ -- throwing methods, but may use the unwind instruction.
+ | ReadOnly
+ -- | This attribute indicates that the function should emit a stack smashing
+ -- protector. It is in the form of a \"canary\"—a random value placed on the
+ -- stack before the local variables that's checked upon return from the
+ -- function to see if it has been overwritten. A heuristic is used to
+ -- determine if a function needs stack protectors or not.
+ --
+ -- If a function that has an ssp attribute is inlined into a function that
+ -- doesn't have an ssp attribute, then the resulting function will have an
+ -- ssp attribute.
+ | Ssp
+ -- | This attribute indicates that the function should always emit a stack
+ -- smashing protector. This overrides the ssp function attribute.
+ --
+ -- If a function that has an sspreq attribute is inlined into a function
+ -- that doesn't have an sspreq attribute or which has an ssp attribute,
+ -- then the resulting function will have an sspreq attribute.
+ | SspReq
+ -- | This attribute indicates that the code generator should not use a red
+ -- zone, even if the target-specific ABI normally permits it.
+ | NoRedZone
+ -- | This attributes disables implicit floating point instructions.
+ | NoImplicitFloat
+ -- | This attribute disables prologue / epilogue emission for the function.
+ -- This can have very system-specific consequences.
+ | Naked
+ deriving (Eq)
+
+instance Outputable LlvmFuncAttr where
+ ppr AlwaysInline = text "alwaysinline"
+ ppr InlineHint = text "inlinehint"
+ ppr NoInline = text "noinline"
+ ppr OptSize = text "optsize"
+ ppr NoReturn = text "noreturn"
+ ppr NoUnwind = text "nounwind"
+ ppr ReadNone = text "readnon"
+ ppr ReadOnly = text "readonly"
+ ppr Ssp = text "ssp"
+ ppr SspReq = text "ssqreq"
+ ppr NoRedZone = text "noredzone"
+ ppr NoImplicitFloat = text "noimplicitfloat"
+ ppr Naked = text "naked"
+
+
+-- | Different types to call a function.
+data LlvmCallType
+ -- | Normal call, allocate a new stack frame.
+ = StdCall
+ -- | Tail call, perform the call in the current stack frame.
+ | TailCall
+ deriving (Eq,Show)
+
+-- | Different calling conventions a function can use.
+data LlvmCallConvention
+ -- | The C calling convention.
+ -- This calling convention (the default if no other calling convention is
+ -- specified) matches the target C calling conventions. This calling
+ -- convention supports varargs function calls and tolerates some mismatch in
+ -- the declared prototype and implemented declaration of the function (as
+ -- does normal C).
+ = CC_Ccc
+ -- | This calling convention attempts to make calls as fast as possible
+ -- (e.g. by passing things in registers). This calling convention allows
+ -- the target to use whatever tricks it wants to produce fast code for the
+ -- target, without having to conform to an externally specified ABI
+ -- (Application Binary Interface). Implementations of this convention should
+ -- allow arbitrary tail call optimization to be supported. This calling
+ -- convention does not support varargs and requires the prototype of al
+ -- callees to exactly match the prototype of the function definition.
+ | CC_Fastcc
+ -- | This calling convention attempts to make code in the caller as efficient
+ -- as possible under the assumption that the call is not commonly executed.
+ -- As such, these calls often preserve all registers so that the call does
+ -- not break any live ranges in the caller side. This calling convention
+ -- does not support varargs and requires the prototype of all callees to
+ -- exactly match the prototype of the function definition.
+ | CC_Coldcc
+ -- | The GHC-specific 'registerised' calling convention.
+ | CC_Ghc
+ -- | Any calling convention may be specified by number, allowing
+ -- target-specific calling conventions to be used. Target specific calling
+ -- conventions start at 64.
+ | CC_Ncc Int
+ -- | X86 Specific 'StdCall' convention. LLVM includes a specific alias for it
+ -- rather than just using CC_Ncc.
+ | CC_X86_Stdcc
+ deriving (Eq)
+
+instance Outputable LlvmCallConvention where
+ ppr CC_Ccc = text "ccc"
+ ppr CC_Fastcc = text "fastcc"
+ ppr CC_Coldcc = text "coldcc"
+ ppr CC_Ghc = text "ghccc"
+ ppr (CC_Ncc i) = text "cc " <> ppr i
+ ppr CC_X86_Stdcc = text "x86_stdcallcc"
+
+
+-- | Functions can have a fixed amount of parameters, or a variable amount.
+data LlvmParameterListType
+ -- Fixed amount of arguments.
+ = FixedArgs
+ -- Variable amount of arguments.
+ | VarArgs
+ deriving (Eq,Show)
+
+
+-- | Linkage type of a symbol.
+--
+-- The description of the constructors is copied from the Llvm Assembly Language
+-- Reference Manual , because
+-- they correspond to the Llvm linkage types.
+data LlvmLinkageType
+ -- | Global values with internal linkage are only directly accessible by
+ -- objects in the current module. In particular, linking code into a module
+ -- with an internal global value may cause the internal to be renamed as
+ -- necessary to avoid collisions. Because the symbol is internal to the
+ -- module, all references can be updated. This corresponds to the notion
+ -- of the @static@ keyword in C.
+ = Internal
+ -- | Globals with @linkonce@ linkage are merged with other globals of the
+ -- same name when linkage occurs. This is typically used to implement
+ -- inline functions, templates, or other code which must be generated
+ -- in each translation unit that uses it. Unreferenced linkonce globals are
+ -- allowed to be discarded.
+ | LinkOnce
+ -- | @weak@ linkage is exactly the same as linkonce linkage, except that
+ -- unreferenced weak globals may not be discarded. This is used for globals
+ -- that may be emitted in multiple translation units, but that are not
+ -- guaranteed to be emitted into every translation unit that uses them. One
+ -- example of this are common globals in C, such as @int X;@ at global
+ -- scope.
+ | Weak
+ -- | @appending@ linkage may only be applied to global variables of pointer
+ -- to array type. When two global variables with appending linkage are
+ -- linked together, the two global arrays are appended together. This is
+ -- the Llvm, typesafe, equivalent of having the system linker append
+ -- together @sections@ with identical names when .o files are linked.
+ | Appending
+ -- | The semantics of this linkage follow the ELF model: the symbol is weak
+ -- until linked, if not linked, the symbol becomes null instead of being an
+ -- undefined reference.
+ | ExternWeak
+ -- | The symbol participates in linkage and can be used to resolve external
+ -- symbol references.
+ | ExternallyVisible
+ -- | Alias for 'ExternallyVisible' but with explicit textual form in LLVM
+ -- assembly.
+ | External
+ -- | Symbol is private to the module and should not appear in the symbol table
+ | Private
+ deriving (Eq)
+
+instance Outputable LlvmLinkageType where
+ ppr Internal = text "internal"
+ ppr LinkOnce = text "linkonce"
+ ppr Weak = text "weak"
+ ppr Appending = text "appending"
+ ppr ExternWeak = text "extern_weak"
+ -- ExternallyVisible does not have a textual representation, it is
+ -- the linkage type a function resolves to if no other is specified
+ -- in Llvm.
+ ppr ExternallyVisible = empty
+ ppr External = text "external"
+ ppr Private = text "private"
+
+-- -----------------------------------------------------------------------------
+-- * LLVM Operations
+--
+
+-- | Llvm binary operators machine operations.
+data LlvmMachOp
+ = LM_MO_Add -- ^ add two integer, floating point or vector values.
+ | LM_MO_Sub -- ^ subtract two ...
+ | LM_MO_Mul -- ^ multiply ..
+ | LM_MO_UDiv -- ^ unsigned integer or vector division.
+ | LM_MO_SDiv -- ^ signed integer ..
+ | LM_MO_URem -- ^ unsigned integer or vector remainder (mod)
+ | LM_MO_SRem -- ^ signed ...
+
+ | LM_MO_FAdd -- ^ add two floating point or vector values.
+ | LM_MO_FSub -- ^ subtract two ...
+ | LM_MO_FMul -- ^ multiply ...
+ | LM_MO_FDiv -- ^ divide ...
+ | LM_MO_FRem -- ^ remainder ...
+
+ -- | Left shift
+ | LM_MO_Shl
+ -- | Logical shift right
+ -- Shift right, filling with zero
+ | LM_MO_LShr
+ -- | Arithmetic shift right
+ -- The most significant bits of the result will be equal to the sign bit of
+ -- the left operand.
+ | LM_MO_AShr
+
+ | LM_MO_And -- ^ AND bitwise logical operation.
+ | LM_MO_Or -- ^ OR bitwise logical operation.
+ | LM_MO_Xor -- ^ XOR bitwise logical operation.
+ deriving (Eq)
+
+instance Outputable LlvmMachOp where
+ ppr LM_MO_Add = text "add"
+ ppr LM_MO_Sub = text "sub"
+ ppr LM_MO_Mul = text "mul"
+ ppr LM_MO_UDiv = text "udiv"
+ ppr LM_MO_SDiv = text "sdiv"
+ ppr LM_MO_URem = text "urem"
+ ppr LM_MO_SRem = text "srem"
+ ppr LM_MO_FAdd = text "fadd"
+ ppr LM_MO_FSub = text "fsub"
+ ppr LM_MO_FMul = text "fmul"
+ ppr LM_MO_FDiv = text "fdiv"
+ ppr LM_MO_FRem = text "frem"
+ ppr LM_MO_Shl = text "shl"
+ ppr LM_MO_LShr = text "lshr"
+ ppr LM_MO_AShr = text "ashr"
+ ppr LM_MO_And = text "and"
+ ppr LM_MO_Or = text "or"
+ ppr LM_MO_Xor = text "xor"
+
+
+-- | Llvm compare operations.
+data LlvmCmpOp
+ = LM_CMP_Eq -- ^ Equal (Signed and Unsigned)
+ | LM_CMP_Ne -- ^ Not equal (Signed and Unsigned)
+ | LM_CMP_Ugt -- ^ Unsigned greater than
+ | LM_CMP_Uge -- ^ Unsigned greater than or equal
+ | LM_CMP_Ult -- ^ Unsigned less than
+ | LM_CMP_Ule -- ^ Unsigned less than or equal
+ | LM_CMP_Sgt -- ^ Signed greater than
+ | LM_CMP_Sge -- ^ Signed greater than or equal
+ | LM_CMP_Slt -- ^ Signed less than
+ | LM_CMP_Sle -- ^ Signed less than or equal
+
+ -- Float comparisons. GHC uses a mix of ordered and unordered float
+ -- comparisons.
+ | LM_CMP_Feq -- ^ Float equal
+ | LM_CMP_Fne -- ^ Float not equal
+ | LM_CMP_Fgt -- ^ Float greater than
+ | LM_CMP_Fge -- ^ Float greater than or equal
+ | LM_CMP_Flt -- ^ Float less than
+ | LM_CMP_Fle -- ^ Float less than or equal
+ deriving (Eq)
+
+instance Outputable LlvmCmpOp where
+ ppr LM_CMP_Eq = text "eq"
+ ppr LM_CMP_Ne = text "ne"
+ ppr LM_CMP_Ugt = text "ugt"
+ ppr LM_CMP_Uge = text "uge"
+ ppr LM_CMP_Ult = text "ult"
+ ppr LM_CMP_Ule = text "ule"
+ ppr LM_CMP_Sgt = text "sgt"
+ ppr LM_CMP_Sge = text "sge"
+ ppr LM_CMP_Slt = text "slt"
+ ppr LM_CMP_Sle = text "sle"
+ ppr LM_CMP_Feq = text "oeq"
+ ppr LM_CMP_Fne = text "une"
+ ppr LM_CMP_Fgt = text "ogt"
+ ppr LM_CMP_Fge = text "oge"
+ ppr LM_CMP_Flt = text "olt"
+ ppr LM_CMP_Fle = text "ole"
+
+
+-- | Llvm cast operations.
+data LlvmCastOp
+ = LM_Trunc -- ^ Integer truncate
+ | LM_Zext -- ^ Integer extend (zero fill)
+ | LM_Sext -- ^ Integer extend (sign fill)
+ | LM_Fptrunc -- ^ Float truncate
+ | LM_Fpext -- ^ Float extend
+ | LM_Fptoui -- ^ Float to unsigned Integer
+ | LM_Fptosi -- ^ Float to signed Integer
+ | LM_Uitofp -- ^ Unsigned Integer to Float
+ | LM_Sitofp -- ^ Signed Int to Float
+ | LM_Ptrtoint -- ^ Pointer to Integer
+ | LM_Inttoptr -- ^ Integer to Pointer
+ | LM_Bitcast -- ^ Cast between types where no bit manipulation is needed
+ deriving (Eq)
+
+instance Outputable LlvmCastOp where
+ ppr LM_Trunc = text "trunc"
+ ppr LM_Zext = text "zext"
+ ppr LM_Sext = text "sext"
+ ppr LM_Fptrunc = text "fptrunc"
+ ppr LM_Fpext = text "fpext"
+ ppr LM_Fptoui = text "fptoui"
+ ppr LM_Fptosi = text "fptosi"
+ ppr LM_Uitofp = text "uitofp"
+ ppr LM_Sitofp = text "sitofp"
+ ppr LM_Ptrtoint = text "ptrtoint"
+ ppr LM_Inttoptr = text "inttoptr"
+ ppr LM_Bitcast = text "bitcast"
+
+
+-- -----------------------------------------------------------------------------
+-- * Floating point conversion
+--
+
+-- | Convert a Haskell Double to an LLVM hex encoded floating point form. In
+-- Llvm float literals can be printed in a big-endian hexadecimal format,
+-- regardless of underlying architecture.
+--
+-- See Note [LLVM Float Types].
+ppDouble :: Double -> SDoc
+ppDouble d
+ = let bs = doubleToBytes d
+ hex d' = case showHex d' "" of
+ [] -> error "dToStr: too few hex digits for float"
+ [x] -> ['0',x]
+ [x,y] -> [x,y]
+ _ -> error "dToStr: too many hex digits for float"
+
+ str = map toUpper $ concat $ fixEndian $ map hex bs
+ in text "0x" <> text str
+
+-- Note [LLVM Float Types]
+-- ~~~~~~~~~~~~~~~~~~~~~~~
+-- We use 'ppDouble' for both printing Float and Double floating point types. This is
+-- as LLVM expects all floating point constants (single & double) to be in IEEE
+-- 754 Double precision format. However, for single precision numbers (Float)
+-- they should be *representable* in IEEE 754 Single precision format. So the
+-- easiest way to do this is to narrow and widen again.
+-- (i.e., Double -> Float -> Double). We must be careful doing this that GHC
+-- doesn't optimize that away.
+
+-- Note [narrowFp & widenFp]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~
+-- NOTE: we use float2Double & co directly as GHC likes to optimize away
+-- successive calls of 'realToFrac', defeating the narrowing. (Bug #7600).
+-- 'realToFrac' has inconsistent behaviour with optimisation as well that can
+-- also cause issues, these methods don't.
+
+narrowFp :: Double -> Float
+{-# NOINLINE narrowFp #-}
+narrowFp = double2Float
+
+widenFp :: Float -> Double
+{-# NOINLINE widenFp #-}
+widenFp = float2Double
+
+ppFloat :: Float -> SDoc
+ppFloat = ppDouble . widenFp
+
+-- | Reverse or leave byte data alone to fix endianness on this target.
+fixEndian :: [a] -> [a]
+#ifdef WORDS_BIGENDIAN
+fixEndian = id
+#else
+fixEndian = reverse
+#endif
+
+
+--------------------------------------------------------------------------------
+-- * Misc functions
+--------------------------------------------------------------------------------
+
+ppCommaJoin :: (Outputable a) => [a] -> SDoc
+ppCommaJoin strs = hsep $ punctuate comma (map ppr strs)
+
+ppSpaceJoin :: (Outputable a) => [a] -> SDoc
+ppSpaceJoin strs = hsep (map ppr strs)
diff --git a/llvmGen/LlvmCodeGen.hs b/llvmGen/LlvmCodeGen.hs
new file mode 100644
--- /dev/null
+++ b/llvmGen/LlvmCodeGen.hs
@@ -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 to i8*, ...]
+ --
+ -- Which is the LLVM way of protecting them against getting removed.
+ ivars <- getUsedVars
+ let cast x = LMBitc (LMStaticPointer (pVarLift x)) i8Ptr
+ ty = (LMArray (length ivars) i8Ptr)
+ usedArray = LMStaticArray (map cast ivars) ty
+ sectName = Just $ fsLit "llvm.metadata"
+ lmUsedVar = LMGlobalVar (fsLit "llvm.used") ty Appending sectName Nothing Constant
+ lmUsed = LMGlobal lmUsedVar (Just usedArray)
+ if null ivars
+ then return ()
+ else renderLlvm $ pprLlvmData ([lmUsed], [])
diff --git a/llvmGen/LlvmCodeGen/Base.hs b/llvmGen/LlvmCodeGen/Base.hs
new file mode 100644
--- /dev/null
+++ b/llvmGen/LlvmCodeGen/Base.hs
@@ -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@.
diff --git a/llvmGen/LlvmCodeGen/CodeGen.hs b/llvmGen/LlvmCodeGen/CodeGen.hs
new file mode 100644
--- /dev/null
+++ b/llvmGen/LlvmCodeGen/CodeGen.hs
@@ -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, but overflowBit is i1, so we need to cast (Cmm expects
+ -- both to be i)
+ (overflow, zext) <- doExpr width $ Cast LM_Zext overflowBit width
+ dstRegV <- getCmmReg (CmmLocal dstV)
+ dstRegO <- getCmmReg (CmmLocal dstO)
+ let storeV = Store value dstRegV
+ storeO = Store overflow dstRegO
+ return (stmts `snocOL` zext `snocOL` storeV `snocOL` storeO, top)
+genCallWithOverflow _ _ _ _ =
+ panic "genCallExtract: wrong ForeignTarget or number of arguments"
+
+-- | A helper function for genCallWithOverflow that handles generating the call
+-- to the LLVM intrinsic and extracting the result from the struct to LlvmVars.
+genCallExtract
+ :: ForeignTarget -- ^ PrimOp
+ -> Width -- ^ Width of the operands.
+ -> (CmmActual, CmmActual) -- ^ Actual arguments.
+ -> (LlvmType, LlvmType) -- ^ LLLVM types of the returned sturct.
+ -> LlvmM (LlvmVar, LlvmVar, StmtData)
+genCallExtract target@(PrimTarget op) w (argA, argB) (llvmTypeA, llvmTypeB) = do
+ let width = widthToLlvmInt w
+ argTy = [width, width]
+ retTy = LMStructU [llvmTypeA, llvmTypeB]
+
+ -- Process the arguments.
+ let args_hints = zip [argA, argB] (snd $ foreignTargetHints target)
+ (argsV1, args1, top1) <- arg_vars args_hints ([], nilOL, [])
+ (argsV2, args2) <- castVars $ zip argsV1 argTy
+
+ -- Get the function and make the call.
+ fname <- cmmPrimOpFunctions op
+ (fptr, _, top2) <- getInstrinct fname retTy argTy
+ -- We use StdCall for primops. See also the last case of genCall.
+ (retV, call) <- doExpr retTy $ Call StdCall fptr argsV2 []
+
+ -- This will result in a two element struct, we need to use "extractvalue"
+ -- to get them out of it.
+ (res1, ext1) <- doExpr llvmTypeA (ExtractV retV 0)
+ (res2, ext2) <- doExpr llvmTypeB (ExtractV retV 1)
+
+ let stmts = args1 `appOL` args2 `snocOL` call `snocOL` ext1 `snocOL` ext2
+ tops = top1 ++ top2
+ return (res1, res2, (stmts, tops))
+
+genCallExtract _ _ _ _ =
+ panic "genCallExtract: unsupported ForeignTarget"
+
+-- Handle simple function call that only need simple type casting, of the form:
+-- truncate arg >>= \a -> call(a) >>= zext
+--
+-- since GHC only really has i32 and i64 types and things like Word8 are backed
+-- by an i32 and just present a logical i8 range. So we must handle conversions
+-- from i32 to i8 explicitly as LLVM is strict about types.
+genCallSimpleCast :: Width -> ForeignTarget -> [CmmFormal] -> [CmmActual]
+ -> LlvmM StmtData
+genCallSimpleCast w t@(PrimTarget op) [dst] args = do
+ let width = widthToLlvmInt w
+ dstTy = cmmToLlvmType $ localRegType dst
+
+ fname <- cmmPrimOpFunctions op
+ (fptr, _, top3) <- getInstrinct fname width [width]
+
+ dstV <- getCmmReg (CmmLocal dst)
+
+ let (_, arg_hints) = foreignTargetHints t
+ let args_hints = zip args arg_hints
+ (argsV, stmts2, top2) <- arg_vars args_hints ([], nilOL, [])
+ (argsV', stmts4) <- castVars $ zip argsV [width]
+ (retV, s1) <- doExpr width $ Call StdCall fptr argsV' []
+ ([retV'], stmts5) <- castVars [(retV,dstTy)]
+ let s2 = Store retV' dstV
+
+ let stmts = stmts2 `appOL` stmts4 `snocOL`
+ s1 `appOL` stmts5 `snocOL` s2
+ return (stmts, top2 ++ top3)
+genCallSimpleCast _ _ dsts _ =
+ panic ("genCallSimpleCast: " ++ show (length dsts) ++ " dsts")
+
+-- | Create a function pointer from a target.
+getFunPtrW :: (LMString -> LlvmType) -> ForeignTarget
+ -> WriterT LlvmAccum LlvmM LlvmVar
+getFunPtrW funTy targ = liftExprData $ getFunPtr funTy targ
+
+-- | Create a function pointer from a target.
+getFunPtr :: (LMString -> LlvmType) -> ForeignTarget
+ -> LlvmM ExprData
+getFunPtr funTy targ = case targ of
+ ForeignTarget (CmmLit (CmmLabel lbl)) _ -> do
+ name <- strCLabel_llvm lbl
+ getHsFunc' name (funTy name)
+
+ ForeignTarget expr _ -> do
+ (v1, stmts, top) <- exprToVar expr
+ dflags <- getDynFlags
+ let fty = funTy $ fsLit "dynamic"
+ cast = case getVarType v1 of
+ ty | isPointer ty -> LM_Bitcast
+ ty | isInt ty -> LM_Inttoptr
+
+ ty -> panic $ "genCall: Expr is of bad type for function"
+ ++ " call! (" ++ showSDoc dflags (ppr ty) ++ ")"
+
+ (v2,s1) <- doExpr (pLift fty) $ Cast cast v1 (pLift fty)
+ return (v2, stmts `snocOL` s1, top)
+
+ PrimTarget mop -> do
+ name <- cmmPrimOpFunctions mop
+ let fty = funTy name
+ getInstrinct2 name fty
+
+-- | Conversion of call arguments.
+arg_varsW :: [(CmmActual, ForeignHint)]
+ -> ([LlvmVar], LlvmStatements, [LlvmCmmDecl])
+ -> WriterT LlvmAccum LlvmM [LlvmVar]
+arg_varsW xs ys = do
+ (vars, stmts, decls) <- lift $ arg_vars xs ys
+ tell $ LlvmAccum stmts decls
+ return vars
+
+-- | Conversion of call arguments.
+arg_vars :: [(CmmActual, ForeignHint)]
+ -> ([LlvmVar], LlvmStatements, [LlvmCmmDecl])
+ -> LlvmM ([LlvmVar], LlvmStatements, [LlvmCmmDecl])
+
+arg_vars [] (vars, stmts, tops)
+ = return (vars, stmts, tops)
+
+arg_vars ((e, AddrHint):rest) (vars, stmts, tops)
+ = do (v1, stmts', top') <- exprToVar e
+ dflags <- getDynFlags
+ let op = case getVarType v1 of
+ ty | isPointer ty -> LM_Bitcast
+ ty | isInt ty -> LM_Inttoptr
+
+ a -> panic $ "genCall: Can't cast llvmType to i8*! ("
+ ++ showSDoc dflags (ppr a) ++ ")"
+
+ (v2, s1) <- doExpr i8Ptr $ Cast op v1 i8Ptr
+ arg_vars rest (vars ++ [v2], stmts `appOL` stmts' `snocOL` s1,
+ tops ++ top')
+
+arg_vars ((e, _):rest) (vars, stmts, tops)
+ = do (v1, stmts', top') <- exprToVar e
+ arg_vars rest (vars ++ [v1], stmts `appOL` stmts', tops ++ top')
+
+
+-- | Cast a collection of LLVM variables to specific types.
+castVarsW :: [(LlvmVar, LlvmType)]
+ -> WriterT LlvmAccum LlvmM [LlvmVar]
+castVarsW vars = do
+ (vars, stmts) <- lift $ castVars vars
+ tell $ LlvmAccum stmts mempty
+ return vars
+
+-- | Cast a collection of LLVM variables to specific types.
+castVars :: [(LlvmVar, LlvmType)]
+ -> LlvmM ([LlvmVar], LlvmStatements)
+castVars vars = do
+ done <- mapM (uncurry castVar) vars
+ let (vars', stmts) = unzip done
+ return (vars', toOL stmts)
+
+-- | Cast an LLVM variable to a specific type, panicing if it can't be done.
+castVar :: LlvmVar -> LlvmType -> LlvmM (LlvmVar, LlvmStatement)
+castVar v t | getVarType v == t
+ = return (v, Nop)
+
+ | otherwise
+ = do dflags <- getDynFlags
+ let op = case (getVarType v, t) of
+ (LMInt n, LMInt m)
+ -> if n < m then LM_Sext else LM_Trunc
+ (vt, _) | isFloat vt && isFloat t
+ -> if llvmWidthInBits dflags vt < llvmWidthInBits dflags t
+ then LM_Fpext else LM_Fptrunc
+ (vt, _) | isInt vt && isFloat t -> LM_Sitofp
+ (vt, _) | isFloat vt && isInt t -> LM_Fptosi
+ (vt, _) | isInt vt && isPointer t -> LM_Inttoptr
+ (vt, _) | isPointer vt && isInt t -> LM_Ptrtoint
+ (vt, _) | isPointer vt && isPointer t -> LM_Bitcast
+ (vt, _) | isVector vt && isVector t -> LM_Bitcast
+
+ (vt, _) -> panic $ "castVars: Can't cast this type ("
+ ++ showSDoc dflags (ppr vt) ++ ") to (" ++ showSDoc dflags (ppr t) ++ ")"
+ doExpr t $ Cast op v t
+
+
+-- | Decide what C function to use to implement a CallishMachOp
+cmmPrimOpFunctions :: CallishMachOp -> LlvmM LMString
+cmmPrimOpFunctions mop = do
+
+ dflags <- getDynFlags
+ let intrinTy1 = "p0i8.p0i8." ++ showSDoc dflags (ppr $ llvmWord dflags)
+ intrinTy2 = "p0i8." ++ showSDoc dflags (ppr $ llvmWord dflags)
+ unsupported = panic ("cmmPrimOpFunctions: " ++ show mop
+ ++ " not supported here")
+
+ return $ case mop of
+ MO_F32_Exp -> fsLit "expf"
+ MO_F32_Log -> fsLit "logf"
+ MO_F32_Sqrt -> fsLit "llvm.sqrt.f32"
+ MO_F32_Fabs -> fsLit "llvm.fabs.f32"
+ MO_F32_Pwr -> fsLit "llvm.pow.f32"
+
+ MO_F32_Sin -> fsLit "llvm.sin.f32"
+ MO_F32_Cos -> fsLit "llvm.cos.f32"
+ MO_F32_Tan -> fsLit "tanf"
+
+ MO_F32_Asin -> fsLit "asinf"
+ MO_F32_Acos -> fsLit "acosf"
+ MO_F32_Atan -> fsLit "atanf"
+
+ MO_F32_Sinh -> fsLit "sinhf"
+ MO_F32_Cosh -> fsLit "coshf"
+ MO_F32_Tanh -> fsLit "tanhf"
+
+ MO_F64_Exp -> fsLit "exp"
+ MO_F64_Log -> fsLit "log"
+ MO_F64_Sqrt -> fsLit "llvm.sqrt.f64"
+ MO_F64_Fabs -> fsLit "llvm.fabs.f64"
+ MO_F64_Pwr -> fsLit "llvm.pow.f64"
+
+ MO_F64_Sin -> fsLit "llvm.sin.f64"
+ MO_F64_Cos -> fsLit "llvm.cos.f64"
+ MO_F64_Tan -> fsLit "tan"
+
+ MO_F64_Asin -> fsLit "asin"
+ MO_F64_Acos -> fsLit "acos"
+ MO_F64_Atan -> fsLit "atan"
+
+ MO_F64_Sinh -> fsLit "sinh"
+ MO_F64_Cosh -> fsLit "cosh"
+ MO_F64_Tanh -> fsLit "tanh"
+
+ MO_Memcpy _ -> fsLit $ "llvm.memcpy." ++ intrinTy1
+ MO_Memmove _ -> fsLit $ "llvm.memmove." ++ intrinTy1
+ MO_Memset _ -> fsLit $ "llvm.memset." ++ intrinTy2
+
+ (MO_PopCnt w) -> fsLit $ "llvm.ctpop." ++ showSDoc dflags (ppr $ widthToLlvmInt w)
+ (MO_BSwap w) -> fsLit $ "llvm.bswap." ++ showSDoc dflags (ppr $ widthToLlvmInt w)
+ (MO_Clz w) -> fsLit $ "llvm.ctlz." ++ showSDoc dflags (ppr $ widthToLlvmInt w)
+ (MO_Ctz w) -> fsLit $ "llvm.cttz." ++ showSDoc dflags (ppr $ widthToLlvmInt w)
+
+ (MO_Prefetch_Data _ )-> fsLit "llvm.prefetch"
+
+ MO_AddIntC w -> fsLit $ "llvm.sadd.with.overflow."
+ ++ showSDoc dflags (ppr $ widthToLlvmInt w)
+ MO_SubIntC w -> fsLit $ "llvm.ssub.with.overflow."
+ ++ showSDoc dflags (ppr $ widthToLlvmInt w)
+ MO_Add2 w -> fsLit $ "llvm.uadd.with.overflow."
+ ++ showSDoc dflags (ppr $ widthToLlvmInt w)
+ MO_SubWordC w -> fsLit $ "llvm.usub.with.overflow."
+ ++ showSDoc dflags (ppr $ widthToLlvmInt w)
+
+ MO_S_QuotRem {} -> unsupported
+ MO_U_QuotRem {} -> unsupported
+ MO_U_QuotRem2 {} -> unsupported
+ -- We support MO_U_Mul2 through ordinary LLVM mul instruction, see the
+ -- appropriate case of genCall.
+ MO_U_Mul2 {} -> unsupported
+ MO_WriteBarrier -> unsupported
+ MO_Touch -> unsupported
+ MO_UF_Conv _ -> unsupported
+
+ MO_AtomicRead _ -> unsupported
+ MO_AtomicRMW _ _ -> unsupported
+ MO_AtomicWrite _ -> unsupported
+ MO_Cmpxchg _ -> unsupported
+
+-- | Tail function calls
+genJump :: CmmExpr -> [GlobalReg] -> LlvmM StmtData
+
+-- Call to known function
+genJump (CmmLit (CmmLabel lbl)) live = do
+ (vf, stmts, top) <- getHsFunc live lbl
+ (stgRegs, stgStmts) <- funEpilogue live
+ let s1 = Expr $ Call TailCall vf stgRegs llvmStdFunAttrs
+ let s2 = Return Nothing
+ return (stmts `appOL` stgStmts `snocOL` s1 `snocOL` s2, top)
+
+
+-- Call to unknown function / address
+genJump expr live = do
+ fty <- llvmFunTy live
+ (vf, stmts, top) <- exprToVar expr
+ dflags <- getDynFlags
+
+ let cast = case getVarType vf of
+ ty | isPointer ty -> LM_Bitcast
+ ty | isInt ty -> LM_Inttoptr
+
+ ty -> panic $ "genJump: Expr is of bad type for function call! ("
+ ++ showSDoc dflags (ppr ty) ++ ")"
+
+ (v1, s1) <- doExpr (pLift fty) $ Cast cast vf (pLift fty)
+ (stgRegs, stgStmts) <- funEpilogue live
+ let s2 = Expr $ Call TailCall v1 stgRegs llvmStdFunAttrs
+ let s3 = Return Nothing
+ return (stmts `snocOL` s1 `appOL` stgStmts `snocOL` s2 `snocOL` s3,
+ top)
+
+
+-- | CmmAssign operation
+--
+-- We use stack allocated variables for CmmReg. The optimiser will replace
+-- these with registers when possible.
+genAssign :: CmmReg -> CmmExpr -> LlvmM StmtData
+genAssign reg val = do
+ vreg <- getCmmReg reg
+ (vval, stmts2, top2) <- exprToVar val
+ let stmts = stmts2
+
+ let ty = (pLower . getVarType) vreg
+ dflags <- getDynFlags
+ case ty of
+ -- Some registers are pointer types, so need to cast value to pointer
+ LMPointer _ | getVarType vval == llvmWord dflags -> do
+ (v, s1) <- doExpr ty $ Cast LM_Inttoptr vval ty
+ let s2 = Store v vreg
+ return (stmts `snocOL` s1 `snocOL` s2, top2)
+
+ LMVector _ _ -> do
+ (v, s1) <- doExpr ty $ Cast LM_Bitcast vval ty
+ let s2 = Store v vreg
+ return (stmts `snocOL` s1 `snocOL` s2, top2)
+
+ _ -> do
+ let s1 = Store vval vreg
+ return (stmts `snocOL` s1, top2)
+
+
+-- | CmmStore operation
+genStore :: CmmExpr -> CmmExpr -> LlvmM StmtData
+
+-- First we try to detect a few common cases and produce better code for
+-- these then the default case. We are mostly trying to detect Cmm code
+-- like I32[Sp + n] and use 'getelementptr' operations instead of the
+-- generic case that uses casts and pointer arithmetic
+genStore addr@(CmmReg (CmmGlobal r)) val
+ = genStore_fast addr r 0 val
+
+genStore addr@(CmmRegOff (CmmGlobal r) n) val
+ = genStore_fast addr r n val
+
+genStore addr@(CmmMachOp (MO_Add _) [
+ (CmmReg (CmmGlobal r)),
+ (CmmLit (CmmInt n _))])
+ val
+ = genStore_fast addr r (fromInteger n) val
+
+genStore addr@(CmmMachOp (MO_Sub _) [
+ (CmmReg (CmmGlobal r)),
+ (CmmLit (CmmInt n _))])
+ val
+ = genStore_fast addr r (negate $ fromInteger n) val
+
+-- generic case
+genStore addr val
+ = getTBAAMeta topN >>= genStore_slow addr val
+
+-- | CmmStore operation
+-- This is a special case for storing to a global register pointer
+-- offset such as I32[Sp+8].
+genStore_fast :: CmmExpr -> GlobalReg -> Int -> CmmExpr
+ -> LlvmM StmtData
+genStore_fast addr r n val
+ = do dflags <- getDynFlags
+ (gv, grt, s1) <- getCmmRegVal (CmmGlobal r)
+ meta <- getTBAARegMeta r
+ let (ix,rem) = n `divMod` ((llvmWidthInBits dflags . pLower) grt `div` 8)
+ case isPointer grt && rem == 0 of
+ True -> do
+ (vval, stmts, top) <- exprToVar val
+ (ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix]
+ -- We might need a different pointer type, so check
+ case pLower grt == getVarType vval of
+ -- were fine
+ True -> do
+ let s3 = MetaStmt meta $ Store vval ptr
+ return (stmts `appOL` s1 `snocOL` s2
+ `snocOL` s3, top)
+
+ -- cast to pointer type needed
+ False -> do
+ let ty = (pLift . getVarType) vval
+ (ptr', s3) <- doExpr ty $ Cast LM_Bitcast ptr ty
+ let s4 = MetaStmt meta $ Store vval ptr'
+ return (stmts `appOL` s1 `snocOL` s2
+ `snocOL` s3 `snocOL` s4, top)
+
+ -- If its a bit type then we use the slow method since
+ -- we can't avoid casting anyway.
+ False -> genStore_slow addr val meta
+
+
+-- | CmmStore operation
+-- Generic case. Uses casts and pointer arithmetic if needed.
+genStore_slow :: CmmExpr -> CmmExpr -> [MetaAnnot] -> LlvmM StmtData
+genStore_slow addr val meta = do
+ (vaddr, stmts1, top1) <- exprToVar addr
+ (vval, stmts2, top2) <- exprToVar val
+
+ let stmts = stmts1 `appOL` stmts2
+ dflags <- getDynFlags
+ case getVarType vaddr of
+ -- sometimes we need to cast an int to a pointer before storing
+ LMPointer ty@(LMPointer _) | getVarType vval == llvmWord dflags -> do
+ (v, s1) <- doExpr ty $ Cast LM_Inttoptr vval ty
+ let s2 = MetaStmt meta $ Store v vaddr
+ return (stmts `snocOL` s1 `snocOL` s2, top1 ++ top2)
+
+ LMPointer _ -> do
+ let s1 = MetaStmt meta $ Store vval vaddr
+ return (stmts `snocOL` s1, top1 ++ top2)
+
+ i@(LMInt _) | i == llvmWord dflags -> do
+ let vty = pLift $ getVarType vval
+ (vptr, s1) <- doExpr vty $ Cast LM_Inttoptr vaddr vty
+ let s2 = MetaStmt meta $ Store vval vptr
+ return (stmts `snocOL` s1 `snocOL` s2, top1 ++ top2)
+
+ other ->
+ pprPanic "genStore: ptr not right type!"
+ (PprCmm.pprExpr addr <+> text (
+ "Size of Ptr: " ++ show (llvmPtrBits dflags) ++
+ ", Size of var: " ++ show (llvmWidthInBits dflags other) ++
+ ", Var: " ++ showSDoc dflags (ppr vaddr)))
+
+
+-- | Unconditional branch
+genBranch :: BlockId -> LlvmM StmtData
+genBranch id =
+ let label = blockIdToLlvm id
+ in return (unitOL $ Branch label, [])
+
+
+-- | Conditional branch
+genCondBranch :: CmmExpr -> BlockId -> BlockId -> Maybe Bool -> LlvmM StmtData
+genCondBranch cond idT idF likely = do
+ let labelT = blockIdToLlvm idT
+ let labelF = blockIdToLlvm idF
+ -- See Note [Literals and branch conditions].
+ (vc, stmts1, top1) <- exprToVarOpt i1Option cond
+ if getVarType vc == i1
+ then do
+ (vc', (stmts2, top2)) <- case likely of
+ Just b -> genExpectLit (if b then 1 else 0) i1 vc
+ _ -> pure (vc, (nilOL, []))
+ let s1 = BranchIf vc' labelT labelF
+ return (stmts1 `appOL` stmts2 `snocOL` s1, top1 ++ top2)
+ else do
+ dflags <- getDynFlags
+ panic $ "genCondBranch: Cond expr not bool! (" ++ showSDoc dflags (ppr vc) ++ ")"
+
+
+-- | Generate call to llvm.expect.x intrinsic. Assigning result to a new var.
+genExpectLit :: Integer -> LlvmType -> LlvmVar -> LlvmM (LlvmVar, StmtData)
+genExpectLit expLit expTy var = do
+ dflags <- getDynFlags
+
+ let
+ lit = LMLitVar $ LMIntLit expLit expTy
+
+ llvmExpectName
+ | isInt expTy = fsLit $ "llvm.expect." ++ showSDoc dflags (ppr expTy)
+ | otherwise = panic $ "genExpectedLit: Type not an int!"
+
+ (llvmExpect, stmts, top) <-
+ getInstrinct llvmExpectName expTy [expTy, expTy]
+ (var', call) <- doExpr expTy $ Call StdCall llvmExpect [var, lit] []
+ return (var', (stmts `snocOL` call, top))
+
+{- Note [Literals and branch conditions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+It is important that whenever we generate branch conditions for
+literals like '1', they are properly narrowed to an LLVM expression of
+type 'i1' (for bools.) Otherwise, nobody is happy. So when we convert
+a CmmExpr to an LLVM expression for a branch conditional, exprToVarOpt
+must be certain to return a properly narrowed type. genLit is
+responsible for this, in the case of literal integers.
+
+Often, we won't see direct statements like:
+
+ if(1) {
+ ...
+ } else {
+ ...
+ }
+
+at this point in the pipeline, because the Glorious Code Generator
+will do trivial branch elimination in the sinking pass (among others,)
+which will eliminate the expression entirely.
+
+However, it's certainly possible and reasonable for this to occur in
+hand-written C-- code. Consider something like:
+
+ #ifndef SOME_CONDITIONAL
+ #define CHECK_THING(x) 1
+ #else
+ #define CHECK_THING(x) some_operation((x))
+ #endif
+
+ f() {
+
+ if (CHECK_THING(xyz)) {
+ ...
+ } else {
+ ...
+ }
+
+ }
+
+In such an instance, CHECK_THING might result in an *expression* in
+one case, and a *literal* in the other, depending on what in
+particular was #define'd. So we must be sure to properly narrow the
+literal in this case to i1 as it won't be eliminated beforehand.
+
+For a real example of this, see ./rts/StgStdThunks.cmm
+
+-}
+
+
+
+-- | Switch branch
+genSwitch :: CmmExpr -> SwitchTargets -> LlvmM StmtData
+genSwitch cond ids = do
+ (vc, stmts, top) <- exprToVar cond
+ let ty = getVarType vc
+
+ let labels = [ (mkIntLit ty ix, blockIdToLlvm b)
+ | (ix, b) <- switchTargetsCases ids ]
+ -- out of range is undefined, so let's just branch to first label
+ let defLbl | Just l <- switchTargetsDefault ids = blockIdToLlvm l
+ | otherwise = snd (head labels)
+
+ let s1 = Switch vc defLbl labels
+ return $ (stmts `snocOL` s1, top)
+
+
+-- -----------------------------------------------------------------------------
+-- * CmmExpr code generation
+--
+
+-- | An expression conversion return data:
+-- * LlvmVar: The var holding the result of the expression
+-- * LlvmStatements: Any statements needed to evaluate the expression
+-- * LlvmCmmDecl: Any global data needed for this expression
+type ExprData = (LlvmVar, LlvmStatements, [LlvmCmmDecl])
+
+-- | Values which can be passed to 'exprToVar' to configure its
+-- behaviour in certain circumstances.
+--
+-- Currently just used for determining if a comparison should return
+-- a boolean (i1) or a word. See Note [Literals and branch conditions].
+newtype EOption = EOption { i1Expected :: Bool }
+-- XXX: EOption is an ugly and inefficient solution to this problem.
+
+-- | i1 type expected (condition scrutinee).
+i1Option :: EOption
+i1Option = EOption True
+
+-- | Word type expected (usual).
+wordOption :: EOption
+wordOption = EOption False
+
+-- | Convert a CmmExpr to a list of LlvmStatements with the result of the
+-- expression being stored in the returned LlvmVar.
+exprToVar :: CmmExpr -> LlvmM ExprData
+exprToVar = exprToVarOpt wordOption
+
+exprToVarOpt :: EOption -> CmmExpr -> LlvmM ExprData
+exprToVarOpt opt e = case e of
+
+ CmmLit lit
+ -> genLit opt lit
+
+ CmmLoad e' ty
+ -> genLoad False e' ty
+
+ -- Cmmreg in expression is the value, so must load. If you want actual
+ -- reg pointer, call getCmmReg directly.
+ CmmReg r -> do
+ (v1, ty, s1) <- getCmmRegVal r
+ case isPointer ty of
+ True -> do
+ -- Cmm wants the value, so pointer types must be cast to ints
+ dflags <- getDynFlags
+ (v2, s2) <- doExpr (llvmWord dflags) $ Cast LM_Ptrtoint v1 (llvmWord dflags)
+ return (v2, s1 `snocOL` s2, [])
+
+ False -> return (v1, s1, [])
+
+ CmmMachOp op exprs
+ -> genMachOp opt op exprs
+
+ CmmRegOff r i
+ -> do dflags <- getDynFlags
+ exprToVar $ expandCmmReg dflags (r, i)
+
+ CmmStackSlot _ _
+ -> panic "exprToVar: CmmStackSlot not supported!"
+
+
+-- | Handle CmmMachOp expressions
+genMachOp :: EOption -> MachOp -> [CmmExpr] -> LlvmM ExprData
+
+-- Unary Machop
+genMachOp _ op [x] = case op of
+
+ MO_Not w ->
+ let all1 = mkIntLit (widthToLlvmInt w) (-1)
+ in negate (widthToLlvmInt w) all1 LM_MO_Xor
+
+ MO_S_Neg w ->
+ let all0 = mkIntLit (widthToLlvmInt w) 0
+ in negate (widthToLlvmInt w) all0 LM_MO_Sub
+
+ MO_F_Neg w ->
+ let all0 = LMLitVar $ LMFloatLit (-0) (widthToLlvmFloat w)
+ in negate (widthToLlvmFloat w) all0 LM_MO_FSub
+
+ MO_SF_Conv _ w -> fiConv (widthToLlvmFloat w) LM_Sitofp
+ MO_FS_Conv _ w -> fiConv (widthToLlvmInt w) LM_Fptosi
+
+ MO_SS_Conv from to
+ -> sameConv from (widthToLlvmInt to) LM_Trunc LM_Sext
+
+ MO_UU_Conv from to
+ -> sameConv from (widthToLlvmInt to) LM_Trunc LM_Zext
+
+ MO_FF_Conv from to
+ -> sameConv from (widthToLlvmFloat to) LM_Fptrunc LM_Fpext
+
+ MO_VS_Neg len w ->
+ let ty = widthToLlvmInt w
+ vecty = LMVector len ty
+ all0 = LMIntLit (-0) ty
+ all0s = LMLitVar $ LMVectorLit (replicate len all0)
+ in negateVec vecty all0s LM_MO_Sub
+
+ MO_VF_Neg len w ->
+ let ty = widthToLlvmFloat w
+ vecty = LMVector len ty
+ all0 = LMFloatLit (-0) ty
+ all0s = LMLitVar $ LMVectorLit (replicate len all0)
+ in negateVec vecty all0s LM_MO_FSub
+
+ -- Handle unsupported cases explicitly so we get a warning
+ -- of missing case when new MachOps added
+ MO_Add _ -> panicOp
+ MO_Mul _ -> panicOp
+ MO_Sub _ -> panicOp
+ MO_S_MulMayOflo _ -> panicOp
+ MO_S_Quot _ -> panicOp
+ MO_S_Rem _ -> panicOp
+ MO_U_MulMayOflo _ -> panicOp
+ MO_U_Quot _ -> panicOp
+ MO_U_Rem _ -> panicOp
+
+ MO_Eq _ -> panicOp
+ MO_Ne _ -> panicOp
+ MO_S_Ge _ -> panicOp
+ MO_S_Gt _ -> panicOp
+ MO_S_Le _ -> panicOp
+ MO_S_Lt _ -> panicOp
+ MO_U_Ge _ -> panicOp
+ MO_U_Gt _ -> panicOp
+ MO_U_Le _ -> panicOp
+ MO_U_Lt _ -> panicOp
+
+ MO_F_Add _ -> panicOp
+ MO_F_Sub _ -> panicOp
+ MO_F_Mul _ -> panicOp
+ MO_F_Quot _ -> panicOp
+ MO_F_Eq _ -> panicOp
+ MO_F_Ne _ -> panicOp
+ MO_F_Ge _ -> panicOp
+ MO_F_Gt _ -> panicOp
+ MO_F_Le _ -> panicOp
+ MO_F_Lt _ -> panicOp
+
+ MO_And _ -> panicOp
+ MO_Or _ -> panicOp
+ MO_Xor _ -> panicOp
+ MO_Shl _ -> panicOp
+ MO_U_Shr _ -> panicOp
+ MO_S_Shr _ -> panicOp
+
+ MO_V_Insert _ _ -> panicOp
+ MO_V_Extract _ _ -> panicOp
+
+ MO_V_Add _ _ -> panicOp
+ MO_V_Sub _ _ -> panicOp
+ MO_V_Mul _ _ -> panicOp
+
+ MO_VS_Quot _ _ -> panicOp
+ MO_VS_Rem _ _ -> panicOp
+
+ MO_VU_Quot _ _ -> panicOp
+ MO_VU_Rem _ _ -> panicOp
+
+ MO_VF_Insert _ _ -> panicOp
+ MO_VF_Extract _ _ -> panicOp
+
+ MO_VF_Add _ _ -> panicOp
+ MO_VF_Sub _ _ -> panicOp
+ MO_VF_Mul _ _ -> panicOp
+ MO_VF_Quot _ _ -> panicOp
+
+ where
+ negate ty v2 negOp = do
+ (vx, stmts, top) <- exprToVar x
+ (v1, s1) <- doExpr ty $ LlvmOp negOp v2 vx
+ return (v1, stmts `snocOL` s1, top)
+
+ negateVec ty v2 negOp = do
+ (vx, stmts1, top) <- exprToVar x
+ ([vx'], stmts2) <- castVars [(vx, ty)]
+ (v1, s1) <- doExpr ty $ LlvmOp negOp v2 vx'
+ return (v1, stmts1 `appOL` stmts2 `snocOL` s1, top)
+
+ fiConv ty convOp = do
+ (vx, stmts, top) <- exprToVar x
+ (v1, s1) <- doExpr ty $ Cast convOp vx ty
+ return (v1, stmts `snocOL` s1, top)
+
+ sameConv from ty reduce expand = do
+ x'@(vx, stmts, top) <- exprToVar x
+ let sameConv' op = do
+ (v1, s1) <- doExpr ty $ Cast op vx ty
+ return (v1, stmts `snocOL` s1, top)
+ dflags <- getDynFlags
+ let toWidth = llvmWidthInBits dflags ty
+ -- LLVM doesn't like trying to convert to same width, so
+ -- need to check for that as we do get Cmm code doing it.
+ case widthInBits from of
+ w | w < toWidth -> sameConv' expand
+ w | w > toWidth -> sameConv' reduce
+ _w -> return x'
+
+ panicOp = panic $ "LLVM.CodeGen.genMachOp: non unary op encountered"
+ ++ "with one argument! (" ++ show op ++ ")"
+
+-- Handle GlobalRegs pointers
+genMachOp opt o@(MO_Add _) e@[(CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))]
+ = genMachOp_fast opt o r (fromInteger n) e
+
+genMachOp opt o@(MO_Sub _) e@[(CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))]
+ = genMachOp_fast opt o r (negate . fromInteger $ n) e
+
+-- Generic case
+genMachOp opt op e = genMachOp_slow opt op e
+
+
+-- | Handle CmmMachOp expressions
+-- This is a specialised method that handles Global register manipulations like
+-- 'Sp - 16', using the getelementptr instruction.
+genMachOp_fast :: EOption -> MachOp -> GlobalReg -> Int -> [CmmExpr]
+ -> LlvmM ExprData
+genMachOp_fast opt op r n e
+ = do (gv, grt, s1) <- getCmmRegVal (CmmGlobal r)
+ dflags <- getDynFlags
+ let (ix,rem) = n `divMod` ((llvmWidthInBits dflags . pLower) grt `div` 8)
+ case isPointer grt && rem == 0 of
+ True -> do
+ (ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix]
+ (var, s3) <- doExpr (llvmWord dflags) $ Cast LM_Ptrtoint ptr (llvmWord dflags)
+ return (var, s1 `snocOL` s2 `snocOL` s3, [])
+
+ False -> genMachOp_slow opt op e
+
+
+-- | Handle CmmMachOp expressions
+-- This handles all the cases not handle by the specialised genMachOp_fast.
+genMachOp_slow :: EOption -> MachOp -> [CmmExpr] -> LlvmM ExprData
+
+-- Element extraction
+genMachOp_slow _ (MO_V_Extract l w) [val, idx] = runExprData $ do
+ vval <- exprToVarW val
+ vidx <- exprToVarW idx
+ [vval'] <- castVarsW [(vval, LMVector l ty)]
+ doExprW ty $ Extract vval' vidx
+ where
+ ty = widthToLlvmInt w
+
+genMachOp_slow _ (MO_VF_Extract l w) [val, idx] = runExprData $ do
+ vval <- exprToVarW val
+ vidx <- exprToVarW idx
+ [vval'] <- castVarsW [(vval, LMVector l ty)]
+ doExprW ty $ Extract vval' vidx
+ where
+ ty = widthToLlvmFloat w
+
+-- Element insertion
+genMachOp_slow _ (MO_V_Insert l w) [val, elt, idx] = runExprData $ do
+ vval <- exprToVarW val
+ velt <- exprToVarW elt
+ vidx <- exprToVarW idx
+ [vval'] <- castVarsW [(vval, ty)]
+ doExprW ty $ Insert vval' velt vidx
+ where
+ ty = LMVector l (widthToLlvmInt w)
+
+genMachOp_slow _ (MO_VF_Insert l w) [val, elt, idx] = runExprData $ do
+ vval <- exprToVarW val
+ velt <- exprToVarW elt
+ vidx <- exprToVarW idx
+ [vval'] <- castVarsW [(vval, ty)]
+ doExprW ty $ Insert vval' velt vidx
+ where
+ ty = LMVector l (widthToLlvmFloat w)
+
+-- Binary MachOp
+genMachOp_slow opt op [x, y] = case op of
+
+ MO_Eq _ -> genBinComp opt LM_CMP_Eq
+ MO_Ne _ -> genBinComp opt LM_CMP_Ne
+
+ MO_S_Gt _ -> genBinComp opt LM_CMP_Sgt
+ MO_S_Ge _ -> genBinComp opt LM_CMP_Sge
+ MO_S_Lt _ -> genBinComp opt LM_CMP_Slt
+ MO_S_Le _ -> genBinComp opt LM_CMP_Sle
+
+ MO_U_Gt _ -> genBinComp opt LM_CMP_Ugt
+ MO_U_Ge _ -> genBinComp opt LM_CMP_Uge
+ MO_U_Lt _ -> genBinComp opt LM_CMP_Ult
+ MO_U_Le _ -> genBinComp opt LM_CMP_Ule
+
+ MO_Add _ -> genBinMach LM_MO_Add
+ MO_Sub _ -> genBinMach LM_MO_Sub
+ MO_Mul _ -> genBinMach LM_MO_Mul
+
+ MO_U_MulMayOflo _ -> panic "genMachOp: MO_U_MulMayOflo unsupported!"
+
+ MO_S_MulMayOflo w -> isSMulOK w x y
+
+ MO_S_Quot _ -> genBinMach LM_MO_SDiv
+ MO_S_Rem _ -> genBinMach LM_MO_SRem
+
+ MO_U_Quot _ -> genBinMach LM_MO_UDiv
+ MO_U_Rem _ -> genBinMach LM_MO_URem
+
+ MO_F_Eq _ -> genBinComp opt LM_CMP_Feq
+ MO_F_Ne _ -> genBinComp opt LM_CMP_Fne
+ MO_F_Gt _ -> genBinComp opt LM_CMP_Fgt
+ MO_F_Ge _ -> genBinComp opt LM_CMP_Fge
+ MO_F_Lt _ -> genBinComp opt LM_CMP_Flt
+ MO_F_Le _ -> genBinComp opt LM_CMP_Fle
+
+ MO_F_Add _ -> genBinMach LM_MO_FAdd
+ MO_F_Sub _ -> genBinMach LM_MO_FSub
+ MO_F_Mul _ -> genBinMach LM_MO_FMul
+ MO_F_Quot _ -> genBinMach LM_MO_FDiv
+
+ MO_And _ -> genBinMach LM_MO_And
+ MO_Or _ -> genBinMach LM_MO_Or
+ MO_Xor _ -> genBinMach LM_MO_Xor
+ MO_Shl _ -> genBinMach LM_MO_Shl
+ MO_U_Shr _ -> genBinMach LM_MO_LShr
+ MO_S_Shr _ -> genBinMach LM_MO_AShr
+
+ MO_V_Add l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_Add
+ MO_V_Sub l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_Sub
+ MO_V_Mul l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_Mul
+
+ MO_VS_Quot l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_SDiv
+ MO_VS_Rem l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_SRem
+
+ MO_VU_Quot l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_UDiv
+ MO_VU_Rem l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_URem
+
+ MO_VF_Add l w -> genCastBinMach (LMVector l (widthToLlvmFloat w)) LM_MO_FAdd
+ MO_VF_Sub l w -> genCastBinMach (LMVector l (widthToLlvmFloat w)) LM_MO_FSub
+ MO_VF_Mul l w -> genCastBinMach (LMVector l (widthToLlvmFloat w)) LM_MO_FMul
+ MO_VF_Quot l w -> genCastBinMach (LMVector l (widthToLlvmFloat w)) LM_MO_FDiv
+
+ MO_Not _ -> panicOp
+ MO_S_Neg _ -> panicOp
+ MO_F_Neg _ -> panicOp
+
+ MO_SF_Conv _ _ -> panicOp
+ MO_FS_Conv _ _ -> panicOp
+ MO_SS_Conv _ _ -> panicOp
+ MO_UU_Conv _ _ -> panicOp
+ MO_FF_Conv _ _ -> panicOp
+
+ MO_V_Insert {} -> panicOp
+ MO_V_Extract {} -> panicOp
+
+ MO_VS_Neg {} -> panicOp
+
+ MO_VF_Insert {} -> panicOp
+ MO_VF_Extract {} -> panicOp
+
+ MO_VF_Neg {} -> panicOp
+
+ where
+ binLlvmOp ty binOp = runExprData $ do
+ vx <- exprToVarW x
+ vy <- exprToVarW y
+ if getVarType vx == getVarType vy
+ then do
+ doExprW (ty vx) $ binOp vx vy
+
+ else do
+ -- Error. Continue anyway so we can debug the generated ll file.
+ dflags <- getDynFlags
+ let style = mkCodeStyle CStyle
+ toString doc = renderWithStyle dflags doc style
+ cmmToStr = (lines . toString . PprCmm.pprExpr)
+ statement $ Comment $ map fsLit $ cmmToStr x
+ statement $ Comment $ map fsLit $ cmmToStr y
+ doExprW (ty vx) $ binOp vx vy
+
+ binCastLlvmOp ty binOp = runExprData $ do
+ vx <- exprToVarW x
+ vy <- exprToVarW y
+ [vx', vy'] <- castVarsW [(vx, ty), (vy, ty)]
+ doExprW ty $ binOp vx' vy'
+
+ -- | Need to use EOption here as Cmm expects word size results from
+ -- comparisons while LLVM return i1. Need to extend to llvmWord type
+ -- if expected. See Note [Literals and branch conditions].
+ genBinComp opt cmp = do
+ ed@(v1, stmts, top) <- binLlvmOp (\_ -> i1) (Compare cmp)
+ dflags <- getDynFlags
+ if getVarType v1 == i1
+ then case i1Expected opt of
+ True -> return ed
+ False -> do
+ let w_ = llvmWord dflags
+ (v2, s1) <- doExpr w_ $ Cast LM_Zext v1 w_
+ return (v2, stmts `snocOL` s1, top)
+ else
+ panic $ "genBinComp: Compare returned type other then i1! "
+ ++ (showSDoc dflags $ ppr $ getVarType v1)
+
+ genBinMach op = binLlvmOp getVarType (LlvmOp op)
+
+ genCastBinMach ty op = binCastLlvmOp ty (LlvmOp op)
+
+ -- | Detect if overflow will occur in signed multiply of the two
+ -- CmmExpr's. This is the LLVM assembly equivalent of the NCG
+ -- implementation. Its much longer due to type information/safety.
+ -- This should actually compile to only about 3 asm instructions.
+ isSMulOK :: Width -> CmmExpr -> CmmExpr -> LlvmM ExprData
+ isSMulOK _ x y = runExprData $ do
+ vx <- exprToVarW x
+ vy <- exprToVarW y
+
+ dflags <- getDynFlags
+ let word = getVarType vx
+ let word2 = LMInt $ 2 * (llvmWidthInBits dflags $ getVarType vx)
+ let shift = llvmWidthInBits dflags word
+ let shift1 = toIWord dflags (shift - 1)
+ let shift2 = toIWord dflags shift
+
+ if isInt word
+ then do
+ x1 <- doExprW word2 $ Cast LM_Sext vx word2
+ y1 <- doExprW word2 $ Cast LM_Sext vy word2
+ r1 <- doExprW word2 $ LlvmOp LM_MO_Mul x1 y1
+ rlow1 <- doExprW word $ Cast LM_Trunc r1 word
+ rlow2 <- doExprW word $ LlvmOp LM_MO_AShr rlow1 shift1
+ rhigh1 <- doExprW word2 $ LlvmOp LM_MO_AShr r1 shift2
+ rhigh2 <- doExprW word $ Cast LM_Trunc rhigh1 word
+ doExprW word $ LlvmOp LM_MO_Sub rlow2 rhigh2
+
+ else
+ panic $ "isSMulOK: Not bit type! (" ++ showSDoc dflags (ppr word) ++ ")"
+
+ panicOp = panic $ "LLVM.CodeGen.genMachOp_slow: unary op encountered"
+ ++ "with two arguments! (" ++ show op ++ ")"
+
+-- More then two expression, invalid!
+genMachOp_slow _ _ _ = panic "genMachOp: More then 2 expressions in MachOp!"
+
+
+-- | Handle CmmLoad expression.
+genLoad :: Atomic -> CmmExpr -> CmmType -> LlvmM ExprData
+
+-- First we try to detect a few common cases and produce better code for
+-- these then the default case. We are mostly trying to detect Cmm code
+-- like I32[Sp + n] and use 'getelementptr' operations instead of the
+-- generic case that uses casts and pointer arithmetic
+genLoad atomic e@(CmmReg (CmmGlobal r)) ty
+ = genLoad_fast atomic e r 0 ty
+
+genLoad atomic e@(CmmRegOff (CmmGlobal r) n) ty
+ = genLoad_fast atomic e r n ty
+
+genLoad atomic e@(CmmMachOp (MO_Add _) [
+ (CmmReg (CmmGlobal r)),
+ (CmmLit (CmmInt n _))])
+ ty
+ = genLoad_fast atomic e r (fromInteger n) ty
+
+genLoad atomic e@(CmmMachOp (MO_Sub _) [
+ (CmmReg (CmmGlobal r)),
+ (CmmLit (CmmInt n _))])
+ ty
+ = genLoad_fast atomic e r (negate $ fromInteger n) ty
+
+-- generic case
+genLoad atomic e ty
+ = getTBAAMeta topN >>= genLoad_slow atomic e ty
+
+-- | Handle CmmLoad expression.
+-- This is a special case for loading from a global register pointer
+-- offset such as I32[Sp+8].
+genLoad_fast :: Atomic -> CmmExpr -> GlobalReg -> Int -> CmmType
+ -> LlvmM ExprData
+genLoad_fast atomic e r n ty = do
+ dflags <- getDynFlags
+ (gv, grt, s1) <- getCmmRegVal (CmmGlobal r)
+ meta <- getTBAARegMeta r
+ let ty' = cmmToLlvmType ty
+ (ix,rem) = n `divMod` ((llvmWidthInBits dflags . pLower) grt `div` 8)
+ case isPointer grt && rem == 0 of
+ True -> do
+ (ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix]
+ -- We might need a different pointer type, so check
+ case grt == ty' of
+ -- were fine
+ True -> do
+ (var, s3) <- doExpr ty' (MExpr meta $ loadInstr ptr)
+ return (var, s1 `snocOL` s2 `snocOL` s3,
+ [])
+
+ -- cast to pointer type needed
+ False -> do
+ let pty = pLift ty'
+ (ptr', s3) <- doExpr pty $ Cast LM_Bitcast ptr pty
+ (var, s4) <- doExpr ty' (MExpr meta $ loadInstr ptr')
+ return (var, s1 `snocOL` s2 `snocOL` s3
+ `snocOL` s4, [])
+
+ -- If its a bit type then we use the slow method since
+ -- we can't avoid casting anyway.
+ False -> genLoad_slow atomic e ty meta
+ where
+ loadInstr ptr | atomic = ALoad SyncSeqCst False ptr
+ | otherwise = Load ptr
+
+-- | Handle Cmm load expression.
+-- Generic case. Uses casts and pointer arithmetic if needed.
+genLoad_slow :: Atomic -> CmmExpr -> CmmType -> [MetaAnnot] -> LlvmM ExprData
+genLoad_slow atomic e ty meta = runExprData $ do
+ iptr <- exprToVarW e
+ dflags <- getDynFlags
+ case getVarType iptr of
+ LMPointer _ -> do
+ doExprW (cmmToLlvmType ty) (MExpr meta $ loadInstr iptr)
+
+ i@(LMInt _) | i == llvmWord dflags -> do
+ let pty = LMPointer $ cmmToLlvmType ty
+ ptr <- doExprW pty $ Cast LM_Inttoptr iptr pty
+ doExprW (cmmToLlvmType ty) (MExpr meta $ loadInstr ptr)
+
+ other -> do pprPanic "exprToVar: CmmLoad expression is not right type!"
+ (PprCmm.pprExpr e <+> text (
+ "Size of Ptr: " ++ show (llvmPtrBits dflags) ++
+ ", Size of var: " ++ show (llvmWidthInBits dflags other) ++
+ ", Var: " ++ showSDoc dflags (ppr iptr)))
+ where
+ loadInstr ptr | atomic = ALoad SyncSeqCst False ptr
+ | otherwise = Load ptr
+
+
+-- | Handle CmmReg expression. This will return a pointer to the stack
+-- location of the register. Throws an error if it isn't allocated on
+-- the stack.
+getCmmReg :: CmmReg -> LlvmM LlvmVar
+getCmmReg (CmmLocal (LocalReg un _))
+ = do exists <- varLookup un
+ dflags <- getDynFlags
+ case exists of
+ Just ety -> return (LMLocalVar un $ pLift ety)
+ Nothing -> fail $ "getCmmReg: Cmm register " ++ showSDoc dflags (ppr un) ++ " was not allocated!"
+ -- This should never happen, as every local variable should
+ -- have been assigned a value at some point, triggering
+ -- "funPrologue" to allocate it on the stack.
+
+getCmmReg (CmmGlobal g)
+ = do onStack <- checkStackReg g
+ dflags <- getDynFlags
+ if onStack
+ then return (lmGlobalRegVar dflags g)
+ else fail $ "getCmmReg: Cmm register " ++ showSDoc dflags (ppr g) ++ " not stack-allocated!"
+
+-- | Return the value of a given register, as well as its type. Might
+-- need to be load from stack.
+getCmmRegVal :: CmmReg -> LlvmM (LlvmVar, LlvmType, LlvmStatements)
+getCmmRegVal reg =
+ case reg of
+ CmmGlobal g -> do
+ onStack <- checkStackReg g
+ dflags <- getDynFlags
+ if onStack then loadFromStack else do
+ let r = lmGlobalRegArg dflags g
+ return (r, getVarType r, nilOL)
+ _ -> loadFromStack
+ where loadFromStack = do
+ ptr <- getCmmReg reg
+ let ty = pLower $ getVarType ptr
+ (v, s) <- doExpr ty (Load ptr)
+ return (v, ty, unitOL s)
+
+-- | Allocate a local CmmReg on the stack
+allocReg :: CmmReg -> (LlvmVar, LlvmStatements)
+allocReg (CmmLocal (LocalReg un ty))
+ = let ty' = cmmToLlvmType ty
+ var = LMLocalVar un (LMPointer ty')
+ alc = Alloca ty' 1
+ in (var, unitOL $ Assignment var alc)
+
+allocReg _ = panic $ "allocReg: Global reg encountered! Global registers should"
+ ++ " have been handled elsewhere!"
+
+
+-- | Generate code for a literal
+genLit :: EOption -> CmmLit -> LlvmM ExprData
+genLit opt (CmmInt i w)
+ -- See Note [Literals and branch conditions].
+ = let width | i1Expected opt = i1
+ | otherwise = LMInt (widthInBits w)
+ -- comm = Comment [ fsLit $ "EOption: " ++ show opt
+ -- , fsLit $ "Width : " ++ show w
+ -- , fsLit $ "Width' : " ++ show (widthInBits w)
+ -- ]
+ in return (mkIntLit width i, nilOL, [])
+
+genLit _ (CmmFloat r w)
+ = return (LMLitVar $ LMFloatLit (fromRational r) (widthToLlvmFloat w),
+ nilOL, [])
+
+genLit opt (CmmVec ls)
+ = do llvmLits <- mapM toLlvmLit ls
+ return (LMLitVar $ LMVectorLit llvmLits, nilOL, [])
+ where
+ toLlvmLit :: CmmLit -> LlvmM LlvmLit
+ toLlvmLit lit = do
+ (llvmLitVar, _, _) <- genLit opt lit
+ case llvmLitVar of
+ LMLitVar llvmLit -> return llvmLit
+ _ -> panic "genLit"
+
+genLit _ cmm@(CmmLabel l)
+ = do var <- getGlobalPtr =<< strCLabel_llvm l
+ dflags <- getDynFlags
+ let lmty = cmmToLlvmType $ cmmLitType dflags cmm
+ (v1, s1) <- doExpr lmty $ Cast LM_Ptrtoint var (llvmWord dflags)
+ return (v1, unitOL s1, [])
+
+genLit opt (CmmLabelOff label off) = do
+ dflags <- getDynFlags
+ (vlbl, stmts, stat) <- genLit opt (CmmLabel label)
+ let voff = toIWord dflags off
+ (v1, s1) <- doExpr (getVarType vlbl) $ LlvmOp LM_MO_Add vlbl voff
+ return (v1, stmts `snocOL` s1, stat)
+
+genLit opt (CmmLabelDiffOff l1 l2 off) = do
+ dflags <- getDynFlags
+ (vl1, stmts1, stat1) <- genLit opt (CmmLabel l1)
+ (vl2, stmts2, stat2) <- genLit opt (CmmLabel l2)
+ let voff = toIWord dflags off
+ let ty1 = getVarType vl1
+ let ty2 = getVarType vl2
+ if (isInt ty1) && (isInt ty2)
+ && (llvmWidthInBits dflags ty1 == llvmWidthInBits dflags ty2)
+
+ then do
+ (v1, s1) <- doExpr (getVarType vl1) $ LlvmOp LM_MO_Sub vl1 vl2
+ (v2, s2) <- doExpr (getVarType v1 ) $ LlvmOp LM_MO_Add v1 voff
+ return (v2, stmts1 `appOL` stmts2 `snocOL` s1 `snocOL` s2,
+ stat1 ++ stat2)
+
+ else
+ panic "genLit: CmmLabelDiffOff encountered with different label ty!"
+
+genLit opt (CmmBlock b)
+ = genLit opt (CmmLabel $ infoTblLbl b)
+
+genLit _ CmmHighStackMark
+ = panic "genStaticLit - CmmHighStackMark unsupported!"
+
+
+-- -----------------------------------------------------------------------------
+-- * Misc
+--
+
+-- | Find CmmRegs that get assigned and allocate them on the stack
+--
+-- Any register that gets written needs to be allcoated on the
+-- stack. This avoids having to map a CmmReg to an equivalent SSA form
+-- and avoids having to deal with Phi node insertion. This is also
+-- the approach recommended by LLVM developers.
+--
+-- On the other hand, this is unnecessarily verbose if the register in
+-- question is never written. Therefore we skip it where we can to
+-- save a few lines in the output and hopefully speed compilation up a
+-- bit.
+funPrologue :: LiveGlobalRegs -> [CmmBlock] -> LlvmM StmtData
+funPrologue live cmmBlocks = do
+
+ trash <- getTrashRegs
+ let getAssignedRegs :: CmmNode O O -> [CmmReg]
+ getAssignedRegs (CmmAssign reg _) = [reg]
+ -- Calls will trash all registers. Unfortunately, this needs them to
+ -- be stack-allocated in the first place.
+ getAssignedRegs (CmmUnsafeForeignCall _ rs _) = map CmmGlobal trash ++ map CmmLocal rs
+ getAssignedRegs _ = []
+ getRegsBlock (_, body, _) = concatMap getAssignedRegs $ blockToList body
+ assignedRegs = nub $ concatMap (getRegsBlock . blockSplit) cmmBlocks
+ isLive r = r `elem` alwaysLive || r `elem` live
+
+ dflags <- getDynFlags
+ stmtss <- flip mapM assignedRegs $ \reg ->
+ case reg of
+ CmmLocal (LocalReg un _) -> do
+ let (newv, stmts) = allocReg reg
+ varInsert un (pLower $ getVarType newv)
+ return stmts
+ CmmGlobal r -> do
+ let reg = lmGlobalRegVar dflags r
+ arg = lmGlobalRegArg dflags r
+ ty = (pLower . getVarType) reg
+ trash = LMLitVar $ LMUndefLit ty
+ rval = if isLive r then arg else trash
+ alloc = Assignment reg $ Alloca (pLower $ getVarType reg) 1
+ markStackReg r
+ return $ toOL [alloc, Store rval reg]
+
+ return (concatOL stmtss, [])
+
+-- | Function epilogue. Load STG variables to use as argument for call.
+-- STG Liveness optimisation done here.
+funEpilogue :: LiveGlobalRegs -> LlvmM ([LlvmVar], LlvmStatements)
+funEpilogue live = do
+
+ -- Have information and liveness optimisation is enabled?
+ let liveRegs = alwaysLive ++ live
+ isSSE (FloatReg _) = True
+ isSSE (DoubleReg _) = True
+ isSSE (XmmReg _) = True
+ isSSE (YmmReg _) = True
+ isSSE (ZmmReg _) = True
+ isSSE _ = False
+
+ -- Set to value or "undef" depending on whether the register is
+ -- actually live
+ dflags <- getDynFlags
+ let loadExpr r = do
+ (v, _, s) <- getCmmRegVal (CmmGlobal r)
+ return (Just $ v, s)
+ loadUndef r = do
+ let ty = (pLower . getVarType $ lmGlobalRegVar dflags r)
+ return (Just $ LMLitVar $ LMUndefLit ty, nilOL)
+ platform <- getDynFlag targetPlatform
+ loads <- flip mapM (activeStgRegs platform) $ \r -> case () of
+ _ | r `elem` liveRegs -> loadExpr r
+ | not (isSSE r) -> loadUndef r
+ | otherwise -> return (Nothing, nilOL)
+
+ let (vars, stmts) = unzip loads
+ return (catMaybes vars, concatOL stmts)
+
+
+-- | A series of statements to trash all the STG registers.
+--
+-- In LLVM we pass the STG registers around everywhere in function calls.
+-- So this means LLVM considers them live across the entire function, when
+-- in reality they usually aren't. For Caller save registers across C calls
+-- the saving and restoring of them is done by the Cmm code generator,
+-- using Cmm local vars. So to stop LLVM saving them as well (and saving
+-- all of them since it thinks they're always live, we trash them just
+-- before the call by assigning the 'undef' value to them. The ones we
+-- need are restored from the Cmm local var and the ones we don't need
+-- are fine to be trashed.
+getTrashStmts :: LlvmM LlvmStatements
+getTrashStmts = do
+ regs <- getTrashRegs
+ stmts <- flip mapM regs $ \ r -> do
+ reg <- getCmmReg (CmmGlobal r)
+ let ty = (pLower . getVarType) reg
+ return $ Store (LMLitVar $ LMUndefLit ty) reg
+ return $ toOL stmts
+
+getTrashRegs :: LlvmM [GlobalReg]
+getTrashRegs = do plat <- getLlvmPlatform
+ return $ filter (callerSaves plat) (activeStgRegs plat)
+
+-- | Get a function pointer to the CLabel specified.
+--
+-- This is for Haskell functions, function type is assumed, so doesn't work
+-- with foreign functions.
+getHsFunc :: LiveGlobalRegs -> CLabel -> LlvmM ExprData
+getHsFunc live lbl
+ = do fty <- llvmFunTy live
+ name <- strCLabel_llvm lbl
+ getHsFunc' name fty
+
+getHsFunc' :: LMString -> LlvmType -> LlvmM ExprData
+getHsFunc' name fty
+ = do fun <- getGlobalPtr name
+ if getVarType fun == fty
+ then return (fun, nilOL, [])
+ else do (v1, s1) <- doExpr (pLift fty)
+ $ Cast LM_Bitcast fun (pLift fty)
+ return (v1, unitOL s1, [])
+
+-- | Create a new local var
+mkLocalVar :: LlvmType -> LlvmM LlvmVar
+mkLocalVar ty = do
+ un <- getUniqueM
+ return $ LMLocalVar un ty
+
+
+-- | Execute an expression, assigning result to a var
+doExpr :: LlvmType -> LlvmExpression -> LlvmM (LlvmVar, LlvmStatement)
+doExpr ty expr = do
+ v <- mkLocalVar ty
+ return (v, Assignment v expr)
+
+
+-- | Expand CmmRegOff
+expandCmmReg :: DynFlags -> (CmmReg, Int) -> CmmExpr
+expandCmmReg dflags (reg, off)
+ = let width = typeWidth (cmmRegType dflags reg)
+ voff = CmmLit $ CmmInt (fromIntegral off) width
+ in CmmMachOp (MO_Add width) [CmmReg reg, voff]
+
+
+-- | Convert a block id into a appropriate Llvm label
+blockIdToLlvm :: BlockId -> LlvmVar
+blockIdToLlvm bid = LMLocalVar (getUnique bid) LMLabel
+
+-- | Create Llvm int Literal
+mkIntLit :: Integral a => LlvmType -> a -> LlvmVar
+mkIntLit ty i = LMLitVar $ LMIntLit (toInteger i) ty
+
+-- | Convert int type to a LLvmVar of word or i32 size
+toI32 :: Integral a => a -> LlvmVar
+toI32 = mkIntLit i32
+
+toIWord :: Integral a => DynFlags -> a -> LlvmVar
+toIWord dflags = mkIntLit (llvmWord dflags)
+
+
+-- | Error functions
+panic :: String -> a
+panic s = Outputable.panic $ "LlvmCodeGen.CodeGen." ++ s
+
+pprPanic :: String -> SDoc -> a
+pprPanic s d = Outputable.pprPanic ("LlvmCodeGen.CodeGen." ++ s) d
+
+
+-- | Returns TBAA meta data by unique
+getTBAAMeta :: Unique -> LlvmM [MetaAnnot]
+getTBAAMeta u = do
+ mi <- getUniqMeta u
+ return [MetaAnnot tbaa (MetaNode i) | let Just i = mi]
+
+-- | Returns TBAA meta data for given register
+getTBAARegMeta :: GlobalReg -> LlvmM [MetaAnnot]
+getTBAARegMeta = getTBAAMeta . getTBAA
+
+
+-- | A more convenient way of accumulating LLVM statements and declarations.
+data LlvmAccum = LlvmAccum LlvmStatements [LlvmCmmDecl]
+
+#if __GLASGOW_HASKELL__ > 710
+instance Semigroup LlvmAccum where
+ LlvmAccum stmtsA declsA <> LlvmAccum stmtsB declsB =
+ LlvmAccum (stmtsA Semigroup.<> stmtsB) (declsA Semigroup.<> declsB)
+#endif
+
+instance Monoid LlvmAccum where
+ mempty = LlvmAccum nilOL []
+ LlvmAccum stmtsA declsA `mappend` LlvmAccum stmtsB declsB =
+ LlvmAccum (stmtsA `mappend` stmtsB) (declsA `mappend` declsB)
+
+liftExprData :: LlvmM ExprData -> WriterT LlvmAccum LlvmM LlvmVar
+liftExprData action = do
+ (var, stmts, decls) <- lift action
+ tell $ LlvmAccum stmts decls
+ return var
+
+statement :: LlvmStatement -> WriterT LlvmAccum LlvmM ()
+statement stmt = tell $ LlvmAccum (unitOL stmt) []
+
+doExprW :: LlvmType -> LlvmExpression -> WriterT LlvmAccum LlvmM LlvmVar
+doExprW a b = do
+ (var, stmt) <- lift $ doExpr a b
+ statement stmt
+ return var
+
+exprToVarW :: CmmExpr -> WriterT LlvmAccum LlvmM LlvmVar
+exprToVarW = liftExprData . exprToVar
+
+runExprData :: WriterT LlvmAccum LlvmM LlvmVar -> LlvmM ExprData
+runExprData action = do
+ (var, LlvmAccum stmts decls) <- runWriterT action
+ return (var, stmts, decls)
+
+runStmtsDecls :: WriterT LlvmAccum LlvmM () -> LlvmM (LlvmStatements, [LlvmCmmDecl])
+runStmtsDecls action = do
+ LlvmAccum stmts decls <- execWriterT action
+ return (stmts, decls)
+
+getCmmRegW :: CmmReg -> WriterT LlvmAccum LlvmM LlvmVar
+getCmmRegW = lift . getCmmReg
+
+genLoadW :: Atomic -> CmmExpr -> CmmType -> WriterT LlvmAccum LlvmM LlvmVar
+genLoadW atomic e ty = liftExprData $ genLoad atomic e ty
+
+doTrashStmts :: WriterT LlvmAccum LlvmM ()
+doTrashStmts = do
+ stmts <- lift getTrashStmts
+ tell $ LlvmAccum stmts mempty
diff --git a/llvmGen/LlvmCodeGen/Data.hs b/llvmGen/LlvmCodeGen/Data.hs
new file mode 100644
--- /dev/null
+++ b/llvmGen/LlvmCodeGen/Data.hs
@@ -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!"
diff --git a/llvmGen/LlvmCodeGen/Ppr.hs b/llvmGen/LlvmCodeGen/Ppr.hs
new file mode 100644
--- /dev/null
+++ b/llvmGen/LlvmCodeGen/Ppr.hs
@@ -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"
diff --git a/llvmGen/LlvmCodeGen/Regs.hs b/llvmGen/LlvmCodeGen/Regs.hs
new file mode 100644
--- /dev/null
+++ b/llvmGen/LlvmCodeGen/Regs.hs
@@ -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
diff --git a/llvmGen/LlvmMangler.hs b/llvmGen/LlvmMangler.hs
new file mode 100644
--- /dev/null
+++ b/llvmGen/LlvmMangler.hs
@@ -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
diff --git a/main/Annotations.hs b/main/Annotations.hs
new file mode 100644
--- /dev/null
+++ b/main/Annotations.hs
@@ -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
diff --git a/main/CmdLineParser.hs b/main/CmdLineParser.hs
new file mode 100644
--- /dev/null
+++ b/main/CmdLineParser.hs
@@ -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).
+-}
diff --git a/main/CodeOutput.hs b/main/CodeOutput.hs
new file mode 100644
--- /dev/null
+++ b/main/CodeOutput.hs
@@ -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
diff --git a/main/Constants.hs b/main/Constants.hs
new file mode 100644
--- /dev/null
+++ b/main/Constants.hs
@@ -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
diff --git a/main/DriverMkDepend.hs b/main/DriverMkDepend.hs
new file mode 100644
--- /dev/null
+++ b/main/DriverMkDepend.hs
@@ -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"
+
diff --git a/main/DriverPhases.hs b/main/DriverPhases.hs
new file mode 100644
--- /dev/null
+++ b/main/DriverPhases.hs
@@ -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)
+
diff --git a/main/DriverPipeline.hs b/main/DriverPipeline.hs
new file mode 100644
--- /dev/null
+++ b/main/DriverPipeline.hs
@@ -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 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,