ghc buildable

ghc-toolkit/boot-libs/ghc/HsVersions.h

@@ -0,0 +1,65 @@
+#pragma once
+
+#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 () }

ghc-toolkit/boot-libs/ghc/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.

ghc-toolkit/boot-libs/ghc/Makefile

@@ -0,0 +1,24 @@
+# -----------------------------------------------------------------------------
+#
+# (c) 2009 The University of Glasgow
+#
+# This file is part of the GHC build system.
+#
+# To understand how the build system works and how to modify it, see
+#      http://ghc.haskell.org/trac/ghc/wiki/Building/Architecture
+#      http://ghc.haskell.org/trac/ghc/wiki/Building/Modifying
+#
+# -----------------------------------------------------------------------------
+
+# If the user says 'make' or 'make stage=2' here, we behave as if they were
+# in the ghc directory instead, so that the executable GHC gets built.
+.PHONY: default_to_ghc all_ghc
+default_to_ghc : all_ghc
+
+dir = compiler
+
+include ../mk/compiler-ghc.mk
+
+all_ghc :
+	+$(TOPMAKE) all_ghc $(EXTRA_MAKE_OPTS)
+

ghc-toolkit/boot-libs/ghc/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

ghc-toolkit/boot-libs/ghc/autogen/Config.hs

@@ -0,0 +1,66 @@
+{-# LANGUAGE CPP #-}
+module Config where
+
+import GhcPrelude
+
+#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   = "422b0b39cdec7f325c1019f8b35276ee58a3514d"
+cProjectVersion       :: String
+cProjectVersion       = "8.8.4"
+cProjectVersionInt    :: String
+cProjectVersionInt    = "808"
+cProjectPatchLevel    :: String
+cProjectPatchLevel    = "4"
+cProjectPatchLevel1   :: String
+cProjectPatchLevel1   = "4"
+cProjectPatchLevel2   :: String
+cProjectPatchLevel2   = ""
+cBooterVersion        :: String
+cBooterVersion        = "8.8.4"
+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           = "v thr"
+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
+cGhcRtsWithLibdw :: Bool
+cGhcRtsWithLibdw = True

ghc-toolkit/boot-libs/ghc/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,

ghc-toolkit/boot-libs/ghc/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

ghc-toolkit/boot-libs/ghc/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))

ghc-toolkit/boot-libs/ghc/autogen/ghc_boot_platform.h

@@ -0,0 +1,34 @@
+#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 LLVM_TARGET "x86_64-unknown-linux"
+
+#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__ */

ghc-toolkit/boot-libs/ghc/autogen/primop-can-fail.hs-incl

@@ -0,0 +1,231 @@
+primOpCanFail IntQuotOp = True
+primOpCanFail IntRemOp = True
+primOpCanFail IntQuotRemOp = True
+primOpCanFail Int8QuotOp = True
+primOpCanFail Int8RemOp = True
+primOpCanFail Int8QuotRemOp = True
+primOpCanFail Word8QuotOp = True
+primOpCanFail Word8RemOp = True
+primOpCanFail Word8QuotRemOp = True
+primOpCanFail Int16QuotOp = True
+primOpCanFail Int16RemOp = True
+primOpCanFail Int16QuotRemOp = True
+primOpCanFail Word16QuotOp = True
+primOpCanFail Word16RemOp = True
+primOpCanFail Word16QuotRemOp = 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 IndexByteArrayOp_Word8AsChar = True
+primOpCanFail IndexByteArrayOp_Word8AsWideChar = True
+primOpCanFail IndexByteArrayOp_Word8AsAddr = True
+primOpCanFail IndexByteArrayOp_Word8AsFloat = True
+primOpCanFail IndexByteArrayOp_Word8AsDouble = True
+primOpCanFail IndexByteArrayOp_Word8AsStablePtr = True
+primOpCanFail IndexByteArrayOp_Word8AsInt16 = True
+primOpCanFail IndexByteArrayOp_Word8AsInt32 = True
+primOpCanFail IndexByteArrayOp_Word8AsInt64 = True
+primOpCanFail IndexByteArrayOp_Word8AsInt = True
+primOpCanFail IndexByteArrayOp_Word8AsWord16 = True
+primOpCanFail IndexByteArrayOp_Word8AsWord32 = True
+primOpCanFail IndexByteArrayOp_Word8AsWord64 = True
+primOpCanFail IndexByteArrayOp_Word8AsWord = 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 ReadByteArrayOp_Word8AsChar = True
+primOpCanFail ReadByteArrayOp_Word8AsWideChar = True
+primOpCanFail ReadByteArrayOp_Word8AsAddr = True
+primOpCanFail ReadByteArrayOp_Word8AsFloat = True
+primOpCanFail ReadByteArrayOp_Word8AsDouble = True
+primOpCanFail ReadByteArrayOp_Word8AsStablePtr = True
+primOpCanFail ReadByteArrayOp_Word8AsInt16 = True
+primOpCanFail ReadByteArrayOp_Word8AsInt32 = True
+primOpCanFail ReadByteArrayOp_Word8AsInt64 = True
+primOpCanFail ReadByteArrayOp_Word8AsInt = True
+primOpCanFail ReadByteArrayOp_Word8AsWord16 = True
+primOpCanFail ReadByteArrayOp_Word8AsWord32 = True
+primOpCanFail ReadByteArrayOp_Word8AsWord64 = True
+primOpCanFail ReadByteArrayOp_Word8AsWord = 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 WriteByteArrayOp_Word8AsChar = True
+primOpCanFail WriteByteArrayOp_Word8AsWideChar = True
+primOpCanFail WriteByteArrayOp_Word8AsAddr = True
+primOpCanFail WriteByteArrayOp_Word8AsFloat = True
+primOpCanFail WriteByteArrayOp_Word8AsDouble = True
+primOpCanFail WriteByteArrayOp_Word8AsStablePtr = True
+primOpCanFail WriteByteArrayOp_Word8AsInt16 = True
+primOpCanFail WriteByteArrayOp_Word8AsInt32 = True
+primOpCanFail WriteByteArrayOp_Word8AsInt64 = True
+primOpCanFail WriteByteArrayOp_Word8AsInt = True
+primOpCanFail WriteByteArrayOp_Word8AsWord16 = True
+primOpCanFail WriteByteArrayOp_Word8AsWord32 = True
+primOpCanFail WriteByteArrayOp_Word8AsWord64 = True
+primOpCanFail WriteByteArrayOp_Word8AsWord = True
+primOpCanFail CompareByteArraysOp = 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 AtomicModifyMutVar2Op = True
+primOpCanFail AtomicModifyMutVar_Op = True
+primOpCanFail ReallyUnsafePtrEqualityOp = 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

ghc-toolkit/boot-libs/ghc/autogen/primop-code-size.hs-incl

@@ -0,0 +1,57 @@
+primOpCodeSize OrdOp = 0
+primOpCodeSize IntAddCOp = 2
+primOpCodeSize IntSubCOp = 2
+primOpCodeSize ChrOp = 0
+primOpCodeSize Int2WordOp = 0
+primOpCodeSize WordAddCOp = 2
+primOpCodeSize WordSubCOp = 2
+primOpCodeSize WordAdd2Op = 2
+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 DoubleAsinhOp =  primOpCodeSizeForeignCall 
+primOpCodeSize DoubleAcoshOp =  primOpCodeSizeForeignCall 
+primOpCodeSize DoubleAtanhOp =  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 FloatAsinhOp =  primOpCodeSizeForeignCall 
+primOpCodeSize FloatAcoshOp =  primOpCodeSizeForeignCall 
+primOpCodeSize FloatAtanhOp =  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 

ghc-toolkit/boot-libs/ghc/autogen/primop-commutable.hs-incl

@@ -0,0 +1,38 @@
+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 IntAddCOp = True
+commutableOp IntEqOp = True
+commutableOp IntNeOp = True
+commutableOp Int8AddOp = True
+commutableOp Int8MulOp = True
+commutableOp Word8AddOp = True
+commutableOp Word8MulOp = True
+commutableOp Int16AddOp = True
+commutableOp Int16MulOp = True
+commutableOp Word16AddOp = True
+commutableOp Word16MulOp = True
+commutableOp WordAddOp = True
+commutableOp WordAddCOp = 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

ghc-toolkit/boot-libs/ghc/autogen/primop-data-decl.hs-incl

@@ -0,0 +1,574 @@
+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
+   | Int8Extend
+   | Int8Narrow
+   | Int8NegOp
+   | Int8AddOp
+   | Int8SubOp
+   | Int8MulOp
+   | Int8QuotOp
+   | Int8RemOp
+   | Int8QuotRemOp
+   | Int8EqOp
+   | Int8GeOp
+   | Int8GtOp
+   | Int8LeOp
+   | Int8LtOp
+   | Int8NeOp
+   | Word8Extend
+   | Word8Narrow
+   | Word8NotOp
+   | Word8AddOp
+   | Word8SubOp
+   | Word8MulOp
+   | Word8QuotOp
+   | Word8RemOp
+   | Word8QuotRemOp
+   | Word8EqOp
+   | Word8GeOp
+   | Word8GtOp
+   | Word8LeOp
+   | Word8LtOp
+   | Word8NeOp
+   | Int16Extend
+   | Int16Narrow
+   | Int16NegOp
+   | Int16AddOp
+   | Int16SubOp
+   | Int16MulOp
+   | Int16QuotOp
+   | Int16RemOp
+   | Int16QuotRemOp
+   | Int16EqOp
+   | Int16GeOp
+   | Int16GtOp
+   | Int16LeOp
+   | Int16LtOp
+   | Int16NeOp
+   | Word16Extend
+   | Word16Narrow
+   | Word16NotOp
+   | Word16AddOp
+   | Word16SubOp
+   | Word16MulOp
+   | Word16QuotOp
+   | Word16RemOp
+   | Word16QuotRemOp
+   | Word16EqOp
+   | Word16GeOp
+   | Word16GtOp
+   | Word16LeOp
+   | Word16LtOp
+   | Word16NeOp
+   | WordAddOp
+   | WordAddCOp
+   | 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
+   | Pdep8Op
+   | Pdep16Op
+   | Pdep32Op
+   | Pdep64Op
+   | PdepOp
+   | Pext8Op
+   | Pext16Op
+   | Pext32Op
+   | Pext64Op
+   | PextOp
+   | 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
+   | DoubleAsinhOp
+   | DoubleAcoshOp
+   | DoubleAtanhOp
+   | 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
+   | FloatAsinhOp
+   | FloatAcoshOp
+   | FloatAtanhOp
+   | 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
+   | IndexByteArrayOp_Word8AsChar
+   | IndexByteArrayOp_Word8AsWideChar
+   | IndexByteArrayOp_Word8AsAddr
+   | IndexByteArrayOp_Word8AsFloat
+   | IndexByteArrayOp_Word8AsDouble
+   | IndexByteArrayOp_Word8AsStablePtr
+   | IndexByteArrayOp_Word8AsInt16
+   | IndexByteArrayOp_Word8AsInt32
+   | IndexByteArrayOp_Word8AsInt64
+   | IndexByteArrayOp_Word8AsInt
+   | IndexByteArrayOp_Word8AsWord16
+   | IndexByteArrayOp_Word8AsWord32
+   | IndexByteArrayOp_Word8AsWord64
+   | IndexByteArrayOp_Word8AsWord
+   | 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
+   | ReadByteArrayOp_Word8AsChar
+   | ReadByteArrayOp_Word8AsWideChar
+   | ReadByteArrayOp_Word8AsAddr
+   | ReadByteArrayOp_Word8AsFloat
+   | ReadByteArrayOp_Word8AsDouble
+   | ReadByteArrayOp_Word8AsStablePtr
+   | ReadByteArrayOp_Word8AsInt16
+   | ReadByteArrayOp_Word8AsInt32
+   | ReadByteArrayOp_Word8AsInt64
+   | ReadByteArrayOp_Word8AsInt
+   | ReadByteArrayOp_Word8AsWord16
+   | ReadByteArrayOp_Word8AsWord32
+   | ReadByteArrayOp_Word8AsWord64
+   | ReadByteArrayOp_Word8AsWord
+   | 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
+   | WriteByteArrayOp_Word8AsChar
+   | WriteByteArrayOp_Word8AsWideChar
+   | WriteByteArrayOp_Word8AsAddr
+   | WriteByteArrayOp_Word8AsFloat
+   | WriteByteArrayOp_Word8AsDouble
+   | WriteByteArrayOp_Word8AsStablePtr
+   | WriteByteArrayOp_Word8AsInt16
+   | WriteByteArrayOp_Word8AsInt32
+   | WriteByteArrayOp_Word8AsInt64
+   | WriteByteArrayOp_Word8AsInt
+   | WriteByteArrayOp_Word8AsWord16
+   | WriteByteArrayOp_Word8AsWord32
+   | WriteByteArrayOp_Word8AsWord64
+   | WriteByteArrayOp_Word8AsWord
+   | CompareByteArraysOp
+   | 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
+   | AtomicModifyMutVar2Op
+   | AtomicModifyMutVar_Op
+   | CasMutVarOp
+   | CatchOp
+   | RaiseOp
+   | RaiseIOOp
+   | MaskAsyncExceptionsOp
+   | MaskUninterruptibleOp
+   | UnmaskAsyncExceptionsOp
+   | MaskStatus
+   | AtomicallyOp
+   | RetryOp
+   | CatchRetryOp
+   | CatchSTMOp
+   | 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
+   | TraceEventBinaryOp
+   | TraceMarkerOp
+   | GetThreadAllocationCounter
+   | SetThreadAllocationCounter
+   | 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

ghc-toolkit/boot-libs/ghc/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

ghc-toolkit/boot-libs/ghc/autogen/primop-has-side-effects.hs-incl

@@ -0,0 +1,242 @@
+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 ReadByteArrayOp_Word8AsChar = True
+primOpHasSideEffects ReadByteArrayOp_Word8AsWideChar = True
+primOpHasSideEffects ReadByteArrayOp_Word8AsAddr = True
+primOpHasSideEffects ReadByteArrayOp_Word8AsFloat = True
+primOpHasSideEffects ReadByteArrayOp_Word8AsDouble = True
+primOpHasSideEffects ReadByteArrayOp_Word8AsStablePtr = True
+primOpHasSideEffects ReadByteArrayOp_Word8AsInt16 = True
+primOpHasSideEffects ReadByteArrayOp_Word8AsInt32 = True
+primOpHasSideEffects ReadByteArrayOp_Word8AsInt64 = True
+primOpHasSideEffects ReadByteArrayOp_Word8AsInt = True
+primOpHasSideEffects ReadByteArrayOp_Word8AsWord16 = True
+primOpHasSideEffects ReadByteArrayOp_Word8AsWord32 = True
+primOpHasSideEffects ReadByteArrayOp_Word8AsWord64 = True
+primOpHasSideEffects ReadByteArrayOp_Word8AsWord = 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 WriteByteArrayOp_Word8AsChar = True
+primOpHasSideEffects WriteByteArrayOp_Word8AsWideChar = True
+primOpHasSideEffects WriteByteArrayOp_Word8AsAddr = True
+primOpHasSideEffects WriteByteArrayOp_Word8AsFloat = True
+primOpHasSideEffects WriteByteArrayOp_Word8AsDouble = True
+primOpHasSideEffects WriteByteArrayOp_Word8AsStablePtr = True
+primOpHasSideEffects WriteByteArrayOp_Word8AsInt16 = True
+primOpHasSideEffects WriteByteArrayOp_Word8AsInt32 = True
+primOpHasSideEffects WriteByteArrayOp_Word8AsInt64 = True
+primOpHasSideEffects WriteByteArrayOp_Word8AsInt = True
+primOpHasSideEffects WriteByteArrayOp_Word8AsWord16 = True
+primOpHasSideEffects WriteByteArrayOp_Word8AsWord32 = True
+primOpHasSideEffects WriteByteArrayOp_Word8AsWord64 = True
+primOpHasSideEffects WriteByteArrayOp_Word8AsWord = 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 AtomicModifyMutVar2Op = True
+primOpHasSideEffects AtomicModifyMutVar_Op = 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 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 TraceEventBinaryOp = True
+primOpHasSideEffects TraceMarkerOp = True
+primOpHasSideEffects GetThreadAllocationCounter = True
+primOpHasSideEffects SetThreadAllocationCounter = 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

ghc-toolkit/boot-libs/ghc/autogen/primop-out-of-line.hs-incl

@@ -0,0 +1,101 @@
+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 AtomicModifyMutVar2Op = True
+primOpOutOfLine AtomicModifyMutVar_Op = 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 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 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 TraceEventBinaryOp = True
+primOpOutOfLine TraceMarkerOp = True
+primOpOutOfLine GetThreadAllocationCounter = True
+primOpOutOfLine SetThreadAllocationCounter = True
+primOpOutOfLine _ = False

ghc-toolkit/boot-libs/ghc/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] exnRes 
+primOpStrictness CatchRetryOp =  \ _arity -> mkClosedStrictSig [ lazyApply1Dmd
+                                                 , 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 

ghc-toolkit/boot-libs/ghc/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

ghc-toolkit/boot-libs/ghc/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,

ghc-toolkit/boot-libs/ghc/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)

ghc-toolkit/boot-libs/ghc/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

ghc-toolkit/boot-libs/ghc/backpack/BkpSyn.hs

@@ -0,0 +1,84 @@
+-- | 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 GhcPrelude
+
+import HsSyn
+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 GhcPs)))
+    | IncludeD   (IncludeDecl n)
+type LHsUnitDecl n = Located (HsUnitDecl n)
+
+-- | An include of another unit
+data IncludeDecl n = IncludeDecl {
+        idUnitId :: LHsUnitId n,
+        idModRenaming :: Maybe [ LRenaming ],
+        -- | Is this a @dependency signature@ include?  If so,
+        -- we don't compile this include when we instantiate this
+        -- unit (as there should not be any modules brought into
+        -- scope.)
+        idSignatureInclude :: Bool
+    }
+
+-- | Rename a module from one name to another.  The identity renaming
+-- means that the module should be brought into scope.
+data Renaming = Renaming { renameFrom :: Located ModuleName
+                         , renameTo :: Maybe (Located ModuleName) }
+type LRenaming = Located Renaming

ghc-toolkit/boot-libs/ghc/backpack/DriverBkp.hs

@@ -0,0 +1,831 @@
+{-# 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"
+
+import GhcPrelude
+
+-- 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`.
+      -- See Note [-fno-code mode]
+      (case session_type of
+        -- Make sure to write interfaces when we are type-checking
+        -- indefinite packages.
+        TcSession | hscTarget dflags /= HscNothing
+                  -> flip gopt_set Opt_WriteInterface
+                  | otherwise -> id
+        CompSession -> id
+        ExeSession -> id) $
+      dflags {
+        hscTarget   = case session_type of
+                        TcSession -> HscNothing
+                        _ -> hscTarget dflags,
+        thisUnitIdInsts_ = Just insts,
+        thisComponentId_ = Just cid,
+        thisInstalledUnitId =
+            case session_type of
+                TcSession -> newInstalledUnitId cid Nothing
+                -- No hash passed if no instances
+                _ | null insts -> newInstalledUnitId cid Nothing
+                  | otherwise  -> newInstalledUnitId cid (Just (hashUnitId cid insts)),
+        -- Setup all of the output directories according to our hierarchy
+        objectDir   = Just (outdir objectDir),
+        hiDir       = Just (outdir hiDir),
+        stubDir     = Just (outdir stubDir),
+        -- Unset output-file for non exe builds
+        outputFile  = if session_type == ExeSession
+                        then outputFile dflags
+                        else Nothing,
+        -- Clear the import path so we don't accidentally grab anything
+        importPaths = [],
+        -- Synthesized the flags
+        packageFlags = packageFlags dflags ++ map (\(uid0, rn) ->
+          let uid = unwireUnitId dflags (improveUnitId (getPackageConfigMap dflags) $ renameHoleUnitId dflags (listToUFM insts) uid0)
+          in ExposePackage
+            (showSDoc dflags
+                (text "-unit-id" <+> ppr uid <+> ppr rn))
+            (UnitIdArg uid) rn) deps
+      } )) $ do
+        dflags <- getSessionDynFlags
+        -- pprTrace "flags" (ppr insts <> ppr deps) $ return ()
+        -- Calls initPackages
+        _ <- setSessionDynFlags dflags
+        do_this
+
+withBkpExeSession :: [(UnitId, ModRenaming)] -> BkpM a -> BkpM a
+withBkpExeSession deps do_this = do
+    withBkpSession (ComponentId (fsLit "main")) [] deps ExeSession do_this
+
+getSource :: ComponentId -> BkpM (LHsUnit HsComponentId)
+getSource cid = do
+    bkp_env <- getBkpEnv
+    case Map.lookup cid (bkp_table bkp_env) of
+        Nothing -> pprPanic "missing needed dependency" (ppr cid)
+        Just lunit -> return lunit
+
+typecheckUnit :: ComponentId -> [(ModuleName, Module)] -> BkpM ()
+typecheckUnit cid insts = do
+    lunit <- getSource cid
+    buildUnit TcSession cid insts lunit
+
+compileUnit :: ComponentId -> [(ModuleName, Module)] -> BkpM ()
+compileUnit cid insts = do
+    -- Let everyone know we're building this unit ID
+    msgUnitId (newUnitId cid insts)
+    lunit <- getSource cid
+    buildUnit CompSession cid insts lunit
+
+-- | Compute the dependencies with instantiations of a syntactic
+-- HsUnit; e.g., wherever you see @dependency p[A=<A>]@ in a
+-- unit file, return the 'UnitId' corresponding to @p[A=<A>]@.
+-- The @include_sigs@ parameter controls whether or not we also
+-- include @dependency signature@ declarations in this calculation.
+--
+-- Invariant: this NEVER returns InstalledUnitId.
+hsunitDeps :: Bool {- include sigs -} -> HsUnit HsComponentId -> [(UnitId, ModRenaming)]
+hsunitDeps include_sigs unit = concatMap get_dep (hsunitBody unit)
+  where
+    get_dep (L _ (IncludeD (IncludeDecl (L _ hsuid) mb_lrn is_sig)))
+        | include_sigs || not is_sig = [(convertHsUnitId hsuid, go mb_lrn)]
+        | otherwise = []
+      where
+        go Nothing = ModRenaming True []
+        go (Just lrns) = ModRenaming False (map convRn lrns)
+          where
+            convRn (L _ (Renaming (L _ from) Nothing))         = (from, from)
+            convRn (L _ (Renaming (L _ from) (Just (L _ to)))) = (from, to)
+    get_dep _ = []
+
+buildUnit :: SessionType -> ComponentId -> [(ModuleName, Module)] -> LHsUnit HsComponentId -> BkpM ()
+buildUnit session cid insts lunit = do
+    -- NB: include signature dependencies ONLY when typechecking.
+    -- If we're compiling, it's not necessary to recursively
+    -- compile a signature since it isn't going to produce
+    -- any object files.
+    let deps_w_rns = hsunitDeps (session == TcSession) (unLoc lunit)
+        raw_deps = map fst deps_w_rns
+    dflags <- getDynFlags
+    -- The compilation dependencies are just the appropriately filled
+    -- in unit IDs which must be compiled before we can compile.
+    let hsubst = listToUFM insts
+        deps0 = map (renameHoleUnitId dflags hsubst) raw_deps
+
+    -- Build dependencies OR make sure they make sense. BUT NOTE,
+    -- we can only check the ones that are fully filled; the rest
+    -- we have to defer until we've typechecked our local signature.
+    -- TODO: work this into GhcMake!!
+    forM_ (zip [1..] deps0) $ \(i, dep) ->
+        case session of
+            TcSession -> return ()
+            _ -> compileInclude (length deps0) (i, dep)
+
+    dflags <- getDynFlags
+    -- IMPROVE IT
+    let deps = map (improveUnitId (getPackageConfigMap dflags)) deps0
+
+    mb_old_eps <- case session of
+                    TcSession -> fmap Just getEpsGhc
+                    _ -> return Nothing
+
+    conf <- withBkpSession cid insts deps_w_rns session $ do
+
+        dflags <- getDynFlags
+        mod_graph <- hsunitModuleGraph dflags (unLoc lunit)
+        -- pprTrace "mod_graph" (ppr mod_graph) $ return ()
+
+        msg <- mkBackpackMsg
+        ok <- load' LoadAllTargets (Just msg) mod_graph
+        when (failed ok) (liftIO $ exitWith (ExitFailure 1))
+
+        let hi_dir = expectJust (panic "hiDir Backpack") $ hiDir dflags
+            export_mod ms = (ms_mod_name ms, ms_mod ms)
+            -- Export everything!
+            mods = [ export_mod ms | ms <- mgModSummaries mod_graph
+                                   , ms_hsc_src ms == HsSrcFile ]
+
+        -- Compile relevant only
+        hsc_env <- getSession
+        let home_mod_infos = eltsUDFM (hsc_HPT hsc_env)
+            linkables = map (expectJust "bkp link" . hm_linkable)
+                      . filter ((==HsSrcFile) . mi_hsc_src . hm_iface)
+                      $ home_mod_infos
+            getOfiles (LM _ _ 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 $ mkModuleGraph $ 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)
+    hie_timestamp <- liftIO $ modificationTimeIfExists (ml_hie_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_hie_date = hie_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 GhcPs))
+              -> 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) -> throwErrors 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 GhcPs)
+                     -> 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 -> addBootSuffixLocnOut 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)
+    hie_timestamp <- liftIO $ modificationTimeIfExists (ml_hie_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,
+            ms_hie_date = hie_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

ghc-toolkit/boot-libs/ghc/backpack/NameShape.hs

@@ -0,0 +1,268 @@
+{-# LANGUAGE CPP #-}
+
+module NameShape(
+    NameShape(..),
+    emptyNameShape,
+    mkNameShape,
+    extendNameShape,
+    nameShapeExports,
+    substNameShape,
+    maybeSubstNameShape,
+    ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import Outputable
+import HscTypes
+import Module
+import UniqFM
+import Avail
+import FieldLabel
+
+import Name
+import NameEnv
+import TcRnMonad
+import Util
+import IfaceEnv
+
+import Control.Monad
+
+-- Note [NameShape]
+-- ~~~~~~~~~~~~~~~~
+-- When we write a declaration in a signature, e.g., data T, we
+-- ascribe to it a *name variable*, e.g., {m.T}.  This
+-- name variable may be substituted with an actual original
+-- name when the signature is implemented (or even if we
+-- merge the signature with one which reexports this entity
+-- from another module).
+
+-- When we instantiate a signature m with a module M,
+-- we also need to substitute over names.  To do so, we must
+-- compute the *name substitution* induced by the *exports*
+-- of the module in question.  A NameShape represents
+-- such a name substitution for a single module instantiation.
+-- The "shape" in the name comes from the fact that the computation
+-- of a name substitution is essentially the *shaping pass* from
+-- Backpack'14, but in a far more restricted form.
+
+-- The name substitution for an export list is easy to explain.  If we are
+-- filling the module variable <m>, given an export N of the form
+-- M.n or {m'.n} (where n is an OccName), the induced name
+-- substitution is from {m.n} to N.  So, for example, if we have
+-- A=impl:B, and the exports of impl:B are impl:B.f and
+-- impl:C.g, then our name substitution is {A.f} to impl:B.f
+-- and {A.g} to impl:C.g
+
+
+
+
+-- The 'NameShape' type is defined in TcRnTypes, because TcRnTypes
+-- needs to refer to NameShape, and having TcRnTypes import
+-- NameShape (even by SOURCE) would cause a large number of
+-- modules to be pulled into the DynFlags cycle.
+{-
+data NameShape = NameShape {
+        ns_mod_name :: ModuleName,
+        ns_exports :: [AvailInfo],
+        ns_map :: OccEnv Name
+    }
+-}
+
+-- NB: substitution functions need 'HscEnv' since they need the name cache
+-- to allocate new names if we change the 'Module' of a 'Name'
+
+-- | Create an empty 'NameShape' (i.e., the renaming that
+-- would occur with an implementing module with no exports)
+-- for a specific hole @mod_name@.
+emptyNameShape :: ModuleName -> NameShape
+emptyNameShape mod_name = NameShape mod_name [] emptyOccEnv
+
+-- | Create a 'NameShape' corresponding to an implementing
+-- module for the hole @mod_name@ that exports a list of 'AvailInfo's.
+mkNameShape :: ModuleName -> [AvailInfo] -> NameShape
+mkNameShape mod_name as =
+    NameShape mod_name as $ mkOccEnv $ do
+        a <- as
+        n <- availName a : availNamesWithSelectors a
+        return (occName n, n)
+
+-- | Given an existing 'NameShape', merge it with a list of 'AvailInfo's
+-- with Backpack style mix-in linking.  This is used solely when merging
+-- signatures together: we successively merge the exports of each
+-- signature until we have the final, full exports of the merged signature.
+--
+-- What makes this operation nontrivial is what we are supposed to do when
+-- we want to merge in an export for M.T when we already have an existing
+-- export {H.T}.  What should happen in this case is that {H.T} should be
+-- unified with @M.T@: we've determined a more *precise* identity for the
+-- export at 'OccName' @T@.
+--
+-- Note that we don't do unrestricted unification: only name holes from
+-- @ns_mod_name ns@ are flexible.  This is because we have a much more
+-- restricted notion of shaping than in Backpack'14: we do shaping
+-- *as* we do type-checking.  Thus, once we shape a signature, its
+-- exports are *final* and we're not allowed to refine them further,
+extendNameShape :: HscEnv -> NameShape -> [AvailInfo] -> IO (Either SDoc NameShape)
+extendNameShape hsc_env ns as =
+    case uAvailInfos (ns_mod_name ns) (ns_exports ns) as of
+        Left err -> return (Left err)
+        Right nsubst -> do
+            as1 <- mapM (liftIO . substNameAvailInfo hsc_env nsubst) (ns_exports ns)
+            as2 <- mapM (liftIO . substNameAvailInfo hsc_env nsubst) as
+            let new_avails = mergeAvails as1 as2
+            return . Right $ ns {
+                ns_exports = new_avails,
+                -- TODO: stop repeatedly rebuilding the OccEnv
+                ns_map = mkOccEnv $ do
+                            a <- new_avails
+                            n <- availName a : availNames a
+                            return (occName n, n)
+                }
+
+-- | The export list associated with this 'NameShape' (i.e., what
+-- the exports of an implementing module which induces this 'NameShape'
+-- would be.)
+nameShapeExports :: NameShape -> [AvailInfo]
+nameShapeExports = ns_exports
+
+-- | Given a 'Name', substitute it according to the 'NameShape' implied
+-- substitution, i.e. map @{A.T}@ to @M.T@, if the implementing module
+-- exports @M.T@.
+substNameShape :: NameShape -> Name -> Name
+substNameShape ns n | nameModule n == ns_module ns
+                    , Just n' <- lookupOccEnv (ns_map ns) (occName n)
+                    = n'
+                    | otherwise
+                    = n
+
+-- | Like 'substNameShape', but returns @Nothing@ if no substitution
+-- works.
+maybeSubstNameShape :: NameShape -> Name -> Maybe Name
+maybeSubstNameShape ns n
+    | nameModule n == ns_module ns
+    = lookupOccEnv (ns_map ns) (occName n)
+    | otherwise
+    = Nothing
+
+-- | The 'Module' of any 'Name's a 'NameShape' has action over.
+ns_module :: NameShape -> Module
+ns_module = mkHoleModule . ns_mod_name
+
+{-
+************************************************************************
+*                                                                      *
+                        Name substitutions
+*                                                                      *
+************************************************************************
+-}
+
+-- | Substitution on @{A.T}@.  We enforce the invariant that the
+-- 'nameModule' of keys of this map have 'moduleUnitId' @hole@
+-- (meaning that if we have a hole substitution, the keys of the map
+-- are never affected.)  Alternatively, this is isomorphic to
+-- @Map ('ModuleName', 'OccName') 'Name'@.
+type ShNameSubst = NameEnv Name
+
+-- NB: In this module, we actually only ever construct 'ShNameSubst'
+-- at a single 'ModuleName'.  But 'ShNameSubst' is more convenient to
+-- work with.
+
+-- | Substitute names in a 'Name'.
+substName :: ShNameSubst -> Name -> Name
+substName env n | Just n' <- lookupNameEnv env n = n'
+                | otherwise                      = n
+
+-- | Substitute names in an 'AvailInfo'.  This has special behavior
+-- for type constructors, where it is sufficient to substitute the 'availName'
+-- to induce a substitution on 'availNames'.
+substNameAvailInfo :: HscEnv -> ShNameSubst -> AvailInfo -> IO AvailInfo
+substNameAvailInfo _ env (Avail 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)

ghc-toolkit/boot-libs/ghc/backpack/RnModIface.hs

@@ -0,0 +1,745 @@
+{-# 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 GhcPrelude
+
+import SrcLoc
+import Outputable
+import HscTypes
+import Module
+import UniqFM
+import Avail
+import IfaceSyn
+import FieldLabel
+import Var
+import ErrUtils
+
+import Name
+import TcRnMonad
+import Util
+import Fingerprint
+import BasicTypes
+
+-- a bit vexing
+import {-# SOURCE #-} LoadIface
+import DynFlags
+
+import qualified Data.Traversable as T
+
+import Bag
+import Data.IORef
+import NameShape
+import IfaceEnv
+
+tcRnMsgMaybe :: IO (Either ErrorMessages a) -> TcM a
+tcRnMsgMaybe do_this = do
+    r <- liftIO $ do_this
+    case r of
+        Left errs -> do
+            addMessages (emptyBag, errs)
+            failM
+        Right x -> return x
+
+tcRnModIface :: [(ModuleName, Module)] -> Maybe NameShape -> ModIface -> TcM ModIface
+tcRnModIface x y z = do
+    hsc_env <- getTopEnv
+    tcRnMsgMaybe $ rnModIface hsc_env x y z
+
+tcRnModExports :: [(ModuleName, Module)] -> ModIface -> TcM [AvailInfo]
+tcRnModExports x y = do
+    hsc_env <- getTopEnv
+    tcRnMsgMaybe $ rnModExports hsc_env x y
+
+failWithRn :: SDoc -> ShIfM a
+failWithRn doc = do
+    errs_var <- fmap sh_if_errs getGblEnv
+    dflags <- getDynFlags
+    errs <- readTcRef errs_var
+    -- TODO: maybe associate this with a source location?
+    writeTcRef errs_var (errs `snocBag` mkPlainErrMsg dflags noSrcSpan doc)
+    failM
+
+-- | What we have is a generalized ModIface, which corresponds to
+-- a module that looks like p[A=<A>]:B.  We need a *specific* ModIface, e.g.
+-- p[A=q():A]:B (or maybe even p[A=<B>]:B) which we load
+-- up (either to merge it, or to just use during typechecking).
+--
+-- Suppose we have:
+--
+--  p[A=<A>]:M  ==>  p[A=q():A]:M
+--
+-- Substitute all occurrences of <A> with q():A (renameHoleModule).
+-- Then, for any Name of form {A.T}, replace the Name with
+-- the Name according to the exports of the implementing module.
+-- This works even for p[A=<B>]:M, since we just read in the
+-- exports of B.hi, which is assumed to be ready now.
+--
+-- This function takes an optional 'NameShape', which can be used
+-- to further refine the identities in this interface: suppose
+-- we read a declaration for {H.T} but we actually know that this
+-- should be Foo.T; then we'll also rename this (this is used
+-- when loading an interface to merge it into a requirement.)
+rnModIface :: HscEnv -> [(ModuleName, Module)] -> Maybe NameShape
+           -> ModIface -> IO (Either ErrorMessages ModIface)
+rnModIface hsc_env insts nsubst iface = do
+    initRnIface hsc_env iface insts nsubst $ do
+        mod <- rnModule (mi_module iface)
+        sig_of <- case mi_sig_of iface of
+                    Nothing -> return Nothing
+                    Just x  -> fmap Just (rnModule x)
+        exports <- mapM rnAvailInfo (mi_exports iface)
+        decls <- mapM rnIfaceDecl' (mi_decls iface)
+        insts <- mapM rnIfaceClsInst (mi_insts iface)
+        fams <- mapM rnIfaceFamInst (mi_fam_insts iface)
+        deps <- rnDependencies (mi_deps iface)
+        -- TODO:
+        -- mi_rules
+        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
+        -- For holes, its necessary to "see through" the instantiation
+        -- of the hole to get accurate family instance dependencies.
+        -- For example, if B imports <A>, and <A> is instantiated with
+        -- F, we must grab and include all of the dep_finsts from
+        -- F to have an accurate transitive dep_finsts list.
+        --
+        -- However, we MUST NOT do this for regular modules.
+        -- First, for efficiency reasons, doing this
+        -- bloats the the dep_finsts list, because we *already* had
+        -- those modules in the list (it wasn't a hole module, after
+        -- all). But there's a second, more important correctness
+        -- consideration: we perform module renaming when running
+        -- --abi-hash.  In this case, GHC's contract to the user is that
+        -- it will NOT go and read out interfaces of any dependencies
+        -- (https://github.com/haskell/cabal/issues/3633); the point of
+        -- --abi-hash is just to get a hash of the on-disk interfaces
+        -- for this *specific* package.  If we go off and tug on the
+        -- interface for /everything/ in dep_finsts, we're gonna have a
+        -- bad time.  (It's safe to do do this for hole modules, though,
+        -- because the hmap for --abi-hash is always trivial, so the
+        -- interface we request is local.  Though, maybe we ought
+        -- not to do it in this case either...)
+        --
+        -- This mistake was bug #15594.
+        let mod' = renameHoleModule dflags hmap mod
+        if isHoleModule mod
+          then do iface <- liftIO . initIfaceCheck (text "rnDepModule") hsc_env
+                                  $ loadSysInterface (text "rnDepModule") mod'
+                  return (mod' : sel (mi_deps iface))
+          else return [mod']
+
+{-
+************************************************************************
+*                                                                      *
+                        ModIface substitution
+*                                                                      *
+************************************************************************
+-}
+
+-- | Run a computation in the 'ShIfM' monad.
+initRnIface :: HscEnv -> ModIface -> [(ModuleName, Module)] -> Maybe NameShape
+            -> ShIfM a -> IO (Either ErrorMessages a)
+initRnIface hsc_env iface insts nsubst do_this = do
+    errs_var <- newIORef emptyBag
+    let dflags = hsc_dflags hsc_env
+        hsubst = listToUFM insts
+        rn_mod = renameHoleModule dflags hsubst
+        env = ShIfEnv {
+            sh_if_module = rn_mod (mi_module iface),
+            sh_if_semantic_module = rn_mod (mi_semantic_module iface),
+            sh_if_hole_subst = listToUFM insts,
+            sh_if_shape = nsubst,
+            sh_if_errs = errs_var
+        }
+    -- Modeled off of 'initTc'
+    res <- initTcRnIf 'c' hsc_env env () $ tryM do_this
+    msgs <- readIORef errs_var
+    case res of
+        Left _                          -> return (Left msgs)
+        Right r | not (isEmptyBag msgs) -> return (Left msgs)
+                | otherwise             -> return (Right r)
+
+-- | Environment for 'ShIfM' monads.
+data ShIfEnv = ShIfEnv {
+        -- What we are renaming the ModIface to.  It assumed that
+        -- the original mi_module of the ModIface is
+        -- @generalizeModule (mi_module iface)@.
+        sh_if_module :: Module,
+        -- The semantic module that we are renaming to
+        sh_if_semantic_module :: Module,
+        -- Cached hole substitution, e.g.
+        -- @sh_if_hole_subst == listToUFM . unitIdInsts . moduleUnitId . sh_if_module@
+        sh_if_hole_subst :: ShHoleSubst,
+        -- An optional name substitution to be applied when renaming
+        -- the names in the interface.  If this is 'Nothing', then
+        -- we just load the target interface and look at the export
+        -- list to determine the renaming.
+        sh_if_shape :: Maybe NameShape,
+        -- Mutable reference to keep track of errors (similar to 'tcl_errs')
+        sh_if_errs :: IORef ErrorMessages
+    }
+
+getHoleSubst :: ShIfM ShHoleSubst
+getHoleSubst = fmap sh_if_hole_subst getGblEnv
+
+type ShIfM = TcRnIf ShIfEnv ()
+type Rename a = a -> ShIfM a
+
+
+rnModule :: Rename Module
+rnModule mod = do
+    hmap <- getHoleSubst
+    dflags <- getDynFlags
+    return (renameHoleModule dflags hmap mod)
+
+rnAvailInfo :: Rename AvailInfo
+rnAvailInfo (Avail n) = Avail <$> rnIfaceGlobal n
+rnAvailInfo (AvailTC n ns fs) = do
+    -- Why don't we rnIfaceGlobal the availName itself?  It may not
+    -- actually be exported by the module it putatively is from, in
+    -- which case we won't be able to tell what the name actually
+    -- is.  But for the availNames they MUST be exported, so they
+    -- will rename fine.
+    ns' <- mapM rnIfaceGlobal ns
+    fs' <- mapM rnFieldLabel fs
+    case ns' ++ map flSelector fs' of
+        [] -> panic "rnAvailInfoEmpty AvailInfo"
+        (rep:rest) -> ASSERT2( all ((== nameModule rep) . nameModule) rest, ppr rep $$ hcat (map ppr rest) ) do
+                         n' <- setNameModule (Just (nameModule rep)) n
+                         return (AvailTC n' ns' fs')
+
+rnFieldLabel :: Rename FieldLabel
+rnFieldLabel (FieldLabel l b sel) = do
+    sel' <- rnIfaceGlobal sel
+    return (FieldLabel l b sel')
+
+
+
+
+-- | The key function.  This gets called on every Name embedded
+-- inside a ModIface.  Our job is to take a Name from some
+-- generalized unit ID p[A=<A>, B=<B>], and change
+-- it to the correct name for a (partially) instantiated unit
+-- ID, e.g. p[A=q[]:A, B=<B>].
+--
+-- There are two important things to do:
+--
+-- If a hole is substituted with a real module implementation,
+-- we need to look at that actual implementation to determine what
+-- the true identity of this name should be.  We'll do this by
+-- loading that module's interface and looking at the mi_exports.
+--
+-- However, there is one special exception: when we are loading
+-- the interface of a requirement.  In this case, we may not have
+-- the "implementing" interface, because we are reading this
+-- interface precisely to "merge it in".
+--
+--     External case:
+--         p[A=<B>]:A (and thisUnitId is something else)
+--     We are loading this in order to determine B.hi!  So
+--     don't load B.hi to find the exports.
+--
+--     Local case:
+--         p[A=<A>]:A (and thisUnitId is p[A=<A>])
+--     This should not happen, because the rename is not necessary
+--     in this case, but if it does we shouldn't load A.hi!
+--
+-- Compare me with 'tcIfaceGlobal'!
+
+-- In effect, this function needs compute the name substitution on the
+-- fly.  What it has is the name that we would like to substitute.
+-- If the name is not a hole name {M.x} (e.g. isHoleModule) then
+-- no renaming can take place (although the inner hole structure must
+-- be updated to account for the hole module renaming.)
+rnIfaceGlobal :: Name -> ShIfM Name
+rnIfaceGlobal n = do
+    hsc_env <- getTopEnv
+    let dflags = hsc_dflags hsc_env
+    iface_semantic_mod <- fmap sh_if_semantic_module getGblEnv
+    mb_nsubst <- fmap sh_if_shape getGblEnv
+    hmap <- getHoleSubst
+    let m = nameModule n
+        m' = renameHoleModule dflags hmap m
+    case () of
+       -- Did we encounter {A.T} while renaming p[A=<B>]:A? If so,
+       -- do NOT assume B.hi is available.
+       -- In this case, rename {A.T} to {B.T} but don't look up exports.
+     _ | m' == iface_semantic_mod
+       , isHoleModule m'
+      -- NB: this could be Nothing for computeExports, we have
+      -- nothing to say.
+      -> do n' <- setNameModule (Just m') n
+            case mb_nsubst of
+                Nothing -> return n'
+                Just nsubst ->
+                    case maybeSubstNameShape nsubst n' of
+                        -- TODO: would love to have context
+                        -- TODO: This will give an unpleasant message if n'
+                        -- is a constructor; then we'll suggest adding T
+                        -- but it won't work.
+                        Nothing -> failWithRn $ vcat [
+                            text "The identifier" <+> ppr (occName n') <+>
+                                text "does not exist in the local signature.",
+                            parens (text "Try adding it to the export list of the hsig file.")
+                            ]
+                        Just n'' -> return n''
+       -- Fastpath: we are renaming p[H=<H>]:A.T, in which case the
+       -- export list is irrelevant.
+       | not (isHoleModule m)
+      -> setNameModule (Just m') n
+       -- The substitution was from <A> to p[]:A.
+       -- But this does not mean {A.T} goes to p[]:A.T:
+       -- p[]:A may reexport T from somewhere else.  Do the name
+       -- substitution.  Furthermore, we need
+       -- to make sure we pick the accurate name NOW,
+       -- or we might accidentally reject a merge.
+       | otherwise
+      -> do -- Make sure we look up the local interface if substitution
+            -- went from <A> to <B>.
+            let m'' = if isHoleModule m'
+                        -- Pull out the local guy!!
+                        then mkModule (thisPackage dflags) (moduleName m')
+                        else m'
+            iface <- liftIO . initIfaceCheck (text "rnIfaceGlobal") hsc_env
+                            $ loadSysInterface (text "rnIfaceGlobal") m''
+            let nsubst = mkNameShape (moduleName m) (mi_exports iface)
+            case maybeSubstNameShape nsubst n of
+                Nothing -> failWithRn $ vcat [
+                    text "The identifier" <+> ppr (occName n) <+>
+                        -- NB: report m' because it's more user-friendly
+                        text "does not exist in the signature for" <+> ppr m',
+                    parens (text "Try adding it to the export list in that hsig file.")
+                    ]
+                Just n' -> return n'
+
+-- | Rename an implicit name, e.g., a DFun or coercion axiom.
+-- Here is where we ensure that DFuns have the correct module as described in
+-- Note [rnIfaceNeverExported].
+rnIfaceNeverExported :: Name -> ShIfM Name
+rnIfaceNeverExported name = do
+    hmap <- getHoleSubst
+    dflags <- getDynFlags
+    iface_semantic_mod <- fmap sh_if_semantic_module getGblEnv
+    let m = renameHoleModule dflags hmap $ nameModule name
+    -- Doublecheck that this DFun/coercion axiom was, indeed, locally defined.
+    MASSERT2( iface_semantic_mod == m, ppr iface_semantic_mod <+> ppr m )
+    setNameModule (Just m) name
+
+-- Note [rnIfaceNeverExported]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- For the high-level overview, see
+-- Note [Handling never-exported TyThings under Backpack]
+--
+-- When we see a reference to an entity that was defined in a signature,
+-- 'rnIfaceGlobal' relies on the identifier in question being part of the
+-- exports of the implementing 'ModIface', so that we can use the exports to
+-- decide how to rename the identifier.  Unfortunately, references to 'DFun's
+-- and 'CoAxiom's will run into trouble under this strategy, because they are
+-- never exported.
+--
+-- Let us consider first what should happen in the absence of promotion.  In
+-- this setting, a reference to a 'DFun' or a 'CoAxiom' can only occur inside
+-- the signature *that is defining it* (as there are no Core terms in
+-- typechecked-only interface files, there's no way for a reference to occur
+-- besides from the defining 'ClsInst' or closed type family).  Thus,
+-- it doesn't really matter what names we give the DFun/CoAxiom, as long
+-- as it's consistent between the declaration site and the use site.
+--
+-- We have to make sure that these bogus names don't get propagated,
+-- but it is fine: see Note [Signature merging DFuns] for the fixups
+-- to the names we do before writing out the merged interface.
+-- (It's even easier for instantiation, since the DFuns all get
+-- dropped entirely; the instances are reexported implicitly.)
+--
+-- Unfortunately, this strategy is not enough in the presence of promotion
+-- (see bug #13149), where modules which import the signature may make
+-- reference to their coercions.  It's not altogether clear how to
+-- fix this case, but it is definitely a bug!
+
+-- PILES AND PILES OF BOILERPLATE
+
+-- | Rename an 'IfaceClsInst', with special handling for an associated
+-- dictionary function.
+rnIfaceClsInst :: Rename IfaceClsInst
+rnIfaceClsInst cls_inst = do
+    n <- rnIfaceGlobal (ifInstCls cls_inst)
+    tys <- mapM rnMaybeIfaceTyCon (ifInstTys cls_inst)
+
+    dfun <- rnIfaceNeverExported (ifDFun cls_inst)
+    return cls_inst { ifInstCls = n
+                    , ifInstTys = tys
+                    , ifDFun = dfun
+                    }
+
+rnMaybeIfaceTyCon :: Rename (Maybe IfaceTyCon)
+rnMaybeIfaceTyCon Nothing = return Nothing
+rnMaybeIfaceTyCon (Just tc) = Just <$> rnIfaceTyCon tc
+
+rnIfaceFamInst :: Rename IfaceFamInst
+rnIfaceFamInst d = do
+    fam <- rnIfaceGlobal (ifFamInstFam d)
+    tys <- mapM rnMaybeIfaceTyCon (ifFamInstTys d)
+    axiom <- rnIfaceGlobal (ifFamInstAxiom d)
+    return d { ifFamInstFam = fam, ifFamInstTys = tys, ifFamInstAxiom = axiom }
+
+rnIfaceDecl' :: Rename (Fingerprint, IfaceDecl)
+rnIfaceDecl' (fp, decl) = (,) fp <$> rnIfaceDecl decl
+
+rnIfaceDecl :: Rename IfaceDecl
+rnIfaceDecl d@IfaceId{} = do
+            name <- case ifIdDetails d of
+                      IfDFunId -> rnIfaceNeverExported (ifName d)
+                      _ | isDefaultMethodOcc (occName (ifName d))
+                        -> rnIfaceNeverExported (ifName d)
+                      -- Typeable bindings. See Note [Grand plan for Typeable].
+                      _ | isTypeableBindOcc (occName (ifName d))
+                        -> rnIfaceNeverExported (ifName d)
+                        | otherwise -> rnIfaceGlobal (ifName d)
+            ty <- rnIfaceType (ifType d)
+            details <- rnIfaceIdDetails (ifIdDetails d)
+            info <- rnIfaceIdInfo (ifIdInfo d)
+            return d { ifName = name
+                     , ifType = ty
+                     , ifIdDetails = details
+                     , ifIdInfo = info
+                     }
+rnIfaceDecl d@IfaceData{} = do
+            name <- rnIfaceGlobal (ifName d)
+            binders <- mapM rnIfaceTyConBinder (ifBinders d)
+            ctxt <- mapM rnIfaceType (ifCtxt d)
+            cons <- rnIfaceConDecls (ifCons d)
+            res_kind <- rnIfaceType (ifResKind d)
+            parent <- rnIfaceTyConParent (ifParent d)
+            return d { ifName = name
+                     , ifBinders = binders
+                     , ifCtxt = ctxt
+                     , ifCons = cons
+                     , ifResKind = res_kind
+                     , ifParent = parent
+                     }
+rnIfaceDecl d@IfaceSynonym{} = do
+            name <- rnIfaceGlobal (ifName d)
+            binders <- mapM rnIfaceTyConBinder (ifBinders d)
+            syn_kind <- rnIfaceType (ifResKind d)
+            syn_rhs <- rnIfaceType (ifSynRhs d)
+            return d { ifName = name
+                     , ifBinders = binders
+                     , ifResKind = syn_kind
+                     , ifSynRhs = syn_rhs
+                     }
+rnIfaceDecl d@IfaceFamily{} = do
+            name <- rnIfaceGlobal (ifName d)
+            binders <- mapM rnIfaceTyConBinder (ifBinders d)
+            fam_kind <- rnIfaceType (ifResKind d)
+            fam_flav <- rnIfaceFamTyConFlav (ifFamFlav d)
+            return d { ifName = name
+                     , ifBinders = binders
+                     , ifResKind = fam_kind
+                     , ifFamFlav = fam_flav
+                     }
+rnIfaceDecl d@IfaceClass{} = do
+            name <- rnIfaceGlobal (ifName d)
+            binders <- mapM rnIfaceTyConBinder (ifBinders d)
+            body <- rnIfaceClassBody (ifBody d)
+            return d { ifName    = name
+                     , ifBinders = binders
+                     , ifBody    = body
+                     }
+rnIfaceDecl d@IfaceAxiom{} = do
+            name <- rnIfaceNeverExported (ifName d)
+            tycon <- rnIfaceTyCon (ifTyCon d)
+            ax_branches <- mapM rnIfaceAxBranch (ifAxBranches d)
+            return d { ifName = name
+                     , ifTyCon = tycon
+                     , ifAxBranches = ax_branches
+                     }
+rnIfaceDecl d@IfacePatSyn{} =  do
+            name <- rnIfaceGlobal (ifName d)
+            let rnPat (n, b) = (,) <$> rnIfaceGlobal n <*> pure b
+            pat_matcher <- rnPat (ifPatMatcher d)
+            pat_builder <- T.traverse rnPat (ifPatBuilder d)
+            pat_univ_bndrs <- mapM rnIfaceForAllBndr (ifPatUnivBndrs d)
+            pat_ex_bndrs <- mapM rnIfaceForAllBndr (ifPatExBndrs d)
+            pat_prov_ctxt <- mapM rnIfaceType (ifPatProvCtxt d)
+            pat_req_ctxt <- mapM rnIfaceType (ifPatReqCtxt d)
+            pat_args <- mapM rnIfaceType (ifPatArgs d)
+            pat_ty <- rnIfaceType (ifPatTy d)
+            return d { ifName = name
+                     , ifPatMatcher = pat_matcher
+                     , ifPatBuilder = pat_builder
+                     , ifPatUnivBndrs = pat_univ_bndrs
+                     , ifPatExBndrs = pat_ex_bndrs
+                     , ifPatProvCtxt = pat_prov_ctxt
+                     , ifPatReqCtxt = pat_req_ctxt
+                     , ifPatArgs = pat_args
+                     , ifPatTy = pat_ty
+                     }
+
+rnIfaceClassBody :: Rename IfaceClassBody
+rnIfaceClassBody IfAbstractClass = return IfAbstractClass
+rnIfaceClassBody d@IfConcreteClass{} = do
+    ctxt <- mapM rnIfaceType (ifClassCtxt d)
+    ats <- mapM rnIfaceAT (ifATs d)
+    sigs <- mapM rnIfaceClassOp (ifSigs d)
+    return d { ifClassCtxt = ctxt, ifATs = ats, ifSigs = sigs }
+
+rnIfaceFamTyConFlav :: Rename IfaceFamTyConFlav
+rnIfaceFamTyConFlav (IfaceClosedSynFamilyTyCon (Just (n, axs)))
+    = IfaceClosedSynFamilyTyCon . Just <$> ((,) <$> rnIfaceNeverExported n
+                                                <*> mapM rnIfaceAxBranch axs)
+rnIfaceFamTyConFlav flav = pure flav
+
+rnIfaceAT :: Rename IfaceAT
+rnIfaceAT (IfaceAT decl mb_ty)
+    = IfaceAT <$> rnIfaceDecl decl <*> T.traverse rnIfaceType mb_ty
+
+rnIfaceTyConParent :: Rename IfaceTyConParent
+rnIfaceTyConParent (IfDataInstance n tc args)
+    = IfDataInstance <$> rnIfaceGlobal n
+                     <*> rnIfaceTyCon tc
+                     <*> rnIfaceAppArgs args
+rnIfaceTyConParent IfNoParent = pure IfNoParent
+
+rnIfaceConDecls :: Rename IfaceConDecls
+rnIfaceConDecls (IfDataTyCon 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 rnIfaceBndr (ifConExTCvs d)
+    con_user_tvbs <- mapM rnIfaceForAllBndr (ifConUserTvBinders d)
+    let rnIfConEqSpec (n,t) = (,) n <$> rnIfaceType t
+    con_eq_spec <- mapM rnIfConEqSpec (ifConEqSpec d)
+    con_ctxt <- mapM rnIfaceType (ifConCtxt d)
+    con_arg_tys <- mapM 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
+             , ifConExTCvs = con_ex_tvs
+             , ifConUserTvBinders = con_user_tvbs
+             , ifConEqSpec = con_eq_spec
+             , ifConCtxt = con_ctxt
+             , ifConArgTys = con_arg_tys
+             , ifConFields = con_fields
+             , ifConStricts = con_stricts
+             }
+
+rnIfaceClassOp :: Rename IfaceClassOp
+rnIfaceClassOp (IfaceClassOp n ty dm) =
+    IfaceClassOp <$> rnIfaceGlobal n
+                 <*> rnIfaceType ty
+                 <*> rnMaybeDefMethSpec dm
+
+rnMaybeDefMethSpec :: Rename (Maybe (DefMethSpec IfaceType))
+rnMaybeDefMethSpec (Just (GenericDM ty)) = Just . GenericDM <$> rnIfaceType ty
+rnMaybeDefMethSpec mb = return mb
+
+rnIfaceAxBranch :: Rename IfaceAxBranch
+rnIfaceAxBranch d = do
+    ty_vars <- mapM rnIfaceTvBndr (ifaxbTyVars d)
+    lhs <- rnIfaceAppArgs (ifaxbLHS d)
+    rhs <- rnIfaceType (ifaxbRHS d)
+    return d { ifaxbTyVars = ty_vars
+             , ifaxbLHS = lhs
+             , ifaxbRHS = rhs }
+
+rnIfaceIdInfo :: Rename IfaceIdInfo
+rnIfaceIdInfo 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) = IfaceTvBndr <$> rnIfaceTvBndr tv_bndr
+
+rnIfaceTvBndr :: Rename IfaceTvBndr
+rnIfaceTvBndr (fs, kind) = (,) fs <$> rnIfaceType kind
+
+rnIfaceTyConBinder :: Rename IfaceTyConBinder
+rnIfaceTyConBinder (Bndr tv vis) = Bndr <$> rnIfaceBndr tv <*> pure vis
+
+rnIfaceAlt :: Rename IfaceAlt
+rnIfaceAlt (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
+
+rnIfaceMCo :: Rename IfaceMCoercion
+rnIfaceMCo IfaceMRefl    = pure IfaceMRefl
+rnIfaceMCo (IfaceMCo co) = IfaceMCo <$> rnIfaceCo co
+
+rnIfaceCo :: Rename IfaceCoercion
+rnIfaceCo (IfaceReflCo ty) = IfaceReflCo <$> rnIfaceType ty
+rnIfaceCo (IfaceGReflCo role ty mco)
+  = IfaceGReflCo role <$> rnIfaceType ty <*> rnIfaceMCo mco
+rnIfaceCo (IfaceFunCo role 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 <$> rnIfaceBndr bndr <*> rnIfaceCo co1 <*> rnIfaceCo co2
+rnIfaceCo (IfaceFreeCoVar c) = pure (IfaceFreeCoVar c)
+rnIfaceCo (IfaceCoVarCo lcl) = IfaceCoVarCo <$> pure lcl
+rnIfaceCo (IfaceHoleCo lcl)  = IfaceHoleCo  <$> 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
+
+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 <*> rnIfaceAppArgs 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 <$> rnIfaceAppArgs tks
+rnIfaceType (IfaceTyConApp tc tks)
+    = IfaceTyConApp <$> rnIfaceTyCon tc <*> rnIfaceAppArgs tks
+rnIfaceType (IfaceForAllTy tv t)
+    = IfaceForAllTy <$> rnIfaceForAllBndr tv <*> rnIfaceType t
+rnIfaceType (IfaceCoercionTy co)
+    = IfaceCoercionTy <$> rnIfaceCo co
+rnIfaceType (IfaceCastTy ty co)
+    = IfaceCastTy <$> rnIfaceType ty <*> rnIfaceCo co
+
+rnIfaceForAllBndr :: Rename IfaceForAllBndr
+rnIfaceForAllBndr (Bndr tv vis) = Bndr <$> rnIfaceBndr tv <*> pure vis
+
+rnIfaceAppArgs :: Rename IfaceAppArgs
+rnIfaceAppArgs (IA_Arg t a ts) = IA_Arg <$> rnIfaceType t <*> pure a
+                                        <*> rnIfaceAppArgs ts
+rnIfaceAppArgs IA_Nil = pure IA_Nil

ghc-toolkit/boot-libs/ghc/basicTypes/Avail.hs

@@ -0,0 +1,286 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+--
+-- (c) The University of Glasgow
+--
+
+#include "HsVersions.h"
+
+module Avail (
+    Avails,
+    AvailInfo(..),
+    avail,
+    availsToNameSet,
+    availsToNameSetWithSelectors,
+    availsToNameEnv,
+    availName, availNames, availNonFldNames,
+    availNamesWithSelectors,
+    availFlds,
+    availsNamesWithOccs,
+    availNamesWithOccs,
+    stableAvailCmp,
+    plusAvail,
+    trimAvail,
+    filterAvail,
+    filterAvails,
+    nubAvails
+
+
+  ) where
+
+import GhcPrelude
+
+import Name
+import NameEnv
+import NameSet
+
+import FieldLabel
+import Binary
+import ListSetOps
+import Outputable
+import Util
+
+import Data.Data ( Data )
+import Data.List ( find )
+import Data.Function
+
+-- -----------------------------------------------------------------------------
+-- The AvailInfo type
+
+-- | Records what things are \"available\", i.e. in scope
+data AvailInfo
+
+  -- | An ordinary identifier in scope
+  = Avail Name
+
+  -- | A type or class in scope
+  --
+  -- The __AvailTC Invariant__: If the type or class is itself to be in scope,
+  -- it must be /first/ in this list.  Thus, typically:
+  --
+  -- > AvailTC Eq [Eq, ==, \/=] []
+  | AvailTC
+       Name         -- ^ The name of the type or class
+       [Name]       -- ^ The available pieces of type or class,
+                    -- excluding field selectors.
+       [FieldLabel] -- ^ The record fields of the type
+                    -- (see Note [Representing fields in AvailInfo]).
+
+   deriving ( Eq    -- ^ Used when deciding if the interface has changed
+            , Data )
+
+-- | 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 _                = []
+
+availsNamesWithOccs :: [AvailInfo] -> [(Name, OccName)]
+availsNamesWithOccs = concatMap availNamesWithOccs
+
+-- | 'Name's made available by the availability information, paired with
+-- the 'OccName' used to refer to each one.
+--
+-- When @DuplicateRecordFields@ is in use, the 'Name' may be the
+-- mangled name of a record selector (e.g. @$sel:foo:MkT@) while the
+-- 'OccName' will be the label of the field (e.g. @foo@).
+--
+-- See Note [Representing fields in AvailInfo].
+availNamesWithOccs :: AvailInfo -> [(Name, OccName)]
+availNamesWithOccs (Avail n) = [(n, nameOccName n)]
+availNamesWithOccs (AvailTC _ ns fs)
+  = [ (n, nameOccName n) | n <- ns ] ++
+    [ (flSelector fl, mkVarOccFS (flLabel fl)) | fl <- fs ]
+
+-- -----------------------------------------------------------------------------
+-- 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)

ghc-toolkit/boot-libs/ghc/basicTypes/ConLike.hs

@@ -0,0 +1,196 @@
+{-
+(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
+        , conLikeExTyCoVars
+        , conLikeName
+        , conLikeStupidTheta
+        , conLikeWrapId_maybe
+        , conLikeImplBangs
+        , conLikeFullSig
+        , conLikeResTy
+        , conLikeFieldType
+        , conLikesWithFields
+        , conLikeIsInfix
+    ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+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/coercion variables
+conLikeExTyCoVars :: ConLike -> [TyCoVar]
+conLikeExTyCoVars (RealDataCon dcon1) = dataConExTyCoVars dcon1
+conLikeExTyCoVars (PatSynCon psyn1)   = patSynExTyVars psyn1
+
+conLikeName :: ConLike -> Name
+conLikeName (RealDataCon data_con) = dataConName data_con
+conLikeName (PatSynCon pat_syn)    = patSynName pat_syn
+
+-- | The \"stupid theta\" of the 'ConLike', such as @data Eq a@ in:
+--
+-- > data Eq a => T a = ...
+-- It is empty for `PatSynCon` as they do not allow such contexts.
+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/coercion variables
+--
+-- 3) The equality specification
+--
+-- 4) The provided theta (the constraints provided by a match)
+--
+-- 5) The required theta (the constraints required for a match)
+--
+-- 6) The original argument types (i.e. before
+--    any change of the representation of the type)
+--
+-- 7) The original result type
+conLikeFullSig :: ConLike
+               -> ([TyVar], [TyCoVar], [EqSpec]
+                   -- Why tyvars for universal but tycovars for existential?
+                   -- See Note [Existential coercion variables] in DataCon
+                  , 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

ghc-toolkit/boot-libs/ghc/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

ghc-toolkit/boot-libs/ghc/basicTypes/DataCon.hs-boot

@@ -0,0 +1,34 @@
+module DataCon where
+
+import GhcPrelude
+import Var( TyVar, TyCoVar, 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
+
+dataConName      :: DataCon -> Name
+dataConTyCon     :: DataCon -> TyCon
+dataConExTyCoVars :: DataCon -> [TyCoVar]
+dataConUserTyVars :: DataCon -> [TyVar]
+dataConUserTyVarBinders :: DataCon -> [TyVarBinder]
+dataConSourceArity  :: DataCon -> Arity
+dataConFieldLabels :: DataCon -> [FieldLabel]
+dataConInstOrigArgTys  :: DataCon -> [Type] -> [Type]
+dataConStupidTheta :: DataCon -> ThetaType
+dataConFullSig :: DataCon
+               -> ([TyVar], [TyCoVar], [EqSpec], ThetaType, [Type], Type)
+isUnboxedSumCon :: DataCon -> Bool
+
+instance Eq DataCon
+instance Uniquable DataCon
+instance NamedThing DataCon
+instance Outputable DataCon
+instance OutputableBndr DataCon

ghc-toolkit/boot-libs/ghc/basicTypes/FieldLabel.hs

@@ -0,0 +1,130 @@
+{-
+%
+% (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 GhcPrelude
+
+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

ghc-toolkit/boot-libs/ghc/basicTypes/Id.hs

@@ -0,0 +1,969 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+\section[Id]{@Ids@: Value and constructor identifiers}
+-}
+
+{-# LANGUAGE 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, zapStableUnfolding,
+        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 GhcPrelude
+
+import DynFlags
+import CoreSyn ( CoreRule, isStableUnfolding, evaldUnfolding,
+                 isCompulsoryUnfolding, 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 Id with the same unique and type as the
+-- incoming Id, but with an *Internal* Name and *LocalId* flavour
+localiseId id
+  | ASSERT( isId id ) isLocalId id && isInternalName name
+  = id
+  | otherwise
+  = Var.mkLocalVar (idDetails id) (localiseName name) (idType id) (idInfo id)
+  where
+    name = idName id
+
+lazySetIdInfo :: Id -> IdInfo -> Id
+lazySetIdInfo = Var.lazySetIdInfo
+
+setIdInfo :: Id -> IdInfo -> Id
+setIdInfo id info = info `seq` (lazySetIdInfo id info)
+        -- Try to avoid space leaks by seq'ing
+
+modifyIdInfo :: HasDebugCallStack => (IdInfo -> IdInfo) -> Id -> Id
+modifyIdInfo fn id = setIdInfo id (fn (idInfo id))
+
+-- maybeModifyIdInfo tries to avoid unnecessary thrashing
+maybeModifyIdInfo :: Maybe IdInfo -> Id -> Id
+maybeModifyIdInfo (Just new_info) id = lazySetIdInfo id new_info
+maybeModifyIdInfo Nothing         id = id
+
+{-
+************************************************************************
+*                                                                      *
+\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 (isCoVarType 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( isCoVarType 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
+  | isCoVarType 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 | isCoVarType 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 (isCoVarType 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 (isCoVarType 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.
+--
+-- 'PrimOpId's also used to be of this kind. See Note [Primop wrappers] in PrimOp.hs.
+-- for the history of this.
+--
+-- Note that CorePrep currently eta expands things no-binding things and this
+-- can cause quite subtle bugs. See Note [Eta expansion of hasNoBinding things
+-- in CorePrep] in CorePrep for details.
+--
+-- EXCEPT: unboxed tuples, which definitely have no binding
+hasNoBinding id = case Var.idDetails id of
+                        PrimOpId _       -> False   -- See Note [Primop wrappers] in PrimOp.hs
+                        FCallId _        -> True
+                        DataConWorkId dc -> isUnboxedTupleCon dc || isUnboxedSumCon dc
+                        _                -> isCompulsoryUnfolding (idUnfolding id)
+                                            -- See Note [Levity-polymorphic Ids]
+
+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 [Levity-polymorphic Ids]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Some levity-polymorphic Ids must be applied and and inlined, not left
+un-saturated.  Example:
+  unsafeCoerceId :: forall r1 r2 (a::TYPE r1) (b::TYPE r2). a -> b
+
+This has a compulsory unfolding because we can't lambda-bind those
+arguments.  But the compulsory unfolding may leave levity-polymorphic
+lambdas if it is not applied to enough arguments; e.g. (Trac #14561)
+  bad :: forall (a :: TYPE r). a -> a
+  bad = unsafeCoerce#
+
+The desugar has special magic to detect such cases: DsExpr.badUseOfLevPolyPrimop.
+And we want that magic to apply to levity-polymorphic compulsory-inline things.
+The easiest way to do this is for hasNoBinding to return True of all things
+that have compulsory unfolding.  A very Ids with a compulsory unfolding also
+have a binding, but it does not harm to say they don't here, and its a very
+simple way to fix Trac #14561.
+-}
+
+isDeadBinder :: Id -> Bool
+isDeadBinder bndr | isId bndr = isDeadOcc (idOccInfo bndr)
+                  | otherwise = False   -- TyVars count as not dead
+
+{-
+************************************************************************
+*                                                                      *
+              Evidence variables
+*                                                                      *
+************************************************************************
+-}
+
+isEvVar :: Var -> Bool
+isEvVar var = isEvVarType (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
+
+        ---------------------------------
+        -- Occurrence INFO
+idOccInfo :: Id -> OccInfo
+idOccInfo id = occInfo (idInfo id)
+
+setIdOccInfo :: Id -> OccInfo -> Id
+setIdOccInfo id occ_info = modifyIdInfo (`setOccInfo` occ_info) id
+
+zapIdOccInfo :: Id -> Id
+zapIdOccInfo b = b `setIdOccInfo` noOccInfo
+
+{-
+        ---------------------------------
+        -- INLINING
+The inline pragma tells us to be very keen to inline this Id, but it's still
+OK not to if optimisation is switched off.
+-}
+
+idInlinePragma :: Id -> InlinePragma
+idInlinePragma id = inlinePragInfo (idInfo id)
+
+setInlinePragma :: Id -> InlinePragma -> Id
+setInlinePragma id prag = modifyIdInfo (`setInlinePragInfo` prag) id
+
+modifyInlinePragma :: Id -> (InlinePragma -> InlinePragma) -> Id
+modifyInlinePragma id fn = modifyIdInfo (\info -> info `setInlinePragInfo` (fn (inlinePragInfo info))) id
+
+idInlineActivation :: Id -> Activation
+idInlineActivation id = inlinePragmaActivation (idInlinePragma id)
+
+setInlineActivation :: Id -> Activation -> Id
+setInlineActivation id act = modifyInlinePragma id (\prag -> setInlinePragmaActivation prag act)
+
+idRuleMatchInfo :: Id -> RuleMatchInfo
+idRuleMatchInfo id = inlinePragmaRuleMatchInfo (idInlinePragma id)
+
+isConLikeId :: Id -> Bool
+isConLikeId id = 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
+
+zapStableUnfolding :: Id -> Id
+zapStableUnfolding id
+ | isStableUnfolding (realIdUnfolding id) = setIdUnfolding id NoUnfolding
+ | otherwise                              = id
+
+{-
+Note [transferPolyIdInfo]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+This transfer is used in three places:
+        FloatOut (long-distance let-floating)
+        SimplUtils.abstractFloats (short-distance let-floating)
+        StgLiftLams (selectively lambda-lift local functions to top-level)
+
+Consider the short-distance let-floating:
+
+   f = /\a. let g = rhs in ...
+
+Then if we float thus
+
+   g' = /\a. rhs
+   f = /\a. ...[g' a/g]....
+
+we *do not* want to lose g's
+  * strictness information
+  * arity
+  * inline pragma (though that is bit more debatable)
+  * occurrence info
+
+Mostly this is just an optimisation, but it's *vital* to
+transfer the occurrence info.  Consider
+
+   NonRec { f = /\a. let Rec { g* = ..g.. } in ... }
+
+where the '*' means 'LoopBreaker'.  Then if we float we must get
+
+   Rec { g'* = /\a. ...(g' a)... }
+   NonRec { f = /\a. ...[g' a/g]....}
+
+where g' is also marked as LoopBreaker.  If not, terrible things
+can happen if we re-simplify the binding (and the Simplifier does
+sometimes simplify a term twice); see 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

ghc-toolkit/boot-libs/ghc/basicTypes/IdInfo.hs

@@ -0,0 +1,629 @@
+{-
+(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, zapUnfolding,
+
+        -- ** 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 GhcPrelude
+
+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 space 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
+
+zapUnfolding :: Unfolding -> Unfolding
+-- Squash all unfolding info, preserving only evaluated-ness
+zapUnfolding unf | isEvaldUnfolding unf = evaldUnfolding
+                 | otherwise            = noUnfolding
+
+zapTailCallInfo :: IdInfo -> Maybe IdInfo
+zapTailCallInfo info
+  = case occInfo info of
+      occ | isAlwaysTailCalled occ -> Just (info `setOccInfo` safe_occ)
+          | otherwise              -> Nothing
+        where
+          safe_occ = occ { occ_tail = NoTailCallInfo }
+
+zapCallArityInfo :: IdInfo -> IdInfo
+zapCallArityInfo info = setCallArityInfo info 0
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{TickBoxOp}
+*                                                                      *
+************************************************************************
+-}
+
+type TickBoxId = Int
+
+-- | Tick box for Hpc-style coverage
+data TickBoxOp
+   = TickBox Module {-# UNPACK #-} !TickBoxId
+
+instance Outputable TickBoxOp where
+    ppr (TickBox mod n)         = text "tick" <+> ppr (mod,n)
+
+{-
+************************************************************************
+*                                                                      *
+   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

ghc-toolkit/boot-libs/ghc/basicTypes/IdInfo.hs-boot

@@ -0,0 +1,11 @@
+module IdInfo where
+import GhcPrelude
+import Outputable
+data IdInfo
+data IdDetails
+
+vanillaIdInfo :: IdInfo
+coVarDetails :: IdDetails
+isCoVarDetails :: IdDetails -> Bool
+pprIdDetails :: IdDetails -> SDoc
+

ghc-toolkit/boot-libs/ghc/basicTypes/Lexeme.hs

@@ -0,0 +1,240 @@
+-- (c) The GHC Team
+--
+-- Functions to evaluate whether or not a string is a valid identifier.
+-- There is considerable overlap between the logic here and the logic
+-- in Lexer.x, but sadly there seems to be no 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 GhcPrelude
+
+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

ghc-toolkit/boot-libs/ghc/basicTypes/Literal.hs

@@ -0,0 +1,820 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1998
+
+\section[Literal]{@Literal@: literals}
+-}
+
+{-# LANGUAGE CPP, DeriveDataTypeable, ScopedTypeVariables #-}
+
+module Literal
+        (
+        -- * Main data type
+          Literal(..)           -- Exported to ParseIface
+        , LitNumType(..)
+
+        -- ** Creating Literals
+        , mkLitInt, mkLitIntWrap, mkLitIntWrapC
+        , mkLitWord, mkLitWordWrap, mkLitWordWrapC
+        , mkLitInt64, mkLitInt64Wrap
+        , mkLitWord64, mkLitWord64Wrap
+        , mkLitFloat, mkLitDouble
+        , mkLitChar, mkLitString
+        , mkLitInteger, mkLitNatural
+        , mkLitNumber, mkLitNumberWrap
+
+        -- ** Operations on Literals
+        , literalType
+        , absentLiteralOf
+        , pprLiteral
+        , litNumIsSigned
+        , litNumCheckRange
+
+        -- ** 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
+        , narrowLit
+        , narrow8IntLit, narrow16IntLit, narrow32IntLit
+        , narrow8WordLit, narrow16WordLit, narrow32WordLit
+        , char2IntLit, int2CharLit
+        , float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit
+        , nullAddrLit, rubbishLit, float2DoubleLit, double2FloatLit
+        ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+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 Data.Proxy
+import Numeric ( fromRat )
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Literals}
+*                                                                      *
+************************************************************************
+-}
+
+-- | So-called 'Literal's are one of:
+--
+-- * An unboxed numeric literal or floating-point literal which is presumed
+--   to be surrounded by appropriate constructors (@Int#@, etc.), so that
+--   the overall thing makes sense.
+--
+--   We maintain the invariant that the 'Integer' in the 'LitNumber'
+--   constructor is actually in the (possibly target-dependent) range.
+--   The mkLit{Int,Word}*Wrap smart constructors ensure this by applying
+--   the target machine's wrapping semantics. Use these in situations
+--   where you know the wrapping semantics are correct.
+--
+-- * The literal derived from the label mentioned in a \"foreign label\"
+--   declaration ('LitLabel')
+--
+-- * A 'LitRubbish' to be used in place of values of 'UnliftedRep'
+--   (i.e. 'MutVar#') when the the value is never used.
+--
+-- * A character
+-- * A string
+-- * The NULL pointer
+--
+data Literal
+  = LitChar    Char             -- ^ @Char#@ - at least 31 bits. Create with
+                                -- 'mkLitChar'
+
+  | LitNumber !LitNumType !Integer Type
+                                -- ^ Any numeric literal that can be
+                                -- internally represented with an Integer
+
+  | LitString  ByteString       -- ^ A string-literal: stored and emitted
+                                -- UTF-8 encoded, we'll arrange to decode it
+                                -- at runtime.  Also emitted with a @\'\\0\'@
+                                -- terminator. Create with 'mkLitString'
+
+  | LitNullAddr                 -- ^ The @NULL@ pointer, the only pointer value
+                                -- that can be represented as a Literal. Create
+                                -- with 'nullAddrLit'
+
+  | LitRubbish                  -- ^ A nonsense value, used when an unlifted
+                                -- binding is absent and has type
+                                -- @forall (a :: 'TYPE' 'UnliftedRep'). a@.
+                                -- May be lowered by code-gen to any possible
+                                -- value. Also see Note [Rubbish literals]
+
+  | LitFloat   Rational         -- ^ @Float#@. Create with 'mkLitFloat'
+  | LitDouble  Rational         -- ^ @Double#@. Create with 'mkLitDouble'
+
+  | LitLabel   FastString (Maybe Int) FunctionOrData
+                                -- ^ A label literal. Parameters:
+                                --
+                                -- 1) The name of the symbol mentioned in the
+                                --    declaration
+                                --
+                                -- 2) The size (in bytes) of the arguments
+                                --    the label expects. Only applicable with
+                                --    @stdcall@ labels. @Just x@ => @\<x\>@ will
+                                --    be appended to label name when emitting
+                                --    assembly.
+                                --
+                                -- 3) Flag indicating whether the symbol
+                                --    references a function or a data
+  deriving Data
+
+-- | Numeric literal type
+data LitNumType
+  = LitNumInteger -- ^ @Integer@ (see Note [Integer literals])
+  | LitNumNatural -- ^ @Natural@ (see Note [Natural literals])
+  | LitNumInt     -- ^ @Int#@ - according to target machine
+  | LitNumInt64   -- ^ @Int64#@ - exactly 64 bits
+  | LitNumWord    -- ^ @Word#@ - according to target machine
+  | LitNumWord64  -- ^ @Word64#@ - exactly 64 bits
+  deriving (Data,Enum,Eq,Ord)
+
+-- | Indicate if a numeric literal type supports negative numbers
+litNumIsSigned :: LitNumType -> Bool
+litNumIsSigned nt = case nt of
+  LitNumInteger -> True
+  LitNumNatural -> False
+  LitNumInt     -> True
+  LitNumInt64   -> True
+  LitNumWord    -> False
+  LitNumWord64  -> False
+
+{-
+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.
+
+Note [Natural literals]
+~~~~~~~~~~~~~~~~~~~~~~~
+Similar to Integer literals.
+
+-}
+
+instance Binary LitNumType where
+   put_ bh numTyp = putByte bh (fromIntegral (fromEnum numTyp))
+   get bh = do
+      h <- getByte bh
+      return (toEnum (fromIntegral h))
+
+instance Binary Literal where
+    put_ bh (LitChar aa)     = do putByte bh 0; put_ bh aa
+    put_ bh (LitString ab)   = do putByte bh 1; put_ bh ab
+    put_ bh (LitNullAddr)    = do putByte bh 2
+    put_ bh (LitFloat ah)    = do putByte bh 3; put_ bh ah
+    put_ bh (LitDouble ai)   = do putByte bh 4; put_ bh ai
+    put_ bh (LitLabel aj mb fod)
+        = do putByte bh 5
+             put_ bh aj
+             put_ bh mb
+             put_ bh fod
+    put_ bh (LitNumber nt i _)
+        = do putByte bh 6
+             put_ bh nt
+             put_ bh i
+    put_ bh (LitRubbish)     = do putByte bh 7
+    get bh = do
+            h <- getByte bh
+            case h of
+              0 -> do
+                    aa <- get bh
+                    return (LitChar aa)
+              1 -> do
+                    ab <- get bh
+                    return (LitString ab)
+              2 -> do
+                    return (LitNullAddr)
+              3 -> do
+                    ah <- get bh
+                    return (LitFloat ah)
+              4 -> do
+                    ai <- get bh
+                    return (LitDouble ai)
+              5 -> do
+                    aj <- get bh
+                    mb <- get bh
+                    fod <- get bh
+                    return (LitLabel aj mb fod)
+              6 -> do
+                    nt <- get bh
+                    i  <- get bh
+                    let t = case nt of
+                            LitNumInt     -> intPrimTy
+                            LitNumInt64   -> int64PrimTy
+                            LitNumWord    -> wordPrimTy
+                            LitNumWord64  -> word64PrimTy
+                            -- See Note [Integer literals]
+                            LitNumInteger ->
+                              panic "Evaluated the place holder for mkInteger"
+                            -- and Note [Natural literals]
+                            LitNumNatural ->
+                              panic "Evaluated the place holder for mkNatural"
+                    return (LitNumber nt i t)
+              _ -> do
+                    return (LitRubbish)
+
+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  }
+
+-- | Needed for the @Ord@ instance of 'AltCon', which in turn is needed in
+-- 'TrieMap.CoreMap'.
+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
+        ~~~~~~~~~~~~
+-}
+
+{- Note [Word/Int underflow/overflow]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+According to the Haskell Report 2010 (Sections 18.1 and 23.1 about signed and
+unsigned integral types): "All arithmetic is performed modulo 2^n, where n is
+the number of bits in the type."
+
+GHC stores Word# and Int# constant values as Integer. Core optimizations such
+as constant folding must ensure that the Integer value remains in the valid
+target Word/Int range (see #13172). The following functions are used to
+ensure this.
+
+Note that we *don't* warn the user about overflow. It's not done at runtime
+either, and compilation of completely harmless things like
+   ((124076834 :: Word32) + (2147483647 :: Word32))
+doesn't yield a warning. Instead we simply squash the value into the *target*
+Int/Word range.
+-}
+
+-- | Wrap a literal number according to its type
+wrapLitNumber :: DynFlags -> Literal -> Literal
+wrapLitNumber dflags v@(LitNumber nt i t) = case nt of
+  LitNumInt -> case platformWordSize (targetPlatform dflags) of
+    4 -> LitNumber nt (toInteger (fromIntegral i :: Int32)) t
+    8 -> LitNumber nt (toInteger (fromIntegral i :: Int64)) t
+    w -> panic ("wrapLitNumber: Unknown platformWordSize: " ++ show w)
+  LitNumWord -> case platformWordSize (targetPlatform dflags) of
+    4 -> LitNumber nt (toInteger (fromIntegral i :: Word32)) t
+    8 -> LitNumber nt (toInteger (fromIntegral i :: Word64)) t
+    w -> panic ("wrapLitNumber: Unknown platformWordSize: " ++ show w)
+  LitNumInt64   -> LitNumber nt (toInteger (fromIntegral i :: Int64)) t
+  LitNumWord64  -> LitNumber nt (toInteger (fromIntegral i :: Word64)) t
+  LitNumInteger -> v
+  LitNumNatural -> v
+wrapLitNumber _ x = x
+
+-- | Create a numeric 'Literal' of the given type
+mkLitNumberWrap :: DynFlags -> LitNumType -> Integer -> Type -> Literal
+mkLitNumberWrap dflags nt i t = wrapLitNumber dflags (LitNumber nt i t)
+
+-- | Check that a given number is in the range of a numeric literal
+litNumCheckRange :: DynFlags -> LitNumType -> Integer -> Bool
+litNumCheckRange dflags nt i = case nt of
+     LitNumInt     -> inIntRange dflags i
+     LitNumWord    -> inWordRange dflags i
+     LitNumInt64   -> inInt64Range i
+     LitNumWord64  -> inWord64Range i
+     LitNumNatural -> i >= 0
+     LitNumInteger -> True
+
+-- | Create a numeric 'Literal' of the given type
+mkLitNumber :: DynFlags -> LitNumType -> Integer -> Type -> Literal
+mkLitNumber dflags nt i t =
+  ASSERT2(litNumCheckRange dflags nt i, integer i)
+  (LitNumber nt i t)
+
+-- | Creates a 'Literal' of type @Int#@
+mkLitInt :: DynFlags -> Integer -> Literal
+mkLitInt dflags x   = ASSERT2( inIntRange dflags x,  integer x )
+                       (mkLitIntUnchecked x)
+
+-- | Creates a 'Literal' of type @Int#@.
+--   If the argument is out of the (target-dependent) range, it is wrapped.
+--   See Note [Word/Int underflow/overflow]
+mkLitIntWrap :: DynFlags -> Integer -> Literal
+mkLitIntWrap dflags i = wrapLitNumber dflags $ mkLitIntUnchecked i
+
+-- | Creates a 'Literal' of type @Int#@ without checking its range.
+mkLitIntUnchecked :: Integer -> Literal
+mkLitIntUnchecked i = LitNumber LitNumInt i intPrimTy
+
+-- | Creates a 'Literal' of type @Int#@, as well as a 'Bool'ean flag indicating
+--   overflow. That is, if the argument is out of the (target-dependent) range
+--   the argument is wrapped and the overflow flag will be set.
+--   See Note [Word/Int underflow/overflow]
+mkLitIntWrapC :: DynFlags -> Integer -> (Literal, Bool)
+mkLitIntWrapC dflags i = (n, i /= i')
+  where
+    n@(LitNumber _ i' _) = mkLitIntWrap dflags i
+
+-- | Creates a 'Literal' of type @Word#@
+mkLitWord :: DynFlags -> Integer -> Literal
+mkLitWord dflags x   = ASSERT2( inWordRange dflags x, integer x )
+                        (mkLitWordUnchecked x)
+
+-- | Creates a 'Literal' of type @Word#@.
+--   If the argument is out of the (target-dependent) range, it is wrapped.
+--   See Note [Word/Int underflow/overflow]
+mkLitWordWrap :: DynFlags -> Integer -> Literal
+mkLitWordWrap dflags i = wrapLitNumber dflags $ mkLitWordUnchecked i
+
+-- | Creates a 'Literal' of type @Word#@ without checking its range.
+mkLitWordUnchecked :: Integer -> Literal
+mkLitWordUnchecked i = LitNumber LitNumWord i wordPrimTy
+
+-- | Creates a 'Literal' of type @Word#@, as well as a 'Bool'ean flag indicating
+--   carry. That is, if the argument is out of the (target-dependent) range
+--   the argument is wrapped and the carry flag will be set.
+--   See Note [Word/Int underflow/overflow]
+mkLitWordWrapC :: DynFlags -> Integer -> (Literal, Bool)
+mkLitWordWrapC dflags i = (n, i /= i')
+  where
+    n@(LitNumber _ i' _) = mkLitWordWrap dflags i
+
+-- | Creates a 'Literal' of type @Int64#@
+mkLitInt64 :: Integer -> Literal
+mkLitInt64  x = ASSERT2( inInt64Range x, integer x ) (mkLitInt64Unchecked x)
+
+-- | Creates a 'Literal' of type @Int64#@.
+--   If the argument is out of the range, it is wrapped.
+mkLitInt64Wrap :: DynFlags -> Integer -> Literal
+mkLitInt64Wrap dflags i = wrapLitNumber dflags $ mkLitInt64Unchecked i
+
+-- | Creates a 'Literal' of type @Int64#@ without checking its range.
+mkLitInt64Unchecked :: Integer -> Literal
+mkLitInt64Unchecked i = LitNumber LitNumInt64 i int64PrimTy
+
+-- | Creates a 'Literal' of type @Word64#@
+mkLitWord64 :: Integer -> Literal
+mkLitWord64 x = ASSERT2( inWord64Range x, integer x ) (mkLitWord64Unchecked x)
+
+-- | Creates a 'Literal' of type @Word64#@.
+--   If the argument is out of the range, it is wrapped.
+mkLitWord64Wrap :: DynFlags -> Integer -> Literal
+mkLitWord64Wrap dflags i = wrapLitNumber dflags $ mkLitWord64Unchecked i
+
+-- | Creates a 'Literal' of type @Word64#@ without checking its range.
+mkLitWord64Unchecked :: Integer -> Literal
+mkLitWord64Unchecked i = LitNumber LitNumWord64 i word64PrimTy
+
+-- | Creates a 'Literal' of type @Float#@
+mkLitFloat :: Rational -> Literal
+mkLitFloat = LitFloat
+
+-- | Creates a 'Literal' of type @Double#@
+mkLitDouble :: Rational -> Literal
+mkLitDouble = LitDouble
+
+-- | Creates a 'Literal' of type @Char#@
+mkLitChar :: Char -> Literal
+mkLitChar = LitChar
+
+-- | Creates a 'Literal' of type @Addr#@, which is appropriate for passing to
+-- e.g. some of the \"error\" functions in GHC.Err such as @GHC.Err.runtimeError@
+mkLitString :: String -> Literal
+-- stored UTF-8 encoded
+mkLitString s = LitString (fastStringToByteString $ mkFastString s)
+
+mkLitInteger :: Integer -> Type -> Literal
+mkLitInteger x ty = LitNumber LitNumInteger x ty
+
+mkLitNatural :: Integer -> Type -> Literal
+mkLitNatural x ty = ASSERT2( inNaturalRange x,  integer x )
+                    (LitNumber LitNumNatural x ty)
+
+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
+
+inNaturalRange :: Integer -> Bool
+inNaturalRange x = x >= 0
+
+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 (LitNumber _ 0 _) = True
+isZeroLit (LitFloat  0)     = True
+isZeroLit (LitDouble 0)     = True
+isZeroLit _                 = False
+
+-- | Returns the 'Integer' contained in the 'Literal', for when that makes
+-- sense, i.e. for 'Char', 'Int', 'Word', 'LitInteger' and 'LitNatural'.
+litValue  :: Literal -> Integer
+litValue l = case isLitValue_maybe l of
+   Just x  -> x
+   Nothing -> pprPanic "litValue" (ppr l)
+
+-- | Returns the 'Integer' contained in the 'Literal', for when that makes
+-- sense, i.e. for 'Char' and numbers.
+isLitValue_maybe  :: Literal -> Maybe Integer
+isLitValue_maybe (LitChar   c)     = Just $ toInteger $ ord c
+isLitValue_maybe (LitNumber _ i _) = Just i
+isLitValue_maybe _                 = Nothing
+
+-- | Apply a function to the 'Integer' contained in the 'Literal', for when that
+-- makes sense, e.g. for 'Char' and numbers.
+-- For fixed-size integral literals, the result will be wrapped in accordance
+-- with the semantics of the target type.
+-- See Note [Word/Int underflow/overflow]
+mapLitValue  :: DynFlags -> (Integer -> Integer) -> Literal -> Literal
+mapLitValue _      f (LitChar   c)      = mkLitChar (fchar c)
+   where fchar = chr . fromInteger . f . toInteger . ord
+mapLitValue dflags f (LitNumber nt i t) = wrapLitNumber dflags
+                                                        (LitNumber nt (f i) t)
+mapLitValue _      _ l                  = pprPanic "mapLitValue" (ppr l)
+
+-- | Indicate if the `Literal` contains an 'Integer' value, e.g. 'Char',
+-- 'Int', 'Word', 'LitInteger' and 'LitNatural'.
+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 (LitNumber LitNumWord w _)
+  -- Map Word range [max_int+1, max_word]
+  -- to Int range   [min_int  , -1]
+  -- Range [0,max_int] has the same representation with both Int and Word
+  | w > tARGET_MAX_INT dflags = mkLitInt dflags (w - tARGET_MAX_WORD dflags - 1)
+  | otherwise                 = mkLitInt dflags w
+word2IntLit _ l = pprPanic "word2IntLit" (ppr l)
+
+int2WordLit dflags (LitNumber LitNumInt i _)
+  -- Map Int range [min_int  , -1]
+  -- to Word range [max_int+1, max_word]
+  -- Range [0,max_int] has the same representation with both Int and Word
+  | i < 0     = mkLitWord dflags (1 + tARGET_MAX_WORD dflags + i)
+  | otherwise = mkLitWord dflags i
+int2WordLit _ l = pprPanic "int2WordLit" (ppr l)
+
+-- | Narrow a literal number (unchecked result range)
+narrowLit :: forall a. Integral a => Proxy a -> Literal -> Literal
+narrowLit _ (LitNumber nt i t) = LitNumber nt (toInteger (fromInteger i :: a)) t
+narrowLit _ l                  = pprPanic "narrowLit" (ppr l)
+
+narrow8IntLit   = narrowLit (Proxy :: Proxy Int8)
+narrow16IntLit  = narrowLit (Proxy :: Proxy Int16)
+narrow32IntLit  = narrowLit (Proxy :: Proxy Int32)
+narrow8WordLit  = narrowLit (Proxy :: Proxy Word8)
+narrow16WordLit = narrowLit (Proxy :: Proxy Word16)
+narrow32WordLit = narrowLit (Proxy :: Proxy Word32)
+
+char2IntLit (LitChar c)       = mkLitIntUnchecked (toInteger (ord c))
+char2IntLit l                 = pprPanic "char2IntLit" (ppr l)
+int2CharLit (LitNumber _ i _) = LitChar (chr (fromInteger i))
+int2CharLit l                 = pprPanic "int2CharLit" (ppr l)
+
+float2IntLit (LitFloat f)      = mkLitIntUnchecked (truncate f)
+float2IntLit l                 = pprPanic "float2IntLit" (ppr l)
+int2FloatLit (LitNumber _ i _) = LitFloat (fromInteger i)
+int2FloatLit l                 = pprPanic "int2FloatLit" (ppr l)
+
+double2IntLit (LitDouble f)     = mkLitIntUnchecked (truncate f)
+double2IntLit l                 = pprPanic "double2IntLit" (ppr l)
+int2DoubleLit (LitNumber _ i _) = LitDouble (fromInteger i)
+int2DoubleLit l                 = pprPanic "int2DoubleLit" (ppr l)
+
+float2DoubleLit (LitFloat  f) = LitDouble f
+float2DoubleLit l             = pprPanic "float2DoubleLit" (ppr l)
+double2FloatLit (LitDouble d) = LitFloat  d
+double2FloatLit l             = pprPanic "double2FloatLit" (ppr l)
+
+nullAddrLit :: Literal
+nullAddrLit = LitNullAddr
+
+-- | A nonsense literal of type @forall (a :: 'TYPE' 'UnliftedRep'). a@.
+rubbishLit :: Literal
+rubbishLit = LitRubbish
+
+{-
+        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 (LitString _)      = False
+litIsTrivial (LitNumber nt _ _) = case nt of
+  LitNumInteger -> False
+  LitNumNatural -> False
+  LitNumInt     -> True
+  LitNumInt64   -> True
+  LitNumWord    -> True
+  LitNumWord64  -> True
+litIsTrivial _                  = True
+
+-- | True if code space does not go bad if we duplicate this literal
+litIsDupable :: DynFlags -> Literal -> Bool
+--      c.f. CoreUtils.exprIsDupable
+litIsDupable _      (LitString _)      = False
+litIsDupable dflags (LitNumber nt i _) = case nt of
+  LitNumInteger -> inIntRange dflags i
+  LitNumNatural -> inIntRange dflags i
+  LitNumInt     -> True
+  LitNumInt64   -> True
+  LitNumWord    -> True
+  LitNumWord64  -> True
+litIsDupable _      _                  = True
+
+litFitsInChar :: Literal -> Bool
+litFitsInChar (LitNumber _ i _) = i >= toInteger (ord minBound)
+                               && i <= toInteger (ord maxBound)
+litFitsInChar _                 = False
+
+litIsLifted :: Literal -> Bool
+litIsLifted (LitNumber nt _ _) = case nt of
+  LitNumInteger -> True
+  LitNumNatural -> True
+  LitNumInt     -> False
+  LitNumInt64   -> False
+  LitNumWord    -> False
+  LitNumWord64  -> False
+litIsLifted _                  = False
+
+{-
+        Types
+        ~~~~~
+-}
+
+-- | Find the Haskell 'Type' the literal occupies
+literalType :: Literal -> Type
+literalType LitNullAddr       = addrPrimTy
+literalType (LitChar _)       = charPrimTy
+literalType (LitString  _)    = addrPrimTy
+literalType (LitFloat _)      = floatPrimTy
+literalType (LitDouble _)     = doublePrimTy
+literalType (LitLabel _ _ _)  = addrPrimTy
+literalType (LitNumber _ _ t) = t
+literalType (LitRubbish)      = mkForAllTy a Inferred (mkTyVarTy a)
+  where
+    a = alphaTyVarUnliftedRep
+
+absentLiteralOf :: TyCon -> Maybe Literal
+-- Return a literal of the appropriate primitive
+-- TyCon, to use as a placeholder when it doesn't matter
+-- Rubbish literals are handled in WwLib, because
+--  1. Looking at the TyCon is not enough, we need the actual type
+--  2. This would need to return a type application to a literal
+absentLiteralOf tc = lookupUFM absent_lits (tyConName tc)
+
+absent_lits :: UniqFM Literal
+absent_lits = listToUFM [ (addrPrimTyConKey,    LitNullAddr)
+                        , (charPrimTyConKey,    LitChar 'x')
+                        , (intPrimTyConKey,     mkLitIntUnchecked 0)
+                        , (int64PrimTyConKey,   mkLitInt64Unchecked 0)
+                        , (wordPrimTyConKey,    mkLitWordUnchecked 0)
+                        , (word64PrimTyConKey,  mkLitWord64Unchecked 0)
+                        , (floatPrimTyConKey,   LitFloat 0)
+                        , (doublePrimTyConKey,  LitDouble 0)
+                        ]
+
+{-
+        Comparison
+        ~~~~~~~~~~
+-}
+
+cmpLit :: Literal -> Literal -> Ordering
+cmpLit (LitChar      a)     (LitChar       b)     = a `compare` b
+cmpLit (LitString    a)     (LitString     b)     = a `compare` b
+cmpLit (LitNullAddr)        (LitNullAddr)         = EQ
+cmpLit (LitFloat     a)     (LitFloat      b)     = a `compare` b
+cmpLit (LitDouble    a)     (LitDouble     b)     = a `compare` b
+cmpLit (LitLabel     a _ _) (LitLabel      b _ _) = a `compare` b
+cmpLit (LitNumber nt1 a _)  (LitNumber nt2  b _)
+  | nt1 == nt2 = a   `compare` b
+  | otherwise  = nt1 `compare` nt2
+cmpLit (LitRubbish)         (LitRubbish)          = EQ
+cmpLit lit1 lit2
+  | litTag lit1 < litTag lit2 = LT
+  | otherwise                 = GT
+
+litTag :: Literal -> Int
+litTag (LitChar      _)   = 1
+litTag (LitString    _)   = 2
+litTag (LitNullAddr)      = 3
+litTag (LitFloat     _)   = 4
+litTag (LitDouble    _)   = 5
+litTag (LitLabel _ _ _)   = 6
+litTag (LitNumber  {})    = 7
+litTag (LitRubbish)       = 8
+
+{-
+        Printing
+        ~~~~~~~~
+* See Note [Printing of literals in Core]
+-}
+
+pprLiteral :: (SDoc -> SDoc) -> Literal -> SDoc
+pprLiteral _       (LitChar c)     = pprPrimChar c
+pprLiteral _       (LitString s)   = pprHsBytes s
+pprLiteral _       (LitNullAddr)   = text "__NULL"
+pprLiteral _       (LitFloat f)    = float (fromRat f) <> primFloatSuffix
+pprLiteral _       (LitDouble d)   = double (fromRat d) <> primDoubleSuffix
+pprLiteral add_par (LitNumber nt i _)
+   = case nt of
+       LitNumInteger -> pprIntegerVal add_par i
+       LitNumNatural -> pprIntegerVal add_par i
+       LitNumInt     -> pprPrimInt i
+       LitNumInt64   -> pprPrimInt64 i
+       LitNumWord    -> pprPrimWord i
+       LitNumWord64  -> pprPrimWord64 i
+pprLiteral add_par (LitLabel 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))
+pprLiteral _       (LitRubbish)     = text "__RUBBISH"
+
+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 (`LitLabel`), if they occur in a context requiring
+an atomic thing (for example function application).
+
+Although not all Core literals would be valid Haskell, we are trying to stay
+as close as possible to Haskell syntax in the printing of Core, to make it
+easier for a Haskell user to read Core.
+
+To that end:
+  * We do print parenthesis around negative `LitInteger`, because we print
+  `LitInteger` using plain number literals (no prefix or suffix), and plain
+  number literals in Haskell require parenthesis in contexts like function
+  application (i.e. `1 - -1` is not valid Haskell).
+
+  * We don't print parenthesis around other (negative) literals, because they
+  aren't needed in GHC/Haskell either (i.e. `1# -# -1#` is accepted by GHC's
+  parser).
+
+Literal         Output             Output if context requires
+                                   an atom (if different)
+-------         -------            ----------------------
+LitChar         'a'#
+LitString       "aaa"#
+LitNullAddr     "__NULL"
+LitInt          -1#
+LitInt64        -1L#
+LitWord          1##
+LitWord64        1L##
+LitFloat        -1.0#
+LitDouble       -1.0##
+LitInteger      -1                 (-1)
+LitLabel        "__label" ...      ("__label" ...)
+LitRubbish      "__RUBBISH"
+
+Note [Rubbish literals]
+~~~~~~~~~~~~~~~~~~~~~~~
+During worker/wrapper after demand analysis, where an argument
+is unused (absent) we do the following w/w split (supposing that
+y is absent):
+
+  f x y z = e
+===>
+  f x y z = $wf x z
+  $wf x z = let y = <absent value>
+            in e
+
+Usually the binding for y is ultimately optimised away, and
+even if not it should never be evaluated -- but that's the
+way the w/w split starts off.
+
+What is <absent value>?
+* For lifted values <absent value> can be a call to 'error'.
+* For primitive types like Int# or Word# we can use any random
+  value of that type.
+* But what about /unlifted/ but /boxed/ types like MutVar# or
+  Array#?   We need a literal value of that type.
+
+That is 'LitRubbish'.  Since we need a rubbish literal for
+many boxed, unlifted types, we say that LitRubbish has type
+  LitRubbish :: forall (a :: TYPE UnliftedRep). a
+
+So we might see a w/w split like
+  $wf x z = let y :: Array# Int = LitRubbish @(Array# Int)
+            in e
+
+Recall that (TYPE UnliftedRep) is the kind of boxed, unlifted
+heap pointers.
+
+Here are the moving parts:
+
+* We define LitRubbish as a constructor in Literal.Literal
+
+* It is given its polymoprhic type by Literal.literalType
+
+* WwLib.mk_absent_let introduces a LitRubbish for absent
+  arguments of boxed, unlifted type.
+
+* In CoreToSTG we convert (RubishLit @t) to just ().  STG is
+  untyped, so it doesn't matter that it points to a lifted
+  value. The important thing is that it is a heap pointer,
+  which the garbage collector can follow if it encounters it.
+
+  We considered maintaining LitRubbish in STG, and lowering
+  it in the code genreators, but it seems simpler to do it
+  once and for all in CoreToSTG.
+
+  In ByteCodeAsm we just lower it as a 0 literal, because
+  it's all boxed and lifted to the host GC anyway.
+-}

ghc-toolkit/boot-libs/ghc/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

ghc-toolkit/boot-libs/ghc/basicTypes/Module.hs-boot

@@ -0,0 +1,14 @@
+module Module where
+
+import GhcPrelude
+import FastString
+
+data Module
+data ModuleName
+data UnitId
+data InstalledUnitId
+newtype ComponentId = ComponentId FastString
+
+moduleName :: Module -> ModuleName
+moduleUnitId :: Module -> UnitId
+unitIdString :: UnitId -> String

ghc-toolkit/boot-libs/ghc/basicTypes/Name.hs

@@ -0,0 +1,701 @@
+{-
+(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 #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE PatternSynonyms #-}
+
+-- |
+-- #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,
+
+        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, pprNameUnqualified,
+        nameStableString,
+
+        -- Re-export the OccName stuff
+        module OccName
+    ) where
+
+import GhcPrelude
+
+import {-# SOURCE #-} TyCoRep( TyThing )
+
+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 #-} !Unique,
+                n_loc  :: !SrcSpan      -- Definition site
+            }
+
+-- NOTE: we make the n_loc field strict to eliminate some potential
+-- (and real!) space leaks, due to the fact that we don't look at
+-- the SrcLoc in a Name all that often.
+
+-- See Note [About the NameSorts]
+data NameSort
+  = External Module
+
+  | 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
+
+{-
+Note [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              :: HasDebugCallStack => Name -> Module
+nameSrcLoc              :: Name -> SrcLoc
+nameSrcSpan             :: Name -> SrcSpan
+
+nameUnique  name = n_uniq name
+nameOccName name = n_occ  name
+nameSrcLoc  name = srcSpanStart (n_loc name)
+nameSrcSpan name = n_loc  name
+
+type instance SrcSpanLess Name = Name
+instance HasSrcSpan Name where
+  composeSrcSpan   (L sp  n) = n {n_loc = sp}
+  decomposeSrcSpan n         = L (n_loc n) n
+
+
+{-
+************************************************************************
+*                                                                      *
+\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 GHCi session
+-- each give rise to a fresh module (Ghci1, Ghci2, etc), but they all come
+-- from the magic 'interactive' package; and all the details are kept in the
+-- TcLclEnv, TcGblEnv, NOT in the HPT or EPT.
+-- See Note [The interactive package] in 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
+-- package 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 = uniq
+                                   , n_sort = Internal
+                                   , n_occ = occ
+                                   , n_loc = loc }
+        -- NB: You might worry that after lots of huffing and
+        -- puffing we might end up with two local names with distinct
+        -- uniques, but the same OccName.  Indeed we can, but that's ok
+        --      * the insides of the compiler don't care: they use the Unique
+        --      * when printing for -ddump-xxx you can switch on -dppr-debug to get the
+        --        uniques if you get confused
+        --      * for interface files we tidyCore first, which makes
+        --        the OccNames distinct when they need to be
+
+mkClonedInternalName :: Unique -> Name -> Name
+mkClonedInternalName uniq (Name { n_occ = occ, n_loc = loc })
+  = Name { n_uniq = uniq, n_sort = Internal
+         , n_occ = occ, n_loc = loc }
+
+mkDerivedInternalName :: (OccName -> OccName) -> Unique -> Name -> Name
+mkDerivedInternalName derive_occ uniq (Name { n_occ = occ, n_loc = loc })
+  = Name { n_uniq = uniq, n_sort = Internal
+         , n_occ = derive_occ occ, n_loc = loc }
+
+-- | Create a name which definitely originates in the given module
+mkExternalName :: Unique -> Module -> OccName -> SrcSpan -> Name
+-- 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 = 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 = uniq,
+           n_sort = WiredIn mod thing built_in,
+           n_occ = occ, n_loc = wiredInSrcSpan }
+
+-- | Create a name brought into being by the compiler
+mkSystemName :: Unique -> OccName -> Name
+mkSystemName uniq occ = mkSystemNameAt uniq occ noSrcSpan
+
+mkSystemNameAt :: Unique -> OccName -> SrcSpan -> Name
+mkSystemNameAt uniq occ loc = Name { n_uniq = uniq, n_sort = System
+                                   , n_occ = occ, n_loc = loc }
+
+mkSystemVarName :: Unique -> FastString -> Name
+mkSystemVarName uniq fs = mkSystemName uniq (mkVarOccFS fs)
+
+mkSysTvName :: Unique -> FastString -> Name
+mkSysTvName uniq fs = mkSystemName uniq (mkTyVarOccFS fs)
+
+-- | Make a name for a foreign call
+mkFCallName :: Unique -> 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 = uniq}
+
+-- This is used for hsigs: we want to use the name of the originally exported
+-- entity, but edit the location to refer to the reexport site
+setNameLoc :: Name -> SrcSpan -> Name
+setNameLoc name loc = name {n_loc = loc}
+
+tidyNameOcc :: Name -> OccName -> Name
+-- We set the OccName of a Name when tidying
+-- In doing so, we change System --> Internal, so that when we print
+-- it we don't get the unique by default.  It's tidy now!
+tidyNameOcc name@(Name { n_sort = System }) occ = name { n_occ = occ, n_sort = Internal}
+tidyNameOcc name                            occ = name { n_occ = occ }
+
+-- | Make the 'Name' into an internal name, regardless of what it was to begin with
+localiseName :: Name -> Name
+localiseName n = n { n_sort = Internal }
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Hashing and comparison}
+*                                                                      *
+************************************************************************
+-}
+
+cmpName :: Name -> Name -> Ordering
+cmpName n1 n2 = n_uniq n1 `nonDetCmpUnique` n_uniq n2
+
+-- | Compare Names lexicographically
+-- This only works for Names that originate in the source code or have been
+-- tidied.
+stableNameCmp :: Name -> Name -> Ordering
+stableNameCmp (Name { n_sort = s1, n_occ = occ1 })
+              (Name { n_sort = s2, n_occ = occ2 })
+  = (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}
+*                                                                      *
+************************************************************************
+-}
+
+-- | The same comments as for `Name`'s `Ord` instance apply.
+instance Eq Name where
+    a == b = case (a `compare` b) of { EQ -> True;  _ -> False }
+    a /= b = case (a `compare` b) of { EQ -> False; _ -> True }
+
+-- | __Caution__: This instance is implemented via `nonDetCmpUnique`, which
+-- means that the ordering is not stable across deserialization or rebuilds.
+--
+-- See `nonDetCmpUnique` for further information, and trac #15240 for a bug
+-- caused by improper use of this instance.
+
+-- For a deterministic lexicographic ordering, use `stableNameCmp`.
+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 = uniq, 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
+
+-- | Print the string of Name unqualifiedly directly.
+pprNameUnqualified :: Name -> SDoc
+pprNameUnqualified Name { n_occ = occ } = ppr_occ_name occ
+
+pprExternal :: PprStyle -> Unique -> Module -> OccName -> Bool -> BuiltInSyntax -> SDoc
+pprExternal sty uniq mod occ is_wired is_builtin
+  | codeStyle sty = ppr mod <> char '_' <> ppr_z_occ_name occ
+        -- In code style, always qualify
+        -- ToDo: maybe we could print all wired-in things unqualified
+        --       in code style, to reduce symbol table bloat?
+  | debugStyle sty = pp_mod <> ppr_occ_name occ
+                     <> braces (hsep [if is_wired then text "(w)" else empty,
+                                      pprNameSpaceBrief (occNameSpace occ),
+                                      pprUnique uniq])
+  | BuiltInSyntax <- is_builtin = ppr_occ_name occ  -- Never qualify builtin syntax
+  | otherwise                   =
+        if isHoleModule mod
+            then case qualName sty mod occ of
+                    NameUnqual -> ppr_occ_name occ
+                    _ -> braces (ppr (moduleName mod) <> dot <> ppr_occ_name occ)
+            else pprModulePrefix sty mod occ <> ppr_occ_name occ
+  where
+    pp_mod = sdocWithDynFlags $ \dflags ->
+             if gopt Opt_SuppressModulePrefixes dflags
+             then empty
+             else ppr mod <> dot
+
+pprInternal :: PprStyle -> Unique -> OccName -> SDoc
+pprInternal sty uniq occ
+  | codeStyle sty  = pprUniqueAlways uniq
+  | debugStyle sty = ppr_occ_name occ <> braces (hsep [pprNameSpaceBrief (occNameSpace occ),
+                                                       pprUnique uniq])
+  | dumpStyle sty  = ppr_occ_name occ <> ppr_underscore_unique uniq
+                        -- For debug dumps, we're not necessarily dumping
+                        -- tidied code, so we need to print the uniques.
+  | otherwise      = ppr_occ_name occ   -- User style
+
+-- Like Internal, except that we only omit the unique in Iface style
+pprSystem :: PprStyle -> Unique -> OccName -> SDoc
+pprSystem sty uniq occ
+  | codeStyle sty  = pprUniqueAlways uniq
+  | debugStyle sty = ppr_occ_name occ <> ppr_underscore_unique uniq
+                     <> braces (pprNameSpaceBrief (occNameSpace occ))
+  | otherwise      = ppr_occ_name occ <> ppr_underscore_unique uniq
+                                -- If the tidy phase hasn't run, the OccName
+                                -- is unlikely to be informative (like 's'),
+                                -- so print the unique
+
+
+pprModulePrefix :: PprStyle -> Module -> OccName -> SDoc
+-- Print the "M." part of a name, based on whether it's in scope or not
+-- See Note [Printing original names] in HscTypes
+pprModulePrefix sty mod occ = sdocWithDynFlags $ \dflags ->
+  if gopt Opt_SuppressModulePrefixes dflags
+  then empty
+  else
+    case qualName sty mod occ of              -- See Outputable.QualifyName:
+      NameQual modname -> ppr modname <> dot       -- Name is in scope
+      NameNotInScope1  -> ppr mod <> dot           -- Not in scope
+      NameNotInScope2  -> ppr (moduleUnitId mod) <> colon     -- Module not in
+                          <> ppr (moduleName mod) <> dot          -- scope either
+      NameUnqual       -> empty                   -- In scope unqualified
+
+pprUnique :: Unique -> SDoc
+-- Print a unique unless we are suppressing them
+pprUnique uniq
+  = sdocWithDynFlags $ \dflags ->
+    ppUnless (gopt Opt_SuppressUniques dflags) $
+    pprUniqueAlways uniq
+
+ppr_underscore_unique :: Unique -> SDoc
+-- Print an underscore separating the name from its unique
+-- But suppress it if we aren't printing the uniques anyway
+ppr_underscore_unique uniq
+  = sdocWithDynFlags $ \dflags ->
+    ppUnless (gopt Opt_SuppressUniques dflags) $
+    char '_' <> pprUniqueAlways uniq
+
+ppr_occ_name :: OccName -> SDoc
+ppr_occ_name occ = ftext (occNameFS occ)
+        -- Don't use pprOccName; instead, just print the string of the OccName;
+        -- we print the namespace in the debug stuff above
+
+-- In code style, we Z-encode the strings.  The results of Z-encoding each FastString are
+-- cached behind the scenes in the FastString implementation.
+ppr_z_occ_name :: OccName -> SDoc
+ppr_z_occ_name occ = ztext (zEncodeFS (occNameFS occ))
+
+-- Prints (if mod information is available) "Defined at <loc>" or
+--  "Defined in <mod>" information for a Name.
+pprDefinedAt :: Name -> SDoc
+pprDefinedAt name = text "Defined" <+> pprNameDefnLoc name
+
+pprNameDefnLoc :: Name -> SDoc
+-- Prints "at <loc>" or
+--     or "in <mod>" depending on what info is available
+pprNameDefnLoc name
+  = case nameSrcLoc name of
+         -- nameSrcLoc rather than nameSrcSpan
+         -- It seems less cluttered to show a location
+         -- rather than a span for the definition point
+       RealSrcLoc s -> text "at" <+> ppr s
+       UnhelpfulLoc s
+         | isInternalName name || isSystemName name
+         -> text "at" <+> ftext s
+         | otherwise
+         -> text "in" <+> quotes (ppr (nameModule name))
+
+
+-- | Get a string representation of a 'Name' that's unique and stable
+-- across recompilations. Used for deterministic generation of binds for
+-- derived instances.
+-- eg. "$aeson_70dylHtv1FFGeai1IoxcQr$Data.Aeson.Types.Internal$String"
+nameStableString :: Name -> String
+nameStableString Name{..} =
+  nameSortStableString n_sort ++ "$" ++ occNameString n_occ
+
+nameSortStableString :: NameSort -> String
+nameSortStableString System = "$_sys"
+nameSortStableString Internal = "$_in"
+nameSortStableString (External mod) = moduleStableString mod
+nameSortStableString (WiredIn mod _ _) = moduleStableString mod
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Overloaded functions related to Names}
+*                                                                      *
+************************************************************************
+-}
+
+-- | A class allowing convenient access to the 'Name' of various datatypes
+class NamedThing a where
+    getOccName :: a -> OccName
+    getName    :: a -> Name
+
+    getOccName n = nameOccName (getName n)      -- Default method
+
+instance NamedThing e => NamedThing (Located e) where
+    getName = getName . unLoc
+
+getSrcLoc           :: NamedThing a => a -> SrcLoc
+getSrcSpan          :: NamedThing a => a -> SrcSpan
+getOccString        :: NamedThing a => a -> String
+getOccFS            :: NamedThing a => a -> FastString
+
+getSrcLoc           = nameSrcLoc           . getName
+getSrcSpan          = nameSrcSpan          . getName
+getOccString        = occNameString        . getOccName
+getOccFS            = occNameFS            . getOccName
+
+pprInfixName :: (Outputable a, NamedThing a) => a -> SDoc
+-- See Outputable.pprPrefixVar, pprInfixVar;
+-- add parens or back-quotes as appropriate
+pprInfixName  n = pprInfixVar (isSymOcc (getOccName n)) (ppr n)
+
+pprPrefixName :: NamedThing a => a -> SDoc
+pprPrefixName thing = pprPrefixVar (isSymOcc (nameOccName name)) (ppr name)
+ where
+   name = getName thing

ghc-toolkit/boot-libs/ghc/basicTypes/Name.hs-boot

@@ -0,0 +1,5 @@
+module Name where
+
+import GhcPrelude ()
+
+data Name

ghc-toolkit/boot-libs/ghc/basicTypes/NameCache.hs

@@ -0,0 +1,120 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE RankNTypes #-}
+
+-- | The Name Cache
+module NameCache
+    ( lookupOrigNameCache
+    , extendOrigNameCache
+    , extendNameCache
+    , initNameCache
+    , NameCache(..), OrigNameCache
+    ) where
+
+import GhcPrelude
+
+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

ghc-toolkit/boot-libs/ghc/basicTypes/NameEnv.hs

@@ -0,0 +1,154 @@
+{-
+(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 GhcPrelude
+
+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]
+-- Perform dependency analysis on a group of definitions,
+-- where each definition may define more than one Name
+--
+-- The get_defs and get_uses functions are called only once per node
+depAnal get_defs get_uses nodes
+  = stronglyConnCompFromEdgedVerticesUniq (map mk_node keyed_nodes)
+  where
+    keyed_nodes = nodes `zip` [(1::Int)..]
+    mk_node (node, key) =
+      DigraphNode 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

ghc-toolkit/boot-libs/ghc/basicTypes/NameSet.hs

@@ -0,0 +1,214 @@
+{-
+(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 GhcPrelude
+
+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

ghc-toolkit/boot-libs/ghc/basicTypes/OccName.hs

@@ -0,0 +1,925 @@
+{-
+(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,
+        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, avoidClashesOccEnv,
+
+        -- FsEnv
+        FastStringEnv, emptyFsEnv, lookupFsEnv, extendFsEnv, mkFsEnv
+    ) where
+
+import GhcPrelude
+
+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.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_"
+
+-- 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]
+
+-- 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)
+
+To achieve this, the function avoidClashesOccEnv can be used to prepare the
+TidyEnv, by “blocking” every name that occurs twice in the map. This way, none
+of the "a"s will get the privilege of keeping this name, and all of them will
+get a suitable number by tidyOccName.
+
+This prepared TidyEnv can then be used with tidyOccName. See tidyTyCoVarBndrs
+for an example where this is used.
+
+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]
+avoidClashesOccEnv :: TidyOccEnv -> [OccName] -> TidyOccEnv
+avoidClashesOccEnv env occs = go env emptyUFM occs
+  where
+    go env _        [] = env
+    go env seenOnce ((OccName _ fs):occs)
+      | fs `elemUFM` env      = go env seenOnce                  occs
+      | fs `elemUFM` seenOnce = go (addToUFM env fs 1) seenOnce  occs
+      | otherwise             = go env (addToUFM seenOnce fs ()) occs
+
+tidyOccName :: TidyOccEnv -> OccName -> (TidyOccEnv, OccName)
+tidyOccName env occ@(OccName occ_sp fs)
+  | not (fs `elemUFM` env)
+  = -- Desired OccName is free, so use it,
+    -- and record in 'env' that it's no longer available
+    (addToUFM env fs 1, occ)
+
+  | otherwise
+  = case lookupUFM env base1 of
+       Nothing -> (addToUFM env base1 2, OccName occ_sp base1)
+       Just n  -> find 1 n
+  where
+    base :: String  -- Drop trailing digits (see Note [TidyOccEnv])
+    base  = dropWhileEndLE isDigit (unpackFS fs)
+    base1 = mkFastString (base ++ "1")
+
+    find !k !n
+      = case 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)

ghc-toolkit/boot-libs/ghc/basicTypes/OccName.hs-boot

@@ -0,0 +1,5 @@
+module OccName where
+
+import GhcPrelude ()
+
+data OccName

ghc-toolkit/boot-libs/ghc/basicTypes/PatSyn.hs

@@ -0,0 +1,469 @@
+{-
+(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,
+
+        updatePatSynIds, pprPatSynType
+    ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+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
+
+        -- Universally-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
+        psResultTy   :: Type,  -- Mentions only psUnivTyVars
+                               -- See Note [Pattern synonym result type]
+
+        -- 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 result type]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+   data T a b = MkT b a
+
+   pattern P :: a -> T [a] Bool
+   pattern P x = MkT True [x]
+
+P's psResultTy is (T a Bool), and it really only matches values of
+type (T [a] Bool).  For example, this is ill-typed
+
+   f :: T p q -> String
+   f (P x) = "urk"
+
+This is different to the situation with GADTs:
+
+   data S a where
+     MkS :: Int -> S Bool
+
+Now MkS (and pattern synonyms coming from MkS) can match a
+value of type (S a), not just (S Bool); we get type refinement.
+
+That in turn means that if you have a pattern
+
+   P x :: T [ty] Bool
+
+it's not entirely straightforward to work out the instantiation of
+P's universal tyvars. You have to /match/
+  the type of the pattern, (T [ty] Bool)
+against
+  the psResultTy for the pattern synonym, T [a] Bool
+to get the instantiation a := ty.
+
+This is very unlike DataCons, where univ tyvars match 1-1 the
+arguments of the TyCon.
+
+
+Note [Pattern synonym representation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider the following pattern synonym declaration
+
+        pattern P x = MkT [x] (Just 42)
+
+where
+        data T a where
+              MkT :: (Show a, Ord b) => [b] -> a -> T a
+
+so pattern P has type
+
+        b -> T (Maybe t)
+
+with the following typeclass constraints:
+
+        requires: (Eq t, Num t)
+        provides: (Show (Maybe t), Ord b)
+
+In this case, the fields of MkPatSyn will be set as follows:
+
+  psArgs       = [b]
+  psArity      = 1
+  psInfix      = False
+
+  psUnivTyVars = [t]
+  psExTyVars   = [b]
+  psProvTheta  = (Show (Maybe t), Ord b)
+  psReqTheta   = (Eq t, Num t)
+  psResultTy  = T (Maybe t)
+
+Note [Matchers and builders for pattern synonyms]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For each pattern synonym P, we generate
+
+  * a "matcher" function, used to desugar uses of P in patterns,
+    which implements pattern matching
+
+  * A "builder" function (for bidirectional pattern synonyms only),
+    used to desugar uses of P in expressions, which constructs P-values.
+
+For the above example, the matcher function has type:
+
+        $mP :: forall (r :: ?) t. (Eq t, Num t)
+            => T (Maybe t)
+            -> (forall b. (Show (Maybe t), Ord b) => b -> r)
+            -> (Void# -> r)
+            -> r
+
+with the following implementation:
+
+        $mP @r @t $dEq $dNum scrut cont fail
+          = case scrut of
+              MkT @b $dShow $dOrd [x] (Just 42) -> cont @b $dShow $dOrd x
+              _                                 -> fail Void#
+
+Notice that the return type 'r' has an open kind, so that it can
+be instantiated by an unboxed type; for example where we see
+     f (P x) = 3#
+
+The extra Void# argument for the failure continuation is needed so that
+it is lazy even when the result type is unboxed.
+
+For the same reason, if the pattern has no arguments, an extra Void#
+argument is added to the success continuation as well.
+
+For *bidirectional* pattern synonyms, we also generate a "builder"
+function which implements the pattern synonym in an expression
+context. For our running example, it will be:
+
+        $bP :: forall t b. (Eq t, Num t, Show (Maybe t), Ord b)
+            => b -> T (Maybe t)
+        $bP x = MkT [x] (Just 42)
+
+NB: the existential/universal and required/provided split does not
+apply to the builder since you are only putting stuff in, not getting
+stuff out.
+
+Injectivity of bidirectional pattern synonyms is checked in
+tcPatToExpr which walks the pattern and returns its corresponding
+expression when available.
+
+Note [Builder for pattern synonyms with unboxed type]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For bidirectional pattern synonyms that have no arguments and have an
+unboxed type, we add an extra Void# argument to the builder, else it
+would be a top-level declaration with an unboxed type.
+
+        pattern P = 0#
+
+        $bP :: Void# -> Int#
+        $bP _ = 0#
+
+This means that when typechecking an occurrence of P in an expression,
+we must remember that the builder has this void argument. This is
+done by 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] in TcSigs):
+
+    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,
+                psResultTy = orig_res_ty,
+                psMatcher = matcher,
+                psBuilder = builder,
+                psFieldLabels = field_labels
+                }
+
+-- | The 'Name' of the 'PatSyn', giving it a unique, rooted identification
+patSynName :: PatSyn -> Name
+patSynName = psName
+
+-- | Should the 'PatSyn' be presented infix?
+patSynIsInfix :: PatSyn -> Bool
+patSynIsInfix = psInfix
+
+-- | Arity of the pattern synonym
+patSynArity :: PatSyn -> Arity
+patSynArity = psArity
+
+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, psResultTy = 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
+
+updatePatSynIds :: (Id -> Id) -> PatSyn -> PatSyn
+updatePatSynIds 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( tyvars `equalLength` inst_tys
+          , text "patSynInstArgTys" <+> ppr name $$ ppr tyvars $$ ppr inst_tys )
+    map (substTyWith tyvars inst_tys) arg_tys
+  where
+    tyvars = binderVars (univ_tvs ++ ex_tvs)
+
+patSynInstResTy :: PatSyn -> [Type] -> Type
+-- Return the type of whole pattern
+-- E.g.  pattern P x y = Just (x,x,y)
+--         P :: a -> b -> Just (a,a,b)
+--         (patSynInstResTy P [Int,Bool] = Maybe (Int,Int,Bool)
+-- NB: unlike patSynInstArgTys, the inst_tys should be just the *universal* tyvars
+patSynInstResTy (MkPatSyn { psName = name, psUnivTyVars = univ_tvs
+                          , psResultTy = res_ty })
+                inst_tys
+  = ASSERT2( univ_tvs `equalLength` inst_tys
+           , text "patSynInstResTy" <+> ppr name $$ ppr univ_tvs $$ ppr inst_tys )
+    substTyWith (binderVars univ_tvs) inst_tys res_ty
+
+-- | Print the type of a pattern synonym. The foralls are printed explicitly
+pprPatSynType :: PatSyn -> SDoc
+pprPatSynType (MkPatSyn { psUnivTyVars = univ_tvs,  psReqTheta  = req_theta
+                        , psExTyVars   = ex_tvs,    psProvTheta = prov_theta
+                        , psArgs       = orig_args, psResultTy = orig_res_ty })
+  = sep [ pprForAll 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)

ghc-toolkit/boot-libs/ghc/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

ghc-toolkit/boot-libs/ghc/basicTypes/SrcLoc.hs

@@ -0,0 +1,690 @@
+-- (c) The University of Glasgow, 1992-2006
+
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE DeriveFunctor      #-}
+{-# LANGUAGE DeriveFoldable     #-}
+{-# LANGUAGE DeriveTraversable  #-}
+{-# LANGUAGE FlexibleInstances  #-}
+{-# LANGUAGE RecordWildCards    #-}
+{-# LANGUAGE TypeFamilies       #-}
+{-# LANGUAGE ViewPatterns       #-}
+{-# LANGUAGE FlexibleContexts   #-}
+{-# LANGUAGE PatternSynonyms    #-}
+
+
+-- | 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,
+        unRealSrcSpan, getRealSrcSpan,
+
+        -- ** Combining and comparing Located values
+        eqLocated, cmpLocated, combineLocs, addCLoc,
+        leftmost_smallest, leftmost_largest, rightmost,
+        spans, isSubspanOf, sortLocated,
+
+        -- ** HasSrcSpan
+        HasSrcSpan(..), SrcSpanLess, dL, cL,
+        pattern LL, onHasSrcSpan, liftL
+    ) where
+
+import GhcPrelude
+
+import Util
+import Json
+import Outputable
+import FastString
+
+import Control.DeepSeq
+import Data.Bits
+import Data.Data
+import Data.List
+import Data.Ord
+
+{-
+************************************************************************
+*                                                                      *
+\subsection[SrcLoc-SrcLocations]{Source-location information}
+*                                                                      *
+************************************************************************
+
+We keep information about the {\em definition} point for each entity;
+this is the obvious stuff:
+-}
+
+-- | Real Source Location
+--
+-- Represents a single point within a file
+data RealSrcLoc
+  = SrcLoc      FastString              -- A precise location (file name)
+                {-# UNPACK #-} !Int     -- line number, begins at 1
+                {-# UNPACK #-} !Int     -- column number, begins at 1
+  deriving (Eq, Ord)
+
+-- | Source Location
+data SrcLoc
+  = RealSrcLoc {-# UNPACK #-}!RealSrcLoc
+  | UnhelpfulLoc FastString     -- Just a general indication
+  deriving (Eq, Ord, Show)
+
+{-
+************************************************************************
+*                                                                      *
+\subsection[SrcLoc-access-fns]{Access functions}
+*                                                                      *
+************************************************************************
+-}
+
+mkSrcLoc :: FastString -> Int -> Int -> SrcLoc
+mkSrcLoc x line col = RealSrcLoc (mkRealSrcLoc x line col)
+
+mkRealSrcLoc :: FastString -> Int -> Int -> RealSrcLoc
+mkRealSrcLoc x line col = SrcLoc x line col
+
+-- | Built-in "bad" 'SrcLoc' values for particular locations
+noSrcLoc, generatedSrcLoc, interactiveSrcLoc :: SrcLoc
+noSrcLoc          = UnhelpfulLoc (fsLit "<no location info>")
+generatedSrcLoc   = UnhelpfulLoc (fsLit "<compiler-generated code>")
+interactiveSrcLoc = UnhelpfulLoc (fsLit "<interactive>")
+
+-- | Creates a "bad" 'SrcLoc' that has no detailed information about its location
+mkGeneralSrcLoc :: FastString -> SrcLoc
+mkGeneralSrcLoc = UnhelpfulLoc
+
+-- | Gives the filename of the 'RealSrcLoc'
+srcLocFile :: RealSrcLoc -> FastString
+srcLocFile (SrcLoc fname _ _) = fname
+
+-- | Raises an error when used on a "bad" 'SrcLoc'
+srcLocLine :: RealSrcLoc -> Int
+srcLocLine (SrcLoc _ l _) = l
+
+-- | Raises an error when used on a "bad" 'SrcLoc'
+srcLocCol :: RealSrcLoc -> Int
+srcLocCol (SrcLoc _ _ c) = c
+
+-- | Move the 'SrcLoc' down by one line if the character is a newline,
+-- to the next 8-char tabstop if it is a tab, and across by one
+-- character in any other case
+advanceSrcLoc :: RealSrcLoc -> Char -> RealSrcLoc
+advanceSrcLoc (SrcLoc f l _) '\n' = SrcLoc f  (l + 1) 1
+advanceSrcLoc (SrcLoc f l c) '\t' = SrcLoc f  l (((((c - 1) `shiftR` 3) + 1)
+                                                  `shiftL` 3) + 1)
+advanceSrcLoc (SrcLoc f l c) _    = SrcLoc f  l (c + 1)
+
+{-
+************************************************************************
+*                                                                      *
+\subsection[SrcLoc-instances]{Instance declarations for various names}
+*                                                                      *
+************************************************************************
+-}
+
+sortLocated :: HasSrcSpan a => [a] -> [a]
+sortLocated things = sortBy (comparing getLoc) things
+
+instance Outputable RealSrcLoc where
+    ppr (SrcLoc src_path src_line src_col)
+      = hcat [ pprFastFilePath src_path <> colon
+             , int src_line <> colon
+             , int src_col ]
+
+-- I don't know why there is this style-based difference
+--        if userStyle sty || debugStyle sty then
+--            hcat [ pprFastFilePath src_path, char ':',
+--                   int src_line,
+--                   char ':', int src_col
+--                 ]
+--        else
+--            hcat [text "{-# LINE ", int src_line, space,
+--                  char '\"', pprFastFilePath src_path, text " #-}"]
+
+instance Outputable SrcLoc where
+    ppr (RealSrcLoc l) = ppr l
+    ppr (UnhelpfulLoc s)  = ftext s
+
+instance Data RealSrcSpan where
+  -- don't traverse?
+  toConstr _   = abstractConstr "RealSrcSpan"
+  gunfold _ _  = error "gunfold"
+  dataTypeOf _ = mkNoRepType "RealSrcSpan"
+
+instance Data SrcSpan where
+  -- don't traverse?
+  toConstr _   = abstractConstr "SrcSpan"
+  gunfold _ _  = error "gunfold"
+  dataTypeOf _ = mkNoRepType "SrcSpan"
+
+{-
+************************************************************************
+*                                                                      *
+\subsection[SrcSpan]{Source Spans}
+*                                                                      *
+************************************************************************
+-}
+
+{- |
+A 'RealSrcSpan' delimits a portion of a text file.  It could be represented
+by a pair of (line,column) coordinates, but in fact we optimise
+slightly by using more compact representations for single-line and
+zero-length spans, both of which are quite common.
+
+The end position is defined to be the column /after/ the end of the
+span.  That is, a span of (1,1)-(1,2) is one character long, and a
+span of (1,1)-(1,1) is zero characters long.
+-}
+
+-- | Real Source Span
+data RealSrcSpan
+  = RealSrcSpan'
+        { srcSpanFile     :: !FastString,
+          srcSpanSLine    :: {-# UNPACK #-} !Int,
+          srcSpanSCol     :: {-# UNPACK #-} !Int,
+          srcSpanELine    :: {-# UNPACK #-} !Int,
+          srcSpanECol     :: {-# UNPACK #-} !Int
+        }
+  deriving Eq
+
+-- | Source Span
+--
+-- A 'SrcSpan' identifies either a specific portion of a text file
+-- or a human-readable description of a location.
+data SrcSpan =
+    RealSrcSpan !RealSrcSpan
+  | UnhelpfulSpan !FastString   -- Just a general indication
+                                -- also used to indicate an empty span
+
+  deriving (Eq, Ord, Show) -- Show is used by Lexer.x, because we
+                           -- derive Show for Token
+
+instance ToJson SrcSpan where
+  json (UnhelpfulSpan {} ) = JSNull --JSObject [( "type", "unhelpful")]
+  json (RealSrcSpan rss)  = json rss
+
+instance ToJson RealSrcSpan where
+  json (RealSrcSpan'{..}) = JSObject [ ("file", JSString (unpackFS srcSpanFile))
+                                     , ("startLine", JSInt srcSpanSLine)
+                                     , ("startCol", JSInt srcSpanSCol)
+                                     , ("endLine", JSInt srcSpanELine)
+                                     , ("endCol", JSInt srcSpanECol)
+                                     ]
+
+instance NFData SrcSpan where
+  rnf x = x `seq` ()
+
+-- | Built-in "bad" 'SrcSpan's for common sources of location uncertainty
+noSrcSpan, wiredInSrcSpan, interactiveSrcSpan :: SrcSpan
+noSrcSpan          = UnhelpfulSpan (fsLit "<no location info>")
+wiredInSrcSpan     = UnhelpfulSpan (fsLit "<wired into compiler>")
+interactiveSrcSpan = UnhelpfulSpan (fsLit "<interactive>")
+
+-- | Create a "bad" 'SrcSpan' that has not location information
+mkGeneralSrcSpan :: FastString -> SrcSpan
+mkGeneralSrcSpan = UnhelpfulSpan
+
+-- | Create a 'SrcSpan' corresponding to a single point
+srcLocSpan :: SrcLoc -> SrcSpan
+srcLocSpan (UnhelpfulLoc str) = UnhelpfulSpan str
+srcLocSpan (RealSrcLoc l) = RealSrcSpan (realSrcLocSpan l)
+
+realSrcLocSpan :: RealSrcLoc -> RealSrcSpan
+realSrcLocSpan (SrcLoc file line col) = RealSrcSpan' file line col line col
+
+-- | Create a 'SrcSpan' between two points in a file
+mkRealSrcSpan :: RealSrcLoc -> RealSrcLoc -> RealSrcSpan
+mkRealSrcSpan loc1 loc2 = RealSrcSpan' file line1 col1 line2 col2
+  where
+        line1 = srcLocLine loc1
+        line2 = srcLocLine loc2
+        col1 = srcLocCol loc1
+        col2 = srcLocCol loc2
+        file = srcLocFile loc1
+
+-- | 'True' if the span is known to straddle only one line.
+isOneLineRealSpan :: RealSrcSpan -> Bool
+isOneLineRealSpan (RealSrcSpan' _ line1 _ line2 _)
+  = line1 == line2
+
+-- | 'True' if the span is a single point
+isPointRealSpan :: RealSrcSpan -> Bool
+isPointRealSpan (RealSrcSpan' _ line1 col1 line2 col2)
+  = line1 == line2 && col1 == col2
+
+-- | Create a 'SrcSpan' between two points in a file
+mkSrcSpan :: SrcLoc -> SrcLoc -> SrcSpan
+mkSrcSpan (UnhelpfulLoc str) _ = UnhelpfulSpan str
+mkSrcSpan _ (UnhelpfulLoc str) = UnhelpfulSpan str
+mkSrcSpan (RealSrcLoc loc1) (RealSrcLoc loc2)
+    = RealSrcSpan (mkRealSrcSpan loc1 loc2)
+
+-- | Combines two 'SrcSpan' into one that spans at least all the characters
+-- within both spans. Returns UnhelpfulSpan if the files differ.
+combineSrcSpans :: SrcSpan -> SrcSpan -> SrcSpan
+combineSrcSpans (UnhelpfulSpan _) r = r -- this seems more useful
+combineSrcSpans l (UnhelpfulSpan _) = l
+combineSrcSpans (RealSrcSpan span1) (RealSrcSpan span2)
+  | srcSpanFile span1 == srcSpanFile span2
+      = RealSrcSpan (combineRealSrcSpans span1 span2)
+  | otherwise = UnhelpfulSpan (fsLit "<combineSrcSpans: files differ>")
+
+-- | 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 = GenLocated SrcSpan
+type RealLocated = GenLocated RealSrcSpan
+
+unLoc :: HasSrcSpan a => a -> SrcSpanLess a
+unLoc (dL->L _ e) = e
+
+getLoc :: HasSrcSpan a => a -> SrcSpan
+getLoc (dL->L l _) = l
+
+noLoc :: HasSrcSpan a => SrcSpanLess a -> a
+noLoc e = cL noSrcSpan e
+
+mkGeneralLocated :: HasSrcSpan e => String -> SrcSpanLess e -> e
+mkGeneralLocated s e = cL (mkGeneralSrcSpan (fsLit s)) e
+
+combineLocs :: (HasSrcSpan a , HasSrcSpan b) => a -> b -> SrcSpan
+combineLocs a b = combineSrcSpans (getLoc a) (getLoc b)
+
+-- | Combine locations from two 'Located' things and add them to a third thing
+addCLoc :: (HasSrcSpan a , HasSrcSpan b , HasSrcSpan c) =>
+           a -> b -> SrcSpanLess c -> c
+addCLoc a b c = cL (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 :: (HasSrcSpan a , Eq (SrcSpanLess a)) => a -> 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 :: (HasSrcSpan a , Ord (SrcSpanLess a)) => a -> 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))
+                whenPprDebug (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
+
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{HasSrcSpan Typeclass to Set/Get Source Location Spans}
+*                                                                      *
+************************************************************************
+-}
+
+{-
+Note [HasSrcSpan Typeclass]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+To be able to uniformly set/get source location spans (of `SrcSpan`) in
+syntactic entities (`HsSyn`), we use the typeclass `HasSrcSpan`.
+More details can be found at the following wiki page
+  ImplementingTreesThatGrow/HandlingSourceLocations
+
+For most syntactic entities, the source location spans are stored in
+a syntactic entity by a wapper constuctor (introduced by TTG's
+new constructor extension), e.g., by `NewPat (WrapperPat sp pat)`
+for a source location span `sp` and a pattern `pat`.
+-}
+
+-- | Determines the type of undecorated syntactic entities
+-- For most syntactic entities `E`, where source location spans are
+-- introduced by a wrapper construtor of the same syntactic entity,
+-- we have `SrcSpanLess E = E`.
+-- However, some syntactic entities have a different type compared to
+-- a syntactic entity `e :: E` may have the type `Located E` when
+-- decorated by wrapping it with `L sp e` for a source span `sp`.
+type family SrcSpanLess a
+
+-- | A typeclass to set/get SrcSpans
+class HasSrcSpan a where
+  -- | Composes a `SrcSpan` decoration with an undecorated syntactic
+  --   entity to form its decorated variant
+  composeSrcSpan   :: Located (SrcSpanLess a) -> a
+
+  -- | Decomposes a decorated syntactic entity into its `SrcSpan`
+  --   decoration and its undecorated variant
+  decomposeSrcSpan :: a -> Located (SrcSpanLess a)
+  {- laws:
+       composeSrcSpan . decomposeSrcSpan = id
+       decomposeSrcSpan . composeSrcSpan = id
+
+     in other words, `HasSrcSpan` defines an iso relation between
+     a `SrcSpan`-decorated syntactic entity and its undecorated variant
+     (together with the `SrcSpan`).
+  -}
+
+type instance SrcSpanLess (GenLocated l e) = e
+instance HasSrcSpan (Located a) where
+  composeSrcSpan   = id
+  decomposeSrcSpan = id
+
+
+-- | An abbreviated form of decomposeSrcSpan,
+--   mainly to be used in ViewPatterns
+dL :: HasSrcSpan a => a -> Located (SrcSpanLess a)
+dL = decomposeSrcSpan
+
+-- | An abbreviated form of composeSrcSpan,
+--   mainly to replace the hardcoded `L`
+cL :: HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
+cL sp e = composeSrcSpan (L sp e)
+
+-- | A Pattern Synonym to Set/Get SrcSpans
+pattern LL :: HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
+pattern LL sp e <- (dL->L sp e)
+  where
+        LL sp e = cL sp e
+
+-- | Lifts a function of undecorated entities to one of decorated ones
+onHasSrcSpan :: (HasSrcSpan a , HasSrcSpan b) =>
+                (SrcSpanLess a -> SrcSpanLess b) -> a -> b
+onHasSrcSpan f (dL->L l e) = cL l (f e)
+
+liftL :: (HasSrcSpan a, HasSrcSpan b, Monad m) =>
+         (SrcSpanLess a -> m (SrcSpanLess b)) -> a -> m b
+liftL f (dL->L loc a) = do
+  a' <- f a
+  return $ cL loc a'
+
+
+getRealSrcSpan :: RealLocated a -> RealSrcSpan
+getRealSrcSpan (L l _) = l
+
+unRealSrcSpan :: RealLocated a -> a
+unRealSrcSpan  (L _ e) = e

ghc-toolkit/boot-libs/ghc/basicTypes/UniqSupply.hs

@@ -0,0 +1,260 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+-}
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE PatternSynonyms #-}
+
+#if !defined(GHC_LOADED_INTO_GHCI)
+{-# LANGUAGE UnboxedTuples #-}
+#endif
+
+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 GhcPrelude
+
+import Unique
+import PlainPanic (panic)
+
+import GHC.IO
+
+import MonadUtils
+import Control.Monad
+import Data.Bits
+import Data.Char
+import Control.Monad.Fail as Fail
+
+#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@}
+*                                                                      *
+************************************************************************
+-}
+
+-- Avoids using unboxed tuples when loading into GHCi
+#if !defined(GHC_LOADED_INTO_GHCI)
+
+type UniqResult result = (# result, UniqSupply #)
+
+pattern UniqResult :: a -> b -> (# a, b #)
+pattern UniqResult x y = (# x, y #)
+{-# COMPLETE UniqResult #-}
+
+#else
+
+data UniqResult result = UniqResult !result {-# UNPACK #-} !UniqSupply
+
+#endif
+
+-- | A monad which just gives the ability to obtain 'Unique's
+newtype UniqSM result = USM { unUSM :: UniqSupply -> UniqResult result }
+
+instance Monad UniqSM where
+  (>>=) = thenUs
+  (>>)  = (*>)
+
+instance Functor UniqSM where
+    fmap f (USM x) = USM (\us0 -> case x us0 of
+                                 UniqResult r us1 -> UniqResult (f r) us1)
+
+instance Applicative UniqSM where
+    pure = returnUs
+    (USM f) <*> (USM x) = USM $ \us0 -> case f us0 of
+                            UniqResult ff us1 -> case x us1 of
+                              UniqResult xx us2 -> UniqResult (ff xx) us2
+    (*>) = thenUs_
+
+-- TODO: try to get rid of this instance
+instance Fail.MonadFail UniqSM where
+    fail = panic
+
+-- | Run the 'UniqSM' action, returning the final 'UniqSupply'
+initUs :: UniqSupply -> UniqSM a -> (a, UniqSupply)
+initUs init_us m = case unUSM m init_us of { UniqResult r us -> (r, us) }
+
+-- | Run the 'UniqSM' action, discarding the final 'UniqSupply'
+initUs_ :: UniqSupply -> UniqSM a -> a
+initUs_ init_us m = case unUSM m init_us of { UniqResult r _ -> r }
+
+{-# INLINE thenUs #-}
+{-# INLINE lazyThenUs #-}
+{-# INLINE returnUs #-}
+{-# INLINE splitUniqSupply #-}
+
+-- @thenUs@ is where we split the @UniqSupply@.
+
+liftUSM :: UniqSM a -> UniqSupply -> (a, UniqSupply)
+liftUSM (USM m) us0 = case m us0 of UniqResult a us1 -> (a, us1)
+
+instance MonadFix UniqSM where
+    mfix m = USM (\us0 -> let (r,us1) = liftUSM (m r) us0 in UniqResult r us1)
+
+thenUs :: UniqSM a -> (a -> UniqSM b) -> UniqSM b
+thenUs (USM expr) cont
+  = USM (\us0 -> case (expr us0) of
+                   UniqResult result us1 -> unUSM (cont result) us1)
+
+lazyThenUs :: UniqSM a -> (a -> UniqSM b) -> UniqSM b
+lazyThenUs expr cont
+  = USM (\us0 -> let (result, us1) = liftUSM expr us0 in unUSM (cont result) us1)
+
+thenUs_ :: UniqSM a -> UniqSM b -> UniqSM b
+thenUs_ (USM expr) (USM cont)
+  = USM (\us0 -> case (expr us0) of { UniqResult _ us1 -> cont us1 })
+
+returnUs :: a -> UniqSM a
+returnUs result = USM (\us -> UniqResult result us)
+
+getUs :: UniqSM UniqSupply
+getUs = USM (\us0 -> case splitUniqSupply us0 of (us1,us2) -> UniqResult us1 us2)
+
+-- | A monad for generating unique identifiers
+class Monad m => MonadUnique m where
+    -- | Get a new UniqueSupply
+    getUniqueSupplyM :: m UniqSupply
+    -- | Get a new unique identifier
+    getUniqueM  :: m Unique
+    -- | Get an infinite list of new unique identifiers
+    getUniquesM :: m [Unique]
+
+    -- This default definition of getUniqueM, while correct, is not as
+    -- efficient as it could be since it needlessly generates and throws away
+    -- an extra Unique. For your instances consider providing an explicit
+    -- definition for 'getUniqueM' which uses 'takeUniqFromSupply' directly.
+    getUniqueM  = liftM uniqFromSupply  getUniqueSupplyM
+    getUniquesM = liftM uniqsFromSupply getUniqueSupplyM
+
+instance MonadUnique UniqSM where
+    getUniqueSupplyM = getUs
+    getUniqueM  = getUniqueUs
+    getUniquesM = getUniquesUs
+
+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 (\us0 -> case takeUniqFromSupply us0 of
+                           (u,us1) -> UniqResult u us1)
+
+getUniquesUs :: UniqSM [Unique]
+getUniquesUs = USM (\us0 -> case splitUniqSupply us0 of
+                            (us1,us2) -> UniqResult (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)

ghc-toolkit/boot-libs/ghc/basicTypes/Unique.hs

@@ -0,0 +1,445 @@
+{-
+(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
+        eqUnique, ltUnique,
+
+        deriveUnique,                   -- Ditto
+        newTagUnique,                   -- Used in CgCase
+        initTyVarUnique,
+        initExitJoinUnique,
+        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, mkPrimOpWrapperUnique,
+        mkPreludeMiscIdUnique, mkPreludeDataConUnique,
+        mkPreludeTyConUnique, mkPreludeClassUnique,
+        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, dataConTyRepNameUnique
+    ) where
+
+#include "HsVersions.h"
+#include "Unique.h"
+
+import GhcPrelude
+
+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
+
+ltUnique :: Unique -> Unique -> Bool
+ltUnique (MkUnique u1) (MkUnique u2) = u1 < u2
+
+-- Provided here to make it explicit at the call-site that it can
+-- introduce non-determinism.
+-- See Note [Unique Determinism]
+-- See Note [No Ord for Unique]
+nonDetCmpUnique :: Unique -> Unique -> Ordering
+nonDetCmpUnique (MkUnique u1) (MkUnique u2)
+  = if u1 == u2 then EQ else if u1 < u2 then LT else GT
+
+{-
+Note [No Ord for Unique]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+As explained in Note [Unique Determinism] the relative order of Uniques
+is nondeterministic. To prevent from accidental use the Ord Unique
+instance has been removed.
+This makes it easier to maintain deterministic builds, but comes with some
+drawbacks.
+The biggest drawback is that Maps keyed by Uniques can't directly be used.
+The alternatives are:
+
+  1) Use UniqFM or UniqDFM, see Note [Deterministic UniqFM] to decide which
+  2) Create a newtype wrapper based on Unique ordering where nondeterminism
+     is controlled. See 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
+-- See Note [Primop wrappers] in PrimOp.hs.
+mkPrimOpWrapperUnique  :: Int -> Unique
+mkPreludeMiscIdUnique  :: 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
+
+--------------------------------------------------
+dataConTyRepNameUnique, dataConWorkerUnique :: Unique -> Unique
+dataConWorkerUnique  u = incrUnique u
+dataConTyRepNameUnique u = stepUnique u 2
+
+--------------------------------------------------
+mkPrimOpIdUnique op         = mkUnique '9' (2*op)
+mkPrimOpWrapperUnique op    = mkUnique '9' (2*op+1)
+mkPreludeMiscIdUnique  i    = mkUnique '0' i
+
+-- 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)
+
+initExitJoinUnique :: Unique
+initExitJoinUnique = mkUnique 's' 0

ghc-toolkit/boot-libs/ghc/basicTypes/Var.hs

@@ -0,0 +1,684 @@
+{-
+(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, TcTyVar, 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
+        VarBndr(..), ArgFlag(..), TyCoVarBinder, TyVarBinder,
+        binderVar, binderVars, binderArgFlag, binderType,
+        isVisibleArgFlag, isInvisibleArgFlag, sameVis,
+        mkTyCoVarBinder, mkTyCoVarBinders,
+        mkTyVarBinder, mkTyVarBinders,
+        isTyVarBinder,
+
+        -- ** 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 GhcPrelude
+
+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 that might be a metavariable
+type TcTyVar = Var
+
+-- | Type Variable
+type TypeVar = Var     -- Definitely a type variable
+
+-- | Kind Variable
+type KindVar = Var     -- Definitely a kind variable
+                       -- See Note [Kind and type variables]
+
+-- See Note [Evidence: EvIds and CoVars]
+-- | Evidence Identifier
+type EvId   = Id        -- Term-level evidence: DictId, IpId, or EqVar
+
+-- | Evidence Variable
+type EvVar  = EvId      -- ...historical name for EvId
+
+-- | Dictionary Function Identifier
+type DFunId = Id        -- A dictionary function
+
+-- | Dictionary Identifier
+type DictId = EvId      -- A dictionary variable
+
+-- | Implicit parameter Identifier
+type IpId   = EvId      -- A term-level implicit parameter
+
+-- | Equality Variable
+type EqVar  = EvId      -- Boxed equality evidence
+type JoinId = Id        -- A join variable
+
+-- | Type or Coercion Variable
+type TyCoVar = Id       -- Type, *or* coercion variable
+                        --   predicate: isTyCoVar
+
+
+{- Many passes apply a substitution, and it's very handy to have type
+   synonyms to remind us whether or not the substitution has been applied -}
+
+type InVar      = Var
+type InTyVar    = TyVar
+type InCoVar    = CoVar
+type 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 used to mean kind *or* type variables. KindVar is used when we
+know for sure that it is a kind variable. In future, we might want to
+go over the whole compiler code to use:
+   - TKVar   to mean kind or type variables
+   - TypeVar to mean         type variables only
+   - KindVar to mean kind         variables
+
+
+************************************************************************
+*                                                                      *
+\subsection{The main data type declarations}
+*                                                                      *
+************************************************************************
+
+
+Every @Var@ has a @Unique@, to uniquify it and for fast comparison, a
+@Type@, and an @IdInfo@ (non-essential info about it, e.g.,
+strictness).  The essential info about different kinds of @Vars@ is
+in its @VarDetails@.
+-}
+
+-- | Variable
+--
+-- Essentially a typed 'Name', that may also contain some additional information
+-- about the 'Var' and its use sites.
+data Var
+  = TyVar {  -- Type and kind variables
+             -- see Note [Kind and type variables]
+        varName    :: !Name,
+        realUnique :: {-# UNPACK #-} !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 [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in TyCoRep
+data ArgFlag = Inferred | Specified | Required
+  deriving (Eq, Ord, Data)
+  -- (<) on ArgFlag means "is less visible than"
+
+-- | 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
+
+instance Outputable ArgFlag where
+  ppr Required  = text "[req]"
+  ppr Specified = text "[spec]"
+  ppr Inferred  = text "[infrd]"
+
+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
+
+{- *********************************************************************
+*                                                                      *
+*                   VarBndr, TyCoVarBinder
+*                                                                      *
+********************************************************************* -}
+
+-- Variable Binder
+--
+-- VarBndr is polymorphic in both var and visibility fields.
+-- Currently there are six different uses of 'VarBndr':
+--   * Var.TyVarBinder   = VarBndr TyVar ArgFlag
+--   * Var.TyCoVarBinder = VarBndr TyCoVar ArgFlag
+--   * TyCon.TyConBinder     = VarBndr TyVar TyConBndrVis
+--   * TyCon.TyConTyCoBinder = VarBndr TyCoVar TyConBndrVis
+--   * IfaceType.IfaceForAllBndr  = VarBndr IfaceBndr ArgFlag
+--   * IfaceType.IfaceTyConBinder = VarBndr IfaceBndr TyConBndrVis
+data VarBndr var argf = Bndr var argf
+  deriving( Data )
+
+-- | Variable Binder
+--
+-- A 'TyCoVarBinder' 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
+--
+-- A 'TyVarBinder' is a binder with only TyVar
+type TyCoVarBinder = VarBndr TyCoVar ArgFlag
+type TyVarBinder   = VarBndr TyVar ArgFlag
+
+binderVar :: VarBndr tv argf -> tv
+binderVar (Bndr v _) = v
+
+binderVars :: [VarBndr tv argf] -> [tv]
+binderVars tvbs = map binderVar tvbs
+
+binderArgFlag :: VarBndr tv argf -> argf
+binderArgFlag (Bndr _ argf) = argf
+
+binderType :: VarBndr TyCoVar argf -> Type
+binderType (Bndr tv _) = varType tv
+
+-- | Make a named binder
+mkTyCoVarBinder :: ArgFlag -> TyCoVar -> TyCoVarBinder
+mkTyCoVarBinder vis var = Bndr var vis
+
+-- | Make a named binder
+-- 'var' should be a type variable
+mkTyVarBinder :: ArgFlag -> TyVar -> TyVarBinder
+mkTyVarBinder vis var
+  = ASSERT( isTyVar var )
+    Bndr var vis
+
+-- | Make many named binders
+mkTyCoVarBinders :: ArgFlag -> [TyCoVar] -> [TyCoVarBinder]
+mkTyCoVarBinders vis = map (mkTyCoVarBinder vis)
+
+-- | Make many named binders
+-- Input vars should be type variables
+mkTyVarBinders :: ArgFlag -> [TyVar] -> [TyVarBinder]
+mkTyVarBinders vis = map (mkTyVarBinder vis)
+
+isTyVarBinder :: TyCoVarBinder -> Bool
+isTyVarBinder (Bndr v _) = isTyVar v
+
+instance Outputable tv => Outputable (VarBndr tv ArgFlag) where
+  ppr (Bndr v Required)  = ppr v
+  ppr (Bndr v Specified) = char '@' <> ppr v
+  ppr (Bndr v Inferred)  = braces (ppr v)
+
+instance (Binary tv, Binary vis) => Binary (VarBndr tv vis) where
+  put_ bh (Bndr tv vis) = do { put_ bh tv; put_ bh vis }
+
+  get bh = do { tv <- get bh; vis <- get bh; return (Bndr tv vis) }
+
+instance NamedThing tv => NamedThing (VarBndr tv flag) where
+  getName (Bndr tv _) = getName 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 }
+
+{-
+%************************************************************************
+%*                                                                      *
+\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

ghc-toolkit/boot-libs/ghc/basicTypes/VarEnv.hs

@@ -0,0 +1,606 @@
+{-
+(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, filterDVarEnv,
+        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, mkEmptyTidyEnv
+    ) where
+
+import GhcPrelude
+
+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)
+
+mkEmptyTidyEnv :: TidyOccEnv -> TidyEnv
+mkEmptyTidyEnv occ_env = (occ_env, 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
+
+filterDVarEnv      :: (a -> Bool) -> DVarEnv a -> DVarEnv a
+filterDVarEnv = filterUDFM
+
+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

ghc-toolkit/boot-libs/ghc/basicTypes/VarSet.hs

@@ -0,0 +1,350 @@
+{-
+(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, mapVarSet,
+        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, dVarSetIntersectVarSet,
+        intersectsDVarSet, disjointDVarSet,
+        isEmptyDVarSet, delDVarSet, delDVarSetList,
+        minusDVarSet, foldDVarSet, filterDVarSet, mapDVarSet,
+        dVarSetMinusVarSet, anyDVarSet, allDVarSet,
+        transCloDVarSet,
+        sizeDVarSet, seqDVarSet,
+        partitionDVarSet,
+        dVarSetToVarSet,
+    ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+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
+
+mapVarSet :: Uniquable b => (a -> b) -> UniqSet a -> UniqSet b
+mapVarSet = mapUniqSet
+
+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
+
+-- The new element always goes to the right of existing ones.
+extendDVarSet :: DVarSet -> Var -> DVarSet
+extendDVarSet = addOneToUniqDSet
+
+elemDVarSet :: Var -> DVarSet -> Bool
+elemDVarSet = elementOfUniqDSet
+
+dVarSetElems :: DVarSet -> [Var]
+dVarSetElems = uniqDSetToList
+
+subDVarSet :: DVarSet -> DVarSet -> Bool
+subDVarSet s1 s2 = isEmptyDVarSet (s1 `minusDVarSet` s2)
+
+unionDVarSet :: DVarSet -> DVarSet -> DVarSet
+unionDVarSet = unionUniqDSets
+
+unionDVarSets :: [DVarSet] -> DVarSet
+unionDVarSets = unionManyUniqDSets
+
+-- | Map the function over the list, and union the results
+mapUnionDVarSet  :: (a -> DVarSet) -> [a] -> DVarSet
+mapUnionDVarSet get_set xs = foldr (unionDVarSet . get_set) emptyDVarSet xs
+
+intersectDVarSet :: DVarSet -> DVarSet -> DVarSet
+intersectDVarSet = intersectUniqDSets
+
+dVarSetIntersectVarSet :: DVarSet -> VarSet -> DVarSet
+dVarSetIntersectVarSet = uniqDSetIntersectUniqSet
+
+-- | True if empty intersection
+disjointDVarSet :: DVarSet -> DVarSet -> Bool
+disjointDVarSet s1 s2 = disjointUDFM (getUniqDSet s1) (getUniqDSet s2)
+
+-- | True if non-empty intersection
+intersectsDVarSet :: DVarSet -> DVarSet -> Bool
+intersectsDVarSet s1 s2 = not (s1 `disjointDVarSet` s2)
+
+isEmptyDVarSet :: DVarSet -> Bool
+isEmptyDVarSet = isEmptyUniqDSet
+
+delDVarSet :: DVarSet -> Var -> DVarSet
+delDVarSet = delOneFromUniqDSet
+
+minusDVarSet :: DVarSet -> DVarSet -> DVarSet
+minusDVarSet = minusUniqDSet
+
+dVarSetMinusVarSet :: DVarSet -> VarSet -> DVarSet
+dVarSetMinusVarSet = uniqDSetMinusUniqSet
+
+foldDVarSet :: (Var -> a -> a) -> a -> DVarSet -> a
+foldDVarSet = foldUniqDSet
+
+anyDVarSet :: (Var -> Bool) -> DVarSet -> Bool
+anyDVarSet p = anyUDFM p . getUniqDSet
+
+allDVarSet :: (Var -> Bool) -> DVarSet -> Bool
+allDVarSet p = allUDFM p . getUniqDSet
+
+mapDVarSet :: Uniquable b => (a -> b) -> UniqDSet a -> UniqDSet b
+mapDVarSet = mapUniqDSet
+
+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 . getUniqDSet
+
+-- | transCloVarSet for DVarSet
+transCloDVarSet :: (DVarSet -> DVarSet)
+                  -- Map some variables in the set to
+                  -- extra variables that should be in it
+                -> DVarSet -> DVarSet
+-- (transCloDVarSet f s) repeatedly applies f to new candidates, adding any
+-- new variables to s that it finds thereby, until it reaches a fixed point.
+--
+-- The function fn could be (Var -> DVarSet), but we use (DVarSet -> DVarSet)
+-- for efficiency, so that the test can be batched up.
+-- It's essential that fn will work fine if given new candidates
+-- one at 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

ghc-toolkit/boot-libs/ghc/cbits/genSym.c

@@ -0,0 +1,40 @@
+#include <assert.h>
+#include "Rts.h"
+#include "Unique.h"
+
+static HsInt GenSymCounter = 0;
+static HsInt GenSymInc = 1;
+
+#define UNIQUE_BITS (sizeof (HsInt) * 8 - UNIQUE_TAG_BITS)
+#define UNIQUE_MASK ((1ULL << UNIQUE_BITS) - 1)
+
+STATIC_INLINE void checkUniqueRange(HsInt u STG_UNUSED) {
+#if DEBUG
+    // Uh oh! We will overflow next time a unique is requested.
+    assert(u != UNIQUE_MASK);
+#endif
+}
+
+HsInt genSym(void) {
+#if defined(THREADED_RTS)
+    if (n_capabilities == 1) {
+        GenSymCounter = (GenSymCounter + GenSymInc) & UNIQUE_MASK;
+        checkUniqueRange(GenSymCounter);
+        return GenSymCounter;
+    } else {
+        HsInt n = atomic_inc((StgWord *)&GenSymCounter, GenSymInc)
+          & UNIQUE_MASK;
+        checkUniqueRange(n);
+        return n;
+    }
+#else
+    GenSymCounter = (GenSymCounter + GenSymInc) & UNIQUE_MASK;
+    checkUniqueRange(GenSymCounter);
+    return GenSymCounter;
+#endif
+}
+
+void initGenSym(HsInt NewGenSymCounter, HsInt NewGenSymInc) {
+  GenSymCounter = NewGenSymCounter;
+  GenSymInc = NewGenSymInc;
+}

ghc-toolkit/boot-libs/ghc/cmm/Bitmap.hs

@@ -0,0 +1,134 @@
+{-# LANGUAGE 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
+
+import GhcPrelude
+
+import SMRep
+import DynFlags
+import Util
+
+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
+

ghc-toolkit/boot-libs/ghc/cmm/BlockId.hs

@@ -0,0 +1,46 @@
+{-# 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 GhcPrelude
+
+import CLabel
+import IdInfo
+import Name
+import Unique
+import UniqSupply
+
+import Hoopl.Label (Label, mkHooplLabel)
+
+----------------------------------------------------------------
+--- Block Ids, their environments, and their sets
+
+{- Note [Unique BlockId]
+~~~~~~~~~~~~~~~~~~~~~~~~
+Although a 'BlockId' is a local label, for reasons of implementation,
+'BlockId's must be unique within an entire compilation unit.  The reason
+is that each local label is mapped to an assembly-language label, and in
+most assembly languages allow, a label is visible throughout the entire
+compilation unit in which it appears.
+-}
+
+type BlockId = Label
+
+mkBlockId :: Unique -> BlockId
+mkBlockId unique = mkHooplLabel $ getKey unique
+
+newBlockId :: MonadUnique m => m BlockId
+newBlockId = mkBlockId <$> getUniqueM
+
+blockLbl :: BlockId -> CLabel
+blockLbl label = mkLocalBlockLabel (getUnique label)
+
+infoTblLbl :: BlockId -> CLabel
+infoTblLbl label
+  = mkBlockInfoTableLabel (mkFCallName (getUnique label) "block") NoCafRefs

ghc-toolkit/boot-libs/ghc/cmm/BlockId.hs-boot

@@ -0,0 +1,8 @@
+module BlockId (BlockId, mkBlockId) where
+
+import Hoopl.Label (Label)
+import Unique (Unique)
+
+type BlockId = Label
+
+mkBlockId :: Unique -> BlockId

ghc-toolkit/boot-libs/ghc/cmm/Cmm.hs

@@ -0,0 +1,230 @@
+-- Cmm representations using Hoopl's Graph CmmNode e x.
+{-# LANGUAGE GADTs #-}
+
+module Cmm (
+     -- * Cmm top-level datatypes
+     CmmProgram, CmmGroup, GenCmmGroup,
+     CmmDecl, GenCmmDecl(..),
+     CmmGraph, GenCmmGraph(..),
+     CmmBlock,
+     RawCmmDecl, RawCmmGroup,
+     Section(..), SectionType(..), CmmStatics(..), CmmStatic(..),
+     isSecConstant,
+
+     -- ** Blocks containing lists
+     GenBasicBlock(..), blockId,
+     ListGraph(..), pprBBlock,
+
+     -- * Info Tables
+     CmmTopInfo(..), CmmStackInfo(..), CmmInfoTable(..), topInfoTable,
+     ClosureTypeInfo(..),
+     ProfilingInfo(..), ConstrDescription,
+
+     -- * Statements, expressions and types
+     module CmmNode,
+     module CmmExpr,
+  ) where
+
+import GhcPrelude
+
+import Id
+import CostCentre
+import CLabel
+import BlockId
+import CmmNode
+import SMRep
+import CmmExpr
+import Hoopl.Block
+import Hoopl.Collections
+import Hoopl.Graph
+import Hoopl.Label
+import Outputable
+
+import Data.Word        ( Word8 )
+
+-----------------------------------------------------------------------------
+--  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
+
+-----------------------------------------------------------------------------
+--     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  :: Maybe CLabel,   -- empty, or a closure address
+      cit_clo  :: Maybe (Id, CostCentreStack)
+        -- Just (id,ccs) <=> build a static closure later
+        -- Nothing <=> don't build a static closure
+        --
+        -- Static closures for FUNs and THUNKs are *not* generated by
+        -- the code generator, because we might want to add SRT
+        -- entries to them later (for FUNs at least; THUNKs are
+        -- treated the same for consistency). See Note [SRTs] in
+        -- CmmBuildInfoTables, in particular the [FUN] optimisation.
+        --
+        -- This is strictly speaking not a part of the info table that
+        -- will be finally generated, but it's the only convenient
+        -- place to convey this information from the code generator to
+        -- where we build the static closures in
+        -- CmmBuildInfoTables.doSRTs.
+    }
+
+data ProfilingInfo
+  = NoProfilingInfo
+  | ProfilingInfo [Word8] [Word8] -- closure_type, closure_desc
+
+-----------------------------------------------------------------------------
+--              Static Data
+-----------------------------------------------------------------------------
+
+data SectionType
+  = Text
+  | Data
+  | ReadOnlyData
+  | RelocatableReadOnlyData
+  | UninitialisedData
+  | ReadOnlyData16      -- .rodata.cst16 on x86_64, 16-byte aligned
+  | CString
+  | OtherSection String
+  deriving (Show)
+
+-- | 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
+
+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))
+

ghc-toolkit/boot-libs/ghc/cmm/CmmBuildInfoTables.hs

@@ -0,0 +1,896 @@
+{-# LANGUAGE GADTs, BangPatterns, RecordWildCards,
+    GeneralizedNewtypeDeriving, NondecreasingIndentation, TupleSections #-}
+
+module CmmBuildInfoTables
+  ( CAFSet, CAFEnv, cafAnal
+  , doSRTs, ModuleSRTInfo, emptySRT
+  ) where
+
+import GhcPrelude hiding (succ)
+
+import Id
+import BlockId
+import Hoopl.Block
+import Hoopl.Graph
+import Hoopl.Label
+import Hoopl.Collections
+import Hoopl.Dataflow
+import Module
+import Platform
+import Digraph
+import CLabel
+import PprCmmDecl ()
+import Cmm
+import CmmUtils
+import DynFlags
+import Maybes
+import Outputable
+import SMRep
+import UniqSupply
+import CostCentre
+import StgCmmHeap
+
+import PprCmm()
+import Control.Monad
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Data.Set (Set)
+import qualified Data.Set as Set
+import Data.Tuple
+import Control.Monad.Trans.State
+import Control.Monad.Trans.Class
+
+
+{- Note [SRTs]
+
+SRTs are the mechanism by which the garbage collector can determine
+the live CAFs in the program.
+
+Representation
+^^^^^^^^^^^^^^
+
++------+
+| info |
+|      |     +-----+---+---+---+
+|   -------->|SRT_2| | | | | 0 |
+|------|     +-----+-|-+-|-+---+
+|      |             |   |
+| code |             |   |
+|      |             v   v
+
+An SRT is simply an object in the program's data segment. It has the
+same representation as a static constructor.  There are 16
+pre-compiled SRT info tables: stg_SRT_1_info, .. stg_SRT_16_info,
+representing SRT objects with 1-16 pointers, respectively.
+
+The entries of an SRT object point to static closures, which are either
+- FUN_STATIC, THUNK_STATIC or CONSTR
+- Another SRT (actually just a CONSTR)
+
+The final field of the SRT is the static link field, used by the
+garbage collector to chain together static closures that it visits and
+to determine whether a static closure has been visited or not. (see
+Note [STATIC_LINK fields])
+
+By traversing the transitive closure of an SRT, the GC will reach all
+of the CAFs that are reachable from the code associated with this SRT.
+
+If we need to create an SRT with more than 16 entries, we build a
+chain of SRT objects with all but the last having 16 entries.
+
++-----+---+- -+---+---+
+|SRT16| | |   | | | 0 |
++-----+-|-+- -+-|-+---+
+        |       |
+        v       v
+              +----+---+---+---+
+              |SRT2| | | | | 0 |
+              +----+-|-+-|-+---+
+                     |   |
+                     |   |
+                     v   v
+
+Referring to an SRT from the info table
+^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+
+The following things have SRTs:
+
+- Static functions (FUN)
+- Static thunks (THUNK), ie. CAFs
+- Continuations (RET_SMALL, etc.)
+
+In each case, the info table points to the SRT.
+
+- info->srt is zero if there's no SRT, otherwise:
+- info->srt == 1 and info->f.srt_offset points to the SRT
+
+e.g. for a FUN with an SRT:
+
+StgFunInfoTable       +------+
+  info->f.srt_offset  |  ------------> offset to SRT object
+StgStdInfoTable       +------+
+  info->layout.ptrs   | ...  |
+  info->layout.nptrs  | ...  |
+  info->srt           |  1   |
+  info->type          | ...  |
+                      |------|
+
+On x86_64, we optimise the info table representation further.  The
+offset to the SRT can be stored in 32 bits (all code lives within a
+2GB region in x86_64's small memory model), so we can save a word in
+the info table by storing the srt_offset in the srt field, which is
+half a word.
+
+On x86_64 with TABLES_NEXT_TO_CODE (except on MachO, due to #15169):
+
+- info->srt is zero if there's no SRT, otherwise:
+- info->srt is an offset from the info pointer to the SRT object
+
+StgStdInfoTable       +------+
+  info->layout.ptrs   |      |
+  info->layout.nptrs  |      |
+  info->srt           |  ------------> offset to SRT object
+                      |------|
+
+
+EXAMPLE
+^^^^^^^
+
+f = \x. ... g ...
+  where
+    g = \y. ... h ... c1 ...
+    h = \z. ... c2 ...
+
+c1 & c2 are CAFs
+
+g and h are local functions, but they have no static closures.  When
+we generate code for f, we start with a CmmGroup of four CmmDecls:
+
+   [ f_closure, f_entry, g_entry, h_entry ]
+
+we process each CmmDecl separately in cpsTop, giving us a list of
+CmmDecls. e.g. for f_entry, we might end up with
+
+   [ f_entry, f1_ret, f2_proc ]
+
+where f1_ret is a return point, and f2_proc is a proc-point.  We have
+a CAFSet for each of these CmmDecls, let's suppose they are
+
+   [ f_entry{g_info}, f1_ret{g_info}, f2_proc{} ]
+   [ g_entry{h_info, c1_closure} ]
+   [ h_entry{c2_closure} ]
+
+Next, we make an SRT for each of these functions:
+
+  f_srt : [g_info]
+  g_srt : [h_info, c1_closure]
+  h_srt : [c2_closure]
+
+Now, for g_info and h_info, we want to refer to the SRTs for g and h
+respectively, which we'll label g_srt and h_srt:
+
+  f_srt : [g_srt]
+  g_srt : [h_srt, c1_closure]
+  h_srt : [c2_closure]
+
+Now, when an SRT has a single entry, we don't actually generate an SRT
+closure for it, instead we just replace references to it with its
+single element.  So, since h_srt == c2_closure, we have
+
+  f_srt : [g_srt]
+  g_srt : [c2_closure, c1_closure]
+  h_srt : [c2_closure]
+
+and the only SRT closure we generate is
+
+  g_srt = SRT_2 [c2_closure, c1_closure]
+
+
+Optimisations
+^^^^^^^^^^^^^
+
+To reduce the code size overhead and the cost of traversing SRTs in
+the GC, we want to simplify SRTs where possible. We therefore apply
+the following optimisations.  Each has a [keyword]; search for the
+keyword in the code below to see where the optimisation is
+implemented.
+
+1. [Inline] we never create an SRT with a single entry, instead we
+   point to the single entry directly from the info table.
+
+   i.e. instead of
+
+    +------+
+    | info |
+    |      |     +-----+---+---+
+    |   -------->|SRT_1| | | 0 |
+    |------|     +-----+-|-+---+
+    |      |             |
+    | code |             |
+    |      |             v
+                         C
+
+   we can point directly to the closure:
+
+    +------+
+    | info |
+    |      |
+    |   -------->C
+    |------|
+    |      |
+    | code |
+    |      |
+
+
+   Furthermore, the SRT for any code that refers to this info table
+   can point directly to C.
+
+   The exception to this is when we're doing dynamic linking. In that
+   case, if the closure is not locally defined then we can't point to
+   it directly from the info table, because this is the text section
+   which cannot contain runtime relocations. In this case we skip this
+   optimisation and generate the singleton SRT, becase SRTs are in the
+   data section and *can* have relocatable references.
+
+2. [FUN] A static function closure can also be an SRT, we simply put
+   the SRT entries as fields in the static closure.  This makes a lot
+   of sense: the static references are just like the free variables of
+   the FUN closure.
+
+   i.e. instead of
+
+   f_closure:
+   +-----+---+
+   |  |  | 0 |
+   +- |--+---+
+      |            +------+
+      |            | info |     f_srt:
+      |            |      |     +-----+---+---+---+
+      |            |   -------->|SRT_2| | | | + 0 |
+      `----------->|------|     +-----+-|-+-|-+---+
+                   |      |             |   |
+                   | code |             |   |
+                   |      |             v   v
+
+
+   We can generate:
+
+   f_closure:
+   +-----+---+---+---+
+   |  |  | | | | | 0 |
+   +- |--+-|-+-|-+---+
+      |    |   |   +------+
+      |    v   v   | info |
+      |            |      |
+      |            |   0  |
+      `----------->|------|
+                   |      |
+                   | code |
+                   |      |
+
+
+   (note: we can't do this for THUNKs, because the thunk gets
+   overwritten when it is entered, so we wouldn't be able to share
+   this SRT with other info tables that want to refer to it (see
+   [Common] below). FUNs are immutable so don't have this problem.)
+
+3. [Common] Identical SRTs can be commoned up.
+
+4. [Filter] If an SRT A refers to an SRT B and a closure C, and B also
+   refers to C (perhaps transitively), then we can omit the reference
+   to C from A.
+
+
+Note that there are many other optimisations that we could do, but
+aren't implemented. In general, we could omit any reference from an
+SRT if everything reachable from it is also reachable from the other
+fields in the SRT. Our [Filter] optimisation is a special case of
+this.
+
+Another opportunity we don't exploit is this:
+
+A = {X,Y,Z}
+B = {Y,Z}
+C = {X,B}
+
+Here we could use C = {A} and therefore [Inline] C = A.
+-}
+
+-- ---------------------------------------------------------------------
+{- Note [Invalid optimisation: shortcutting]
+
+You might think that if we have something like
+
+A's SRT = {B}
+B's SRT = {X}
+
+that we could replace the reference to B in A's SRT with X.
+
+A's SRT = {X}
+B's SRT = {X}
+
+and thereby perhaps save a little work at runtime, because we don't
+have to visit B.
+
+But this is NOT valid.
+
+Consider these cases:
+
+0. B can't be a constructor, because constructors don't have SRTs
+
+1. B is a CAF. This is the easy one. Obviously we want A's SRT to
+   point to B, so that it keeps B alive.
+
+2. B is a function.  This is the tricky one. The reason we can't
+shortcut in this case is that we aren't allowed to resurrect static
+objects.
+
+== How does this cause a problem? ==
+
+The particular case that cropped up when we tried this was #15544.
+- A is a thunk
+- B is a static function
+- X is a CAF
+- suppose we GC when A is alive, and B is not otherwise reachable.
+- B is "collected", meaning that it doesn't make it onto the static
+  objects list during this GC, but nothing bad happens yet.
+- Next, suppose we enter A, and then call B. (remember that A refers to B)
+  At the entry point to B, we GC. This puts B on the stack, as part of the
+  RET_FUN stack frame that gets pushed when we GC at a function entry point.
+- This GC will now reach B
+- But because B was previous "collected", it breaks the assumption
+  that static objects are never resurrected. See Note [STATIC_LINK
+  fields] in rts/sm/Storage.h for why this is bad.
+- In practice, the GC thinks that B has already been visited, and so
+  doesn't visit X, and catastrophe ensues.
+
+== Isn't this caused by the RET_FUN business? ==
+
+Maybe, but could you prove that RET_FUN is the only way that
+resurrection can occur?
+
+So, no shortcutting.
+-}
+
+-- ---------------------------------------------------------------------
+-- Label types
+
+-- Labels that come from cafAnal can be:
+--   - _closure labels for static functions or CAFs
+--   - _info labels for dynamic functions, thunks, or continuations
+--   - _entry labels for functions or thunks
+--
+-- Meanwhile the labels on top-level blocks are _entry labels.
+--
+-- To put everything in the same namespace we convert all labels to
+-- closure labels using toClosureLbl.  Note that some of these
+-- labels will not actually exist; that's ok because we're going to
+-- map them to SRTEntry later, which ranges over labels that do exist.
+--
+newtype CAFLabel = CAFLabel CLabel
+  deriving (Eq,Ord,Outputable)
+
+type CAFSet = Set CAFLabel
+type CAFEnv = LabelMap CAFSet
+
+mkCAFLabel :: CLabel -> CAFLabel
+mkCAFLabel lbl = CAFLabel (toClosureLbl lbl)
+
+-- This is a label that we can put in an SRT.  It *must* be a closure label,
+-- pointing to either a FUN_STATIC, THUNK_STATIC, or CONSTR.
+newtype SRTEntry = SRTEntry CLabel
+  deriving (Eq, Ord, Outputable)
+
+-- ---------------------------------------------------------------------
+-- CAF analysis
+
+-- |
+-- For each code block:
+--   - collect the references reachable from this code block to FUN,
+--     THUNK or RET labels for which hasCAF == True
+--
+-- This gives us a `CAFEnv`: a mapping from code block to sets of labels
+--
+cafAnal
+  :: LabelSet   -- The blocks representing continuations, ie. those
+                -- that will get RET info tables.  These labels will
+                -- get their own SRTs, so we don't aggregate CAFs from
+                -- references to these labels, we just use the label.
+  -> CLabel     -- The top label of the proc
+  -> CmmGraph
+  -> CAFEnv
+cafAnal contLbls topLbl cmmGraph =
+  analyzeCmmBwd cafLattice
+    (cafTransfers contLbls (g_entry cmmGraph) topLbl) cmmGraph mapEmpty
+
+
+cafLattice :: DataflowLattice CAFSet
+cafLattice = DataflowLattice Set.empty add
+  where
+    add (OldFact old) (NewFact new) =
+        let !new' = old `Set.union` new
+        in changedIf (Set.size new' > Set.size old) new'
+
+
+cafTransfers :: LabelSet -> Label -> CLabel -> TransferFun CAFSet
+cafTransfers contLbls entry topLbl
+  (BlockCC eNode middle xNode) fBase =
+    let joined = cafsInNode xNode $! live'
+        !result = foldNodesBwdOO cafsInNode middle joined
+
+        facts = mapMaybe successorFact (successors xNode)
+        live' = joinFacts cafLattice facts
+
+        successorFact s
+          -- If this is a loop back to the entry, we can refer to the
+          -- entry label.
+          | s == entry = Just (add topLbl Set.empty)
+          -- If this is a continuation, we want to refer to the
+          -- SRT for the continuation's info table
+          | s `setMember` contLbls
+          = Just (Set.singleton (mkCAFLabel (infoTblLbl s)))
+          -- Otherwise, takes the CAF references from the destination
+          | otherwise
+          = lookupFact s fBase
+
+        cafsInNode :: CmmNode e x -> CAFSet -> CAFSet
+        cafsInNode node set = foldExpDeep addCaf node set
+
+        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 (mkCAFLabel l) s
+                | otherwise = s
+
+    in mapSingleton (entryLabel eNode) result
+
+
+-- -----------------------------------------------------------------------------
+-- ModuleSRTInfo
+
+data ModuleSRTInfo = ModuleSRTInfo
+  { thisModule :: Module
+    -- ^ Current module being compiled. Required for calling labelDynamic.
+  , dedupSRTs :: Map (Set SRTEntry) SRTEntry
+    -- ^ previous SRTs we've emitted, so we can de-duplicate.
+    -- Used to implement the [Common] optimisation.
+  , flatSRTs :: Map SRTEntry (Set SRTEntry)
+    -- ^ The reverse mapping, so that we can remove redundant
+    -- entries. e.g.  if we have an SRT [a,b,c], and we know that b
+    -- points to [c,d], we can omit c and emit [a,b].
+    -- Used to implement the [Filter] optimisation.
+  }
+instance Outputable ModuleSRTInfo where
+  ppr ModuleSRTInfo{..} =
+    text "ModuleSRTInfo:" <+> ppr dedupSRTs <+> ppr flatSRTs
+
+emptySRT :: Module -> ModuleSRTInfo
+emptySRT mod =
+  ModuleSRTInfo
+    { thisModule = mod
+    , dedupSRTs = Map.empty
+    , flatSRTs = Map.empty }
+
+-- -----------------------------------------------------------------------------
+-- Constructing SRTs
+
+{- Implementation notes
+
+- In each CmmDecl there is a mapping info_tbls from Label -> CmmInfoTable
+
+- The entry in info_tbls corresponding to g_entry is the closure info
+  table, the rest are continuations.
+
+- Each entry in info_tbls possibly needs an SRT.  We need to make a
+  label for each of these.
+
+- We get the CAFSet for each entry from the CAFEnv
+
+-}
+
+-- | Return a (Label,CLabel) pair for each labelled block of a CmmDecl,
+--   where the label is
+--   - the info label for a continuation or dynamic closure
+--   - the closure label for a top-level function (not a CAF)
+getLabelledBlocks :: CmmDecl -> [(Label, CAFLabel)]
+getLabelledBlocks (CmmData _ _) = []
+getLabelledBlocks (CmmProc top_info _ _ _) =
+  [ (blockId, mkCAFLabel (cit_lbl info))
+  | (blockId, info) <- mapToList (info_tbls top_info)
+  , let rep = cit_rep info
+  , not (isStaticRep rep) || not (isThunkRep rep)
+  ]
+
+
+-- | Put the labelled blocks that we will be annotating with SRTs into
+-- dependency order.  This is so that we can process them one at a
+-- time, resolving references to earlier blocks to point to their
+-- SRTs. CAFs themselves are not included here; see getCAFs below.
+depAnalSRTs
+  :: CAFEnv
+  -> [CmmDecl]
+  -> [SCC (Label, CAFLabel, Set CAFLabel)]
+depAnalSRTs cafEnv decls =
+  srtTrace "depAnalSRTs" (ppr graph) graph
+ where
+  labelledBlocks = concatMap getLabelledBlocks decls
+  labelToBlock = Map.fromList (map swap labelledBlocks)
+  graph = stronglyConnCompFromEdgedVerticesOrd
+             [ let cafs' = Set.delete lbl cafs in
+               DigraphNode (l,lbl,cafs') l
+                 (mapMaybe (flip Map.lookup labelToBlock) (Set.toList cafs'))
+             | (l, lbl) <- labelledBlocks
+             , Just cafs <- [mapLookup l cafEnv] ]
+
+
+-- | Get (Label, CAFLabel, Set CAFLabel) for each block that represents a CAF.
+-- These are treated differently from other labelled blocks:
+--  - we never shortcut a reference to a CAF to the contents of its
+--    SRT, since the point of SRTs is to keep CAFs alive.
+--  - CAFs therefore don't take part in the dependency analysis in depAnalSRTs.
+--    instead we generate their SRTs after everything else.
+getCAFs :: CAFEnv -> [CmmDecl] -> [(Label, CAFLabel, Set CAFLabel)]
+getCAFs cafEnv decls =
+  [ (g_entry g, mkCAFLabel topLbl, cafs)
+  | CmmProc top_info topLbl _ g <- decls
+  , Just info <- [mapLookup (g_entry g) (info_tbls top_info)]
+  , let rep = cit_rep info
+  , isStaticRep rep && isThunkRep rep
+  , Just cafs <- [mapLookup (g_entry g) cafEnv]
+  ]
+
+
+-- | Get the list of blocks that correspond to the entry points for
+-- FUN_STATIC closures.  These are the blocks for which if we have an
+-- SRT we can merge it with the static closure. [FUN]
+getStaticFuns :: [CmmDecl] -> [(BlockId, CLabel)]
+getStaticFuns decls =
+  [ (g_entry g, lbl)
+  | CmmProc top_info _ _ g <- decls
+  , Just info <- [mapLookup (g_entry g) (info_tbls top_info)]
+  , Just (id, _) <- [cit_clo info]
+  , let rep = cit_rep info
+  , isStaticRep rep && isFunRep rep
+  , let lbl = mkLocalClosureLabel (idName id) (idCafInfo id)
+  ]
+
+
+-- | Maps labels from 'cafAnal' to the final CLabel that will appear
+-- in the SRT.
+--   - closures with singleton SRTs resolve to their single entry
+--   - closures with larger SRTs map to the label for that SRT
+--   - CAFs must not map to anything!
+--   - if a labels maps to Nothing, we found that this label's SRT
+--     is empty, so we don't need to refer to it from other SRTs.
+type SRTMap = Map CAFLabel (Maybe SRTEntry)
+
+-- | resolve a CAFLabel to its SRTEntry using the SRTMap
+resolveCAF :: SRTMap -> CAFLabel -> Maybe SRTEntry
+resolveCAF srtMap lbl@(CAFLabel l) =
+  Map.findWithDefault (Just (SRTEntry (toClosureLbl l))) lbl srtMap
+
+
+-- | Attach SRTs to all info tables in the CmmDecls, and add SRT
+-- declarations to the ModuleSRTInfo.
+--
+doSRTs
+  :: DynFlags
+  -> ModuleSRTInfo
+  -> [(CAFEnv, [CmmDecl])]
+  -> IO (ModuleSRTInfo, [CmmDecl])
+
+doSRTs dflags moduleSRTInfo tops = do
+  us <- mkSplitUniqSupply 'u'
+
+  -- Ignore the original grouping of decls, and combine all the
+  -- CAFEnvs into a single CAFEnv.
+  let (cafEnvs, declss) = unzip tops
+      cafEnv = mapUnions cafEnvs
+      decls = concat declss
+      staticFuns = mapFromList (getStaticFuns decls)
+
+  -- Put the decls in dependency order. Why? So that we can implement
+  -- [Inline] and [Filter].  If we need to refer to an SRT that has
+  -- a single entry, we use the entry itself, which means that we
+  -- don't need to generate the singleton SRT in the first place.  But
+  -- to do this we need to process blocks before things that depend on
+  -- them.
+  let
+    sccs = depAnalSRTs cafEnv decls
+    cafsWithSRTs = getCAFs cafEnv decls
+
+  -- On each strongly-connected group of decls, construct the SRT
+  -- closures and the SRT fields for info tables.
+  let result ::
+        [ ( [CmmDecl]              -- generated SRTs
+          , [(Label, CLabel)]      -- SRT fields for info tables
+          , [(Label, [SRTEntry])]  -- SRTs to attach to static functions
+          ) ]
+      ((result, _srtMap), moduleSRTInfo') =
+        initUs_ us $
+        flip runStateT moduleSRTInfo $
+        flip runStateT Map.empty $ do
+          nonCAFs <- mapM (doSCC dflags staticFuns) sccs
+          cAFs <- forM cafsWithSRTs $ \(l, cafLbl, cafs) ->
+            oneSRT dflags staticFuns [l] [cafLbl] True{-is a CAF-} cafs
+          return (nonCAFs ++ cAFs)
+
+      (declss, pairs, funSRTs) = unzip3 result
+
+  -- Next, update the info tables with the SRTs
+  let
+    srtFieldMap = mapFromList (concat pairs)
+    funSRTMap = mapFromList (concat funSRTs)
+    decls' = concatMap (updInfoSRTs dflags srtFieldMap funSRTMap) decls
+
+  return (moduleSRTInfo', concat declss ++ decls')
+
+
+-- | Build the SRT for a strongly-connected component of blocks
+doSCC
+  :: DynFlags
+  -> LabelMap CLabel           -- which blocks are static function entry points
+  -> SCC (Label, CAFLabel, Set CAFLabel)
+  -> StateT SRTMap
+        (StateT ModuleSRTInfo UniqSM)
+        ( [CmmDecl]              -- generated SRTs
+        , [(Label, CLabel)]      -- SRT fields for info tables
+        , [(Label, [SRTEntry])]  -- SRTs to attach to static functions
+        )
+
+doSCC dflags staticFuns  (AcyclicSCC (l, cafLbl, cafs)) =
+  oneSRT dflags staticFuns [l] [cafLbl] False cafs
+
+doSCC dflags staticFuns (CyclicSCC nodes) = do
+  -- build a single SRT for the whole cycle, see Note [recursive SRTs]
+  let (blockids, lbls, cafsets) = unzip3 nodes
+      cafs = Set.unions cafsets
+  oneSRT dflags staticFuns blockids lbls False cafs
+
+
+{- Note [recursive SRTs]
+
+If the dependency analyser has found us a recursive group of
+declarations, then we build a single SRT for the whole group, on the
+grounds that everything in the group is reachable from everything
+else, so we lose nothing by having a single SRT.
+
+However, there are a couple of wrinkles to be aware of.
+
+* The Set CAFLabel for this SRT will contain labels in the group
+itself. The SRTMap will therefore not contain entries for these labels
+yet, so we can't turn them into SRTEntries using resolveCAF. BUT we
+can just remove recursive references from the Set CAFLabel before
+generating the SRT - the SRT will still contain all the CAFLabels that
+we need to refer to from this group's SRT.
+
+* That is, EXCEPT for static function closures. For the same reason
+described in Note [Invalid optimisation: shortcutting], we cannot omit
+references to static function closures.
+  - But, since we will merge the SRT with one of the static function
+    closures (see [FUN]), we can omit references to *that* static
+    function closure from the SRT.
+-}
+
+-- | Build an SRT for a set of blocks
+oneSRT
+  :: DynFlags
+  -> LabelMap CLabel            -- which blocks are static function entry points
+  -> [Label]                    -- blocks in this set
+  -> [CAFLabel]                 -- labels for those blocks
+  -> Bool                       -- True <=> this SRT is for a CAF
+  -> Set CAFLabel               -- SRT for this set
+  -> StateT SRTMap
+       (StateT ModuleSRTInfo UniqSM)
+       ( [CmmDecl]                    -- SRT objects we built
+       , [(Label, CLabel)]            -- SRT fields for these blocks' itbls
+       , [(Label, [SRTEntry])]        -- SRTs to attach to static functions
+       )
+
+oneSRT dflags staticFuns blockids lbls isCAF cafs = do
+  srtMap <- get
+  topSRT <- lift get
+  let
+    -- Can we merge this SRT with a FUN_STATIC closure?
+    (maybeFunClosure, otherFunLabels) =
+      case [ (l,b) | b <- blockids, Just l <- [mapLookup b staticFuns] ] of
+        [] -> (Nothing, [])
+        ((l,b):xs) -> (Just (l,b), map (mkCAFLabel . fst) xs)
+
+    -- Remove recursive references from the SRT, except for (all but
+    -- one of the) static functions. See Note [recursive SRTs].
+    nonRec = cafs `Set.difference`
+      (Set.fromList lbls `Set.difference` Set.fromList otherFunLabels)
+
+    -- First resolve all the CAFLabels to SRTEntries
+    -- Implements the [Inline] optimisation.
+    resolved =
+       Set.fromList $
+       catMaybes (map (resolveCAF srtMap) (Set.toList nonRec))
+
+    -- The set of all SRTEntries in SRTs that we refer to from here.
+    allBelow =
+      Set.unions [ lbls | caf <- Set.toList resolved
+                        , Just lbls <- [Map.lookup caf (flatSRTs topSRT)] ]
+
+    -- Remove SRTEntries that are also in an SRT that we refer to.
+    -- Implements the [Filter] optimisation.
+    filtered = Set.difference resolved allBelow
+
+  srtTrace "oneSRT:"
+     (ppr cafs <+> ppr resolved <+> ppr allBelow <+> ppr filtered) $ return ()
+
+  let
+    isStaticFun = isJust maybeFunClosure
+
+    -- For a label without a closure (e.g. a continuation), we must
+    -- update the SRTMap for the label to point to a closure. It's
+    -- important that we don't do this for static functions or CAFs,
+    -- see Note [Invalid optimisation: shortcutting].
+    updateSRTMap srtEntry =
+      when (not isCAF && not isStaticFun) $ do
+        let newSRTMap = Map.fromList [(cafLbl, srtEntry) | cafLbl <- lbls]
+        put (Map.union newSRTMap srtMap)
+
+    this_mod = thisModule topSRT
+
+  case Set.toList filtered of
+    [] -> do
+      srtTrace "oneSRT: empty" (ppr lbls) $ return ()
+      updateSRTMap Nothing
+      return ([], [], [])
+
+    -- [Inline] - when we have only one entry there is no need to
+    -- build an SRT object at all, instead we put the singleton SRT
+    -- entry in the info table.
+    [one@(SRTEntry lbl)]
+      | -- Info tables refer to SRTs by offset (as noted in the section
+        -- "Referring to an SRT from the info table" of Note [SRTs]). However,
+        -- when dynamic linking is used we cannot guarantee that the offset
+        -- between the SRT and the info table will fit in the offset field.
+        -- Consequently we build a singleton SRT in in this case.
+        not (labelDynamic dflags this_mod lbl)
+
+        -- MachO relocations can't express offsets between compilation units at
+        -- all, so we are always forced to build a singleton SRT in this case.
+          && (not (osMachOTarget $ platformOS $ targetPlatform dflags)
+             || isLocalCLabel this_mod lbl) -> do
+
+        -- If we have a static function closure, then it becomes the
+        -- SRT object, and everything else points to it. (the only way
+        -- we could have multiple labels here is if this is a
+        -- recursive group, see Note [recursive SRTs])
+        case maybeFunClosure of
+          Just (staticFunLbl,staticFunBlock) -> return ([], withLabels, [])
+            where
+              withLabels =
+                [ (b, if b == staticFunBlock then lbl else staticFunLbl)
+                | b <- blockids ]
+          Nothing -> do
+            updateSRTMap (Just one)
+            return ([], map (,lbl) blockids, [])
+
+    cafList ->
+      -- Check whether an SRT with the same entries has been emitted already.
+      -- Implements the [Common] optimisation.
+      case Map.lookup filtered (dedupSRTs topSRT) of
+        Just srtEntry@(SRTEntry srtLbl)  -> do
+          srtTrace "oneSRT [Common]" (ppr lbls <+> ppr srtLbl) $ return ()
+          updateSRTMap (Just srtEntry)
+          return ([], map (,srtLbl) blockids, [])
+        Nothing -> do
+          -- No duplicates: we have to build a new SRT object
+          srtTrace "oneSRT: new" (ppr lbls <+> ppr filtered) $ return ()
+          (decls, funSRTs, srtEntry) <-
+            case maybeFunClosure of
+              Just (fun,block) ->
+                return ( [], [(block, cafList)], SRTEntry fun )
+              Nothing -> do
+                (decls, entry) <- lift . lift $ buildSRTChain dflags cafList
+                return (decls, [], entry)
+          updateSRTMap (Just srtEntry)
+          let allBelowThis = Set.union allBelow filtered
+              oldFlatSRTs = flatSRTs topSRT
+              newFlatSRTs = Map.insert srtEntry allBelowThis oldFlatSRTs
+              newDedupSRTs = Map.insert filtered srtEntry (dedupSRTs topSRT)
+          lift (put (topSRT { dedupSRTs = newDedupSRTs
+                            , flatSRTs = newFlatSRTs }))
+          let SRTEntry lbl = srtEntry
+          return (decls, map (,lbl) blockids, funSRTs)
+
+
+-- | build a static SRT object (or a chain of objects) from a list of
+-- SRTEntries.
+buildSRTChain
+   :: DynFlags
+   -> [SRTEntry]
+   -> UniqSM
+        ( [CmmDecl]    -- The SRT object(s)
+        , SRTEntry     -- label to use in the info table
+        )
+buildSRTChain _ [] = panic "buildSRT: empty"
+buildSRTChain dflags cafSet =
+  case splitAt mAX_SRT_SIZE cafSet of
+    (these, []) -> do
+      (decl,lbl) <- buildSRT dflags these
+      return ([decl], lbl)
+    (these,those) -> do
+      (rest, rest_lbl) <- buildSRTChain dflags (head these : those)
+      (decl,lbl) <- buildSRT dflags (rest_lbl : tail these)
+      return (decl:rest, lbl)
+  where
+    mAX_SRT_SIZE = 16
+
+
+buildSRT :: DynFlags -> [SRTEntry] -> UniqSM (CmmDecl, SRTEntry)
+buildSRT dflags refs = do
+  id <- getUniqueM
+  let
+    lbl = mkSRTLabel id
+    srt_n_info = mkSRTInfoLabel (length refs)
+    fields =
+      mkStaticClosure dflags srt_n_info dontCareCCS
+        [ CmmLabel lbl | SRTEntry lbl <- refs ]
+        [] -- no padding
+        [mkIntCLit dflags 0] -- link field
+        [] -- no saved info
+  return (mkDataLits (Section Data lbl) lbl fields, SRTEntry lbl)
+
+
+-- | Update info tables with references to their SRTs. Also generate
+-- static closures, splicing in SRT fields as necessary.
+updInfoSRTs
+  :: DynFlags
+  -> LabelMap CLabel               -- SRT labels for each block
+  -> LabelMap [SRTEntry]           -- SRTs to merge into FUN_STATIC closures
+  -> CmmDecl
+  -> [CmmDecl]
+
+updInfoSRTs dflags srt_env funSRTEnv (CmmProc top_info top_l live g)
+  | Just (_,closure) <- maybeStaticClosure = [ proc, closure ]
+  | otherwise = [ proc ]
+  where
+    proc = CmmProc top_info { info_tbls = newTopInfo } top_l live g
+    newTopInfo = mapMapWithKey updInfoTbl (info_tbls top_info)
+    updInfoTbl l info_tbl
+      | l == g_entry g, Just (inf, _) <- maybeStaticClosure = inf
+      | otherwise  = info_tbl { cit_srt = mapLookup l srt_env }
+
+    -- Generate static closures [FUN].  Note that this also generates
+    -- static closures for thunks (CAFs), because it's easier to treat
+    -- them uniformly in the code generator.
+    maybeStaticClosure :: Maybe (CmmInfoTable, CmmDecl)
+    maybeStaticClosure
+      | Just info_tbl@CmmInfoTable{..} <-
+           mapLookup (g_entry g) (info_tbls top_info)
+      , Just (id, ccs) <- cit_clo
+      , isStaticRep cit_rep =
+        let
+          (newInfo, srtEntries) = case mapLookup (g_entry g) funSRTEnv of
+            Nothing ->
+              -- if we don't add SRT entries to this closure, then we
+              -- want to set the srt field in its info table as usual
+              (info_tbl { cit_srt = mapLookup (g_entry g) srt_env }, [])
+            Just srtEntries -> srtTrace "maybeStaticFun" (ppr res)
+              (info_tbl { cit_rep = new_rep }, res)
+              where res = [ CmmLabel lbl | SRTEntry lbl <- srtEntries ]
+          fields = mkStaticClosureFields dflags info_tbl ccs (idCafInfo id)
+            srtEntries
+          new_rep = case cit_rep of
+             HeapRep sta ptrs nptrs ty ->
+               HeapRep sta (ptrs + length srtEntries) nptrs ty
+             _other -> panic "maybeStaticFun"
+          lbl = mkLocalClosureLabel (idName id) (idCafInfo id)
+        in
+          Just (newInfo, mkDataLits (Section Data lbl) lbl fields)
+      | otherwise = Nothing
+
+updInfoSRTs _ _ _ t = [t]
+
+
+srtTrace :: String -> SDoc -> b -> b
+-- srtTrace = pprTrace
+srtTrace _ _ b = b

ghc-toolkit/boot-libs/ghc/cmm/CmmCallConv.hs

@@ -0,0 +1,212 @@
+module CmmCallConv (
+  ParamLocation(..),
+  assignArgumentsPos,
+  assignStack,
+  realArgRegsCover
+) where
+
+import GhcPrelude
+
+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
+
+-- We used to spill vector registers to the stack since the LLVM backend didn't
+-- support vector registers in its calling convention. However, this has now
+-- been fixed. This function remains only as a convenient way to re-enable
+-- spilling when debugging code generation.
+passVectorInReg :: Width -> DynFlags -> Bool
+passVectorInReg _ _ = True
+
+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)
+              off' = offset + size
+              -- Stack arguments always take a whole number of words, we never
+              -- pack them unlike constructor fields.
+              size = roundUpToWords dflags (widthInBytes w)
+
+-----------------------------------------------------------------------------
+-- 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)

ghc-toolkit/boot-libs/ghc/cmm/CmmCommonBlockElim.hs

@@ -0,0 +1,321 @@
+{-# LANGUAGE GADTs, BangPatterns, ScopedTypeVariables #-}
+
+module CmmCommonBlockElim
+  ( elimCommonBlocks
+  )
+where
+
+
+import GhcPrelude hiding (iterate, succ, unzip, zip)
+
+import BlockId
+import Cmm
+import CmmUtils
+import CmmSwitch (eqSwitchTargetWith)
+import CmmContFlowOpt
+-- import PprCmm ()
+
+import Hoopl.Block
+import Hoopl.Graph
+import Hoopl.Label
+import Hoopl.Collections
+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 qualified TrieMap as TM
+import UniqFM
+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
+     -- The order of blocks doesn't matter here. While we could use
+     -- revPostorder which drops unreachable blocks this is done in
+     -- ContFlowOpt already which runs before this pass. So we use
+     -- toBlockList since it is faster.
+     groups = groupByInt hash_block (toBlockList g) :: [[CmmBlock]]
+     blocks_with_key = [ [ (successors b, [b]) | b <- bs] | bs <- groups]
+
+-- Invariant: The blocks in the list are pairwise distinct
+-- (so avoid comparing them again)
+type DistinctBlocks = [CmmBlock]
+type Key = [Label]
+type Subst = LabelMap BlockId
+
+-- The outer list groups by hash. We retain this grouping throughout.
+iterate :: Subst -> [[(Key, DistinctBlocks)]] -> Subst
+iterate subst blocks
+    | mapNull new_substs = subst
+    | otherwise = iterate subst' updated_blocks
+  where
+    grouped_blocks :: [[(Key, [DistinctBlocks])]]
+    grouped_blocks = map groupByLabel blocks
+
+    merged_blocks :: [[(Key, DistinctBlocks)]]
+    (new_substs, merged_blocks) = List.mapAccumL (List.mapAccumL go) mapEmpty grouped_blocks
+      where
+        go !new_subst1 (k,dbs) = (new_subst1 `mapUnion` new_subst2, (k,db))
+          where
+            (new_subst2, db) = mergeBlockList subst dbs
+
+    subst' = subst `mapUnion` new_substs
+    updated_blocks = map (map (first (map (lookupBid subst')))) merged_blocks
+
+-- Combine two lists of blocks.
+-- While they are internally distinct they can still share common blocks.
+mergeBlocks :: Subst -> DistinctBlocks -> DistinctBlocks -> (Subst, DistinctBlocks)
+mergeBlocks subst existing new = go new
+  where
+    go [] = (mapEmpty, existing)
+    go (b:bs) = case List.find (eqBlockBodyWith (eqBid subst) b) existing of
+        -- This block is a duplicate. Drop it, and add it to the substitution
+        Just b' -> first (mapInsert (entryLabel b) (entryLabel b')) $ go bs
+        -- This block is not a duplicate, keep it.
+        Nothing -> second (b:) $ go bs
+
+mergeBlockList :: Subst -> [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 && eqListWith (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 = eqListWith 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 = eqListWith (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
+
+eqListWith :: (a -> b -> Bool) -> [a] -> [b] -> Bool
+eqListWith f (a : as) (b : bs) = f a b && eqListWith f as bs
+eqListWith _ []       []       = True
+eqListWith _ _        _        = False
+
+-- | Given a block map, ensure that all "target" blocks are covered by
+-- the same ticks as the respective "source" blocks. This not only
+-- means copying ticks, but also adjusting tick scopes where
+-- necessary.
+copyTicks :: LabelMap BlockId -> CmmGraph -> CmmGraph
+copyTicks env g
+  | mapNull env = g
+  | otherwise   = ofBlockMap (g_entry g) $ mapMap copyTo blockMap
+  where -- Reverse block merge map
+        blockMap = toBlockMap g
+        revEnv = mapFoldlWithKey insertRev M.empty env
+        insertRev m k x = M.insertWith (const (k:)) x [k] m
+        -- Copy ticks and scopes into the given block
+        copyTo block = case M.lookup (entryLabel block) revEnv of
+          Nothing -> block
+          Just ls -> foldr copy block $ mapMaybe (flip mapLookup blockMap) ls
+        copy from to =
+          let ticks = blockTicks from
+              CmmEntry  _   scp0        = firstNode from
+              (CmmEntry lbl scp1, code) = blockSplitHead to
+          in CmmEntry lbl (combineTickScopes scp0 scp1) `blockJoinHead`
+             foldr blockCons code (map CmmTick ticks)
+
+-- Group by [Label]
+-- See Note [Compressed TrieMap] in coreSyn/TrieMap about the usage of GenMap.
+groupByLabel :: [(Key, DistinctBlocks)] -> [(Key, [DistinctBlocks])]
+groupByLabel =
+  go (TM.emptyTM :: TM.ListMap (TM.GenMap LabelMap) (Key, [DistinctBlocks]))
+    where
+      go !m [] = TM.foldTM (:) m []
+      go !m ((k,v) : entries) = go (TM.alterTM k adjust m) entries
+        where --k' = map (getKey . getUnique) k
+              adjust Nothing       = Just (k,[v])
+              adjust (Just (_,vs)) = Just (k,v:vs)
+
+groupByInt :: (a -> Int) -> [a] -> [[a]]
+groupByInt f xs = nonDetEltsUFM $ List.foldl' go emptyUFM xs
+   -- See Note [Unique Determinism and code generation]
+  where
+    go m x = alterUFM addEntry m (f x)
+      where
+        addEntry xs = Just $! maybe [x] (x:) xs

ghc-toolkit/boot-libs/ghc/cmm/CmmContFlowOpt.hs

@@ -0,0 +1,444 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE BangPatterns #-}
+{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
+module CmmContFlowOpt
+    ( cmmCfgOpts
+    , cmmCfgOptsProc
+    , removeUnreachableBlocksProc
+    , replaceLabels
+    )
+where
+
+import GhcPrelude hiding (succ, unzip, zip)
+
+import Hoopl.Block
+import Hoopl.Collections
+import Hoopl.Graph
+import Hoopl.Label
+import BlockId
+import Cmm
+import CmmUtils
+import CmmSwitch (mapSwitchTargets)
+import Maybes
+import Panic
+import Util
+
+import Control.Monad
+
+
+-- Note [What is shortcutting]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- Consider this Cmm code:
+--
+-- L1: ...
+--     goto L2;
+-- L2: goto L3;
+-- L3: ...
+--
+-- Here L2 is an empty block and contains only an unconditional branch
+-- to L3. In this situation any block that jumps to L2 can jump
+-- directly to L3:
+--
+-- L1: ...
+--     goto L3;
+-- L2: goto L3;
+-- L3: ...
+--
+-- In this situation we say that we shortcut L2 to L3. One of
+-- consequences of shortcutting is that some blocks of code may become
+-- unreachable (in the example above this is true for L2).
+
+
+-- Note [Control-flow optimisations]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- This optimisation does three things:
+--
+--   - If a block finishes in an unconditional branch to another block
+--     and that is the only jump to that block we concatenate the
+--     destination block at the end of the current one.
+--
+--   - If a block finishes in a call whose continuation block is a
+--     goto, then we can shortcut the destination, making the
+--     continuation block the destination of the goto - but see Note
+--     [Shortcut call returns].
+--
+--   - For any block that is not a call we try to shortcut the
+--     destination(s). Additionally, if a block ends with a
+--     conditional branch we try to invert the condition.
+--
+-- Blocks are processed using postorder DFS traversal. A side effect
+-- of determining traversal order with a graph search is elimination
+-- of any blocks that are unreachable.
+--
+-- Transformations are improved by working from the end of the graph
+-- towards the beginning, because we may be able to perform many
+-- shortcuts in one go.
+
+
+-- Note [Shortcut call returns]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- We are going to maintain the "current" graph (LabelMap CmmBlock) as
+-- we go, and also a mapping from BlockId to BlockId, representing
+-- continuation labels that we have renamed.  This latter mapping is
+-- important because we might shortcut a CmmCall continuation.  For
+-- example:
+--
+--    Sp[0] = L
+--    call g returns to L
+--    L: goto M
+--    M: ...
+--
+-- So when we shortcut the L block, we need to replace not only
+-- the continuation of the call, but also references to L in the
+-- code (e.g. the assignment Sp[0] = L):
+--
+--    Sp[0] = M
+--    call g returns to M
+--    M: ...
+--
+-- So we keep track of which labels we have renamed and apply the mapping
+-- at the end with replaceLabels.
+
+
+-- Note [Shortcut call returns and proc-points]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- Consider this code that you might get from a recursive
+-- let-no-escape:
+--
+--       goto L1
+--      L1:
+--       if (Hp > HpLim) then L2 else L3
+--      L2:
+--       call stg_gc_noregs returns to L4
+--      L4:
+--       goto L1
+--      L3:
+--       ...
+--       goto L1
+--
+-- Then the control-flow optimiser shortcuts L4.  But that turns L1
+-- into the call-return proc point, and every iteration of the loop
+-- has to shuffle variables to and from the stack.  So we must *not*
+-- shortcut L4.
+--
+-- Moreover not shortcutting call returns is probably fine.  If L4 can
+-- concat with its branch target then it will still do so.  And we
+-- save some compile time because we don't have to traverse all the
+-- code in replaceLabels.
+--
+-- However, we probably do want to do this if we are splitting proc
+-- points, because L1 will be a proc-point anyway, so merging it with
+-- L4 reduces the number of proc points.  Unfortunately recursive
+-- let-no-escapes won't generate very good code with proc-point
+-- splitting on - we should probably compile them to explicitly use
+-- the native calling convention instead.
+
+cmmCfgOpts :: Bool -> CmmGraph -> CmmGraph
+cmmCfgOpts split g = fst (blockConcat split g)
+
+cmmCfgOptsProc :: Bool -> CmmDecl -> CmmDecl
+cmmCfgOptsProc split (CmmProc info lbl live g) = CmmProc info' lbl live g'
+    where (g', env) = blockConcat split g
+          info' = info{ info_tbls = new_info_tbls }
+          new_info_tbls = mapFromList (map upd_info (mapToList (info_tbls info)))
+
+          -- If we changed any labels, then we have to update the info tables
+          -- too, except for the top-level info table because that might be
+          -- referred to by other procs.
+          upd_info (k,info)
+             | Just k' <- mapLookup k env
+             = (k', if k' == g_entry g'
+                       then info
+                       else info{ cit_lbl = infoTblLbl k' })
+             | otherwise
+             = (k,info)
+cmmCfgOptsProc _ top = top
+
+
+blockConcat :: Bool -> CmmGraph -> (CmmGraph, LabelMap BlockId)
+blockConcat splitting_procs g@CmmGraph { g_entry = entry_id }
+  = (replaceLabels shortcut_map $ ofBlockMap new_entry new_blocks, shortcut_map')
+  where
+     -- We might be able to shortcut the entry BlockId itself.
+     -- Remember to update the shortcut_map, since we also have to
+     -- update the info_tbls mapping now.
+     (new_entry, shortcut_map')
+       | Just entry_blk <- mapLookup entry_id new_blocks
+       , Just dest      <- canShortcut entry_blk
+       = (dest, mapInsert entry_id dest shortcut_map)
+       | otherwise
+       = (entry_id, shortcut_map)
+
+     -- blocks are sorted in reverse postorder, but we want to go from the exit
+     -- towards beginning, so we use foldr below.
+     blocks = revPostorder g
+     blockmap = foldl' (flip addBlock) emptyBody blocks
+
+     -- Accumulator contains three components:
+     --  * map of blocks in a graph
+     --  * map of shortcut labels. See Note [Shortcut call returns]
+     --  * map containing number of predecessors for each block. We discard
+     --    it after we process all blocks.
+     (new_blocks, shortcut_map, _) =
+           foldr maybe_concat (blockmap, mapEmpty, initialBackEdges) blocks
+
+     -- Map of predecessors for initial graph. We increase number of
+     -- predecessors for entry block by one to denote that it is
+     -- target of a jump, even if no block in the current graph jumps
+     -- to it.
+     initialBackEdges = incPreds entry_id (predMap blocks)
+
+     maybe_concat :: CmmBlock
+                  -> (LabelMap CmmBlock, LabelMap BlockId, LabelMap Int)
+                  -> (LabelMap CmmBlock, LabelMap BlockId, LabelMap Int)
+     maybe_concat block (!blocks, !shortcut_map, !backEdges)
+        -- If:
+        --   (1) current block ends with unconditional branch to b' and
+        --   (2) it has exactly one predecessor (namely, current block)
+        --
+        -- Then:
+        --   (1) append b' block at the end of current block
+        --   (2) remove b' from the map of blocks
+        --   (3) remove information about b' from predecessors map
+        --
+        -- Since we know that the block has only one predecessor we call
+        -- mapDelete directly instead of calling decPreds.
+        --
+        -- Note that we always maintain an up-to-date list of predecessors, so
+        -- we can ignore the contents of shortcut_map
+        | CmmBranch b' <- last
+        , hasOnePredecessor b'
+        , Just blk' <- mapLookup b' blocks
+        = let bid' = entryLabel blk'
+          in ( mapDelete bid' $ mapInsert bid (splice head blk') blocks
+             , shortcut_map
+             , mapDelete b' backEdges )
+
+        -- If:
+        --   (1) we are splitting proc points (see Note
+        --       [Shortcut call returns and proc-points]) and
+        --   (2) current block is a CmmCall or CmmForeignCall with
+        --       continuation b' and
+        --   (3) we can shortcut that continuation to dest
+        -- Then:
+        --   (1) we change continuation to point to b'
+        --   (2) create mapping from b' to dest
+        --   (3) increase number of predecessors of dest by 1
+        --   (4) decrease number of predecessors of b' by 1
+        --
+        -- Later we will use replaceLabels to substitute all occurrences of b'
+        -- with dest.
+        | splitting_procs
+        , Just b'   <- callContinuation_maybe last
+        , Just blk' <- mapLookup b' blocks
+        , Just dest <- canShortcut blk'
+        = ( mapInsert bid (blockJoinTail head (update_cont dest)) blocks
+          , mapInsert b' dest shortcut_map
+          , decPreds b' $ incPreds dest backEdges )
+
+        -- If:
+        --   (1) a block does not end with a call
+        -- Then:
+        --   (1) if it ends with a conditional attempt to invert the
+        --       conditional
+        --   (2) attempt to shortcut all destination blocks
+        --   (3) if new successors of a block are different from the old ones
+        --       update the of predecessors accordingly
+        --
+        -- A special case of this is a situation when a block ends with an
+        -- unconditional jump to a block that can be shortcut.
+        | Nothing <- callContinuation_maybe last
+        = let oldSuccs = successors last
+              newSuccs = successors rewrite_last
+          in ( mapInsert bid (blockJoinTail head rewrite_last) blocks
+             , shortcut_map
+             , if oldSuccs == newSuccs
+               then backEdges
+               else foldr incPreds (foldr decPreds backEdges oldSuccs) newSuccs )
+
+        -- Otherwise don't do anything
+        | otherwise
+        = ( blocks, shortcut_map, backEdges )
+        where
+          (head, last) = blockSplitTail block
+          bid = entryLabel block
+
+          -- Changes continuation of a call to a specified label
+          update_cont dest =
+              case last of
+                CmmCall{}        -> last { cml_cont = Just dest }
+                CmmForeignCall{} -> last { succ = dest }
+                _                -> panic "Can't shortcut continuation."
+
+          -- Attempts to shortcut successors of last node
+          shortcut_last = mapSuccessors shortcut last
+            where
+              shortcut l =
+                 case mapLookup l blocks of
+                   Just b | Just dest <- canShortcut b -> dest
+                   _otherwise -> l
+
+          rewrite_last
+            -- Sometimes we can get rid of the conditional completely.
+            | CmmCondBranch _cond t f _l <- shortcut_last
+            , t == f
+            = CmmBranch t
+
+            -- See Note [Invert Cmm conditionals]
+            | CmmCondBranch cond t f l <- shortcut_last
+            , hasOnePredecessor t -- inverting will make t a fallthrough
+            , likelyTrue l || (numPreds f > 1)
+            , Just cond' <- maybeInvertCmmExpr cond
+            = CmmCondBranch cond' f t (invertLikeliness l)
+
+            | otherwise
+            = shortcut_last
+
+          likelyTrue (Just True)   = True
+          likelyTrue _             = False
+
+          invertLikeliness :: Maybe Bool -> Maybe Bool
+          invertLikeliness         = fmap not
+
+          -- Number of predecessors for a block
+          numPreds bid = mapLookup bid backEdges `orElse` 0
+
+          hasOnePredecessor b = numPreds b == 1
+
+{-
+  Note [Invert Cmm conditionals]
+  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+  The native code generator always produces jumps to the true branch.
+  Falling through to the false branch is however faster. So we try to
+  arrange for that to happen.
+  This means we invert the condition if:
+  * The likely path will become a fallthrough.
+  * We can't guarantee a fallthrough for the false branch but for the
+    true branch.
+
+  In some cases it's faster to avoid inverting when the false branch is likely.
+  However determining when that is the case is neither easy nor cheap so for
+  now we always invert as this produces smaller binaries and code that is
+  equally fast on average. (On an i7-6700K)
+
+  TODO:
+  There is also the edge case when both branches have multiple predecessors.
+  In this case we could assume that we will end up with a jump for BOTH
+  branches. In this case it might be best to put the likely path in the true
+  branch especially if there are large numbers of predecessors as this saves
+  us the jump thats not taken. However I haven't tested this and as of early
+  2018 we almost never generate cmm where this would apply.
+-}
+
+-- Functions for incrementing and decrementing number of predecessors. If
+-- decrementing would set the predecessor count to 0, we remove entry from the
+-- map.
+-- Invariant: if a block has no predecessors it should be dropped from the
+-- graph because it is unreachable. maybe_concat is constructed to maintain
+-- that invariant, but calling replaceLabels may introduce unreachable blocks.
+-- We rely on subsequent passes in the Cmm pipeline to remove unreachable
+-- blocks.
+incPreds, decPreds :: BlockId -> LabelMap Int -> LabelMap Int
+incPreds bid edges = mapInsertWith (+) bid 1 edges
+decPreds bid edges = case mapLookup bid edges of
+                       Just preds | preds > 1 -> mapInsert bid (preds - 1) edges
+                       Just _                 -> mapDelete bid edges
+                       _                      -> edges
+
+
+-- Checks if a block consists only of "goto dest". If it does than we return
+-- "Just dest" label. See Note [What is shortcutting]
+canShortcut :: CmmBlock -> Maybe BlockId
+canShortcut block
+    | (_, middle, CmmBranch dest) <- blockSplit block
+    , all dont_care $ blockToList middle
+    = Just dest
+    | otherwise
+    = Nothing
+    where dont_care CmmComment{} = True
+          dont_care CmmTick{}    = True
+          dont_care _other       = False
+
+-- Concatenates two blocks. First one is assumed to be open on exit, the second
+-- is assumed to be closed on entry (i.e. it has a label attached to it, which
+-- the splice function removes by calling snd on result of blockSplitHead).
+splice :: Block CmmNode C O -> CmmBlock -> CmmBlock
+splice head rest = entry `blockJoinHead` code0 `blockAppend` code1
+  where (CmmEntry lbl sc0, code0) = blockSplitHead head
+        (CmmEntry _   sc1, code1) = blockSplitHead rest
+        entry = CmmEntry lbl (combineTickScopes sc0 sc1)
+
+-- If node is a call with continuation call return Just label of that
+-- continuation. Otherwise return Nothing.
+callContinuation_maybe :: CmmNode O C -> Maybe BlockId
+callContinuation_maybe (CmmCall { cml_cont = Just b }) = Just b
+callContinuation_maybe (CmmForeignCall { succ = b })   = Just b
+callContinuation_maybe _ = Nothing
+
+
+-- Map over the CmmGraph, replacing each label with its mapping in the
+-- supplied LabelMap.
+replaceLabels :: LabelMap BlockId -> CmmGraph -> CmmGraph
+replaceLabels env g
+  | mapNull env = g
+  | otherwise   = replace_eid $ mapGraphNodes1 txnode g
+   where
+     replace_eid g = g {g_entry = lookup (g_entry g)}
+     lookup id = mapLookup id env `orElse` id
+
+     txnode :: CmmNode e x -> CmmNode e x
+     txnode (CmmBranch bid) = CmmBranch (lookup bid)
+     txnode (CmmCondBranch p t f l) =
+       mkCmmCondBranch (exp p) (lookup t) (lookup f) l
+     txnode (CmmSwitch e ids) =
+       CmmSwitch (exp e) (mapSwitchTargets lookup ids)
+     txnode (CmmCall t k rg a res r) =
+       CmmCall (exp t) (liftM lookup k) rg a res r
+     txnode fc@CmmForeignCall{} =
+       fc{ args = map exp (args fc), succ = lookup (succ fc) }
+     txnode other = mapExpDeep exp other
+
+     exp :: CmmExpr -> CmmExpr
+     exp (CmmLit (CmmBlock bid))                = CmmLit (CmmBlock (lookup bid))
+     exp (CmmStackSlot (Young id) i) = CmmStackSlot (Young (lookup id)) i
+     exp e                                      = e
+
+mkCmmCondBranch :: CmmExpr -> Label -> Label -> Maybe Bool -> CmmNode O C
+mkCmmCondBranch p t f l =
+  if t == f then CmmBranch t else CmmCondBranch p t f l
+
+-- Build a map from a block to its set of predecessors.
+predMap :: [CmmBlock] -> LabelMap Int
+predMap blocks = foldr add_preds mapEmpty blocks
+  where
+    add_preds block env = foldr add env (successors block)
+      where add lbl env = mapInsertWith (+) lbl 1 env
+
+-- Removing unreachable blocks
+removeUnreachableBlocksProc :: CmmDecl -> CmmDecl
+removeUnreachableBlocksProc proc@(CmmProc info lbl live g)
+   | used_blocks `lengthLessThan` mapSize (toBlockMap g)
+   = CmmProc info' lbl live g'
+   | otherwise
+   = proc
+   where
+     g'    = ofBlockList (g_entry g) used_blocks
+     info' = info { info_tbls = keep_used (info_tbls info) }
+             -- Remove any info_tbls for unreachable
+
+     keep_used :: LabelMap CmmInfoTable -> LabelMap CmmInfoTable
+     keep_used bs = mapFoldlWithKey keep mapEmpty bs
+
+     keep :: LabelMap CmmInfoTable -> Label -> CmmInfoTable -> LabelMap CmmInfoTable
+     keep env l i | l `setMember` used_lbls = mapInsert l i env
+                  | otherwise               = env
+
+     used_blocks :: [CmmBlock]
+     used_blocks = revPostorder g
+
+     used_lbls :: LabelSet
+     used_lbls = setFromList $ map entryLabel used_blocks

ghc-toolkit/boot-libs/ghc/cmm/CmmExpr.hs

@@ -0,0 +1,604 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module CmmExpr
+    ( CmmExpr(..), cmmExprType, cmmExprWidth, maybeInvertCmmExpr
+    , CmmReg(..), cmmRegType, cmmRegWidth
+    , CmmLit(..), cmmLitType
+    , LocalReg(..), localRegType
+    , GlobalReg(..), isArgReg, globalRegType
+    , spReg, hpReg, spLimReg, hpLimReg, nodeReg
+    , currentTSOReg, currentNurseryReg, hpAllocReg, cccsReg
+    , 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 GhcPrelude
+
+import BlockId
+import CLabel
+import CmmMachOp
+import CmmType
+import DynFlags
+import Outputable (panic)
+import Unique
+
+import Data.Set (Set)
+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 Width -- label1 - label2 + offset
+        -- In an expression, the width just has the effect of MO_SS_Conv
+        -- from wordWidth to the desired width.
+        --
+        -- In a static literal, the supported Widths depend on the
+        -- architecture: wordWidth is supported on all
+        -- architectures. Additionally W32 is supported on x86_64 when
+        -- using the small memory model.
+
+  | CmmBlock {-# UNPACK #-} !BlockId     -- Code label
+        -- Invariant: must be a continuation BlockId
+        -- See Note [Continuation 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 _      (CmmLabelDiffOff _ _ _ width) = cmmBits width
+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
+
+cmmRegWidth :: DynFlags -> CmmReg -> Width
+cmmRegWidth dflags = typeWidth . cmmRegType dflags
+
+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, hpLimReg, nodeReg,
+  currentTSOReg, currentNurseryReg, hpAllocReg, cccsReg  :: CmmReg
+baseReg = CmmGlobal BaseReg
+spReg = CmmGlobal Sp
+hpReg = CmmGlobal Hp
+hpLimReg = CmmGlobal HpLim
+spLimReg = CmmGlobal SpLim
+nodeReg = CmmGlobal node
+currentTSOReg = CmmGlobal CurrentTSO
+currentNurseryReg = CmmGlobal CurrentNursery
+hpAllocReg = CmmGlobal HpAlloc
+cccsReg = CmmGlobal CCCS
+
+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

ghc-toolkit/boot-libs/ghc/cmm/CmmImplementSwitchPlans.hs

@@ -0,0 +1,92 @@
+{-# LANGUAGE GADTs #-}
+module CmmImplementSwitchPlans
+  ( cmmImplementSwitchPlans
+  )
+where
+
+import GhcPrelude
+
+import Hoopl.Block
+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 separate 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)

ghc-toolkit/boot-libs/ghc/cmm/CmmInfo.hs

@@ -0,0 +1,587 @@
+{-# 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 GhcPrelude
+
+import Cmm
+import CmmUtils
+import CLabel
+import SMRep
+import Bitmap
+import Stream (Stream)
+import qualified Stream
+import Hoopl.Collections
+
+import Platform
+import Maybes
+import DynFlags
+import Panic
+import UniqSupply
+import MonadUtils
+import Util
+import Outputable
+import Module
+
+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  = Nothing
+                 , cit_clo  = Nothing }
+
+cmmToRawCmm :: DynFlags -> Maybe Module -> Stream IO CmmGroup ()
+            -> IO (Stream IO RawCmmGroup ())
+cmmToRawCmm dflags _ cmms
+  = do { uniqs <- mkSplitUniqSupply 'i'
+       ; let do_one uniqs cmm = do
+                case initUs uniqs $ concatMapM (mkInfoTable dflags) cmm of
+                  (b,uniqs') -> return (uniqs',b)
+                  -- NB. strictness fixes a space leak.  DO NOT REMOVE.
+       ; return (Stream.mapAccumL do_one uniqs cmms >> return ())
+       }
+
+-- Make a concrete info table, represented as a list of CmmStatic
+-- (it can't be simply a list of Word, because the SRT field is
+-- represented by a label+offset expression).
+--
+-- With tablesNextToCode, the layout is
+--      <reversed variable part>
+--      <normal forward StgInfoTable, but without
+--              an entry point at the front>
+--      <code>
+--
+-- Without tablesNextToCode, the layout of an info table is
+--      <entry label>
+--      <normal forward rest of StgInfoTable>
+--      <forward variable part>
+--
+--      See includes/rts/storage/InfoTables.h
+--
+-- For return-points these are as follows
+--
+-- Tables next to code:
+--
+--                      <srt slot>
+--                      <standard info table>
+--      ret-addr -->    <entry code (if any)>
+--
+-- Not tables-next-to-code:
+--
+--      ret-addr -->    <ptr to entry code>
+--                      <standard info table>
+--                      <srt slot>
+--
+--  * The SRT slot is only there if there is SRT info to record
+
+mkInfoTable :: DynFlags -> CmmDecl -> UniqSM [RawCmmDecl]
+mkInfoTable _ (CmmData sec dat)
+  = return [CmmData sec dat]
+
+mkInfoTable dflags proc@(CmmProc infos entry_lbl live blocks)
+  --
+  -- in the non-tables-next-to-code case, procs can have at most a
+  -- single info table associated with the entry label of the proc.
+  --
+  | not (tablesNextToCode dflags)
+  = case topInfoTable proc of   --  must be at most one
+      -- no info table
+      Nothing ->
+         return [CmmProc mapEmpty entry_lbl live blocks]
+
+      Just info@CmmInfoTable { cit_lbl = info_lbl } -> do
+        (top_decls, (std_info, extra_bits)) <-
+             mkInfoTableContents dflags info Nothing
+        let
+          rel_std_info   = map (makeRelativeRefTo dflags info_lbl) std_info
+          rel_extra_bits = map (makeRelativeRefTo dflags info_lbl) extra_bits
+        --
+        -- Separately emit info table (with the function entry
+        -- point as first entry) and the entry code
+        --
+        return (top_decls ++
+                [CmmProc mapEmpty entry_lbl live blocks,
+                 mkRODataLits info_lbl
+                    (CmmLabel entry_lbl : rel_std_info ++ rel_extra_bits)])
+
+  --
+  -- With tables-next-to-code, we can have many info tables,
+  -- associated with some of the BlockIds of the proc.  For each info
+  -- table we need to turn it into CmmStatics, and collect any new
+  -- CmmDecls that arise from doing so.
+  --
+  | otherwise
+  = do
+    (top_declss, raw_infos) <-
+       unzip `fmap` mapM do_one_info (mapToList (info_tbls infos))
+    return (concat top_declss ++
+            [CmmProc (mapFromList raw_infos) entry_lbl live blocks])
+
+  where
+   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 info_lbl 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 info_lbl srt
+       ; (mb_srt_field, mb_layout, extra_bits, ct_data)
+                                <- mk_pieces closure_type srt_label
+       ; let std_info = mkStdInfoTable dflags prof_lits
+                                       (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 CmmLit  -- Override the SRT field with this
+                        , Maybe CmmLit  -- Override the layout field with this
+                        , [CmmLit]           -- "Extra bits" for info table
+                        , [RawCmmDecl])      -- Auxiliary data decls
+    mk_pieces (Constr con_tag con_descr) _no_srt    -- A data constructor
+      = do { (descr_lit, decl) <- newStringLit con_descr
+           ; return ( Just (CmmInt (fromIntegral con_tag)
+                                   (halfWordWidth dflags))
+                    , Nothing, [descr_lit], [decl]) }
+
+    mk_pieces Thunk srt_label
+      = return (Nothing, Nothing, srt_label, [])
+
+    mk_pieces (ThunkSelector offset) _no_srt
+      = return (Just (CmmInt 0 (halfWordWidth dflags)),
+                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 ]
+                           ++ (if inlineSRT dflags then [] else [ 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
+         -> CLabel
+         -> Maybe CLabel
+         -> ([CmmLit],    -- srt_label, if any
+             CmmLit)      -- srt_bitmap
+mkSRTLit dflags info_lbl (Just lbl)
+  | inlineSRT dflags
+  = ([], CmmLabelDiffOff lbl info_lbl 0 (halfWordWidth dflags))
+mkSRTLit dflags _ Nothing    = ([], CmmInt 0 (halfWordWidth dflags))
+mkSRTLit dflags _ (Just lbl) = ([CmmLabel lbl], CmmInt 1 (halfWordWidth dflags))
+
+
+-- | Is the SRT offset field inline in the info table on this platform?
+--
+-- See the section "Referring to an SRT from the info table" in
+-- Note [SRTs] in CmmBuildInfoTables.hs
+inlineSRT :: DynFlags -> Bool
+inlineSRT dflags = platformArch (targetPlatform dflags) == ArchX86_64
+  && tablesNextToCode dflags
+
+-------------------------------------------------------------------------
+--
+--      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 (wordWidth dflags)
+makeRelativeRefTo dflags info_lbl (CmmLabelOff lbl off)
+  | tablesNextToCode dflags
+  = CmmLabelDiffOff lbl info_lbl off (wordWidth dflags)
+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
+   -> CmmLit            -- SRT length
+   -> CmmLit            -- layout field
+   -> [CmmLit]
+
+mkStdInfoTable dflags (type_descr, closure_descr) cl_type srt layout_lit
+ =      -- Parallel revertible-black hole field
+    prof_info
+        -- Ticky info (none at present)
+        -- Debug info (none at present)
+ ++ [layout_lit, tag, srt]
+
+ where
+    prof_info
+        | gopt Opt_SccProfilingOn dflags = [type_descr, closure_descr]
+        | otherwise = []
+
+    tag = CmmInt (fromIntegral cl_type) (halfWordWidth dflags)
+
+-------------------------------------------------------------------------
+--
+--      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
+--
+-------------------------------------------------------------------------
+
+-- | Wrap a 'CmmExpr' in an alignment check when @-falignment-sanitisation@ is
+-- enabled.
+wordAligned :: DynFlags -> CmmExpr -> CmmExpr
+wordAligned dflags e
+  | gopt Opt_AlignmentSanitisation dflags
+  = CmmMachOp (MO_AlignmentCheck (wORD_SIZE dflags) (wordWidth dflags)) [e]
+  | otherwise
+  = e
+
+closureInfoPtr :: DynFlags -> CmmExpr -> CmmExpr
+-- Takes a closure pointer and returns the info table pointer
+closureInfoPtr dflags e =
+    CmmLoad (wordAligned dflags 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

ghc-toolkit/boot-libs/ghc/cmm/CmmLex.x

@@ -0,0 +1,368 @@
+-----------------------------------------------------------------------------
+--
+-- (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.)
+--
+-----------------------------------------------------------------------------
+
+{
+module CmmLex (
+   CmmToken(..), cmmlex,
+  ) where
+
+import GhcPrelude
+
+import CmmExpr
+
+import Lexer
+import CmmMonad
+import SrcLoc
+import UniqFM
+import StringBuffer
+import FastString
+import Ctype
+import Util
+--import TRACE
+
+import Data.Word
+import Data.Char
+}
+
+$whitechar   = [\ \t\n\r\f\v\xa0] -- \xa0 is Unicode no-break space
+$white_no_nl = $whitechar # \n
+
+$ascdigit  = 0-9
+$unidigit  = \x01 -- Trick Alex into handling Unicode. See alexGetChar.
+$digit     = [$ascdigit $unidigit]
+$octit     = 0-7
+$hexit     = [$digit A-F a-f]
+
+$unilarge  = \x03 -- Trick Alex into handling Unicode. See alexGetChar.
+$asclarge  = [A-Z \xc0-\xd6 \xd8-\xde]
+$large     = [$asclarge $unilarge]
+
+$unismall  = \x04 -- Trick Alex into handling Unicode. See alexGetChar.
+$ascsmall  = [a-z \xdf-\xf6 \xf8-\xff]
+$small     = [$ascsmall $unismall \_]
+
+$namebegin = [$large $small \. \$ \@]
+$namechar  = [$namebegin $digit]
+
+@decimal     = $digit+
+@octal       = $octit+
+@hexadecimal = $hexit+
+@exponent    = [eE] [\-\+]? @decimal
+
+@floating_point = @decimal \. @decimal @exponent? | @decimal @exponent
+
+@escape      = \\ ([abfnrt\\\'\"\?] | x $hexit{1,2} | $octit{1,3})
+@strchar     = ($printable # [\"\\]) | @escape
+
+cmm :-
+
+$white_no_nl+           ;
+^\# pragma .* \n        ; -- Apple GCC 3.3 CPP generates pragmas in its output
+
+^\# (line)?             { begin line_prag }
+
+-- single-line line pragmas, of the form
+--    # <line> "<file>" <extra-stuff> \n
+<line_prag> $digit+                     { setLine line_prag1 }
+<line_prag1> \" [^\"]* \"       { setFile line_prag2 }
+<line_prag2> .*                         { pop }
+
+<0> {
+  \n                    ;
+
+  [\:\;\{\}\[\]\(\)\=\`\~\/\*\%\-\+\&\^\|\>\<\,\!]      { special_char }
+
+  ".."                  { kw CmmT_DotDot }
+  "::"                  { kw CmmT_DoubleColon }
+  ">>"                  { kw CmmT_Shr }
+  "<<"                  { kw CmmT_Shl }
+  ">="                  { kw CmmT_Ge }
+  "<="                  { kw CmmT_Le }
+  "=="                  { kw CmmT_Eq }
+  "!="                  { kw CmmT_Ne }
+  "&&"                  { kw CmmT_BoolAnd }
+  "||"                  { kw CmmT_BoolOr }
+
+  "True"                { kw CmmT_True  }
+  "False"               { kw CmmT_False }
+  "likely"              { kw CmmT_likely}
+
+  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
+  | CmmT_False
+  | CmmT_True
+  | CmmT_likely
+  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 ),
+        ( "likely",             CmmT_likely),
+        ( "True",               CmmT_True  ),
+        ( "False",              CmmT_False )
+        ]
+
+tok_decimal span buf len
+  = return (L span (CmmT_Int  $! parseUnsignedInteger buf len 10 octDecDigit))
+
+tok_octal span buf len
+  = return (L span (CmmT_Int  $! parseUnsignedInteger (offsetBytes 1 buf) (len-1) 8 octDecDigit))
+
+tok_hexadecimal span buf len
+  = return (L span (CmmT_Int  $! parseUnsignedInteger (offsetBytes 2 buf) (len-2) 16 hexDigit))
+
+tok_float str = CmmT_Float $! readRational str
+
+tok_string str = CmmT_String (read str)
+                 -- urk, not quite right, but it'll do for now
+
+-- -----------------------------------------------------------------------------
+-- Line pragmas
+
+setLine :: Int -> Action
+setLine code 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 } ()
+}

ghc-toolkit/boot-libs/ghc/cmm/CmmLint.hs

@@ -0,0 +1,262 @@
+-----------------------------------------------------------------------------
+--
+-- (c) The University of Glasgow 2011
+--
+-- CmmLint: checking the correctness of Cmm statements and expressions
+--
+-----------------------------------------------------------------------------
+{-# LANGUAGE GADTs #-}
+module CmmLint (
+    cmmLint, cmmLintGraph
+  ) where
+
+import GhcPrelude
+
+import Hoopl.Block
+import Hoopl.Collections
+import Hoopl.Graph
+import Hoopl.Label
+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))
+-}
+

ghc-toolkit/boot-libs/ghc/cmm/CmmLive.hs

@@ -0,0 +1,93 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module CmmLive
+    ( CmmLocalLive
+    , cmmLocalLiveness
+    , cmmGlobalLiveness
+    , liveLattice
+    , gen_kill
+    )
+where
+
+import GhcPrelude
+
+import DynFlags
+import BlockId
+import Cmm
+import PprCmmExpr ()
+import Hoopl.Block
+import Hoopl.Collections
+import Hoopl.Dataflow
+import Hoopl.Label
+
+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) #-}

ghc-toolkit/boot-libs/ghc/cmm/CmmMachOp.hs

@@ -0,0 +1,658 @@
+module CmmMachOp
+    ( MachOp(..)
+    , pprMachOp, isCommutableMachOp, isAssociativeMachOp
+    , isComparisonMachOp, maybeIntComparison, machOpResultType
+    , machOpArgReps, maybeInvertComparison, isFloatComparison
+
+    -- MachOp builders
+    , mo_wordAdd, mo_wordSub, mo_wordEq, mo_wordNe,mo_wordMul, mo_wordSQuot
+    , mo_wordSRem, mo_wordSNeg, mo_wordUQuot, mo_wordURem
+    , mo_wordSGe, mo_wordSLe, mo_wordSGt, mo_wordSLt, mo_wordUGe
+    , mo_wordULe, mo_wordUGt, mo_wordULt
+    , mo_wordAnd, mo_wordOr, mo_wordXor, mo_wordNot
+    , mo_wordShl, mo_wordSShr, mo_wordUShr
+    , mo_u_8To32, mo_s_8To32, mo_u_16To32, mo_s_16To32
+    , mo_u_8ToWord, mo_s_8ToWord, mo_u_16ToWord, mo_s_16ToWord
+    , mo_u_32ToWord, mo_s_32ToWord
+    , mo_32To8, mo_32To16, mo_WordTo8, mo_WordTo16, mo_WordTo32, mo_WordTo64
+
+    -- CallishMachOp
+    , CallishMachOp(..), callishMachOpHints
+    , pprCallishMachOp
+    , machOpMemcpyishAlign
+
+    -- Atomic read-modify-write
+    , AtomicMachOp(..)
+   )
+where
+
+import GhcPrelude
+
+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_XX_Conv Width Width      -- int -> int; puts no requirements on the
+                                -- contents of upper bits when extending;
+                                -- narrowing is simply truncation; the only
+                                -- expectation is that we can recover the
+                                -- original value by applying the opposite
+                                -- MO_XX_Conv, e.g.,
+                                --   MO_XX_CONV W64 W8 (MO_XX_CONV W8 W64 x)
+                                -- is equivalent to just x.
+  | MO_FF_Conv Width Width      -- Float -> Float
+
+  -- 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 negation
+  | MO_VF_Mul  Length Width
+  | MO_VF_Quot Length Width
+
+  -- Alignment check (for -falignment-sanitisation)
+  | MO_AlignmentCheck Int 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
+
+isFloatComparison :: MachOp -> Bool
+isFloatComparison mop =
+  case mop of
+    MO_F_Eq {} -> True
+    MO_F_Ne {} -> True
+    MO_F_Ge {} -> True
+    MO_F_Le {} -> True
+    MO_F_Gt {} -> True
+    MO_F_Lt {} -> True
+    _other     -> False
+
+-- -----------------------------------------------------------------------------
+-- 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_XX_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)
+
+    MO_AlignmentCheck _ _ -> ty1
+  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_XX_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]
+
+    MO_AlignmentCheck _ 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_Asinh
+  | MO_F64_Acosh
+  | MO_F64_Atanh
+  | 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_Asinh
+  | MO_F32_Acosh
+  | MO_F32_Atanh
+  | 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_AddWordC  Width
+  | MO_SubWordC  Width
+  | MO_AddIntC   Width
+  | MO_SubIntC   Width
+  | MO_U_Mul2    Width
+
+  | MO_ReadBarrier
+  | 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_Memcmp Int
+
+  | MO_PopCnt Width
+  | MO_Pdep Width
+  | MO_Pext 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])
+  MO_Memcmp _  -> ([], [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
+  MO_Memcmp  align -> Just align
+  _                -> Nothing

ghc-toolkit/boot-libs/ghc/cmm/CmmMonad.hs

@@ -0,0 +1,59 @@
+{-# LANGUAGE CPP #-}
+
+-----------------------------------------------------------------------------
+-- 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.
+-----------------------------------------------------------------------------
+module CmmMonad (
+    PD(..)
+  , liftP
+  ) where
+
+import GhcPrelude
+
+import Control.Monad
+import qualified Control.Monad.Fail as MonadFail
+
+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
+#if !MIN_VERSION_base(4,13,0)
+  fail = MonadFail.fail
+#endif
+
+instance MonadFail.MonadFail PD where
+  fail = failPD
+
+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 warnFn span err -> PFailed warnFn span err
+
+failPD :: String -> PD a
+failPD = liftP . fail
+
+instance HasDynFlags PD where
+   getDynFlags = PD $ \d s -> POk s d

ghc-toolkit/boot-libs/ghc/cmm/CmmNode.hs

@@ -0,0 +1,724 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ExplicitForAll #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+
+-- 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, mapCollectSuccessors,
+
+     -- * Tick scopes
+     CmmTickScope(..), isTickSubScope, combineTickScopes,
+  ) where
+
+import GhcPrelude hiding (succ)
+
+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 Hoopl.Block
+import Hoopl.Graph
+import Hoopl.Collections
+import Hoopl.Label
+import Data.Maybe
+import Data.List (tails,sortBy)
+import Unique (nonDetCmpUnique)
+import Util
+
+
+------------------------
+-- CmmNode
+
+#define ULabel {-# UNPACK #-} !Label
+
+data CmmNode e x where
+  CmmEntry :: ULabel -> CmmTickScope -> CmmNode C O
+
+  CmmComment :: FastString -> CmmNode O O
+
+    -- Tick annotation, covering Cmm code in our tick scope. We only
+    -- expect non-code @Tickish@ at this point (e.g. @SourceNote@).
+    -- See Note [CmmTick scoping details]
+  CmmTick :: !CmmTickish -> CmmNode O O
+
+    -- Unwind pseudo-instruction, encoding stack unwinding
+    -- instructions for a debugger. This describes how to reconstruct
+    -- the "old" value of a register if we want to navigate the stack
+    -- up one frame. Having unwind information for @Sp@ will allow the
+    -- debugger to "walk" the stack.
+    --
+    -- See Note [What is this unwinding business?] in Debug
+  CmmUnwind :: [(GlobalReg, Maybe CmmExpr)] -> CmmNode O O
+
+  CmmAssign :: !CmmReg -> !CmmExpr -> CmmNode O O
+    -- Assign to register
+
+  CmmStore :: !CmmExpr -> !CmmExpr -> CmmNode O O
+    -- Assign to memory location.  Size is
+    -- given by cmmExprType of the rhs.
+
+  CmmUnsafeForeignCall ::       -- An unsafe foreign call;
+                                -- see Note [Foreign calls]
+                                -- Like a "fat machine instruction"; can occur
+                                -- in the middle of a block
+      ForeignTarget ->          -- call target
+      [CmmFormal] ->            -- zero or more results
+      [CmmActual] ->            -- zero or more arguments
+      CmmNode O O
+      -- Semantics: clobbers any GlobalRegs for which callerSaves r == True
+      -- See Note [Unsafe foreign calls clobber caller-save registers]
+      --
+      -- Invariant: the arguments and the ForeignTarget must not
+      -- mention any registers for which CodeGen.Platform.callerSaves
+      -- is True.  See Note [Register Parameter Passing].
+
+  CmmBranch :: ULabel -> CmmNode O C
+                                   -- Goto another block in the same procedure
+
+  CmmCondBranch :: {                 -- conditional branch
+      cml_pred :: CmmExpr,
+      cml_true, cml_false :: ULabel,
+      cml_likely :: Maybe Bool       -- likely result of the conditional,
+                                     -- if known
+  } -> CmmNode O C
+
+  CmmSwitch
+    :: CmmExpr       -- Scrutinee, of some integral type
+    -> SwitchTargets -- Cases. See [Note SwitchTargets]
+    -> CmmNode O C
+
+  CmmCall :: {                -- A native call or tail call
+      cml_target :: CmmExpr,  -- never a CmmPrim to a CallishMachOp!
+
+      cml_cont :: Maybe Label,
+          -- Label of continuation (Nothing for return or tail call)
+          --
+          -- Note [Continuation BlockId]: these BlockIds are called
+          -- Continuation BlockIds, and are the only BlockIds that can
+          -- occur in CmmExprs, namely as (CmmLit (CmmBlock b)) or
+          -- (CmmStackSlot (Young b) _).
+
+      cml_args_regs :: [GlobalReg],
+          -- The argument GlobalRegs (Rx, Fx, Dx, Lx) that are passed
+          -- to the call.  This is essential information for the
+          -- native code generator's register allocator; without
+          -- knowing which GlobalRegs are live it has to assume that
+          -- they are all live.  This list should only include
+          -- GlobalRegs that are mapped to real machine registers on
+          -- the target platform.
+
+      cml_args :: ByteOff,
+          -- Byte offset, from the *old* end of the Area associated with
+          -- the Label (if cml_cont = Nothing, then Old area), of
+          -- youngest outgoing arg.  Set the stack pointer to this before
+          -- transferring control.
+          -- (NB: an update frame might also have been stored in the Old
+          --      area, but it'll be in an older part than the args.)
+
+      cml_ret_args :: ByteOff,
+          -- For calls *only*, the byte offset for youngest returned value
+          -- This is really needed at the *return* point rather than here
+          -- at the call, but in practice it's convenient to record it here.
+
+      cml_ret_off :: ByteOff
+        -- For calls *only*, the byte offset of the base of the frame that
+        -- must be described by the info table for the return point.
+        -- The older words are an update frames, which have their own
+        -- info-table and layout information
+
+        -- From a liveness point of view, the stack words older than
+        -- cml_ret_off are treated as live, even if the sequel of
+        -- the call goes into a loop.
+  } -> CmmNode O C
+
+  CmmForeignCall :: {           -- A safe foreign call; see Note [Foreign calls]
+                                -- Always the last node of a block
+      tgt   :: ForeignTarget,   -- call target and convention
+      res   :: [CmmFormal],     -- zero or more results
+      args  :: [CmmActual],     -- zero or more arguments; see Note [Register parameter passing]
+      succ  :: ULabel,          -- Label of continuation
+      ret_args :: ByteOff,      -- same as cml_ret_args
+      ret_off :: ByteOff,       -- same as cml_ret_off
+      intrbl:: Bool             -- whether or not the call is interruptible
+  } -> CmmNode O C
+
+{- Note [Foreign calls]
+~~~~~~~~~~~~~~~~~~~~~~~
+A CmmUnsafeForeignCall is used for *unsafe* foreign calls;
+a CmmForeignCall call is used for *safe* foreign calls.
+
+Unsafe ones are mostly easy: think of them as a "fat machine
+instruction".  In particular, they do *not* kill all live registers,
+just the registers they return to (there was a bit of code in GHC that
+conservatively assumed otherwise.)  However, see [Register parameter passing].
+
+Safe ones are trickier.  A safe foreign call
+     r = f(x)
+ultimately expands to
+     push "return address"      -- Never used to return to;
+                                -- just points an info table
+     save registers into TSO
+     call suspendThread
+     r = f(x)                   -- Make the call
+     call resumeThread
+     restore registers
+     pop "return address"
+We cannot "lower" a safe foreign call to this sequence of Cmms, because
+after we've saved Sp all the Cmm optimiser's assumptions are broken.
+
+Note that a safe foreign call needs an info table.
+
+So Safe Foreign Calls must remain as last nodes until the stack is
+made manifest in CmmLayoutStack, where they are lowered into the above
+sequence.
+-}
+
+{- Note [Unsafe foreign calls clobber caller-save registers]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+A foreign call is defined to clobber any GlobalRegs that are mapped to
+caller-saves machine registers (according to the prevailing C ABI).
+StgCmmUtils.callerSaves tells you which GlobalRegs are caller-saves.
+
+This is a design choice that makes it easier to generate code later.
+We could instead choose to say that foreign calls do *not* clobber
+caller-saves regs, but then we would have to figure out which regs
+were live across the call later and insert some saves/restores.
+
+Furthermore when we generate code we never have any GlobalRegs live
+across a call, because they are always copied-in to LocalRegs and
+copied-out again before making a call/jump.  So all we have to do is
+avoid any code motion that would make a caller-saves GlobalReg live
+across a foreign call during subsequent optimisations.
+-}
+
+{- Note [Register parameter passing]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+On certain architectures, some registers are utilized for parameter
+passing in the C calling convention.  For example, in x86-64 Linux
+convention, rdi, rsi, rdx and rcx (as well as r8 and r9) may be used for
+argument passing.  These are registers R3-R6, which our generated
+code may also be using; as a result, it's necessary to save these
+values before doing a foreign call.  This is done during initial
+code generation in callerSaveVolatileRegs in StgCmmUtils.hs.  However,
+one result of doing this is that the contents of these registers
+may mysteriously change if referenced inside the arguments.  This
+is dangerous, so you'll need to disable inlining much in the same
+way is done in cmm/CmmOpt.hs currently.  We should fix this!
+-}
+
+---------------------------------------------
+-- Eq instance of CmmNode
+
+deriving instance Eq (CmmNode e x)
+
+----------------------------------------------
+-- Hoopl instances of CmmNode
+
+instance NonLocal CmmNode where
+  entryLabel (CmmEntry l _) = l
+
+  successors (CmmBranch l) = [l]
+  successors (CmmCondBranch {cml_true=t, cml_false=f}) = [f, t] -- meets layout constraint
+  successors (CmmSwitch _ ids) = switchTargetsToList ids
+  successors (CmmCall {cml_cont=l}) = maybeToList l
+  successors (CmmForeignCall {succ=l}) = [l]
+
+
+--------------------------------------------------
+-- Various helper types
+
+type CmmActual = CmmExpr
+type CmmFormal = LocalReg
+
+type UpdFrameOffset = ByteOff
+
+-- | A convention maps a list of values (function arguments or return
+-- values) to registers or stack locations.
+data Convention
+  = NativeDirectCall
+       -- ^ top-level Haskell functions use @NativeDirectCall@, which
+       -- maps arguments to registers starting with R2, according to
+       -- how many registers are available on the platform.  This
+       -- convention ignores R1, because for a top-level function call
+       -- the function closure is implicit, and doesn't need to be passed.
+  | NativeNodeCall
+       -- ^ non-top-level Haskell functions, which pass the address of
+       -- the function closure in R1 (regardless of whether R1 is a
+       -- real register or not), and the rest of the arguments in
+       -- registers or on the stack.
+  | NativeReturn
+       -- ^ a native return.  The convention for returns depends on
+       -- how many values are returned: for just one value returned,
+       -- the appropriate register is used (R1, F1, etc.). regardless
+       -- of whether it is a real register or not.  For multiple
+       -- values returned, they are mapped to registers or the stack.
+  | Slow
+       -- ^ Slow entry points: all args pushed on the stack
+  | GC
+       -- ^ Entry to the garbage collector: uses the node reg!
+       -- (TODO: I don't think we need this --SDM)
+  deriving( Eq )
+
+data ForeignConvention
+  = ForeignConvention
+        CCallConv               -- Which foreign-call convention
+        [ForeignHint]           -- Extra info about the args
+        [ForeignHint]           -- Extra info about the result
+        CmmReturnInfo
+  deriving Eq
+
+data CmmReturnInfo
+  = CmmMayReturn
+  | CmmNeverReturns
+  deriving ( Eq )
+
+data ForeignTarget        -- The target of a foreign call
+  = ForeignTarget                -- A foreign procedure
+        CmmExpr                  -- Its address
+        ForeignConvention        -- Its calling convention
+  | PrimTarget            -- A possibly-side-effecting machine operation
+        CallishMachOp            -- Which one
+  deriving Eq
+
+foreignTargetHints :: ForeignTarget -> ([ForeignHint], [ForeignHint])
+foreignTargetHints target
+  = ( res_hints ++ repeat NoHint
+    , arg_hints ++ repeat NoHint )
+  where
+    (res_hints, arg_hints) =
+       case target of
+          PrimTarget op -> callishMachOpHints op
+          ForeignTarget _ (ForeignConvention _ arg_hints res_hints _) ->
+             (res_hints, arg_hints)
+
+--------------------------------------------------
+-- Instances of register and slot users / definers
+
+instance UserOfRegs LocalReg (CmmNode e x) where
+  foldRegsUsed dflags f !z n = case n of
+    CmmAssign _ expr -> fold f z expr
+    CmmStore addr rval -> fold f (fold f z addr) rval
+    CmmUnsafeForeignCall t _ args -> fold f (fold f z t) args
+    CmmCondBranch expr _ _ _ -> fold f z expr
+    CmmSwitch expr _ -> fold f z expr
+    CmmCall {cml_target=tgt} -> fold f z tgt
+    CmmForeignCall {tgt=tgt, args=args} -> fold f (fold f z tgt) args
+    _ -> z
+    where fold :: forall a b. UserOfRegs LocalReg a
+               => (b -> LocalReg -> b) -> b -> a -> b
+          fold f z n = foldRegsUsed dflags f z n
+
+instance UserOfRegs GlobalReg (CmmNode e x) where
+  foldRegsUsed dflags f !z n = case n of
+    CmmAssign _ expr -> fold f z expr
+    CmmStore addr rval -> fold f (fold f z addr) rval
+    CmmUnsafeForeignCall t _ args -> fold f (fold f z t) args
+    CmmCondBranch expr _ _ _ -> fold f z expr
+    CmmSwitch expr _ -> fold f z expr
+    CmmCall {cml_target=tgt, cml_args_regs=args} -> fold f (fold f z args) tgt
+    CmmForeignCall {tgt=tgt, args=args} -> fold f (fold f z tgt) args
+    _ -> z
+    where fold :: forall a b.  UserOfRegs GlobalReg a
+               => (b -> GlobalReg -> b) -> b -> a -> b
+          fold f z n = foldRegsUsed dflags f z n
+
+instance (Ord r, UserOfRegs r CmmReg) => UserOfRegs r ForeignTarget where
+  -- The (Ord r) in the context is necessary here
+  -- See Note [Recursive superclasses] in TcInstDcls
+  foldRegsUsed _      _ !z (PrimTarget _)      = z
+  foldRegsUsed dflags f !z (ForeignTarget e _) = foldRegsUsed dflags f z e
+
+instance DefinerOfRegs LocalReg (CmmNode e x) where
+  foldRegsDefd dflags f !z n = case n of
+    CmmAssign lhs _ -> fold f z lhs
+    CmmUnsafeForeignCall _ fs _ -> fold f z fs
+    CmmForeignCall {res=res} -> fold f z res
+    _ -> z
+    where fold :: forall a b. DefinerOfRegs LocalReg a
+               => (b -> LocalReg -> b) -> b -> a -> b
+          fold f z n = foldRegsDefd dflags f z n
+
+instance DefinerOfRegs GlobalReg (CmmNode e x) where
+  foldRegsDefd dflags f !z n = case n of
+    CmmAssign lhs _ -> fold f z lhs
+    CmmUnsafeForeignCall tgt _ _  -> fold f z (foreignTargetRegs tgt)
+    CmmCall        {} -> fold f z activeRegs
+    CmmForeignCall {} -> fold f z activeRegs
+                      -- See Note [Safe foreign calls clobber STG registers]
+    _ -> z
+    where fold :: forall a b. DefinerOfRegs GlobalReg a
+               => (b -> GlobalReg -> b) -> b -> a -> b
+          fold f z n = foldRegsDefd dflags f z n
+
+          platform = targetPlatform dflags
+          activeRegs = activeStgRegs platform
+          activeCallerSavesRegs = filter (callerSaves platform) activeRegs
+
+          foreignTargetRegs (ForeignTarget _ (ForeignConvention _ _ _ CmmNeverReturns)) = []
+          foreignTargetRegs _ = activeCallerSavesRegs
+
+-- Note [Safe foreign calls clobber STG registers]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- During stack layout phase every safe foreign call is expanded into a block
+-- that contains unsafe foreign call (instead of safe foreign call) and ends
+-- with a normal call (See Note [Foreign calls]). This means that we must
+-- treat safe foreign call as if it was a normal call (because eventually it
+-- will be). This is important if we try to run sinking pass before stack
+-- layout phase. Consider this example of what might go wrong (this is cmm
+-- code from stablename001 test). Here is code after common block elimination
+-- (before stack layout):
+--
+--  c1q6:
+--      _s1pf::P64 = R1;
+--      _c1q8::I64 = performMajorGC;
+--      I64[(young<c1q9> + 8)] = c1q9;
+--      foreign call "ccall" arg hints:  []  result hints:  [] (_c1q8::I64)(...)
+--                   returns to c1q9 args: ([]) ress: ([])ret_args: 8ret_off: 8;
+--  c1q9:
+--      I64[(young<c1qb> + 8)] = c1qb;
+--      R1 = _s1pc::P64;
+--      call stg_makeStableName#(R1) returns to c1qb, args: 8, res: 8, upd: 8;
+--
+-- If we run sinking pass now (still before stack layout) we will get this:
+--
+--  c1q6:
+--      I64[(young<c1q9> + 8)] = c1q9;
+--      foreign call "ccall" arg hints:  []  result hints:  [] performMajorGC(...)
+--                   returns to c1q9 args: ([]) ress: ([])ret_args: 8ret_off: 8;
+--  c1q9:
+--      I64[(young<c1qb> + 8)] = c1qb;
+--      _s1pf::P64 = R1;         <------ _s1pf sunk past safe foreign call
+--      R1 = _s1pc::P64;
+--      call stg_makeStableName#(R1) returns to c1qb, args: 8, res: 8, upd: 8;
+--
+-- Notice that _s1pf was sunk past a foreign call. When we run stack layout
+-- safe call to performMajorGC will be turned into:
+--
+--  c1q6:
+--      _s1pc::P64 = P64[Sp + 8];
+--      I64[Sp - 8] = c1q9;
+--      Sp = Sp - 8;
+--      I64[I64[CurrentTSO + 24] + 16] = Sp;
+--      P64[CurrentNursery + 8] = Hp + 8;
+--      (_u1qI::I64) = call "ccall" arg hints:  [PtrHint,]
+--                           result hints:  [PtrHint] suspendThread(BaseReg, 0);
+--      call "ccall" arg hints:  []  result hints:  [] performMajorGC();
+--      (_u1qJ::I64) = call "ccall" arg hints:  [PtrHint]
+--                           result hints:  [PtrHint] resumeThread(_u1qI::I64);
+--      BaseReg = _u1qJ::I64;
+--      _u1qK::P64 = CurrentTSO;
+--      _u1qL::P64 = I64[_u1qK::P64 + 24];
+--      Sp = I64[_u1qL::P64 + 16];
+--      SpLim = _u1qL::P64 + 192;
+--      HpAlloc = 0;
+--      Hp = I64[CurrentNursery + 8] - 8;
+--      HpLim = I64[CurrentNursery] + (%MO_SS_Conv_W32_W64(I32[CurrentNursery + 48]) * 4096 - 1);
+--      call (I64[Sp])() returns to c1q9, args: 8, res: 8, upd: 8;
+--  c1q9:
+--      I64[(young<c1qb> + 8)] = c1qb;
+--      _s1pf::P64 = R1;         <------ INCORRECT!
+--      R1 = _s1pc::P64;
+--      call stg_makeStableName#(R1) returns to c1qb, args: 8, res: 8, upd: 8;
+--
+-- Notice that c1q6 now ends with a call. Sinking _s1pf::P64 = R1 past that
+-- call is clearly incorrect. This is what would happen if we assumed that
+-- safe foreign call has the same semantics as unsafe foreign call. To prevent
+-- this we need to treat safe foreign call as if was normal call.
+
+-----------------------------------
+-- mapping Expr in CmmNode
+
+mapForeignTarget :: (CmmExpr -> CmmExpr) -> ForeignTarget -> ForeignTarget
+mapForeignTarget exp   (ForeignTarget e c) = ForeignTarget (exp e) c
+mapForeignTarget _   m@(PrimTarget _)      = m
+
+wrapRecExp :: (CmmExpr -> CmmExpr) -> CmmExpr -> CmmExpr
+-- Take a transformer on expressions and apply it recursively.
+-- (wrapRecExp f e) first recursively applies itself to sub-expressions of e
+--                  then  uses f to rewrite the resulting expression
+wrapRecExp f (CmmMachOp op es)    = f (CmmMachOp op $ map (wrapRecExp f) es)
+wrapRecExp f (CmmLoad addr ty)    = f (CmmLoad (wrapRecExp f addr) ty)
+wrapRecExp f e                    = f e
+
+mapExp :: (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
+mapExp _ f@(CmmEntry{})                          = f
+mapExp _ m@(CmmComment _)                        = m
+mapExp _ m@(CmmTick _)                           = m
+mapExp f   (CmmUnwind regs)                      = CmmUnwind (map (fmap (fmap f)) regs)
+mapExp f   (CmmAssign r e)                       = CmmAssign r (f e)
+mapExp f   (CmmStore addr e)                     = CmmStore (f addr) (f e)
+mapExp f   (CmmUnsafeForeignCall tgt fs as)      = CmmUnsafeForeignCall (mapForeignTarget f tgt) fs (map f as)
+mapExp _ l@(CmmBranch _)                         = l
+mapExp f   (CmmCondBranch e ti fi l)             = CmmCondBranch (f e) ti fi l
+mapExp f   (CmmSwitch e ids)                     = CmmSwitch (f e) ids
+mapExp f   n@CmmCall {cml_target=tgt}            = n{cml_target = f tgt}
+mapExp f   (CmmForeignCall tgt fs as succ ret_args updfr intrbl) = CmmForeignCall (mapForeignTarget f tgt) fs (map f as) succ ret_args updfr intrbl
+
+mapExpDeep :: (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
+mapExpDeep f = mapExp $ wrapRecExp f
+
+------------------------------------------------------------------------
+-- mapping Expr in CmmNode, but not performing allocation if no changes
+
+mapForeignTargetM :: (CmmExpr -> Maybe CmmExpr) -> ForeignTarget -> Maybe ForeignTarget
+mapForeignTargetM f (ForeignTarget e c) = (\x -> ForeignTarget x c) `fmap` f e
+mapForeignTargetM _ (PrimTarget _)      = Nothing
+
+wrapRecExpM :: (CmmExpr -> Maybe CmmExpr) -> (CmmExpr -> Maybe CmmExpr)
+-- (wrapRecExpM f e) first recursively applies itself to sub-expressions of e
+--                   then  gives f a chance to rewrite the resulting expression
+wrapRecExpM f n@(CmmMachOp op es)  = maybe (f n) (f . CmmMachOp op)    (mapListM (wrapRecExpM f) es)
+wrapRecExpM f n@(CmmLoad addr ty)  = maybe (f n) (f . flip CmmLoad ty) (wrapRecExpM f addr)
+wrapRecExpM f e                    = f e
+
+mapExpM :: (CmmExpr -> Maybe CmmExpr) -> CmmNode e x -> Maybe (CmmNode e x)
+mapExpM _ (CmmEntry{})              = Nothing
+mapExpM _ (CmmComment _)            = Nothing
+mapExpM _ (CmmTick _)               = Nothing
+mapExpM f (CmmUnwind regs)          = CmmUnwind `fmap` mapM (\(r,e) -> mapM f e >>= \e' -> pure (r,e')) regs
+mapExpM f (CmmAssign r e)           = CmmAssign r `fmap` f e
+mapExpM f (CmmStore addr e)         = (\[addr', e'] -> CmmStore addr' e') `fmap` mapListM f [addr, e]
+mapExpM _ (CmmBranch _)             = Nothing
+mapExpM f (CmmCondBranch e ti fi l) = (\x -> CmmCondBranch x ti fi l) `fmap` f e
+mapExpM f (CmmSwitch e tbl)         = (\x -> CmmSwitch x tbl)       `fmap` f e
+mapExpM f (CmmCall tgt mb_id r o i s) = (\x -> CmmCall x mb_id r o i s) `fmap` f tgt
+mapExpM f (CmmUnsafeForeignCall tgt fs as)
+    = case mapForeignTargetM f tgt of
+        Just tgt' -> Just (CmmUnsafeForeignCall tgt' fs (mapListJ f as))
+        Nothing   -> (\xs -> CmmUnsafeForeignCall tgt fs xs) `fmap` mapListM f as
+mapExpM f (CmmForeignCall tgt fs as succ ret_args updfr intrbl)
+    = case mapForeignTargetM f tgt of
+        Just tgt' -> Just (CmmForeignCall tgt' fs (mapListJ f as) succ ret_args updfr intrbl)
+        Nothing   -> (\xs -> CmmForeignCall tgt fs xs succ ret_args updfr intrbl) `fmap` mapListM f as
+
+-- share as much as possible
+mapListM :: (a -> Maybe a) -> [a] -> Maybe [a]
+mapListM f xs = let (b, r) = mapListT f xs
+                in if b then Just r else Nothing
+
+mapListJ :: (a -> Maybe a) -> [a] -> [a]
+mapListJ f xs = snd (mapListT f xs)
+
+mapListT :: (a -> Maybe a) -> [a] -> (Bool, [a])
+mapListT f xs = foldr g (False, []) (zip3 (tails xs) xs (map f xs))
+    where g (_,   y, Nothing) (True, ys)  = (True,  y:ys)
+          g (_,   _, Just y)  (True, ys)  = (True,  y:ys)
+          g (ys', _, Nothing) (False, _)  = (False, ys')
+          g (_,   _, Just y)  (False, ys) = (True,  y:ys)
+
+mapExpDeepM :: (CmmExpr -> Maybe CmmExpr) -> CmmNode e x -> Maybe (CmmNode e x)
+mapExpDeepM f = mapExpM $ wrapRecExpM f
+
+-----------------------------------
+-- folding Expr in CmmNode
+
+foldExpForeignTarget :: (CmmExpr -> z -> z) -> ForeignTarget -> z -> z
+foldExpForeignTarget exp (ForeignTarget e _) z = exp e z
+foldExpForeignTarget _   (PrimTarget _)      z = z
+
+-- Take a folder on expressions and apply it recursively.
+-- Specifically (wrapRecExpf f e z) deals with CmmMachOp and CmmLoad
+-- itself, delegating all the other CmmExpr forms to 'f'.
+wrapRecExpf :: (CmmExpr -> z -> z) -> CmmExpr -> z -> z
+wrapRecExpf f e@(CmmMachOp _ es) z = foldr (wrapRecExpf f) (f e z) es
+wrapRecExpf f e@(CmmLoad addr _) z = wrapRecExpf f addr (f e z)
+wrapRecExpf f e                  z = f e z
+
+foldExp :: (CmmExpr -> z -> z) -> CmmNode e x -> z -> z
+foldExp _ (CmmEntry {}) z                         = z
+foldExp _ (CmmComment {}) z                       = z
+foldExp _ (CmmTick {}) z                          = z
+foldExp f (CmmUnwind xs) z                        = foldr (maybe id f) z (map snd xs)
+foldExp f (CmmAssign _ e) z                       = f e z
+foldExp f (CmmStore addr e) z                     = f addr $ f e z
+foldExp f (CmmUnsafeForeignCall t _ as) z         = foldr f (foldExpForeignTarget f t z) as
+foldExp _ (CmmBranch _) z                         = z
+foldExp f (CmmCondBranch e _ _ _) z               = f e z
+foldExp f (CmmSwitch e _) z                       = f e z
+foldExp f (CmmCall {cml_target=tgt}) z            = f tgt z
+foldExp f (CmmForeignCall {tgt=tgt, args=args}) z = foldr f (foldExpForeignTarget f tgt z) args
+
+foldExpDeep :: (CmmExpr -> z -> z) -> CmmNode e x -> z -> z
+foldExpDeep f = foldExp (wrapRecExpf f)
+
+-- -----------------------------------------------------------------------------
+
+mapSuccessors :: (Label -> Label) -> CmmNode O C -> CmmNode O C
+mapSuccessors f (CmmBranch bid)         = CmmBranch (f bid)
+mapSuccessors f (CmmCondBranch p y n l) = CmmCondBranch p (f y) (f n) l
+mapSuccessors f (CmmSwitch e ids)       = CmmSwitch e (mapSwitchTargets f ids)
+mapSuccessors _ n = n
+
+mapCollectSuccessors :: forall a. (Label -> (Label,a)) -> CmmNode O C
+                     -> (CmmNode O C, [a])
+mapCollectSuccessors f (CmmBranch bid)
+  = let (bid', acc) = f bid in (CmmBranch bid', [acc])
+mapCollectSuccessors f (CmmCondBranch p y n l)
+  = let (bidt, acct) = f y
+        (bidf, accf) = f n
+    in  (CmmCondBranch p bidt bidf l, [accf, acct])
+mapCollectSuccessors f (CmmSwitch e ids)
+  = let lbls = switchTargetsToList ids :: [Label]
+        lblMap = mapFromList $ zip lbls (map f lbls) :: LabelMap (Label, a)
+    in ( CmmSwitch e
+          (mapSwitchTargets
+            (\l -> fst $ mapFindWithDefault (error "impossible") l lblMap) ids)
+          , map snd (mapElems lblMap)
+        )
+mapCollectSuccessors _ n = (n, [])
+
+-- -----------------------------------------------------------------------------
+
+-- | 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

ghc-toolkit/boot-libs/ghc/cmm/CmmOpt.hs

@@ -0,0 +1,427 @@
+-- The default iteration limit is a bit too low for the definitions
+-- in this module.
+{-# OPTIONS_GHC -fmax-pmcheck-iterations=10000000 #-}
+
+-----------------------------------------------------------------------------
+--
+-- Cmm optimisation
+--
+-- (c) The University of Glasgow 2006
+--
+-----------------------------------------------------------------------------
+
+module CmmOpt (
+        constantFoldNode,
+        constantFoldExpr,
+        cmmMachOpFold,
+        cmmMachOpFoldM
+ ) where
+
+import GhcPrelude
+
+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 ...
+-- See Note [Comparison operators]
+
+cmmMachOpFoldM dflags mop [x, y@(CmmLit (CmmInt 0 _))]
+  = case mop of
+        -- Arithmetic
+        MO_Add   _ -> Just x   -- x + 0 = x
+        MO_Sub   _ -> Just x   -- x - 0 = x
+        MO_Mul   _ -> Just y   -- x * 0 = 0
+
+        -- Logical operations
+        MO_And   _ -> Just y   -- x &     0 = 0
+        MO_Or    _ -> Just x   -- x |     0 = x
+        MO_Xor   _ -> Just x   -- x `xor` 0 = x
+
+        -- Shifts
+        MO_Shl   _ -> Just x   -- x << 0 = x
+        MO_S_Shr _ -> Just x   -- ditto shift-right
+        MO_U_Shr _ -> Just x
+
+        -- Comparisons; these ones are trickier
+        -- See Note [Comparison operators]
+        MO_Ne    _ | isComparisonExpr x -> Just x                -- (x > y) != 0  =  x > y
+        MO_Eq    _ | Just x' <- maybeInvertCmmExpr x -> Just x'  -- (x > y) == 0  =  x <= y
+        MO_U_Gt  _ | isComparisonExpr x -> Just x                -- (x > y) > 0   =  x > y
+        MO_S_Gt  _ | isComparisonExpr x -> Just x                -- ditto
+        MO_U_Lt  _ | isComparisonExpr x -> Just zero             -- (x > y) < 0  =  0
+        MO_S_Lt  _ | isComparisonExpr x -> Just zero
+        MO_U_Ge  _ | isComparisonExpr x -> Just one              -- (x > y) >= 0  =  1
+        MO_S_Ge  _ | isComparisonExpr x -> Just one
+
+        MO_U_Le  _ | Just x' <- maybeInvertCmmExpr x -> Just x'  -- (x > y) <= 0  =  x <= y
+        MO_S_Le  _ | Just x' <- maybeInvertCmmExpr x -> Just x'
+        _ -> Nothing
+  where
+    zero = CmmLit (CmmInt 0 (wordWidth dflags))
+    one  = CmmLit (CmmInt 1 (wordWidth dflags))
+
+cmmMachOpFoldM dflags mop [x, (CmmLit (CmmInt 1 rep))]
+  = case mop of
+        -- Arithmetic: x*1 = x, etc
+        MO_Mul    _ -> Just x
+        MO_S_Quot _ -> Just x
+        MO_U_Quot _ -> Just x
+        MO_S_Rem  _ -> Just $ CmmLit (CmmInt 0 rep)
+        MO_U_Rem  _ -> Just $ CmmLit (CmmInt 0 rep)
+
+        -- Comparisons; trickier
+        -- See Note [Comparison operators]
+        MO_Ne    _ | Just x' <- maybeInvertCmmExpr x -> Just x'  -- (x>y) != 1  =  x<=y
+        MO_Eq    _ | isComparisonExpr x -> Just x                -- (x>y) == 1  =  x>y
+        MO_U_Lt  _ | Just x' <- maybeInvertCmmExpr x -> Just x'  -- (x>y) < 1   =  x<=y
+        MO_S_Lt  _ | Just x' <- maybeInvertCmmExpr x -> Just x'  -- ditto
+        MO_U_Gt  _ | isComparisonExpr x -> Just zero             -- (x>y) > 1   = 0
+        MO_S_Gt  _ | isComparisonExpr x -> Just zero
+        MO_U_Le  _ | isComparisonExpr x -> Just one              -- (x>y) <= 1  = 1
+        MO_S_Le  _ | isComparisonExpr x -> Just one
+        MO_U_Ge  _ | isComparisonExpr x -> Just x                -- (x>y) >= 1  = x>y
+        MO_S_Ge  _ | isComparisonExpr x -> Just x
+        _ -> Nothing
+  where
+    zero = CmmLit (CmmInt 0 (wordWidth dflags))
+    one  = CmmLit (CmmInt 1 (wordWidth dflags))
+
+-- 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_U_Rem rep
+           | Just _ <- exactLog2 n ->
+                 Just (cmmMachOpFold dflags (MO_And rep) [x, CmmLit (CmmInt (n - 1) rep)])
+        MO_S_Quot rep
+           | Just p <- exactLog2 n,
+             CmmReg _ <- x ->   -- We duplicate x in signedQuotRemHelper, hence require
+                                -- it is a reg.  FIXME: remove this restriction.
+                Just (cmmMachOpFold dflags (MO_S_Shr rep)
+                  [signedQuotRemHelper rep p, CmmLit (CmmInt p rep)])
+        MO_S_Rem rep
+           | Just p <- exactLog2 n,
+             CmmReg _ <- x ->   -- We duplicate x in signedQuotRemHelper, hence require
+                                -- it is a reg.  FIXME: remove this restriction.
+                -- We replace (x `rem` 2^p) by (x - (x `quot` 2^p) * 2^p).
+                -- Moreover, we fuse MO_S_Shr (last operation of MO_S_Quot)
+                -- and MO_S_Shl (multiplication by 2^p) into a single MO_And operation.
+                Just (cmmMachOpFold dflags (MO_Sub rep)
+                    [x, cmmMachOpFold dflags (MO_And rep)
+                      [signedQuotRemHelper rep p, CmmLit (CmmInt (- n) rep)]])
+        _ -> Nothing
+  where
+    -- In contrast with unsigned integers, for signed ones
+    -- shift right is not the same as quot, because it rounds
+    -- to minus infinity, whereas quot rounds toward zero.
+    -- To fix this up, we add one less than the divisor to the
+    -- dividend if it is a negative number.
+    --
+    -- to avoid a test/jump, we use the following sequence:
+    --      x1 = x >> word_size-1  (all 1s if -ve, all 0s if +ve)
+    --      x2 = y & (divisor-1)
+    --      result = x + x2
+    -- this could be done a bit more simply using conditional moves,
+    -- but we're processor independent here.
+    --
+    -- we optimise the divide by 2 case slightly, generating
+    --      x1 = x >> word_size-1  (unsigned)
+    --      return = x + x1
+    signedQuotRemHelper :: Width -> Integer -> CmmExpr
+    signedQuotRemHelper rep p = CmmMachOp (MO_Add rep) [x, x2]
+      where
+        bits = fromIntegral (widthInBits rep) - 1
+        shr = if p == 1 then MO_U_Shr rep else MO_S_Shr rep
+        x1 = CmmMachOp shr [x, CmmLit (CmmInt bits rep)]
+        x2 = if p == 1 then x1 else
+             CmmMachOp (MO_And rep) [x1, CmmLit (CmmInt (n-1) rep)]
+
+-- ToDo (#7116): optimise floating-point multiplication, e.g. x*2.0 -> x+x
+-- Unfortunately this needs a unique supply because x might not be a
+-- register.  See #2253 (program 6) for an example.
+
+
+-- Anything else is just too hard.
+
+cmmMachOpFoldM _ _ _ = Nothing
+
+{- Note [Comparison operators]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If we have
+   CmmCondBranch ((x>#y) == 1) t f
+we really want to convert to
+   CmmCondBranch (x>#y) t f
+
+That's what the constant-folding operations on comparison operators do above.
+-}
+
+
+-- -----------------------------------------------------------------------------
+-- Utils
+
+isPicReg :: CmmExpr -> Bool
+isPicReg (CmmReg (CmmGlobal PicBaseReg)) = True
+isPicReg _ = False

ghc-toolkit/boot-libs/ghc/cmm/CmmPipeline.hs

@@ -0,0 +1,360 @@
+{-# 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 GhcPrelude
+
+import Cmm
+import CmmLint
+import CmmBuildInfoTables
+import CmmCommonBlockElim
+import CmmImplementSwitchPlans
+import CmmProcPoint
+import CmmContFlowOpt
+import CmmLayoutStack
+import CmmSink
+import Hoopl.Collections
+
+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
+ -> ModuleSRTInfo        -- Info about SRTs generated so far
+ -> CmmGroup             -- Input C-- with Procedures
+ -> IO (ModuleSRTInfo, CmmGroup) -- Output CPS transformed C--
+
+cmmPipeline hsc_env srtInfo prog =
+  do let dflags = hsc_dflags hsc_env
+
+     tops <- {-# SCC "tops" #-} mapM (cpsTop hsc_env) prog
+
+     (srtInfo, cmms) <- {-# SCC "doSRTs" #-} doSRTs dflags srtInfo tops
+     dumpWith dflags Opt_D_dump_cmm_cps "Post CPS Cmm" (ppr cmms)
+
+     return (srtInfo, 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 call_pps l g
+       dumpWith dflags Opt_D_dump_cmm_caf "CAFEnv" (ppr cafEnv)
+
+       g <- if splitting_proc_points
+            then do
+               ------------- Split into separate procedures -----------------------
+               let pp_map = {-# SCC "procPointAnalysis" #-}
+                            procPointAnalysis proc_points g
+               dumpWith dflags Opt_D_dump_cmm_procmap "procpoint map" $
+                    ppr pp_map
+               g <- {-# SCC "splitAtProcPoints" #-} runUniqSM $
+                    splitAtProcPoints dflags l call_pps proc_points pp_map
+                                      (CmmProc h l v g)
+               dumps Opt_D_dump_cmm_split "Post splitting" g
+               return g
+             else do
+               -- attach info tables to return points
+               return $ [attachContInfoTables call_pps (CmmProc h l v g)]
+
+       ------------- Populate info tables with stack info -----------------
+       g <- {-# SCC "setInfoTableStackMap" #-}
+            return $ map (setInfoTableStackMap dflags stackmaps) g
+       dumps Opt_D_dump_cmm_info "after setInfoTableStackMap" g
+
+       ----------- Control-flow optimisations -----------------------------
+       g <- {-# SCC "cmmCfgOpts(2)" #-}
+            return $ if optLevel dflags >= 1
+                     then map (cmmCfgOptsProc splitting_proc_points) g
+                     else g
+       g <- return (map removeUnreachableBlocksProc g)
+            -- See Note [unreachable blocks]
+       dumps Opt_D_dump_cmm_cfg "Post control-flow optimisations" g
+
+       return (cafEnv, g)
+
+  where dflags = hsc_dflags hsc_env
+        platform = targetPlatform dflags
+        dump = dumpGraph dflags
+
+        dumps flag name
+           = mapM_ (dumpWith dflags flag name . ppr)
+
+        condPass flag pass g dumpflag dumpname =
+            if gopt flag dflags
+               then do
+                    g <- return $ pass g
+                    dump dumpflag dumpname g
+                    return g
+               else return g
+
+        -- we don't need to split proc points for the NCG, unless
+        -- tablesNextToCode is off.  The latter is because we have no
+        -- label to put on info tables for basic blocks that are not
+        -- the entry point.
+        splitting_proc_points = hscTarget dflags /= HscAsm
+                             || not (tablesNextToCode dflags)
+                             || -- Note [inconsistent-pic-reg]
+                                usingInconsistentPicReg
+        usingInconsistentPicReg
+           = case (platformArch platform, platformOS platform, positionIndependent dflags)
+             of   (ArchX86, OSDarwin, pic) -> pic
+                  _                        -> False
+
+-- Note [Sinking after stack layout]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- In the past we considered running sinking pass also before stack
+-- layout, but after making some measurements we realized that:
+--
+--   a) running sinking only before stack layout produces slower
+--      code than running sinking only before stack layout
+--
+--   b) running sinking both before and after stack layout produces
+--      code that has the same performance as when running sinking
+--      only after stack layout.
+--
+-- In other words sinking before stack layout doesn't buy as anything.
+--
+-- An interesting question is "why is it better to run sinking after
+-- stack layout"? It seems that the major reason are stores and loads
+-- generated by stack layout. Consider this code before stack layout:
+--
+--  c1E:
+--      _c1C::P64 = R3;
+--      _c1B::P64 = R2;
+--      _c1A::P64 = R1;
+--      I64[(young<c1D> + 8)] = c1D;
+--      call stg_gc_noregs() returns to c1D, args: 8, res: 8, upd: 8;
+--  c1D:
+--      R3 = _c1C::P64;
+--      R2 = _c1B::P64;
+--      R1 = _c1A::P64;
+--      call (P64[(old + 8)])(R3, R2, R1) args: 8, res: 0, upd: 8;
+--
+-- Stack layout pass will save all local variables live across a call
+-- (_c1C, _c1B and _c1A in this example) on the stack just before
+-- making a call and reload them from the stack after returning from a
+-- call:
+--
+--  c1E:
+--      _c1C::P64 = R3;
+--      _c1B::P64 = R2;
+--      _c1A::P64 = R1;
+--      I64[Sp - 32] = c1D;
+--      P64[Sp - 24] = _c1A::P64;
+--      P64[Sp - 16] = _c1B::P64;
+--      P64[Sp - 8] = _c1C::P64;
+--      Sp = Sp - 32;
+--      call stg_gc_noregs() returns to c1D, args: 8, res: 8, upd: 8;
+--  c1D:
+--      _c1A::P64 = P64[Sp + 8];
+--      _c1B::P64 = P64[Sp + 16];
+--      _c1C::P64 = P64[Sp + 24];
+--      R3 = _c1C::P64;
+--      R2 = _c1B::P64;
+--      R1 = _c1A::P64;
+--      Sp = Sp + 32;
+--      call (P64[Sp])(R3, R2, R1) args: 8, res: 0, upd: 8;
+--
+-- If we don't run sinking pass after stack layout we are basically
+-- left with such code. However, running sinking on this code can lead
+-- to significant improvements:
+--
+--  c1E:
+--      I64[Sp - 32] = c1D;
+--      P64[Sp - 24] = R1;
+--      P64[Sp - 16] = R2;
+--      P64[Sp - 8] = R3;
+--      Sp = Sp - 32;
+--      call stg_gc_noregs() returns to c1D, args: 8, res: 8, upd: 8;
+--  c1D:
+--      R3 = P64[Sp + 24];
+--      R2 = P64[Sp + 16];
+--      R1 = P64[Sp + 8];
+--      Sp = Sp + 32;
+--      call (P64[Sp])(R3, R2, R1) args: 8, res: 0, upd: 8;
+--
+-- Now we only have 9 assignments instead of 15.
+--
+-- There is one case when running sinking before stack layout could
+-- be beneficial. Consider this:
+--
+--   L1:
+--      x = y
+--      call f() returns L2
+--   L2: ...x...y...
+--
+-- Since both x and y are live across a call to f, they will be stored
+-- on the stack during stack layout and restored after the call:
+--
+--   L1:
+--      x = y
+--      P64[Sp - 24] = L2
+--      P64[Sp - 16] = x
+--      P64[Sp - 8]  = y
+--      Sp = Sp - 24
+--      call f() returns L2
+--   L2:
+--      y = P64[Sp + 16]
+--      x = P64[Sp + 8]
+--      Sp = Sp + 24
+--      ...x...y...
+--
+-- However, if we run sinking before stack layout we would propagate x
+-- to its usage place (both x and y must be local register for this to
+-- be possible - global registers cannot be floated past a call):
+--
+--   L1:
+--      x = y
+--      call f() returns L2
+--   L2: ...y...y...
+--
+-- Thus making x dead at the call to f(). If we ran stack layout now
+-- we would generate less stores and loads:
+--
+--   L1:
+--      x = y
+--      P64[Sp - 16] = L2
+--      P64[Sp - 8]  = y
+--      Sp = Sp - 16
+--      call f() returns L2
+--   L2:
+--      y = P64[Sp + 8]
+--      Sp = Sp + 16
+--      ...y...y...
+--
+-- But since we don't see any benefits from running sinking befroe stack
+-- layout, this situation probably doesn't arise too often in practice.
+--
+
+{- Note [inconsistent-pic-reg]
+
+On x86/Darwin, PIC is implemented by inserting a sequence like
+
+    call 1f
+ 1: popl %reg
+
+at the proc entry point, and then referring to labels as offsets from
+%reg.  If we don't split proc points, then we could have many entry
+points in a proc that would need this sequence, and each entry point
+would then get a different value for %reg.  If there are any join
+points, then at the join point we don't have a consistent value for
+%reg, so we don't know how to refer to labels.
+
+Hence, on x86/Darwin, we have to split proc points, and then each proc
+point will get its own PIC initialisation sequence.
+
+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

ghc-toolkit/boot-libs/ghc/cmm/CmmProcPoint.hs

@@ -0,0 +1,496 @@
+{-# LANGUAGE GADTs, DisambiguateRecordFields, BangPatterns #-}
+
+module CmmProcPoint
+    ( ProcPointSet, Status(..)
+    , callProcPoints, minimalProcPointSet
+    , splitAtProcPoints, procPointAnalysis
+    , attachContInfoTables
+    )
+where
+
+import GhcPrelude 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.Block
+import Hoopl.Collections
+import Hoopl.Dataflow
+import Hoopl.Graph
+import Hoopl.Label
+
+-- Compute a minimal set of proc points for a control-flow graph.
+
+-- Determine a protocol for each proc point (which live variables will
+-- be passed as arguments and which will be on the stack).
+
+{-
+A proc point is a basic block that, after CPS transformation, will
+start a new function.  The entry block of the original function is a
+proc point, as is the continuation of each function call.
+A third kind of proc point arises if we want to avoid copying code.
+Suppose we have code like the following:
+
+  f() {
+    if (...) { ..1..; call foo(); ..2..}
+    else     { ..3..; call bar(); ..4..}
+    x = y + z;
+    return x;
+  }
+
+The statement 'x = y + z' can be reached from two different proc
+points: the continuations of foo() and bar().  We would prefer not to
+put a copy in each continuation; instead we would like 'x = y + z' to
+be the start of a new procedure to which the continuations can jump:
+
+  f_cps () {
+    if (...) { ..1..; push k_foo; jump foo_cps(); }
+    else     { ..3..; push k_bar; jump bar_cps(); }
+  }
+  k_foo() { ..2..; jump k_join(y, z); }
+  k_bar() { ..4..; jump k_join(y, z); }
+  k_join(y, z) { x = y + z; return x; }
+
+You might think then that a criterion to make a node a proc point is
+that it is directly reached by two distinct proc points.  (Note
+[Direct reachability].)  But this criterion is a bit too simple; for
+example, 'return x' is also reached by two proc points, yet there is
+no point in pulling it out of k_join.  A good criterion would be to
+say that a node should be made a proc point if it is reached by a set
+of proc points that is different than its immediate dominator.  NR
+believes this criterion can be shown to produce a minimum set of proc
+points, and given a dominator tree, the proc points can be chosen in
+time linear in the number of blocks.  Lacking a dominator analysis,
+however, we turn instead to an iterative solution, starting with no
+proc points and adding them according to these rules:
+
+  1. The entry block is a proc point.
+  2. The continuation of a call is a proc point.
+  3. A node is a proc point if it is directly reached by more proc
+     points than one of its predecessors.
+
+Because we don't understand the problem very well, we apply rule 3 at
+most once per iteration, then recompute the reachability information.
+(See Note [No simple dataflow].)  The choice of the new proc point is
+arbitrary, and I don't know if the choice affects the final solution,
+so I don't know if the number of proc points chosen is the
+minimum---but the set will be minimal.
+
+
+
+Note [Proc-point analysis]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Given a specified set of proc-points (a set of block-ids), "proc-point
+analysis" figures out, for every block, which proc-point it belongs to.
+All the blocks belonging to proc-point P will constitute a single
+top-level C procedure.
+
+A non-proc-point block B "belongs to" a proc-point P iff B is
+reachable from P without going through another proc-point.
+
+Invariant: a block B should belong to at most one proc-point; if it
+belongs to two, that's a bug.
+
+Note [Non-existing proc-points]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+On some architectures it might happen that the list of proc-points
+computed before stack layout pass will be invalidated by the stack
+layout. This will happen if stack layout removes from the graph
+blocks that were determined to be proc-points. Later on in the pipeline
+we use list of proc-points to perform [Proc-point analysis], but
+if a proc-point does not exist anymore then we will get compiler panic.
+See #8205.
+-}
+
+type ProcPointSet = LabelSet
+
+data Status
+  = ReachedBy ProcPointSet  -- set of proc points that directly reach the block
+  | ProcPoint               -- this block is itself a proc point
+
+instance Outputable Status where
+  ppr (ReachedBy ps)
+      | setNull ps = text "<not-reached>"
+      | otherwise = text "reached by" <+>
+                    (hsep $ punctuate comma $ map ppr $ setElems ps)
+  ppr ProcPoint = text "<procpt>"
+
+--------------------------------------------------
+-- Proc point analysis
+
+-- Once you know what the proc-points are, figure out
+-- what proc-points each block is reachable from
+-- See Note [Proc-point analysis]
+procPointAnalysis :: ProcPointSet -> CmmGraph -> LabelMap Status
+procPointAnalysis procPoints cmmGraph@(CmmGraph {g_graph = graph}) =
+    analyzeCmmFwd procPointLattice procPointTransfer cmmGraph initProcPoints
+  where
+    initProcPoints =
+        mkFactBase
+            procPointLattice
+            [ (id, ProcPoint)
+            | id <- setElems procPoints
+            -- See Note [Non-existing proc-points]
+            , id `setMember` labelsInGraph
+            ]
+    labelsInGraph = labelsDefined graph
+
+procPointTransfer :: TransferFun Status
+procPointTransfer block facts =
+    let label = entryLabel block
+        !fact = case getFact procPointLattice label facts of
+            ProcPoint -> ReachedBy $! setSingleton label
+            f -> f
+        result = map (\id -> (id, fact)) (successors block)
+    in mkFactBase procPointLattice result
+
+procPointLattice :: DataflowLattice Status
+procPointLattice = DataflowLattice unreached add_to
+  where
+    unreached = ReachedBy setEmpty
+    add_to (OldFact ProcPoint) _ = NotChanged ProcPoint
+    add_to _ (NewFact ProcPoint) = Changed ProcPoint -- because of previous case
+    add_to (OldFact (ReachedBy p)) (NewFact (ReachedBy p'))
+        | setSize union > setSize p = Changed (ReachedBy union)
+        | otherwise = NotChanged (ReachedBy p)
+      where
+        union = setUnion p' p
+
+----------------------------------------------------------------------
+
+-- It is worth distinguishing two sets of proc points: those that are
+-- induced by calls in the original graph and those that are
+-- introduced because they're reachable from multiple proc points.
+--
+-- Extract the set of Continuation BlockIds, see Note [Continuation BlockIds].
+callProcPoints      :: CmmGraph -> ProcPointSet
+callProcPoints g = foldlGraphBlocks add (setSingleton (g_entry g)) g
+  where add :: LabelSet -> CmmBlock -> LabelSet
+        add set b = case lastNode b of
+                      CmmCall {cml_cont = Just k} -> setInsert k set
+                      CmmForeignCall {succ=k}     -> setInsert k set
+                      _ -> set
+
+minimalProcPointSet :: Platform -> ProcPointSet -> CmmGraph
+                    -> 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 (revPostorder g) callProcPoints
+
+extendPPSet
+    :: Platform -> CmmGraph -> [CmmBlock] -> ProcPointSet -> UniqSM ProcPointSet
+extendPPSet platform g blocks procPoints =
+    let env = procPointAnalysis procPoints g
+        add pps block = let id = entryLabel block
+                        in  case mapLookup id env of
+                              Just ProcPoint -> setInsert id pps
+                              _ -> pps
+        procPoints' = foldlGraphBlocks add setEmpty g
+        newPoints = mapMaybe ppSuccessor blocks
+        newPoint  = listToMaybe newPoints
+        ppSuccessor b =
+            let nreached id = case mapLookup id env `orElse`
+                                    pprPanic "no ppt" (ppr id <+> 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 add_block
+             :: LabelMap (LabelMap CmmBlock)
+             -> CmmBlock
+             -> LabelMap (LabelMap CmmBlock)
+         add_block graphEnv b =
+           case mapLookup bid procMap of
+             Just ProcPoint -> add graphEnv bid bid b
+             Just (ReachedBy set) ->
+               case setElems set of
+                 []   -> graphEnv
+                 [id] -> add graphEnv id bid b
+                 _    -> panic "Each block should be reachable from only one ProcPoint"
+             Nothing -> graphEnv
+           where bid = entryLabel b
+         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 $ foldlGraphBlocks add_block mapEmpty g
+
+     -- Build a map from proc point BlockId to pairs of:
+     --  * Labels for their new procedures
+     --  * Labels for the info tables of their new procedures (only if
+     --    the proc point is a callPP)
+     -- Due to common blockification, we may overestimate the set of procpoints.
+     let add_label map pp = mapInsert pp lbls map
+           where lbls | pp == entry = (entry_label, fmap cit_lbl (mapLookup entry info_tbls))
+                      | otherwise   = (block_lbl, guard (setMember pp callPPs) >>
+                                                    Just info_table_lbl)
+                      where block_lbl      = blockLbl pp
+                            info_table_lbl = infoTblLbl pp
+
+         procLabels :: LabelMap (CLabel, Maybe CLabel)
+         procLabels = foldl' add_label mapEmpty
+                             (filter (flip mapMember (toBlockMap g)) (setElems procPoints))
+
+     -- In each new graph, add blocks jumping off to the new procedures,
+     -- and replace branches to procpoints with branches to the jump-off blocks
+     let add_jump_block
+             :: (LabelMap Label, [CmmBlock])
+             -> (Label, CLabel)
+             -> 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
+                    mapFoldr 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 addBlock) blockEnv'' jumpBlocks
+              let g' = ofBlockMap ppId blockEnv'''
+              -- pprTrace "g' pre jumps" (ppr g') $ do
+              return (mapInsert ppId g' newGraphEnv)
+
+     graphEnv <- foldM add_jumps mapEmpty $ mapToList graphEnv
+
+     let to_proc (bid, g)
+             | bid == entry
+             =  CmmProc (TopInfo {info_tbls  = info_tbls,
+                                  stack_info = stack_info})
+                        top_l live g'
+             | otherwise
+             = case expectJust "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)
+                   (revPostorder 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.
+-}

ghc-toolkit/boot-libs/ghc/cmm/CmmSink.hs

@@ -0,0 +1,855 @@
+{-# LANGUAGE GADTs #-}
+module CmmSink (
+     cmmSink
+  ) where
+
+import GhcPrelude
+
+import Cmm
+import CmmOpt
+import CmmLive
+import CmmUtils
+import Hoopl.Block
+import Hoopl.Label
+import Hoopl.Collections
+import Hoopl.Graph
+import CodeGen.Platform
+import Platform (isARM, platformArch)
+
+import DynFlags
+import Unique
+import UniqFM
+import PprCmm ()
+
+import qualified Data.IntSet as IntSet
+import Data.List (partition)
+import qualified Data.Set as Set
+import Data.Maybe
+
+-- Compact sets for membership tests of local variables.
+
+type LRegSet = IntSet.IntSet
+
+emptyLRegSet :: LRegSet
+emptyLRegSet = IntSet.empty
+
+nullLRegSet :: LRegSet -> Bool
+nullLRegSet = IntSet.null
+
+insertLRegSet :: LocalReg -> LRegSet -> LRegSet
+insertLRegSet l = IntSet.insert (getKey (getUnique l))
+
+elemLRegSet :: LocalReg -> LRegSet -> Bool
+elemLRegSet l = IntSet.member (getKey (getUnique l))
+
+-- -----------------------------------------------------------------------------
+-- 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 = revPostorder graph
+
+  join_pts = findJoinPoints blocks
+
+  sink :: LabelMap Assignments -> [CmmBlock] -> [CmmBlock]
+  sink _ [] = []
+  sink sunk (b:bs) =
+    -- pprTrace "sink" (ppr lbl) $
+    blockJoin first final_middle final_last : sink sunk' bs
+    where
+      lbl = entryLabel b
+      (first, middle, last) = blockSplit b
+
+      succs = successors last
+
+      -- Annotate the middle nodes with the registers live *after*
+      -- the node.  This will help us decide whether we can inline
+      -- an assignment in the current node or not.
+      live = 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.
+-- This also does constant folding for primpops, since
+-- inlining opens up opportunities for doing so.
+
+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 emptyLRegSet 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' (insertLRegSet 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 `elemLRegSet` 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 = improveConditional (mapExpDeep inl_exp node)
+
+        inl_exp :: CmmExpr -> CmmExpr
+        -- inl_exp is where the inlining actually takes place!
+        inl_exp (CmmReg    (CmmLocal l'))     | l == l' = rhs
+        inl_exp (CmmRegOff (CmmLocal l') off) | l == l'
+                    = cmmOffset dflags rhs off
+                    -- re-constant fold after inlining
+        inl_exp (CmmMachOp op args) = cmmMachOpFold dflags op args
+        inl_exp other = other
+
+
+{- Note [improveConditional]
+
+cmmMachOpFold tries to simplify conditionals to turn things like
+  (a == b) != 1
+into
+  (a != b)
+but there's one case it can't handle: when the comparison is over
+floating-point values, we can't invert it, because floating-point
+comparisons aren't invertible (because of NaNs).
+
+But we *can* optimise this conditional by swapping the true and false
+branches. Given
+  CmmCondBranch ((a >## b) != 1) t f
+we can turn it into
+  CmmCondBranch (a >## b) f t
+
+So here we catch conditionals that weren't optimised by cmmMachOpFold,
+and apply above transformation to eliminate the comparison against 1.
+
+It's tempting to just turn every != into == and then let cmmMachOpFold
+do its thing, but that risks changing a nice fall-through conditional
+into one that requires two jumps. (see swapcond_last in
+CmmContFlowOpt), so instead we carefully look for just the cases where
+we can eliminate a comparison.
+-}
+improveConditional :: CmmNode O x -> CmmNode O x
+improveConditional
+  (CmmCondBranch (CmmMachOp mop [x, CmmLit (CmmInt 1 _)]) t f l)
+  | neLike mop, isComparisonExpr x
+  = CmmCondBranch x f t (fmap not l)
+  where
+    neLike (MO_Ne _) = True
+    neLike (MO_U_Lt _) = True   -- (x<y) < 1 behaves like (x<y) != 1
+    neLike (MO_S_Lt _) = True   -- (x<y) < 1 behaves like (x<y) != 1
+    neLike _ = False
+improveConditional 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 :: LRegSet -> CmmExpr -> Bool
+regsUsedIn ls _ | nullLRegSet ls = False
+regsUsedIn ls e = wrapRecExpf f e False
+  where f (CmmReg (CmmLocal l))      _ | l `elemLRegSet` ls = True
+        f (CmmRegOff (CmmLocal l) _) _ | l `elemLRegSet` ls = True
+        f _ z = z
+
+-- we don't inline into CmmUnsafeForeignCall if the expression refers
+-- to global registers.  This is a HACK to avoid global registers
+-- clashing with C argument-passing registers, really the back-end
+-- ought to be able to handle it properly, but currently neither PprC
+-- nor the NCG can do it.  See Note [Register parameter passing]
+-- See also StgCmmForeign:load_args_into_temps.
+okToInline :: DynFlags -> CmmExpr -> CmmNode e x -> Bool
+okToInline dflags expr node@(CmmUnsafeForeignCall{}) =
+    not (globalRegistersConflict dflags expr node)
+okToInline _ _ _ = True
+
+-- -----------------------------------------------------------------------------
+
+-- | @conflicts (r,e) node@ is @False@ if and only if the assignment
+-- @r = e@ can be safely commuted past statement @node@.
+conflicts :: DynFlags -> Assignment -> CmmNode O x -> Bool
+conflicts dflags (r, rhs, addr) node
+
+  -- (1) node defines registers used by rhs of assignment. This catches
+  -- assignments and all three kinds of calls. See Note [Sinking and calls]
+  | globalRegistersConflict dflags rhs node                       = True
+  | localRegistersConflict  dflags rhs node                       = True
+
+  -- (2) node uses register defined by assignment
+  | foldRegsUsed dflags (\b r' -> r == r' || b) False node        = True
+
+  -- (3) a store to an address conflicts with a read of the same memory
+  | CmmStore addr' e <- node
+  , memConflicts addr (loadAddr dflags addr' (cmmExprWidth dflags e)) = True
+
+  -- (4) an assignment to Hp/Sp conflicts with a heap/stack read respectively
+  | HeapMem    <- addr, CmmAssign (CmmGlobal Hp) _ <- node        = True
+  | StackMem   <- addr, CmmAssign (CmmGlobal Sp) _ <- node        = True
+  | SpMem{}    <- addr, CmmAssign (CmmGlobal Sp) _ <- node        = True
+
+  -- (5) foreign calls clobber heap: see Note [Foreign calls clobber heap]
+  | CmmUnsafeForeignCall{} <- node, memConflicts addr AnyMem      = True
+
+  -- (6) native calls clobber any memory
+  | CmmCall{} <- node, memConflicts addr AnyMem                   = True
+
+  -- (7) otherwise, no conflict
+  | otherwise = False
+
+-- Returns True if node defines any global registers that are used in the
+-- Cmm expression
+globalRegistersConflict :: DynFlags -> CmmExpr -> CmmNode e x -> Bool
+globalRegistersConflict dflags expr node =
+    foldRegsDefd dflags (\b r -> b || regUsedIn dflags (CmmGlobal r) expr)
+                 False node
+
+-- Returns True if node defines any local registers that are used in the
+-- Cmm expression
+localRegistersConflict :: DynFlags -> CmmExpr -> CmmNode e x -> Bool
+localRegistersConflict dflags expr node =
+    foldRegsDefd dflags (\b r -> b || regUsedIn dflags (CmmLocal  r) expr)
+                 False node
+
+-- Note [Sinking and calls]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- We have three kinds of calls: normal (CmmCall), safe foreign (CmmForeignCall)
+-- and unsafe foreign (CmmUnsafeForeignCall). We perform sinking pass after
+-- stack layout (see Note [Sinking after stack layout]) which leads to two
+-- invariants related to calls:
+--
+--   a) during stack layout phase all safe foreign calls are turned into
+--      unsafe foreign calls (see Note [Lower safe foreign calls]). This
+--      means that we will never encounter CmmForeignCall node when running
+--      sinking after stack layout
+--
+--   b) stack layout saves all variables live across a call on the stack
+--      just before making a call (remember we are not sinking assignments to
+--      stack):
+--
+--       L1:
+--          x = R1
+--          P64[Sp - 16] = L2
+--          P64[Sp - 8]  = x
+--          Sp = Sp - 16
+--          call f() returns L2
+--       L2:
+--
+--      We will attempt to sink { x = R1 } but we will detect conflict with
+--      { P64[Sp - 8]  = x } and hence we will drop { x = R1 } without even
+--      checking whether it conflicts with { call f() }. In this way we will
+--      never need to check any assignment conflicts with CmmCall. Remember
+--      that we still need to check for potential memory conflicts.
+--
+-- So the result is that we only need to worry about CmmUnsafeForeignCall nodes
+-- when checking conflicts (see Note [Unsafe foreign calls clobber caller-save registers]).
+-- This assumption holds only when we do sinking after stack layout. If we run
+-- it before stack layout we need to check for possible conflicts with all three
+-- kinds of calls. Our `conflicts` function does that by using a generic
+-- foldRegsDefd and foldRegsUsed functions defined in DefinerOfRegs and
+-- UserOfRegs typeclasses.
+--
+
+-- An abstraction of memory read or written.
+data AbsMem
+  = NoMem            -- no memory accessed
+  | AnyMem           -- arbitrary memory
+  | HeapMem          -- definitely heap memory
+  | StackMem         -- definitely stack memory
+  | SpMem            -- <size>[Sp+n]
+       {-# UNPACK #-} !Int
+       {-# UNPACK #-} !Int
+
+-- Having SpMem is important because it lets us float loads from Sp
+-- past stores to Sp as long as they don't overlap, and this helps to
+-- unravel some long sequences of
+--    x1 = [Sp + 8]
+--    x2 = [Sp + 16]
+--    ...
+--    [Sp + 8]  = xi
+--    [Sp + 16] = xj
+--
+-- Note that SpMem is invalidated if Sp is changed, but the definition
+-- of 'conflicts' above handles that.
+
+-- ToDo: this won't currently fix the following commonly occurring code:
+--    x1 = [R1 + 8]
+--    x2 = [R1 + 16]
+--    ..
+--    [Hp - 8] = x1
+--    [Hp - 16] = x2
+--    ..
+
+-- because [R1 + 8] and [Hp - 8] are both HeapMem.  We know that
+-- assignments to [Hp + n] do not conflict with any other heap memory,
+-- but this is tricky to nail down.  What if we had
+--
+--   x = Hp + n
+--   [x] = ...
+--
+--  the store to [x] should be "new heap", not "old heap".
+--  Furthermore, you could imagine that if we started inlining
+--  functions in Cmm then there might well be reads of heap memory
+--  that was written in the same basic block.  To take advantage of
+--  non-aliasing of heap memory we will have to be more clever.
+
+-- Note [Foreign calls clobber heap]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- It is tempting to say that foreign calls clobber only
+-- non-heap/stack memory, but unfortunately we break this invariant in
+-- the RTS.  For example, in stg_catch_retry_frame we call
+-- stmCommitNestedTransaction() which modifies the contents of the
+-- TRec it is passed (this actually caused incorrect code to be
+-- generated).
+--
+-- Since the invariant is true for the majority of foreign calls,
+-- perhaps we ought to have a special annotation for calls that can
+-- modify heap/stack memory.  For now we just use the conservative
+-- definition here.
+--
+-- Some CallishMachOp imply a memory barrier e.g. AtomicRMW and
+-- therefore we should never float any memory operations across one of
+-- these calls.
+
+
+bothMems :: AbsMem -> AbsMem -> AbsMem
+bothMems NoMem    x         = x
+bothMems x        NoMem     = x
+bothMems HeapMem  HeapMem   = HeapMem
+bothMems StackMem StackMem     = StackMem
+bothMems (SpMem o1 w1) (SpMem o2 w2)
+  | o1 == o2  = SpMem o1 (max w1 w2)
+  | otherwise = StackMem
+bothMems SpMem{}  StackMem  = StackMem
+bothMems StackMem SpMem{}   = StackMem
+bothMems _         _        = AnyMem
+
+memConflicts :: AbsMem -> AbsMem -> Bool
+memConflicts NoMem      _          = False
+memConflicts _          NoMem      = False
+memConflicts HeapMem    StackMem   = False
+memConflicts StackMem   HeapMem    = False
+memConflicts SpMem{}    HeapMem    = False
+memConflicts HeapMem    SpMem{}    = False
+memConflicts (SpMem o1 w1) (SpMem o2 w2)
+  | o1 < o2   = o1 + w1 > o2
+  | otherwise = o2 + w2 > o1
+memConflicts _         _         = True
+
+exprMem :: DynFlags -> CmmExpr -> AbsMem
+exprMem dflags (CmmLoad addr w)  = bothMems (loadAddr dflags addr (typeWidth w)) (exprMem dflags addr)
+exprMem dflags (CmmMachOp _ es)  = foldr bothMems NoMem (map (exprMem dflags) es)
+exprMem _      _                 = NoMem
+
+loadAddr :: DynFlags -> CmmExpr -> Width -> AbsMem
+loadAddr dflags e w =
+  case e of
+   CmmReg r       -> regAddr dflags r 0 w
+   CmmRegOff r i  -> regAddr dflags r i w
+   _other | regUsedIn dflags spReg 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));
+-}

ghc-toolkit/boot-libs/ghc/cmm/CmmSwitch.hs

@@ -0,0 +1,500 @@
+{-# LANGUAGE GADTs #-}
+module CmmSwitch (
+     SwitchTargets,
+     mkSwitchTargets,
+     switchTargetsCases, switchTargetsDefault, switchTargetsRange, switchTargetsSigned,
+     mapSwitchTargets, switchTargetsToTable, switchTargetsFallThrough,
+     switchTargetsToList, eqSwitchTargetWith,
+
+     SwitchPlan(..),
+     targetSupportsSwitch,
+     createSwitchPlan,
+  ) where
+
+import GhcPrelude
+
+import Outputable
+import DynFlags
+import Hoopl.Label (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 constructor mkSwitchTargets normalises the map a bit:
+--  * No entries outside the range
+--  * No entries equal to the default
+--  * No default if all elements have explicit values
+mkSwitchTargets :: Bool -> (Integer, Integer) -> Maybe Label -> M.Map Integer Label -> SwitchTargets
+mkSwitchTargets signed range@(lo,hi) mbdef ids
+    = SwitchTargets signed range mbdef' ids'
+  where
+    ids' = dropDefault $ restrict ids
+    mbdef' | defaultNeeded = mbdef
+           | otherwise     = Nothing
+
+    -- Drop entries outside the range, if there is a range
+    restrict = restrictMap (lo,hi)
+
+    -- Drop entries that equal the default, if there is a default
+    dropDefault | Just l <- mbdef = M.filter (/= l)
+                | otherwise       = id
+
+    -- Check if the default is still needed
+    defaultNeeded = fromIntegral (M.size ids') /= hi-lo+1
+
+
+-- | Changes all labels mentioned in the SwitchTargets value
+mapSwitchTargets :: (Label -> Label) -> SwitchTargets -> SwitchTargets
+mapSwitchTargets f (SwitchTargets signed range mbdef branches)
+    = SwitchTargets signed range (fmap f mbdef) (fmap f branches)
+
+-- | 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.
+
+{-
+  Note [Two alts + default]
+  ~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Discussion and a bit more info at #14644
+
+When dealing with a switch of the form:
+switch(e) {
+  case 1: goto l1;
+  case 3000: goto l2;
+  default: goto ldef;
+}
+
+If we treat it as a sparse jump table we would generate:
+
+if (e > 3000) //Check if value is outside of the jump table.
+    goto ldef;
+else {
+    if (e < 3000) { //Compare to upper value
+        if(e != 1) //Compare to remaining value
+            goto ldef;
+          else
+            goto l2;
+    }
+    else
+        goto l1;
+}
+
+Instead we special case this to :
+
+if (e==1) goto l1;
+else if (e==3000) goto l2;
+else goto l3;
+
+This means we have:
+* Less comparisons for: 1,<3000
+* Unchanged for 3000
+* One more for >3000
+
+This improves code in a few ways:
+* One comparison less means smaller code which helps with cache.
+* It exchanges a taken jump for two jumps no taken in the >range case.
+  Jumps not taken are cheaper (See Agner guides) making this about as fast.
+* For all other cases the first range check is removed making it faster.
+
+The end result is that the change is not measurably slower for the case
+>3000 and faster for the other cases.
+
+This makes running this kind of match in an inner loop cheaper by 10-20%
+depending on the data.
+In nofib this improves wheel-sieve1 by 4-9% depending on problem
+size.
+
+We could also add a second conditional jump after the comparison to
+keep the range check like this:
+    cmp 3000, rArgument
+    jg <default>
+    je <branch 2>
+While this is fairly cheap it made no big difference for the >3000 case
+and slowed down all other cases making it not worthwhile.
+-}
+
+
+-- | 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
+    --Checking If |range| = 2 is enough if we have two unique literals
+    , hi - lo == 1
+    = IfEqual x1 l1 (Unconditionally l2)
+-- See Note [Two alts + default]
+createSwitchPlan (SwitchTargets _signed _range (Just defLabel) m)
+    | [(x1, l1), (x2,l2)] <- M.toAscList m
+    = IfEqual x1 l1 (IfEqual x2 l2 (Unconditionally defLabel))
+createSwitchPlan (SwitchTargets signed range mbdef m) =
+    -- pprTrace "createSwitchPlan" (text (show ids) $$ text (show (range,m)) $$ text (show pieces) $$ text (show flatPlan) $$ text (show plan)) $
+    plan
+  where
+    pieces = concatMap breakTooSmall $ splitAtHoles maxJumpTableHole m
+    flatPlan = findSingleValues $ mkFlatSwitchPlan signed mbdef range pieces
+    plan = buildTree signed $ flatPlan
+
+
+---
+--- Step 1: Splitting at large holes
+---
+splitAtHoles :: Integer -> M.Map Integer a -> [M.Map Integer a]
+splitAtHoles _        m | M.null m = []
+splitAtHoles holeSize m = map (\range -> restrictMap range m) nonHoles
+  where
+    holes = filter (\(l,h) -> h - l > holeSize) $ zip (M.keys m) (tail (M.keys m))
+    nonHoles = reassocTuples lo holes hi
+
+    (lo,_) = M.findMin m
+    (hi,_) = M.findMax m
+
+---
+--- Step 2: Avoid small jump tables
+---
+-- We do not want jump tables below a certain size. This breaks them up
+-- (into singleton maps, for now).
+breakTooSmall :: M.Map Integer a -> [M.Map Integer a]
+breakTooSmall m
+  | M.size m > minJumpTableSize = [m]
+  | otherwise                   = [M.singleton k v | (k,v) <- M.toList m]
+
+---
+---  Step 3: Fill in the blanks
+---
+
+-- | A FlatSwitchPlan is a list of SwitchPlans, with an integer 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.

ghc-toolkit/boot-libs/ghc/cmm/CmmType.hs

@@ -0,0 +1,442 @@
+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, isBitsType
+    , 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
+
+
+import GhcPrelude
+
+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, isBitsType :: CmmType -> Bool
+isFloatType (CmmType FloatCat    _) = True
+isFloatType _other                  = False
+
+isGcPtrType (CmmType GcPtrCat _) = True
+isGcPtrType _other               = False
+
+isBitsType (CmmType BitsCat _) = True
+isBitsType _                   = 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 -> PtrString
+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.
+
+-}
+

ghc-toolkit/boot-libs/ghc/cmm/CmmUtils.hs

@@ -0,0 +1,591 @@
+{-# LANGUAGE 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, isLit, isComparisonExpr,
+
+        baseExpr, spExpr, hpExpr, spLimExpr, hpLimExpr,
+        currentTSOExpr, currentNurseryExpr, cccsExpr,
+
+        -- 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,
+        ofBlockList, toBlockList, bodyToBlockList,
+        toBlockListEntryFirst, toBlockListEntryFirstFalseFallthrough,
+        foldlGraphBlocks, mapGraphNodes, revPostorder, mapGraphNodes1,
+
+        -- * Ticks
+        blockTicks
+  ) where
+
+import GhcPrelude
+
+import TyCon    ( PrimRep(..), PrimElemRep(..) )
+import RepType  ( UnaryType, SlotTy (..), typePrimRep1 )
+
+import SMRep
+import Cmm
+import BlockId
+import CLabel
+import Outputable
+import DynFlags
+import CodeGen.Platform
+
+import Data.Word
+import Data.Bits
+import Hoopl.Graph
+import Hoopl.Label
+import Hoopl.Block
+import Hoopl.Collections
+
+---------------------------------------------------
+--
+--      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 _      Int8Rep          = b8
+primRepCmmType _      Word8Rep         = b8
+primRepCmmType _      Int16Rep         = b16
+primRepCmmType _      Word16Rep        = b16
+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 Int8Rep      = SignedHint
+primRepForeignHint Int16Rep     = SignedHint
+primRepForeignHint Int64Rep     = SignedHint
+primRepForeignHint WordRep      = NoHint
+primRepForeignHint Word8Rep     = NoHint
+primRepForeignHint Word16Rep    = NoHint
+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 w) byte_off
+                                        = CmmLabelDiffOff l1 l2 (m+byte_off) w
+cmmOffsetLit (CmmInt m rep)    byte_off = CmmInt (m + fromIntegral byte_off) rep
+cmmOffsetLit _                 byte_off = pprPanic "cmmOffsetLit" (ppr byte_off)
+
+cmmLabelOff :: CLabel -> Int -> CmmLit
+-- Smart constructor for CmmLabelOff
+cmmLabelOff lbl 0        = CmmLabel lbl
+cmmLabelOff lbl byte_off = CmmLabelOff lbl byte_off
+
+-- | Useful for creating an index into an array, with a statically known offset.
+-- The type is the element type; used for making the multiplier
+cmmIndex :: 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]
+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
+
+isLit :: CmmExpr -> Bool
+isLit (CmmLit _) = True
+isLit _          = False
+
+isComparisonExpr :: CmmExpr -> Bool
+isComparisonExpr (CmmMachOp op _) = isComparisonMachOp op
+isComparisonExpr _                  = False
+
+---------------------------------------------------
+--
+--      Tagging
+--
+---------------------------------------------------
+
+-- Tag bits mask
+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, cmmIsTagged, cmmConstrTag1 :: 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 dflags e = cmmNeWord dflags (cmmAndWord dflags e (cmmTagMask dflags)) (zeroExpr dflags)
+
+-- 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 -> [LocalReg] -> Liveness
+mkLiveness _      [] = []
+mkLiveness dflags (reg:regs)
+  = bits ++ mkLiveness dflags regs
+  where
+    sizeW = (widthInBytes (typeWidth (localRegType reg)) + wORD_SIZE dflags - 1)
+            `quot` wORD_SIZE dflags
+            -- number of words, rounded up
+    bits = replicate sizeW is_non_ptr -- True <=> Non Ptr
+
+    is_non_ptr = not $ isGcPtrType (localRegType reg)
+
+
+-- ============================================== -
+-- ============================================== -
+-- ============================================== -
+
+---------------------------------------------------
+--
+--      Manipulating CmmGraphs
+--
+---------------------------------------------------
+
+modifyGraph :: (Graph n C C -> Graph n' C C) -> GenCmmGraph n -> GenCmmGraph n'
+modifyGraph f g = CmmGraph {g_entry=g_entry g, g_graph=f (g_graph g)}
+
+toBlockMap :: CmmGraph -> LabelMap CmmBlock
+toBlockMap (CmmGraph {g_graph=GMany NothingO body NothingO}) = body
+
+ofBlockMap :: BlockId -> LabelMap CmmBlock -> CmmGraph
+ofBlockMap entry bodyMap = CmmGraph {g_entry=entry, g_graph=GMany NothingO bodyMap NothingO}
+
+toBlockList :: CmmGraph -> [CmmBlock]
+toBlockList g = mapElems $ toBlockMap g
+
+-- | like 'toBlockList', but the entry block always comes first
+toBlockListEntryFirst :: CmmGraph -> [CmmBlock]
+toBlockListEntryFirst g
+  | mapNull m  = []
+  | otherwise  = entry_block : others
+  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
+-- defined 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)
+
+
+foldlGraphBlocks :: (a -> CmmBlock -> a) -> a -> CmmGraph -> a
+foldlGraphBlocks k z g = mapFoldl k z $ toBlockMap g
+
+revPostorder :: CmmGraph -> [CmmBlock]
+revPostorder g = {-# SCC "revPostorder" #-}
+    revPostorderFrom (toBlockMap g) (g_entry g)
+
+-------------------------------------------------
+-- Tick utilities
+
+-- | Extract all tick annotations from the given block
+blockTicks :: Block CmmNode C C -> [CmmTickish]
+blockTicks b = reverse $ foldBlockNodesF goStmt b []
+  where goStmt :: CmmNode e x -> [CmmTickish] -> [CmmTickish]
+        goStmt  (CmmTick t) ts = t:ts
+        goStmt  _other      ts = ts
+
+
+-- -----------------------------------------------------------------------------
+-- Access to common global registers
+
+baseExpr, spExpr, hpExpr, currentTSOExpr, currentNurseryExpr,
+  spLimExpr, hpLimExpr, cccsExpr :: CmmExpr
+baseExpr = CmmReg baseReg
+spExpr = CmmReg spReg
+spLimExpr = CmmReg spLimReg
+hpExpr = CmmReg hpReg
+hpLimExpr = CmmReg hpLimReg
+currentTSOExpr = CmmReg currentTSOReg
+currentNurseryExpr = CmmReg currentNurseryReg
+cccsExpr = CmmReg cccsReg

ghc-toolkit/boot-libs/ghc/cmm/Debug.hs

@@ -0,0 +1,550 @@
+{-# 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 GhcPrelude
+
+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            ( seqList )
+
+import Hoopl.Block
+import Hoopl.Collections
+import Hoopl.Graph
+import Hoopl.Label
+
+import Data.Maybe
+import Data.List     ( minimumBy, nubBy )
+import Data.Ord      ( comparing )
+import qualified Data.Map as Map
+import Data.Either   ( partitionEithers )
+
+-- | 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)
+        = partitionEithers $ 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 may pass to either c2ff or c2fg; let's first consider the
+former. In this case there is nothing in particular that we need to do other
+than reiterate what we already know about Sp,
+
+       c2ff:
+           unwind Sp = Just Sp + 0;
+           R2 = v :: P64;
+           R1 = test_closure;
+           call (stg_gc_fun)(R2, R1) args: 8, res: 0, upd: 8;
+
+In contrast, c2fg updates Sp midway through its body. To ensure that unwinding
+can happen correctly after this point we must include an unwind statement there,
+in addition to the usual beginning-of-block statement,
+
+       c2fg:
+           unwind Sp = Just Sp + 0;
+           I64[Sp - 8] = c2dD;
+           R1 = v :: P64;
+           Sp = Sp - 8;
+           unwind Sp = Just Sp + 8;
+           if (R1 & 7 != 0) goto c2dD; else goto c2dE;
+
+The remaining blocks are simple,
+
+       c2dE:
+           unwind Sp = Just Sp + 8;
+           call (I64[R1])(R1) returns to c2dD, args: 8, res: 8, upd: 8;
+       c2dD:
+           unwind Sp = Just Sp + 8;
+           w :: P64 = R1;
+           Hp = Hp + 48;
+           if (Hp > HpLim) (likely: False) goto c2fj; else goto c2fi;
+       ...
+  },
+
+
+The flow of unwinding information through the compiler is a bit convoluted:
+
+ * C-- begins life in 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 DebugBlocks are then converted to, e.g., DWARF unwinding tables
+   (by the Dwarf module) and emitted in the final object.
+
+See also:
+  Note [Unwinding information in the NCG] in AsmCodeGen,
+  Note [Unwind pseudo-instruction in Cmm],
+  Note [Debugging DWARF unwinding info].
+
+
+Note [Debugging DWARF unwinding info]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+For debugging generated unwinding info I've found it most useful to dump the
+disassembled binary with objdump -D and dump the debug info with
+readelf --debug-dump=frames-interp.
+
+You should get something like this:
+
+  0000000000000010 <stg_catch_frame_info>:
+    10:   48 83 c5 18             add    $0x18,%rbp
+    14:   ff 65 00                jmpq   *0x0(%rbp)
+
+and:
+
+  Contents of the .debug_frame section:
+
+  00000000 0000000000000014 ffffffff CIE "" cf=1 df=-8 ra=16
+     LOC           CFA      rbp   rsp   ra
+  0000000000000000 rbp+0    v+0   s     c+0
+
+  00000018 0000000000000024 00000000 FDE cie=00000000 pc=000000000000000f..0000000000000017
+     LOC           CFA      rbp   rsp   ra
+  000000000000000f rbp+0    v+0   s     c+0
+  000000000000000f rbp+24   v+0   s     c+0
+
+To read it http://www.dwarfstd.org/doc/dwarf-2.0.0.pdf has a nice example in
+Appendix 5 (page 101 of the pdf) and more details in the relevant section.
+
+The key thing to keep in mind is that the value at LOC is the value from
+*before* the instruction at LOC executes. In other words it answers the
+question: if my $rip is at LOC, how do I get the relevant values given the
+values obtained through unwinding so far.
+
+If the readelf --debug-dump=frames-interp output looks wrong, it may also be
+useful to look at readelf --debug-dump=frames, which is closer to the
+information that GHC generated.
+
+It's also useful to dump the relevant Cmm with -ddump-cmm -ddump-opt-cmm
+-ddump-cmm-proc -ddump-cmm-verbose. Note [Unwind pseudo-instruction in Cmm]
+explains how to interpret it.
+
+Inside gdb there are a couple useful commands for inspecting frames.
+For example:
+
+  gdb> info frame <num>
+
+It shows the values of registers obtained through unwinding.
+
+Another useful thing to try when debugging the DWARF unwinding is to enable
+extra debugging output in GDB:
+
+  gdb> set debug frame 1
+
+This makes GDB produce a trace of its internal workings. Having gone this far,
+it's just a tiny step to run GDB in GDB. Make sure you install debugging
+symbols for gdb if you obtain it through a package manager.
+
+Keep in mind that the current release of GDB has an instruction pointer handling
+heuristic that works well for C-like languages, but doesn't always work for
+Haskell. See Note [Info Offset] in Dwarf.Types for more details.
+
+Note [Unwind pseudo-instruction in Cmm]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+One of the possible CmmNodes is a CmmUnwind pseudo-instruction. It doesn't
+generate any assembly, but controls what DWARF unwinding information gets
+generated.
+
+It's important to understand what ranges of code the unwind pseudo-instruction
+refers to.
+For a sequence of CmmNodes like:
+
+  A // starts at addr X and ends at addr Y-1
+  unwind Sp = Just Sp + 16;
+  B // starts at addr Y and ends at addr Z
+
+the unwind statement reflects the state after A has executed, but before B
+has executed. If you consult the Note [Debugging DWARF unwinding info], the
+LOC this information will end up in is Y.
+-}
+
+-- | A label associated with an 'UnwindTable'
+data UnwindPoint = UnwindPoint !CLabel !UnwindTable
+
+instance 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)

ghc-toolkit/boot-libs/ghc/cmm/Hoopl/Block.hs

@@ -0,0 +1,328 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+module Hoopl.Block
+    ( C
+    , O
+    , MaybeO(..)
+    , IndexedCO
+    , Block(..)
+    , blockAppend
+    , blockCons
+    , blockFromList
+    , blockJoin
+    , blockJoinHead
+    , blockJoinTail
+    , blockSnoc
+    , blockSplit
+    , blockSplitHead
+    , blockSplitTail
+    , blockToList
+    , emptyBlock
+    , firstNode
+    , foldBlockNodesB
+    , foldBlockNodesB3
+    , foldBlockNodesF
+    , isEmptyBlock
+    , lastNode
+    , mapBlock
+    , mapBlock'
+    , mapBlock3'
+    , replaceFirstNode
+    , replaceLastNode
+    ) where
+
+import GhcPrelude
+
+-- -----------------------------------------------------------------------------
+-- Shapes: Open and Closed
+
+-- | Used at the type level to indicate an "open" structure with
+-- a unique, unnamed control-flow edge flowing in or out.
+-- "Fallthrough" and concatenation are permitted at an open point.
+data O
+
+-- | Used at the type level to indicate a "closed" structure which
+-- supports control transfer only through the use of named
+-- labels---no "fallthrough" is permitted.  The number of control-flow
+-- edges is unconstrained.
+data C
+
+-- | Either type indexed by closed/open using type families
+type family IndexedCO ex a b :: *
+type instance IndexedCO C a _b = a
+type instance IndexedCO O _a b = b
+
+-- | Maybe type indexed by open/closed
+data MaybeO ex t where
+  JustO    :: t -> MaybeO O t
+  NothingO ::      MaybeO C t
+
+-- | Maybe type indexed by closed/open
+data MaybeC ex t where
+  JustC    :: t -> MaybeC C t
+  NothingC ::      MaybeC O t
+
+
+instance Functor (MaybeO ex) where
+  fmap _ NothingO = NothingO
+  fmap f (JustO a) = JustO (f a)
+
+instance Functor (MaybeC ex) where
+  fmap _ NothingC = NothingC
+  fmap f (JustC a) = JustC (f a)
+
+-- -----------------------------------------------------------------------------
+-- The Block type
+
+-- | A sequence of nodes.  May be any of four shapes (O/O, O/C, C/O, C/C).
+-- Open at the entry means single entry, mutatis mutandis for exit.
+-- A closed/closed block is a /basic/ block and can't be extended further.
+-- Clients should avoid manipulating blocks and should stick to either nodes
+-- or graphs.
+data Block n e x where
+  BlockCO  :: n C O -> Block n O O          -> Block n C O
+  BlockCC  :: n C O -> Block n O O -> n O C -> Block n C C
+  BlockOC  ::          Block n O O -> n O C -> Block n O C
+
+  BNil    :: Block n O O
+  BMiddle :: n O O                      -> Block n O O
+  BCat    :: Block n O O -> Block n O O -> Block n O O
+  BSnoc   :: Block n O O -> n O O       -> Block n O O
+  BCons   :: n O O       -> Block n O O -> Block n O O
+
+
+-- -----------------------------------------------------------------------------
+-- Simple operations on Blocks
+
+-- Predicates
+
+isEmptyBlock :: Block n e x -> Bool
+isEmptyBlock BNil       = True
+isEmptyBlock (BCat l r) = isEmptyBlock l && isEmptyBlock r
+isEmptyBlock _          = False
+
+
+-- Building
+
+emptyBlock :: Block n O O
+emptyBlock = BNil
+
+blockCons :: n O O -> Block n O x -> Block n O x
+blockCons n b = case b of
+  BlockOC b l  -> (BlockOC $! (n `blockCons` b)) l
+  BNil{}    -> BMiddle n
+  BMiddle{} -> n `BCons` b
+  BCat{}    -> n `BCons` b
+  BSnoc{}   -> n `BCons` b
+  BCons{}   -> n `BCons` b
+
+blockSnoc :: Block n e O -> n O O -> Block n e O
+blockSnoc b n = case b of
+  BlockCO f b -> BlockCO f $! (b `blockSnoc` n)
+  BNil{}      -> BMiddle n
+  BMiddle{}   -> b `BSnoc` n
+  BCat{}      -> b `BSnoc` n
+  BSnoc{}     -> b `BSnoc` n
+  BCons{}     -> b `BSnoc` n
+
+blockJoinHead :: n C O -> Block n O x -> Block n C x
+blockJoinHead f (BlockOC b l) = BlockCC f b l
+blockJoinHead f b = BlockCO f BNil `cat` b
+
+blockJoinTail :: Block n e O -> n O C -> Block n e C
+blockJoinTail (BlockCO f b) t = BlockCC f b t
+blockJoinTail b t = b `cat` BlockOC BNil t
+
+blockJoin :: n C O -> Block n O O -> n O C -> Block n C C
+blockJoin f b t = BlockCC f b t
+
+blockAppend :: Block n e O -> Block n O x -> Block n e x
+blockAppend = cat
+
+
+-- Taking apart
+
+firstNode :: Block n C x -> n C O
+firstNode (BlockCO n _)   = n
+firstNode (BlockCC n _ _) = n
+
+lastNode :: Block n x C -> n O C
+lastNode (BlockOC   _ n) = n
+lastNode (BlockCC _ _ n) = n
+
+blockSplitHead :: Block n C x -> (n C O, Block n O x)
+blockSplitHead (BlockCO n b)   = (n, b)
+blockSplitHead (BlockCC n b t) = (n, BlockOC b t)
+
+blockSplitTail :: Block n e C -> (Block n e O, n O C)
+blockSplitTail (BlockOC b n)   = (b, n)
+blockSplitTail (BlockCC f b t) = (BlockCO f b, t)
+
+-- | Split a closed block into its entry node, open middle block, and
+-- exit node.
+blockSplit :: Block n C C -> (n C O, Block n O O, n O C)
+blockSplit (BlockCC f b t) = (f, b, t)
+
+blockToList :: Block n O O -> [n O O]
+blockToList b = go b []
+   where go :: Block n O O -> [n O O] -> [n O O]
+         go BNil         r = r
+         go (BMiddle n)  r = n : r
+         go (BCat b1 b2) r = go b1 $! go b2 r
+         go (BSnoc b1 n) r = go b1 (n:r)
+         go (BCons n b1) r = n : go b1 r
+
+blockFromList :: [n O O] -> Block n O O
+blockFromList = foldr BCons BNil
+
+-- Modifying
+
+replaceFirstNode :: Block n C x -> n C O -> Block n C x
+replaceFirstNode (BlockCO _ b)   f = BlockCO f b
+replaceFirstNode (BlockCC _ b n) f = BlockCC f b n
+
+replaceLastNode :: Block n x C -> n O C -> Block n x C
+replaceLastNode (BlockOC   b _) n = BlockOC b n
+replaceLastNode (BlockCC l b _) n = BlockCC l b n
+
+-- -----------------------------------------------------------------------------
+-- General concatenation
+
+cat :: Block n e O -> Block n O x -> Block n e x
+cat x y = case x of
+  BNil -> y
+
+  BlockCO l b1 -> case y of
+                   BlockOC b2 n -> (BlockCC l $! (b1 `cat` b2)) n
+                   BNil         -> x
+                   BMiddle _    -> BlockCO l $! (b1 `cat` y)
+                   BCat{}       -> BlockCO l $! (b1 `cat` y)
+                   BSnoc{}      -> BlockCO l $! (b1 `cat` y)
+                   BCons{}      -> BlockCO l $! (b1 `cat` y)
+
+  BMiddle n -> case y of
+                   BlockOC b2 n2 -> (BlockOC $! (x `cat` b2)) n2
+                   BNil          -> x
+                   BMiddle{}     -> BCons n y
+                   BCat{}        -> BCons n y
+                   BSnoc{}       -> BCons n y
+                   BCons{}       -> BCons n y
+
+  BCat{} -> case y of
+                   BlockOC b3 n2 -> (BlockOC $! (x `cat` b3)) n2
+                   BNil          -> x
+                   BMiddle n     -> BSnoc x n
+                   BCat{}        -> BCat x y
+                   BSnoc{}       -> BCat x y
+                   BCons{}       -> BCat x y
+
+  BSnoc{} -> case y of
+                   BlockOC b2 n2 -> (BlockOC $! (x `cat` b2)) n2
+                   BNil          -> x
+                   BMiddle n     -> BSnoc x n
+                   BCat{}        -> BCat x y
+                   BSnoc{}       -> BCat x y
+                   BCons{}       -> BCat x y
+
+
+  BCons{} -> case y of
+                   BlockOC b2 n2 -> (BlockOC $! (x `cat` b2)) n2
+                   BNil          -> x
+                   BMiddle n     -> BSnoc x n
+                   BCat{}        -> BCat x y
+                   BSnoc{}       -> BCat x y
+                   BCons{}       -> BCat x y
+
+
+-- -----------------------------------------------------------------------------
+-- Mapping
+
+-- | map a function over the nodes of a 'Block'
+mapBlock :: (forall e x. n e x -> n' e x) -> Block n e x -> Block n' e x
+mapBlock f (BlockCO n b  ) = BlockCO (f n) (mapBlock f b)
+mapBlock f (BlockOC   b n) = BlockOC       (mapBlock f b) (f n)
+mapBlock f (BlockCC n b m) = BlockCC (f n) (mapBlock f b) (f m)
+mapBlock _  BNil           = BNil
+mapBlock f (BMiddle n)     = BMiddle (f n)
+mapBlock f (BCat b1 b2)    = BCat    (mapBlock f b1) (mapBlock f b2)
+mapBlock f (BSnoc b n)     = BSnoc   (mapBlock f b)  (f n)
+mapBlock f (BCons n b)     = BCons   (f n)  (mapBlock f b)
+
+-- | A strict 'mapBlock'
+mapBlock' :: (forall e x. n e x -> n' e x) -> (Block n e x -> Block n' e x)
+mapBlock' f = mapBlock3' (f, f, f)
+
+-- | map over a block, with different functions to apply to first nodes,
+-- middle nodes and last nodes respectively.  The map is strict.
+--
+mapBlock3' :: forall n n' e x .
+             ( n C O -> n' C O
+             , n O O -> n' O O,
+               n O C -> n' O C)
+          -> Block n e x -> Block n' e x
+mapBlock3' (f, m, l) b = go b
+  where go :: forall e x . Block n e x -> Block n' e x
+        go (BlockOC b y)   = (BlockOC $! go b) $! l y
+        go (BlockCO x b)   = (BlockCO $! f x) $! (go b)
+        go (BlockCC x b y) = ((BlockCC $! f x) $! go b) $! (l y)
+        go BNil            = BNil
+        go (BMiddle n)     = BMiddle $! m n
+        go (BCat x y)      = (BCat $! go x) $! (go y)
+        go (BSnoc x n)     = (BSnoc $! go x) $! (m n)
+        go (BCons n x)     = (BCons $! m n) $! (go x)
+
+-- -----------------------------------------------------------------------------
+-- Folding
+
+
+-- | Fold a function over every node in a block, forward or backward.
+-- The fold function must be polymorphic in the shape of the nodes.
+foldBlockNodesF3 :: forall n a b c .
+                   ( n C O       -> a -> b
+                   , n O O       -> b -> b
+                   , n O C       -> b -> c)
+                 -> (forall e x . Block n e x -> IndexedCO e a b -> IndexedCO x c b)
+foldBlockNodesF  :: forall n a .
+                    (forall e x . n e x       -> a -> a)
+                 -> (forall e x . Block n e x -> IndexedCO e a a -> IndexedCO x a a)
+foldBlockNodesB3 :: forall n a b c .
+                   ( n C O       -> b -> c
+                   , n O O       -> b -> b
+                   , n O C       -> a -> b)
+                 -> (forall e x . Block n e x -> IndexedCO x a b -> IndexedCO e c b)
+foldBlockNodesB  :: forall n a .
+                    (forall e x . n e x       -> a -> a)
+                 -> (forall e x . Block n e x -> IndexedCO x a a -> IndexedCO e a a)
+
+foldBlockNodesF3 (ff, fm, fl) = block
+  where block :: forall e x . Block n e x -> IndexedCO e a b -> IndexedCO x c b
+        block (BlockCO f b  )   = ff f `cat` block b
+        block (BlockCC f b l)   = ff f `cat` block b `cat` fl l
+        block (BlockOC   b l)   =            block b `cat` fl l
+        block BNil              = id
+        block (BMiddle node)    = fm node
+        block (b1 `BCat`    b2) = block b1 `cat` block b2
+        block (b1 `BSnoc` n)    = block b1 `cat` fm n
+        block (n `BCons` b2)    = fm n `cat` block b2
+        cat :: forall a b c. (a -> b) -> (b -> c) -> a -> c
+        cat f f' = f' . f
+
+foldBlockNodesF f = foldBlockNodesF3 (f, f, f)
+
+foldBlockNodesB3 (ff, fm, fl) = block
+  where block :: forall e x . Block n e x -> IndexedCO x a b -> IndexedCO e c b
+        block (BlockCO f b  )   = ff f `cat` block b
+        block (BlockCC f b l)   = ff f `cat` block b `cat` fl l
+        block (BlockOC   b l)   =            block b `cat` fl l
+        block BNil              = id
+        block (BMiddle node)    = fm node
+        block (b1 `BCat`    b2) = block b1 `cat` block b2
+        block (b1 `BSnoc` n)    = block b1 `cat` fm n
+        block (n `BCons` b2)    = fm n `cat` block b2
+        cat :: forall a b c. (b -> c) -> (a -> b) -> a -> c
+        cat f f' = f . f'
+
+foldBlockNodesB f = foldBlockNodesB3 (f, f, f)
+

ghc-toolkit/boot-libs/ghc/cmm/Hoopl/Collections.hs

@@ -0,0 +1,177 @@
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+module Hoopl.Collections
+    ( IsSet(..)
+    , setInsertList, setDeleteList, setUnions
+    , IsMap(..)
+    , mapInsertList, mapDeleteList, mapUnions
+    , UniqueMap, UniqueSet
+    ) where
+
+import GhcPrelude
+
+import qualified Data.IntMap.Strict as M
+import qualified Data.IntSet as S
+
+import Data.List (foldl1')
+
+class IsSet set where
+  type ElemOf set
+
+  setNull :: set -> Bool
+  setSize :: set -> Int
+  setMember :: ElemOf set -> set -> Bool
+
+  setEmpty :: set
+  setSingleton :: ElemOf set -> set
+  setInsert :: ElemOf set -> set -> set
+  setDelete :: ElemOf set -> set -> set
+
+  setUnion :: set -> set -> set
+  setDifference :: set -> set -> set
+  setIntersection :: set -> set -> set
+  setIsSubsetOf :: set -> set -> Bool
+  setFilter :: (ElemOf set -> Bool) -> set -> set
+
+  setFoldl :: (b -> ElemOf set -> b) -> b -> set -> b
+  setFoldr :: (ElemOf set -> b -> b) -> b -> set -> b
+
+  setElems :: set -> [ElemOf set]
+  setFromList :: [ElemOf set] -> set
+
+-- Helper functions for IsSet class
+setInsertList :: IsSet set => [ElemOf set] -> set -> set
+setInsertList keys set = foldl' (flip setInsert) set keys
+
+setDeleteList :: IsSet set => [ElemOf set] -> set -> set
+setDeleteList keys set = foldl' (flip setDelete) set keys
+
+setUnions :: IsSet set => [set] -> set
+setUnions [] = setEmpty
+setUnions sets = foldl1' setUnion sets
+
+
+class IsMap map where
+  type KeyOf map
+
+  mapNull :: map a -> Bool
+  mapSize :: map a -> Int
+  mapMember :: KeyOf map -> map a -> Bool
+  mapLookup :: KeyOf map -> map a -> Maybe a
+  mapFindWithDefault :: a -> KeyOf map -> map a -> a
+
+  mapEmpty :: map a
+  mapSingleton :: KeyOf map -> a -> map a
+  mapInsert :: KeyOf map -> a -> map a -> map a
+  mapInsertWith :: (a -> a -> a) -> KeyOf map -> a -> map a -> map a
+  mapDelete :: KeyOf map -> map a -> map a
+  mapAlter :: (Maybe a -> Maybe a) -> KeyOf map -> map a -> map a
+  mapAdjust :: (a -> a) -> KeyOf map -> map a -> map a
+
+  mapUnion :: map a -> map a -> map a
+  mapUnionWithKey :: (KeyOf map -> a -> a -> a) -> map a -> map a -> map a
+  mapDifference :: map a -> map a -> map a
+  mapIntersection :: map a -> map a -> map a
+  mapIsSubmapOf :: Eq a => map a -> map a -> Bool
+
+  mapMap :: (a -> b) -> map a -> map b
+  mapMapWithKey :: (KeyOf map -> a -> b) -> map a -> map b
+  mapFoldl :: (b -> a -> b) -> b -> map a -> b
+  mapFoldr :: (a -> b -> b) -> b -> map a -> b
+  mapFoldlWithKey :: (b -> KeyOf map -> a -> b) -> b -> map a -> b
+  mapFoldMapWithKey :: Monoid m => (KeyOf map -> a -> m) -> map a -> m
+  mapFilter :: (a -> Bool) -> map a -> map a
+  mapFilterWithKey :: (KeyOf map -> a -> Bool) -> map a -> map a
+
+
+  mapElems :: map a -> [a]
+  mapKeys :: map a -> [KeyOf map]
+  mapToList :: map a -> [(KeyOf map, a)]
+  mapFromList :: [(KeyOf map, a)] -> map a
+  mapFromListWith :: (a -> a -> a) -> [(KeyOf map,a)] -> map a
+
+-- Helper functions for IsMap class
+mapInsertList :: IsMap map => [(KeyOf map, a)] -> map a -> map a
+mapInsertList assocs map = foldl' (flip (uncurry mapInsert)) map assocs
+
+mapDeleteList :: IsMap map => [KeyOf map] -> map a -> map a
+mapDeleteList keys map = foldl' (flip mapDelete) map keys
+
+mapUnions :: IsMap map => [map a] -> map a
+mapUnions [] = mapEmpty
+mapUnions maps = foldl1' mapUnion maps
+
+-----------------------------------------------------------------------------
+-- Basic instances
+-----------------------------------------------------------------------------
+
+newtype UniqueSet = US S.IntSet deriving (Eq, Ord, Show, Semigroup, Monoid)
+
+instance IsSet UniqueSet where
+  type ElemOf UniqueSet = Int
+
+  setNull (US s) = S.null s
+  setSize (US s) = S.size s
+  setMember k (US s) = S.member k s
+
+  setEmpty = US S.empty
+  setSingleton k = US (S.singleton k)
+  setInsert k (US s) = US (S.insert k s)
+  setDelete k (US s) = US (S.delete k s)
+
+  setUnion (US x) (US y) = US (S.union x y)
+  setDifference (US x) (US y) = US (S.difference x y)
+  setIntersection (US x) (US y) = US (S.intersection x y)
+  setIsSubsetOf (US x) (US y) = S.isSubsetOf x y
+  setFilter f (US s) = US (S.filter f s)
+
+  setFoldl k z (US s) = S.foldl' k z s
+  setFoldr k z (US s) = S.foldr k z s
+
+  setElems (US s) = S.elems s
+  setFromList ks = US (S.fromList ks)
+
+newtype UniqueMap v = UM (M.IntMap v)
+  deriving (Eq, Ord, Show, Functor, Foldable, Traversable)
+
+instance IsMap UniqueMap where
+  type KeyOf UniqueMap = Int
+
+  mapNull (UM m) = M.null m
+  mapSize (UM m) = M.size m
+  mapMember k (UM m) = M.member k m
+  mapLookup k (UM m) = M.lookup k m
+  mapFindWithDefault def k (UM m) = M.findWithDefault def k m
+
+  mapEmpty = UM M.empty
+  mapSingleton k v = UM (M.singleton k v)
+  mapInsert k v (UM m) = UM (M.insert k v m)
+  mapInsertWith f k v (UM m) = UM (M.insertWith f k v m)
+  mapDelete k (UM m) = UM (M.delete k m)
+  mapAlter f k (UM m) = UM (M.alter f k m)
+  mapAdjust f k (UM m) = UM (M.adjust f k m)
+
+  mapUnion (UM x) (UM y) = UM (M.union x y)
+  mapUnionWithKey f (UM x) (UM y) = UM (M.unionWithKey f x y)
+  mapDifference (UM x) (UM y) = UM (M.difference x y)
+  mapIntersection (UM x) (UM y) = UM (M.intersection x y)
+  mapIsSubmapOf (UM x) (UM y) = M.isSubmapOf x y
+
+  mapMap f (UM m) = UM (M.map f m)
+  mapMapWithKey f (UM m) = UM (M.mapWithKey f m)
+  mapFoldl k z (UM m) = M.foldl' k z m
+  mapFoldr k z (UM m) = M.foldr k z m
+  mapFoldlWithKey k z (UM m) = M.foldlWithKey' k z m
+  mapFoldMapWithKey f (UM m) = M.foldMapWithKey f m
+  mapFilter f (UM m) = UM (M.filter f m)
+  mapFilterWithKey f (UM m) = UM (M.filterWithKey f m)
+
+  mapElems (UM m) = M.elems m
+  mapKeys (UM m) = M.keys m
+  mapToList (UM m) = M.toList m
+  mapFromList assocs = UM (M.fromList assocs)
+  mapFromListWith f assocs = UM (M.fromListWith f assocs)

ghc-toolkit/boot-libs/ghc/cmm/Hoopl/Dataflow.hs

@@ -0,0 +1,440 @@
+{-# 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
+  , foldRewriteNodesBwdOO
+  , DataflowLattice(..), OldFact(..), NewFact(..), JoinedFact(..)
+  , TransferFun, RewriteFun
+  , Fact, FactBase
+  , getFact, mkFactBase
+  , analyzeCmmFwd, analyzeCmmBwd
+  , rewriteCmmBwd
+  , changedIf
+  , joinOutFacts
+  , joinFacts
+  )
+where
+
+import GhcPrelude
+
+import Cmm
+import UniqSupply
+
+import Data.Array
+import Data.Maybe
+import Data.IntSet (IntSet)
+import qualified Data.IntSet as IntSet
+
+import Hoopl.Block
+import Hoopl.Graph
+import Hoopl.Collections
+import Hoopl.Label
+
+type family   Fact x f :: *
+type instance Fact C f = FactBase f
+type instance Fact O f = f
+
+newtype OldFact a = OldFact a
+
+newtype NewFact a = NewFact a
+
+-- | The result of joining OldFact and NewFact.
+data JoinedFact a
+    = Changed !a     -- ^ Result is different than OldFact.
+    | NotChanged !a  -- ^ Result is the same as OldFact.
+
+getJoined :: JoinedFact a -> a
+getJoined (Changed a) = a
+getJoined (NotChanged a) = a
+
+changedIf :: Bool -> a -> JoinedFact a
+changedIf True = Changed
+changedIf False = NotChanged
+
+type JoinFun a = OldFact a -> NewFact a -> JoinedFact a
+
+data DataflowLattice a = DataflowLattice
+    { fact_bot :: a
+    , fact_join :: JoinFun a
+    }
+
+data Direction = Fwd | Bwd
+
+type TransferFun f = CmmBlock -> FactBase f -> FactBase f
+
+-- | Function for rewrtiting and analysis combined. To be used with
+-- @rewriteCmm@.
+--
+-- Currently set to work with @UniqSM@ monad, but we could probably abstract
+-- that away (if we do that, we might want to specialize the fixpoint algorithms
+-- to the particular monads through SPECIALIZE).
+type RewriteFun f = CmmBlock -> FactBase f -> UniqSM (CmmBlock, FactBase f)
+
+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
+    in fixpointAnalysis dir lattice transfer entry blockMap initFact
+
+-- Fixpoint algorithm.
+fixpointAnalysis
+    :: forall f.
+       Direction
+    -> DataflowLattice f
+    -> TransferFun f
+    -> Label
+    -> LabelMap CmmBlock
+    -> FactBase f
+    -> FactBase f
+fixpointAnalysis direction lattice do_block entry blockmap = loop start
+  where
+    -- Sorting the blocks helps to minimize the number of times we need to
+    -- process blocks. For instance, for forward analysis we want to look at
+    -- blocks in reverse postorder. Also, see comments for sortBlocks.
+    blocks     = sortBlocks direction entry blockmap
+    num_blocks = length blocks
+    block_arr  = {-# SCC "block_arr" #-} listArray (0, num_blocks - 1) blocks
+    start      = {-# SCC "start" #-} IntSet.fromDistinctAscList
+      [0 .. num_blocks - 1]
+    dep_blocks = {-# SCC "dep_blocks" #-} mkDepBlocks direction blocks
+    join       = fact_join lattice
+
+    loop
+        :: IntHeap     -- ^ Worklist, i.e., blocks to process
+        -> FactBase f  -- ^ Current result (increases monotonically)
+        -> FactBase f
+    loop todo !fbase1 | Just (index, todo1) <- IntSet.minView todo =
+        let block = block_arr ! index
+            out_facts = {-# SCC "do_block" #-} do_block block fbase1
+            -- For each of the outgoing edges, we join it with the current
+            -- information in fbase1 and (if something changed) we update it
+            -- and add the affected blocks to the worklist.
+            (todo2, fbase2) = {-# SCC "mapFoldWithKey" #-}
+                mapFoldlWithKey
+                    (updateFact join dep_blocks) (todo1, fbase1) out_facts
+        in loop todo2 fbase2
+    loop _ !fbase1 = fbase1
+
+rewriteCmmBwd
+    :: DataflowLattice f
+    -> RewriteFun f
+    -> CmmGraph
+    -> FactBase f
+    -> UniqSM (CmmGraph, FactBase f)
+rewriteCmmBwd = rewriteCmm Bwd
+
+rewriteCmm
+    :: Direction
+    -> DataflowLattice f
+    -> RewriteFun f
+    -> CmmGraph
+    -> FactBase f
+    -> UniqSM (CmmGraph, FactBase f)
+rewriteCmm dir lattice rwFun cmmGraph initFact = do
+    let entry = g_entry cmmGraph
+        hooplGraph = g_graph cmmGraph
+        blockMap1 =
+            case hooplGraph of
+                GMany NothingO bm NothingO -> bm
+    (blockMap2, facts) <-
+        fixpointRewrite dir lattice rwFun entry blockMap1 initFact
+    return (cmmGraph {g_graph = GMany NothingO blockMap2 NothingO}, facts)
+
+fixpointRewrite
+    :: forall f.
+       Direction
+    -> DataflowLattice f
+    -> RewriteFun f
+    -> Label
+    -> LabelMap CmmBlock
+    -> FactBase f
+    -> UniqSM (LabelMap CmmBlock, FactBase f)
+fixpointRewrite dir lattice do_block entry blockmap = loop start blockmap
+  where
+    -- Sorting the blocks helps to minimize the number of times we need to
+    -- process blocks. For instance, for forward analysis we want to look at
+    -- blocks in reverse postorder. Also, see comments for sortBlocks.
+    blocks     = sortBlocks dir entry blockmap
+    num_blocks = length blocks
+    block_arr  = {-# SCC "block_arr_rewrite" #-}
+                 listArray (0, num_blocks - 1) blocks
+    start      = {-# SCC "start_rewrite" #-}
+                 IntSet.fromDistinctAscList [0 .. num_blocks - 1]
+    dep_blocks = {-# SCC "dep_blocks_rewrite" #-} mkDepBlocks dir blocks
+    join       = fact_join lattice
+
+    loop
+        :: IntHeap            -- ^ Worklist, i.e., blocks to process
+        -> LabelMap CmmBlock  -- ^ Rewritten blocks.
+        -> FactBase f         -- ^ Current facts.
+        -> UniqSM (LabelMap CmmBlock, FactBase f)
+    loop todo !blocks1 !fbase1
+      | Just (index, todo1) <- IntSet.minView todo = do
+        -- Note that we use the *original* block here. This is important.
+        -- We're optimistically rewriting blocks even before reaching the fixed
+        -- point, which means that the rewrite might be incorrect. So if the
+        -- facts change, we need to rewrite the original block again (taking
+        -- into account the new facts).
+        let block = block_arr ! index
+        (new_block, out_facts) <- {-# SCC "do_block_rewrite" #-}
+            do_block block fbase1
+        let blocks2 = mapInsert (entryLabel new_block) new_block blocks1
+            (todo2, fbase2) = {-# SCC "mapFoldWithKey_rewrite" #-}
+                mapFoldlWithKey
+                    (updateFact join dep_blocks) (todo1, fbase1) out_facts
+        loop todo2 blocks2 fbase2
+    loop _ !blocks1 !fbase1 = return (blocks1, fbase1)
+
+
+{-
+Note [Unreachable blocks]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+A block that is not in the domain of tfb_fbase is "currently unreachable".
+A currently-unreachable block is not even analyzed.  Reason: consider
+constant prop and this graph, with entry point L1:
+  L1: x:=3; goto L4
+  L2: x:=4; goto L4
+  L4: if x>3 goto L2 else goto L5
+Here L2 is actually unreachable, but if we process it with bottom input fact,
+we'll propagate (x=4) to L4, and nuke the otherwise-good rewriting of L4.
+
+* If a currently-unreachable block is not analyzed, then its rewritten
+  graph will not be accumulated in tfb_rg.  And that is good:
+  unreachable blocks simply do not appear in the output.
+
+* Note that clients must be careful to provide a fact (even if bottom)
+  for each entry point. Otherwise useful blocks may be garbage collected.
+
+* Note that updateFact must set the change-flag if a label goes from
+  not-in-fbase to in-fbase, even if its fact is bottom.  In effect the
+  real fact lattice is
+       UNR
+       bottom
+       the points above bottom
+
+* Even if the fact is going from UNR to bottom, we still call the
+  client's fact_join function because it might give the client
+  some useful debugging information.
+
+* All of this only applies for *forward* ixpoints.  For the backward
+  case we must treat every block as reachable; it might finish with a
+  'return', and therefore have no successors, for example.
+-}
+
+
+-----------------------------------------------------------------------------
+--  Pieces that are shared by fixpoint and fixpoint_anal
+-----------------------------------------------------------------------------
+
+-- | Sort the blocks into the right order for analysis. This means reverse
+-- postorder for a forward analysis. For the backward one, we simply reverse
+-- that (see Note [Backward vs forward analysis]).
+sortBlocks
+    :: NonLocal n
+    => Direction -> Label -> LabelMap (Block n C C) -> [Block n C C]
+sortBlocks direction entry blockmap =
+    case direction of
+        Fwd -> fwd
+        Bwd -> reverse fwd
+  where
+    fwd = revPostorderFrom blockmap entry
+
+-- Note [Backward vs forward analysis]
+--
+-- The forward and backward cases are not dual.  In the forward case, the entry
+-- points are known, and one simply traverses the body blocks from those points.
+-- In the backward case, something is known about the exit points, but a
+-- backward analysis must also include reachable blocks that don't reach the
+-- exit, as in a procedure that loops forever and has side effects.)
+-- For instance, let E be the entry and X the exit blocks (arrows indicate
+-- control flow)
+--   E -> X
+--   E -> B
+--   B -> C
+--   C -> B
+-- We do need to include B and C even though they're unreachable in the
+-- *reverse* graph (that we could use for backward analysis):
+--   E <- X
+--   E <- B
+--   B <- C
+--   C <- B
+-- So when sorting the blocks for the backward analysis, we simply take the
+-- reverse of what is used for the forward one.
+
+
+-- | Construct a mapping from a @Label@ to the block indexes that should be
+-- re-analyzed if the facts at that @Label@ change.
+--
+-- Note that we're considering here the entry point of the block, so if the
+-- facts change at the entry:
+-- * for a backward analysis we need to re-analyze all the predecessors, but
+-- * for a forward analysis, we only need to re-analyze the current block
+--   (and that will in turn propagate facts into its successors).
+mkDepBlocks :: Direction -> [CmmBlock] -> LabelMap IntSet
+mkDepBlocks Fwd blocks = go blocks 0 mapEmpty
+  where
+    go []     !_ !dep_map = dep_map
+    go (b:bs) !n !dep_map =
+        go bs (n + 1) $ mapInsert (entryLabel b) (IntSet.singleton n) dep_map
+mkDepBlocks Bwd blocks = go blocks 0 mapEmpty
+  where
+    go []     !_ !dep_map = dep_map
+    go (b:bs) !n !dep_map =
+        let insert m l = mapInsertWith IntSet.union l (IntSet.singleton n) m
+        in go bs (n + 1) $ foldl' insert dep_map (successors b)
+
+-- | After some new facts have been generated by analysing a block, we
+-- fold this function over them to generate (a) a list of block
+-- indices to (re-)analyse, and (b) the new FactBase.
+updateFact
+    :: JoinFun f
+    -> LabelMap IntSet
+    -> (IntHeap, FactBase f)
+    -> Label
+    -> f -- out fact
+    -> (IntHeap, FactBase f)
+updateFact fact_join dep_blocks (todo, fbase) lbl new_fact
+  = case lookupFact lbl fbase of
+      Nothing ->
+          -- Note [No old fact]
+          let !z = mapInsert lbl new_fact fbase in (changed, z)
+      Just old_fact ->
+          case fact_join (OldFact old_fact) (NewFact new_fact) of
+              (NotChanged _) -> (todo, fbase)
+              (Changed f) -> let !z = mapInsert lbl f fbase in (changed, z)
+  where
+    changed = todo `IntSet.union`
+              mapFindWithDefault IntSet.empty lbl dep_blocks
+
+{-
+Note [No old fact]
+
+We know that the new_fact is >= _|_, so we don't need to join.  However,
+if the new fact is also _|_, and we have already analysed its block,
+we don't need to record a change.  So there's a tradeoff here.  It turns
+out that always recording a change is faster.
+-}
+
+----------------------------------------------------------------
+--       Utilities
+----------------------------------------------------------------
+
+-- Fact lookup: the fact `orelse` bottom
+getFact  :: DataflowLattice f -> Label -> FactBase f -> f
+getFact lat l fb = case lookupFact l fb of Just  f -> f
+                                           Nothing -> fact_bot lat
+
+-- | Returns the result of joining the facts from all the successors of the
+-- provided node or block.
+joinOutFacts :: (NonLocal n) => DataflowLattice f -> n e C -> FactBase f -> f
+joinOutFacts lattice nonLocal fact_base = foldl' join (fact_bot lattice) facts
+  where
+    join new old = getJoined $ fact_join lattice (OldFact old) (NewFact new)
+    facts =
+        [ fromJust fact
+        | s <- successors nonLocal
+        , let fact = lookupFact s fact_base
+        , isJust fact
+        ]
+
+joinFacts :: DataflowLattice f -> [f] -> f
+joinFacts lattice facts  = foldl' join (fact_bot lattice) facts
+  where
+    join new old = getJoined $ fact_join lattice (OldFact old) (NewFact new)
+
+-- | Returns the joined facts for each label.
+mkFactBase :: DataflowLattice f -> [(Label, f)] -> FactBase f
+mkFactBase lattice = foldl' add mapEmpty
+  where
+    join = fact_join lattice
+
+    add result (l, f1) =
+        let !newFact =
+                case mapLookup l result of
+                    Nothing -> f1
+                    Just f2 -> getJoined $ join (OldFact f1) (NewFact f2)
+        in mapInsert l newFact result
+
+-- | Folds backward over all nodes of an open-open block.
+-- Strict in the accumulator.
+foldNodesBwdOO :: (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 #-}
+
+-- | Folds backward over all the nodes of an open-open block and allows
+-- rewriting them. The accumulator is both the block of nodes and @f@ (usually
+-- dataflow facts).
+-- Strict in both accumulated parts.
+foldRewriteNodesBwdOO
+    :: forall f.
+       (CmmNode O O -> f -> UniqSM (Block CmmNode O O, f))
+    -> Block CmmNode O O
+    -> f
+    -> UniqSM (Block CmmNode O O, f)
+foldRewriteNodesBwdOO rewriteOO initBlock initFacts = go initBlock initFacts
+  where
+    go (BCons node1 block1) !fact1 = (rewriteOO node1 `comp` go block1) fact1
+    go (BSnoc block1 node1) !fact1 = (go block1 `comp` rewriteOO node1) fact1
+    go (BCat blockA1 blockB1) !fact1 = (go blockA1 `comp` go blockB1) fact1
+    go (BMiddle node) !fact1 = rewriteOO node fact1
+    go BNil !fact = return (BNil, fact)
+
+    comp rew1 rew2 = \f1 -> do
+        (b, f2) <- rew2 f1
+        (a, !f3) <- rew1 f2
+        let !c = joinBlocksOO a b
+        return (c, f3)
+    {-# INLINE comp #-}
+{-# INLINABLE foldRewriteNodesBwdOO #-}
+
+joinBlocksOO :: Block n O O -> Block n O O -> Block n O O
+joinBlocksOO BNil b = b
+joinBlocksOO b BNil = b
+joinBlocksOO (BMiddle n) b = blockCons n b
+joinBlocksOO b (BMiddle n) = blockSnoc b n
+joinBlocksOO b1 b2 = BCat b1 b2
+
+type IntHeap = IntSet

ghc-toolkit/boot-libs/ghc/cmm/Hoopl/Graph.hs

@@ -0,0 +1,185 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+module Hoopl.Graph
+    ( Body
+    , Graph
+    , Graph'(..)
+    , NonLocal(..)
+    , addBlock
+    , bodyList
+    , emptyBody
+    , labelsDefined
+    , mapGraph
+    , mapGraphBlocks
+    , revPostorderFrom
+    ) where
+
+
+import GhcPrelude
+import Util
+
+import Hoopl.Label
+import Hoopl.Block
+import Hoopl.Collections
+
+-- | A (possibly empty) collection of closed/closed blocks
+type Body n = LabelMap (Block n C C)
+
+-- | @Body@ abstracted over @block@
+type Body' block (n :: * -> * -> *) = LabelMap (block n C C)
+
+-------------------------------
+-- | Gives access to the anchor points for
+-- nonlocal edges as well as the edges themselves
+class NonLocal thing where
+  entryLabel :: thing C x -> Label   -- ^ The label of a first node or block
+  successors :: thing e C -> [Label] -- ^ Gives control-flow successors
+
+instance NonLocal n => NonLocal (Block n) where
+  entryLabel (BlockCO f _)   = entryLabel f
+  entryLabel (BlockCC f _ _) = entryLabel f
+
+  successors (BlockOC   _ n) = successors n
+  successors (BlockCC _ _ n) = successors n
+
+
+emptyBody :: Body' block n
+emptyBody = mapEmpty
+
+bodyList :: Body' block n -> [(Label,block n C C)]
+bodyList body = mapToList body
+
+addBlock
+    :: (NonLocal block, HasDebugCallStack)
+    => block C C -> LabelMap (block C C) -> LabelMap (block C C)
+addBlock block body = mapAlter add lbl body
+  where
+    lbl = entryLabel block
+    add Nothing = Just block
+    add _ = error $ "duplicate label " ++ show lbl ++ " in graph"
+
+
+-- ---------------------------------------------------------------------------
+-- Graph
+
+-- | A control-flow graph, which may take any of four shapes (O/O,
+-- O/C, C/O, C/C).  A graph open at the entry has a single,
+-- distinguished, anonymous entry point; if a graph is closed at the
+-- entry, its entry point(s) are supplied by a context.
+type Graph = Graph' Block
+
+-- | @Graph'@ is abstracted over the block type, so that we can build
+-- graphs of annotated blocks for example (Compiler.Hoopl.Dataflow
+-- needs this).
+data Graph' block (n :: * -> * -> *) e x where
+  GNil  :: Graph' block n O O
+  GUnit :: block n O O -> Graph' block n O O
+  GMany :: MaybeO e (block n O C)
+        -> Body' block n
+        -> MaybeO x (block n C O)
+        -> Graph' block n e x
+
+
+-- -----------------------------------------------------------------------------
+-- Mapping over graphs
+
+-- | Maps over all nodes in a graph.
+mapGraph :: (forall e x. n e x -> n' e x) -> Graph n e x -> Graph n' e x
+mapGraph f = mapGraphBlocks (mapBlock f)
+
+-- | Function 'mapGraphBlocks' enables a change of representation of blocks,
+-- nodes, or both.  It lifts a polymorphic block transform into a polymorphic
+-- graph transform.  When the block representation stabilizes, a similar
+-- function should be provided for blocks.
+mapGraphBlocks :: forall block n block' n' e x .
+                  (forall e x . block n e x -> block' n' e x)
+               -> (Graph' block n e x -> Graph' block' n' e x)
+
+mapGraphBlocks f = map
+  where map :: Graph' block n e x -> Graph' block' n' e x
+        map GNil = GNil
+        map (GUnit b) = GUnit (f b)
+        map (GMany e b x) = GMany (fmap f e) (mapMap f b) (fmap f x)
+
+-- -----------------------------------------------------------------------------
+-- Extracting Labels from graphs
+
+labelsDefined :: forall block n e x . NonLocal (block n) => Graph' block n e x
+              -> LabelSet
+labelsDefined GNil      = setEmpty
+labelsDefined (GUnit{}) = setEmpty
+labelsDefined (GMany _ body x) = mapFoldlWithKey addEntry (exitLabel x) body
+  where addEntry :: forall a. LabelSet -> ElemOf LabelSet -> a -> LabelSet
+        addEntry labels label _ = setInsert label labels
+        exitLabel :: MaybeO x (block n C O) -> LabelSet
+        exitLabel NothingO  = setEmpty
+        exitLabel (JustO b) = setSingleton (entryLabel b)
+
+
+----------------------------------------------------------------
+
+-- | Returns a list of blocks reachable from the provided Labels in the reverse
+-- postorder.
+--
+-- This is the most important traversal over this data structure.  It drops
+-- unreachable code and puts blocks in an order that is good for solving forward
+-- dataflow problems quickly.  The reverse order is good for solving backward
+-- dataflow problems quickly.  The forward order is also reasonably good for
+-- emitting instructions, except that it will not usually exploit Forrest
+-- Baskett's trick of eliminating the unconditional branch from a loop.  For
+-- that you would need a more serious analysis, probably based on dominators, to
+-- identify loop headers.
+--
+-- For forward analyses we want reverse postorder visitation, consider:
+-- @
+--      A -> [B,C]
+--      B -> D
+--      C -> D
+-- @
+-- Postorder: [D, C, B, A] (or [D, B, C, A])
+-- Reverse postorder: [A, B, C, D] (or [A, C, B, D])
+-- This matters for, e.g., forward analysis, because we want to analyze *both*
+-- B and C before we analyze D.
+revPostorderFrom
+  :: forall block.  (NonLocal block)
+  => LabelMap (block C C) -> Label -> [block C C]
+revPostorderFrom graph start = go start_worklist setEmpty []
+  where
+    start_worklist = lookup_for_descend start Nil
+
+    -- To compute the postorder we need to "visit" a block (mark as done)
+    -- *after* visiting all its successors. So we need to know whether we
+    -- already processed all successors of each block (and @NonLocal@ allows
+    -- arbitrary many successors). So we use an explicit stack with an extra bit
+    -- of information:
+    -- * @ConsTodo@ means to explore the block if it wasn't visited before
+    -- * @ConsMark@ means that all successors were already done and we can add
+    --   the block to the result.
+    --
+    -- NOTE: We add blocks to the result list in postorder, but we *prepend*
+    -- them (i.e., we use @(:)@), which means that the final list is in reverse
+    -- postorder.
+    go :: DfsStack (block C C) -> LabelSet -> [block C C] -> [block C C]
+    go Nil                      !_           !result = result
+    go (ConsMark block rest)    !wip_or_done !result =
+        go rest wip_or_done (block : result)
+    go (ConsTodo block rest)    !wip_or_done !result
+        | entryLabel block `setMember` wip_or_done = go rest wip_or_done result
+        | otherwise =
+            let new_worklist =
+                    foldr lookup_for_descend
+                          (ConsMark block rest)
+                          (successors block)
+            in go new_worklist (setInsert (entryLabel block) wip_or_done) result
+
+    lookup_for_descend :: Label -> DfsStack (block C C) -> DfsStack (block C C)
+    lookup_for_descend label wl
+      | Just b <- mapLookup label graph = ConsTodo b wl
+      | otherwise =
+           error $ "Label that doesn't have a block?! " ++ show label
+
+data DfsStack a = ConsTodo a (DfsStack a) | ConsMark a (DfsStack a) | Nil

ghc-toolkit/boot-libs/ghc/cmm/Hoopl/Label.hs

@@ -0,0 +1,142 @@
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+module Hoopl.Label
+    ( Label
+    , LabelMap
+    , LabelSet
+    , FactBase
+    , lookupFact
+    , mkHooplLabel
+    ) where
+
+import GhcPrelude
+
+import Outputable
+
+-- TODO: This should really just use GHC's Unique and Uniq{Set,FM}
+import Hoopl.Collections
+
+import Unique (Uniquable(..))
+import TrieMap
+
+
+-----------------------------------------------------------------------------
+--              Label
+-----------------------------------------------------------------------------
+
+newtype Label = Label { lblToUnique :: Int }
+  deriving (Eq, Ord)
+
+mkHooplLabel :: Int -> Label
+mkHooplLabel = Label
+
+instance Show Label where
+  show (Label n) = "L" ++ show n
+
+instance Uniquable Label where
+  getUnique label = getUnique (lblToUnique label)
+
+instance Outputable Label where
+  ppr label = ppr (getUnique label)
+
+-----------------------------------------------------------------------------
+-- LabelSet
+
+newtype LabelSet = LS UniqueSet deriving (Eq, Ord, Show, Monoid, Semigroup)
+
+instance IsSet LabelSet where
+  type ElemOf LabelSet = Label
+
+  setNull (LS s) = setNull s
+  setSize (LS s) = setSize s
+  setMember (Label k) (LS s) = setMember k s
+
+  setEmpty = LS setEmpty
+  setSingleton (Label k) = LS (setSingleton k)
+  setInsert (Label k) (LS s) = LS (setInsert k s)
+  setDelete (Label k) (LS s) = LS (setDelete k s)
+
+  setUnion (LS x) (LS y) = LS (setUnion x y)
+  setDifference (LS x) (LS y) = LS (setDifference x y)
+  setIntersection (LS x) (LS y) = LS (setIntersection x y)
+  setIsSubsetOf (LS x) (LS y) = setIsSubsetOf x y
+  setFilter f (LS s) = LS (setFilter (f . mkHooplLabel) s)
+  setFoldl k z (LS s) = setFoldl (\a v -> k a (mkHooplLabel v)) z s
+  setFoldr k z (LS s) = setFoldr (\v a -> k (mkHooplLabel v) a) z s
+
+  setElems (LS s) = map mkHooplLabel (setElems s)
+  setFromList ks = LS (setFromList (map lblToUnique ks))
+
+-----------------------------------------------------------------------------
+-- LabelMap
+
+newtype LabelMap v = LM (UniqueMap v)
+  deriving (Eq, Ord, Show, Functor, Foldable, Traversable)
+
+instance IsMap LabelMap where
+  type KeyOf LabelMap = Label
+
+  mapNull (LM m) = mapNull m
+  mapSize (LM m) = mapSize m
+  mapMember (Label k) (LM m) = mapMember k m
+  mapLookup (Label k) (LM m) = mapLookup k m
+  mapFindWithDefault def (Label k) (LM m) = mapFindWithDefault def k m
+
+  mapEmpty = LM mapEmpty
+  mapSingleton (Label k) v = LM (mapSingleton k v)
+  mapInsert (Label k) v (LM m) = LM (mapInsert k v m)
+  mapInsertWith f (Label k) v (LM m) = LM (mapInsertWith f k v m)
+  mapDelete (Label k) (LM m) = LM (mapDelete k m)
+  mapAlter f (Label k) (LM m) = LM (mapAlter f k m)
+  mapAdjust f (Label k) (LM m) = LM (mapAdjust f k m)
+
+  mapUnion (LM x) (LM y) = LM (mapUnion x y)
+  mapUnionWithKey f (LM x) (LM y) = LM (mapUnionWithKey (f . mkHooplLabel) x y)
+  mapDifference (LM x) (LM y) = LM (mapDifference x y)
+  mapIntersection (LM x) (LM y) = LM (mapIntersection x y)
+  mapIsSubmapOf (LM x) (LM y) = mapIsSubmapOf x y
+
+  mapMap f (LM m) = LM (mapMap f m)
+  mapMapWithKey f (LM m) = LM (mapMapWithKey (f . mkHooplLabel) m)
+  mapFoldl k z (LM m) = mapFoldl k z m
+  mapFoldr k z (LM m) = mapFoldr k z m
+  mapFoldlWithKey k z (LM m) =
+      mapFoldlWithKey (\a v -> k a (mkHooplLabel v)) z m
+  mapFoldMapWithKey f (LM m) = mapFoldMapWithKey (\k v -> f (mkHooplLabel k) v) m
+  mapFilter f (LM m) = LM (mapFilter f m)
+  mapFilterWithKey f (LM m) = LM (mapFilterWithKey (f . mkHooplLabel) m)
+
+  mapElems (LM m) = mapElems m
+  mapKeys (LM m) = map mkHooplLabel (mapKeys m)
+  mapToList (LM m) = [(mkHooplLabel k, v) | (k, v) <- mapToList m]
+  mapFromList assocs = LM (mapFromList [(lblToUnique k, v) | (k, v) <- assocs])
+  mapFromListWith f assocs = LM (mapFromListWith f [(lblToUnique k, v) | (k, v) <- assocs])
+
+-----------------------------------------------------------------------------
+-- Instances
+
+instance Outputable LabelSet where
+  ppr = ppr . setElems
+
+instance Outputable a => Outputable (LabelMap a) where
+  ppr = ppr . mapToList
+
+instance TrieMap LabelMap where
+  type Key LabelMap = Label
+  emptyTM = mapEmpty
+  lookupTM k m = mapLookup k m
+  alterTM k f m = mapAlter f k m
+  foldTM k m z = mapFoldr k z m
+  mapTM f m = mapMap f m
+
+-----------------------------------------------------------------------------
+-- FactBase
+
+type FactBase f = LabelMap f
+
+lookupFact :: Label -> FactBase f -> Maybe f
+lookupFact = mapLookup

ghc-toolkit/boot-libs/ghc/cmm/MkGraph.hs

@@ -0,0 +1,484 @@
+{-# LANGUAGE BangPatterns, 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 GhcPrelude hiding ( (<*>) ) -- avoid importing (<*>)
+
+import BlockId
+import Cmm
+import CmmCallConv
+import CmmSwitch (SwitchTargets)
+
+import Hoopl.Block
+import Hoopl.Graph
+import Hoopl.Label
+import DynFlags
+import FastString
+import ForeignCall
+import OrdList
+import SMRep (ByteOff)
+import UniqSupply
+import Util
+import Panic
+
+
+-----------------------------------------------------------------------------
+-- Building Graphs
+
+
+-- | CmmAGraph is a chunk of code consisting of:
+--
+--   * ordinary statements (assignments, stores etc.)
+--   * jumps
+--   * labels
+--   * out-of-line labelled blocks
+--
+-- The semantics is that control falls through labels and out-of-line
+-- blocks.  Everything after a jump up to the next label is by
+-- definition unreachable code, and will be discarded.
+--
+-- Two CmmAGraphs can be stuck together with <*>, with the meaning that
+-- control flows from the first to the second.
+--
+-- A 'CmmAGraph' can be turned into a 'CmmGraph' (closed at both ends)
+-- by providing a label for the entry point and a tick scope; see
+-- 'labelAGraph'.
+type CmmAGraph = OrdList CgStmt
+-- | Unlabeled graph with tick scope
+type CmmAGraphScoped = (CmmAGraph, CmmTickScope)
+
+data CgStmt
+  = CgLabel BlockId CmmTickScope
+  | CgStmt  (CmmNode O O)
+  | CgLast  (CmmNode O C)
+  | CgFork  BlockId CmmAGraph CmmTickScope
+
+flattenCmmAGraph :: BlockId -> CmmAGraphScoped -> 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
+
+-- | creates a sequence "goto id; id:" as an AGraph
+mkLabel        :: BlockId -> CmmTickScope -> CmmAGraph
+mkLabel bid scp = unitOL (CgLabel bid scp)
+
+-- | creates an open AGraph from a given node
+mkMiddle        :: CmmNode O O -> CmmAGraph
+mkMiddle middle = unitOL (CgStmt middle)
+
+-- | creates a closed AGraph from a given node
+mkLast         :: CmmNode O C -> CmmAGraph
+mkLast last     = unitOL (CgLast last)
+
+-- | A labelled code block; should end in a last node
+outOfLine      :: BlockId -> CmmAGraphScoped -> CmmAGraph
+outOfLine l (c,s) = unitOL (CgFork l c s)
+
+-- | allocate a fresh label for the entry point
+lgraphOfAGraph :: CmmAGraphScoped -> 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
+mkComment fs
+  -- SDM: generating all those comments takes time, this saved about 4% for me
+  | debugIsOn = mkMiddle $ CmmComment fs
+  | otherwise = nilOL
+
+---------- Assignment and store
+mkAssign     :: CmmReg  -> CmmExpr -> CmmAGraph
+mkAssign l (CmmReg r) | l == r  = mkNop
+mkAssign l r  = mkMiddle $ CmmAssign l r
+
+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
+    -- See Note [Width of parameters]
+    ci (reg, RegisterParam r@(VanillaReg {})) =
+        let local = CmmLocal reg
+            global = CmmReg (CmmGlobal r)
+            width = cmmRegWidth dflags local
+            expr
+                | width == wordWidth dflags = global
+                | width < wordWidth dflags =
+                    CmmMachOp (MO_XX_Conv (wordWidth dflags) width) [global]
+                | otherwise = panic "Parameter width greater than word width"
+
+        in CmmAssign local expr
+
+    -- Non VanillaRegs
+    ci (reg, RegisterParam r) =
+        CmmAssign (CmmLocal reg) (CmmReg (CmmGlobal r))
+
+    ci (reg, StackParam off)
+      | isBitsType $ localRegType reg
+      , typeWidth (localRegType reg) < wordWidth dflags =
+        let
+          stack_slot = (CmmLoad (CmmStackSlot area off) (cmmBits $ wordWidth dflags))
+          local = CmmLocal reg
+          width = cmmRegWidth dflags local
+          expr  = CmmMachOp (MO_XX_Conv (wordWidth dflags) width) [stack_slot]
+        in CmmAssign local expr 
+         
+      | otherwise =
+         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)
+
+    -- See Note [Width of parameters]
+    co (v, RegisterParam r@(VanillaReg {})) (rs, ms) =
+        let width = cmmExprWidth dflags v
+            value
+                | width == wordWidth dflags = v
+                | width < wordWidth dflags =
+                    CmmMachOp (MO_XX_Conv width (wordWidth dflags)) [v]
+                | otherwise = panic "Parameter width greater than word width"
+
+        in (r:rs, mkAssign (CmmGlobal r) value <*> ms)
+
+    -- Non VanillaRegs
+    co (v, RegisterParam r) (rs, ms) =
+        (r:rs, mkAssign (CmmGlobal r) v <*> ms)
+
+    -- See Note [Width of parameters]
+    co (v, StackParam off)  (rs, ms)
+      = (rs, mkStore (CmmStackSlot area off) (value v) <*> ms)
+
+    width v = cmmExprWidth dflags v
+    value v
+      | isBitsType $ cmmExprType dflags v
+      , width v < wordWidth dflags =
+        CmmMachOp (MO_XX_Conv (width v) (wordWidth dflags)) [v]
+      | otherwise = v
+
+    (setRA, init_offset) =
+      case area of
+            Young id ->  -- Generate a store instruction for
+                         -- the return address if making a call
+                  case transfer of
+                     Call ->
+                       ([(CmmLit (CmmBlock id), StackParam init_offset)],
+                       widthInBytes (wordWidth 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
+
+
+-- Note [Width of parameters]
+--
+-- Consider passing a small (< word width) primitive like Int8# to a function.
+-- It's actually non-trivial to do this without extending/narrowing:
+-- * Global registers are considered to have native word width (i.e., 64-bits on
+--   x86-64), so CmmLint would complain if we assigned an 8-bit parameter to a
+--   global register.
+-- * Same problem exists with LLVM IR.
+-- * Lowering gets harder since on x86-32 not every register exposes its lower
+--   8 bits (e.g., for %eax we can use %al, but there isn't a corresponding
+--   8-bit register for %edi). So we would either need to extend/narrow anyway,
+--   or complicate the calling convention.
+-- * Passing a small integer in a stack slot, which has native word width,
+--   requires extending to word width when writing to the stack and narrowing
+--   when reading off the stack (see #16258).
+-- So instead, we always extend every parameter smaller than native word width
+-- in copyOutOflow and then truncate it back to the expected width in copyIn.
+-- Note that we do this in cmm using MO_XX_Conv to avoid requiring
+-- zero-/sign-extending - it's up to a backend to handle this in a most
+-- efficient way (e.g., a simple register move or a smaller size store).
+-- This convention (of ignoring the upper bits) is different from some C ABIs,
+-- e.g. all PowerPC ELF ABIs, that require sign or zero extending parameters.
+--
+-- There was some discussion about this on this PR:
+-- https://github.com/ghc-proposals/ghc-proposals/pull/74
+
+
+mkCallEntry :: 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

ghc-toolkit/boot-libs/ghc/cmm/PprCmm.hs

@@ -0,0 +1,311 @@
+{-# 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.cs.tufts.edu/~nr/c--/index.html. We
+-- differ slightly, in some cases. For one, we use I8 .. I64 for types, rather
+-- than C--'s bits8 .. bits64.
+--
+-- We try to ensure that all information available in the abstract
+-- syntax is reproduced, or reproducible, in the concrete syntax.
+-- Data that is not in printed out can be reconstructed according to
+-- conventions used in the pretty printer. There are at least two such
+-- cases:
+--      1) if a value has wordRep type, the type is not appended in the
+--      output.
+--      2) MachOps that operate over wordRep type are printed in a
+--      C-style, rather than as their internal MachRep name.
+--
+-- These conventions produce much more readable Cmm output.
+--
+-- A useful example pass over Cmm is in nativeGen/MachCodeGen.hs
+
+module PprCmm
+  ( module PprCmmDecl
+  , module PprCmmExpr
+  )
+where
+
+import GhcPrelude hiding (succ)
+
+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 Hoopl.Block
+import Hoopl.Graph
+
+-------------------------------------------------
+-- 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_tbls: " <> 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 = revPostorder g
+    -- revPostorder has the side-effect of discarding unreachable code,
+    -- so pretty-printed Cmm will omit any unreachable blocks.  This can
+    -- sometimes be confusing.
+
+---------------------------------------------
+-- Outputting CmmNode and types which it contains
+
+pprConvention :: Convention -> SDoc
+pprConvention (NativeNodeCall   {}) = text "<native-node-call-convention>"
+pprConvention (NativeDirectCall {}) = text "<native-direct-call-convention>"
+pprConvention (NativeReturn {})     = text "<native-ret-convention>"
+pprConvention  Slow                 = text "<slow-convention>"
+pprConvention  GC                   = text "<gc-convention>"
+
+pprForeignConvention :: ForeignConvention -> SDoc
+pprForeignConvention (ForeignConvention c args res ret) =
+          doubleQuotes (ppr c) <+> text "arg hints: " <+> ppr args <+> text " result hints: " <+> ppr res <+> ppr ret
+
+pprReturnInfo :: CmmReturnInfo -> SDoc
+pprReturnInfo CmmMayReturn = empty
+pprReturnInfo CmmNeverReturns = text "never returns"
+
+pprForeignTarget :: 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 -> lbl <> colon <+>
+         (sdocWithDynFlags $ \dflags ->
+           ppUnless (gopt Opt_SuppressTicks dflags) (text "//" <+> ppr tscope))
+          where
+            lbl = if gopt Opt_SuppressUniques dflags
+                then text "_lbl_"
+                else ppr id
+
+      -- // 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:"
+                            , braces (text "goto" <+> ppr l <> semi)
+                            ]
+                | otherwise = empty
+
+            range = brackets $ hsep [integer lo, text "..", integer hi]
+              where (lo,hi) = switchTargetsRange ids
+
+      CmmCall tgt k regs out res updfr_off ->
+          hcat [ text "call", space
+               , pprFun tgt, parens (interpp'SP regs), space
+               , returns <+>
+                 text "args: " <> ppr out <> comma <+>
+                 text "res: " <> ppr res <> comma <+>
+                 text "upd: " <> ppr updfr_off
+               , semi ]
+          where pprFun f@(CmmLit _) = 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

ghc-toolkit/boot-libs/ghc/cmm/PprCmmDecl.hs

@@ -0,0 +1,170 @@
+----------------------------------------------------------------------------
+--
+-- Pretty-printing of common Cmm types
+--
+-- (c) The University of Glasgow 2004-2006
+--
+-----------------------------------------------------------------------------
+
+--
+-- This is where we walk over Cmm emitting an external representation,
+-- suitable for parsing, in a syntax strongly reminiscent of C--. This
+-- is the "External Core" for the Cmm layer.
+--
+-- As such, this should be a well-defined syntax: we want it to look nice.
+-- Thus, we try wherever possible to use syntax defined in [1],
+-- "The C-- Reference Manual", http://www.cs.tufts.edu/~nr/c--/index.html. We
+-- differ slightly, in some cases. For one, we use I8 .. I64 for types, rather
+-- than C--'s bits8 .. bits64.
+--
+-- We try to ensure that all information available in the abstract
+-- syntax is reproduced, or reproducible, in the concrete syntax.
+-- Data that is not in printed out can be reconstructed according to
+-- conventions used in the pretty printer. There are at least two such
+-- cases:
+--      1) if a value has wordRep type, the type is not appended in the
+--      output.
+--      2) MachOps that operate over wordRep type are printed in a
+--      C-style, rather than as their internal MachRep name.
+--
+-- These conventions produce much more readable Cmm output.
+--
+-- A useful example pass over Cmm is in nativeGen/MachCodeGen.hs
+--
+
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module PprCmmDecl
+    ( writeCmms, pprCmms, pprCmmGroup, pprSection, pprStatic
+    )
+where
+
+import GhcPrelude
+
+import PprCmmExpr
+import Cmm
+
+import DynFlags
+import Outputable
+import FastString
+
+import Data.List
+import System.IO
+
+-- Temp Jan08
+import SMRep
+
+
+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 ]
+         , text "srt: " <> ppr srt ]
+
+instance Outputable ForeignHint where
+  ppr NoHint     = empty
+  ppr SignedHint = quotes(text "signed")
+--  ppr AddrHint   = quotes(text "address")
+-- Temp Jan08
+  ppr AddrHint   = (text "PtrHint")
+
+-- --------------------------------------------------------------------------
+-- Static data.
+--      Strings are printed as C strings, and we print them as I8[],
+--      following C--
+--
+pprStatics :: 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.