mirror of
https://github.com/tweag/asterius.git
synced 2024-09-11 08:55:32 +03:00
ghc buildable
This commit is contained in:
parent
078f4333d3
commit
da7f74952b
65
ghc-toolkit/boot-libs/ghc/HsVersions.h
Normal file
65
ghc-toolkit/boot-libs/ghc/HsVersions.h
Normal file
@ -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 () }
|
31
ghc-toolkit/boot-libs/ghc/LICENSE
Normal file
31
ghc-toolkit/boot-libs/ghc/LICENSE
Normal file
@ -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.
|
24
ghc-toolkit/boot-libs/ghc/Makefile
Normal file
24
ghc-toolkit/boot-libs/ghc/Makefile
Normal file
@ -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)
|
||||
|
5
ghc-toolkit/boot-libs/ghc/Unique.h
Normal file
5
ghc-toolkit/boot-libs/ghc/Unique.h
Normal file
@ -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
|
1141
ghc-toolkit/boot-libs/ghc/autogen/CodeGen.Platform.hs
Normal file
1141
ghc-toolkit/boot-libs/ghc/autogen/CodeGen.Platform.hs
Normal file
File diff suppressed because it is too large
Load Diff
66
ghc-toolkit/boot-libs/ghc/autogen/Config.hs
Normal file
66
ghc-toolkit/boot-libs/ghc/autogen/Config.hs
Normal file
@ -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
|
125
ghc-toolkit/boot-libs/ghc/autogen/GHCConstantsHaskellExports.hs
Normal file
125
ghc-toolkit/boot-libs/ghc/autogen/GHCConstantsHaskellExports.hs
Normal file
@ -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,
|
134
ghc-toolkit/boot-libs/ghc/autogen/GHCConstantsHaskellType.hs
Normal file
134
ghc-toolkit/boot-libs/ghc/autogen/GHCConstantsHaskellType.hs
Normal file
@ -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
|
250
ghc-toolkit/boot-libs/ghc/autogen/GHCConstantsHaskellWrappers.hs
Normal file
250
ghc-toolkit/boot-libs/ghc/autogen/GHCConstantsHaskellWrappers.hs
Normal file
@ -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))
|
34
ghc-toolkit/boot-libs/ghc/autogen/ghc_boot_platform.h
Normal file
34
ghc-toolkit/boot-libs/ghc/autogen/ghc_boot_platform.h
Normal file
@ -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__ */
|
231
ghc-toolkit/boot-libs/ghc/autogen/primop-can-fail.hs-incl
Normal file
231
ghc-toolkit/boot-libs/ghc/autogen/primop-can-fail.hs-incl
Normal file
@ -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
|
57
ghc-toolkit/boot-libs/ghc/autogen/primop-code-size.hs-incl
Normal file
57
ghc-toolkit/boot-libs/ghc/autogen/primop-code-size.hs-incl
Normal file
@ -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
|
38
ghc-toolkit/boot-libs/ghc/autogen/primop-commutable.hs-incl
Normal file
38
ghc-toolkit/boot-libs/ghc/autogen/primop-commutable.hs-incl
Normal file
@ -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
|
574
ghc-toolkit/boot-libs/ghc/autogen/primop-data-decl.hs-incl
Normal file
574
ghc-toolkit/boot-libs/ghc/autogen/primop-data-decl.hs-incl
Normal file
@ -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
|
20
ghc-toolkit/boot-libs/ghc/autogen/primop-fixity.hs-incl
Normal file
20
ghc-toolkit/boot-libs/ghc/autogen/primop-fixity.hs-incl
Normal file
@ -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
|
@ -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
|
1193
ghc-toolkit/boot-libs/ghc/autogen/primop-list.hs-incl
Normal file
1193
ghc-toolkit/boot-libs/ghc/autogen/primop-list.hs-incl
Normal file
File diff suppressed because it is too large
Load Diff
101
ghc-toolkit/boot-libs/ghc/autogen/primop-out-of-line.hs-incl
Normal file
101
ghc-toolkit/boot-libs/ghc/autogen/primop-out-of-line.hs-incl
Normal file
@ -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
|
1192
ghc-toolkit/boot-libs/ghc/autogen/primop-primop-info.hs-incl
Normal file
1192
ghc-toolkit/boot-libs/ghc/autogen/primop-primop-info.hs-incl
Normal file
File diff suppressed because it is too large
Load Diff
22
ghc-toolkit/boot-libs/ghc/autogen/primop-strictness.hs-incl
Normal file
22
ghc-toolkit/boot-libs/ghc/autogen/primop-strictness.hs-incl
Normal file
@ -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
|
1195
ghc-toolkit/boot-libs/ghc/autogen/primop-tag.hs-incl
Normal file
1195
ghc-toolkit/boot-libs/ghc/autogen/primop-tag.hs-incl
Normal file
File diff suppressed because it is too large
Load Diff
@ -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
|
@ -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,
|
180
ghc-toolkit/boot-libs/ghc/autogen/primop-vector-tys.hs-incl
Normal file
180
ghc-toolkit/boot-libs/ghc/autogen/primop-vector-tys.hs-incl
Normal file
@ -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)
|
@ -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
|
84
ghc-toolkit/boot-libs/ghc/backpack/BkpSyn.hs
Normal file
84
ghc-toolkit/boot-libs/ghc/backpack/BkpSyn.hs
Normal file
@ -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
|
831
ghc-toolkit/boot-libs/ghc/backpack/DriverBkp.hs
Normal file
831
ghc-toolkit/boot-libs/ghc/backpack/DriverBkp.hs
Normal file
@ -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
|
268
ghc-toolkit/boot-libs/ghc/backpack/NameShape.hs
Normal file
268
ghc-toolkit/boot-libs/ghc/backpack/NameShape.hs
Normal file
@ -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)
|
745
ghc-toolkit/boot-libs/ghc/backpack/RnModIface.hs
Normal file
745
ghc-toolkit/boot-libs/ghc/backpack/RnModIface.hs
Normal file
@ -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
|
286
ghc-toolkit/boot-libs/ghc/basicTypes/Avail.hs
Normal file
286
ghc-toolkit/boot-libs/ghc/basicTypes/Avail.hs
Normal file
@ -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)
|
1614
ghc-toolkit/boot-libs/ghc/basicTypes/BasicTypes.hs
Normal file
1614
ghc-toolkit/boot-libs/ghc/basicTypes/BasicTypes.hs
Normal file
File diff suppressed because it is too large
Load Diff
196
ghc-toolkit/boot-libs/ghc/basicTypes/ConLike.hs
Normal file
196
ghc-toolkit/boot-libs/ghc/basicTypes/ConLike.hs
Normal file
@ -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
|
9
ghc-toolkit/boot-libs/ghc/basicTypes/ConLike.hs-boot
Normal file
9
ghc-toolkit/boot-libs/ghc/basicTypes/ConLike.hs-boot
Normal file
@ -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
|
1509
ghc-toolkit/boot-libs/ghc/basicTypes/DataCon.hs
Normal file
1509
ghc-toolkit/boot-libs/ghc/basicTypes/DataCon.hs
Normal file
File diff suppressed because it is too large
Load Diff
34
ghc-toolkit/boot-libs/ghc/basicTypes/DataCon.hs-boot
Normal file
34
ghc-toolkit/boot-libs/ghc/basicTypes/DataCon.hs-boot
Normal file
@ -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
|
2124
ghc-toolkit/boot-libs/ghc/basicTypes/Demand.hs
Normal file
2124
ghc-toolkit/boot-libs/ghc/basicTypes/Demand.hs
Normal file
File diff suppressed because it is too large
Load Diff
130
ghc-toolkit/boot-libs/ghc/basicTypes/FieldLabel.hs
Normal file
130
ghc-toolkit/boot-libs/ghc/basicTypes/FieldLabel.hs
Normal file
@ -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
|
969
ghc-toolkit/boot-libs/ghc/basicTypes/Id.hs
Normal file
969
ghc-toolkit/boot-libs/ghc/basicTypes/Id.hs
Normal file
@ -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
|
629
ghc-toolkit/boot-libs/ghc/basicTypes/IdInfo.hs
Normal file
629
ghc-toolkit/boot-libs/ghc/basicTypes/IdInfo.hs
Normal file
@ -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
|
11
ghc-toolkit/boot-libs/ghc/basicTypes/IdInfo.hs-boot
Normal file
11
ghc-toolkit/boot-libs/ghc/basicTypes/IdInfo.hs-boot
Normal file
@ -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
|
||||
|
240
ghc-toolkit/boot-libs/ghc/basicTypes/Lexeme.hs
Normal file
240
ghc-toolkit/boot-libs/ghc/basicTypes/Lexeme.hs
Normal file
@ -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
|
820
ghc-toolkit/boot-libs/ghc/basicTypes/Literal.hs
Normal file
820
ghc-toolkit/boot-libs/ghc/basicTypes/Literal.hs
Normal file
@ -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.
|
||||
-}
|
1630
ghc-toolkit/boot-libs/ghc/basicTypes/MkId.hs
Normal file
1630
ghc-toolkit/boot-libs/ghc/basicTypes/MkId.hs
Normal file
File diff suppressed because it is too large
Load Diff
15
ghc-toolkit/boot-libs/ghc/basicTypes/MkId.hs-boot
Normal file
15
ghc-toolkit/boot-libs/ghc/basicTypes/MkId.hs-boot
Normal file
@ -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
|
1303
ghc-toolkit/boot-libs/ghc/basicTypes/Module.hs
Normal file
1303
ghc-toolkit/boot-libs/ghc/basicTypes/Module.hs
Normal file
File diff suppressed because it is too large
Load Diff
14
ghc-toolkit/boot-libs/ghc/basicTypes/Module.hs-boot
Normal file
14
ghc-toolkit/boot-libs/ghc/basicTypes/Module.hs-boot
Normal file
@ -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
|
701
ghc-toolkit/boot-libs/ghc/basicTypes/Name.hs
Normal file
701
ghc-toolkit/boot-libs/ghc/basicTypes/Name.hs
Normal file
@ -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
|
5
ghc-toolkit/boot-libs/ghc/basicTypes/Name.hs-boot
Normal file
5
ghc-toolkit/boot-libs/ghc/basicTypes/Name.hs-boot
Normal file
@ -0,0 +1,5 @@
|
||||
module Name where
|
||||
|
||||
import GhcPrelude ()
|
||||
|
||||
data Name
|
120
ghc-toolkit/boot-libs/ghc/basicTypes/NameCache.hs
Normal file
120
ghc-toolkit/boot-libs/ghc/basicTypes/NameCache.hs
Normal file
@ -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
|
154
ghc-toolkit/boot-libs/ghc/basicTypes/NameEnv.hs
Normal file
154
ghc-toolkit/boot-libs/ghc/basicTypes/NameEnv.hs
Normal file
@ -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
|
214
ghc-toolkit/boot-libs/ghc/basicTypes/NameSet.hs
Normal file
214
ghc-toolkit/boot-libs/ghc/basicTypes/NameSet.hs
Normal file
@ -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
|
925
ghc-toolkit/boot-libs/ghc/basicTypes/OccName.hs
Normal file
925
ghc-toolkit/boot-libs/ghc/basicTypes/OccName.hs
Normal file
@ -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)
|
5
ghc-toolkit/boot-libs/ghc/basicTypes/OccName.hs-boot
Normal file
5
ghc-toolkit/boot-libs/ghc/basicTypes/OccName.hs-boot
Normal file
@ -0,0 +1,5 @@
|
||||
module OccName where
|
||||
|
||||
import GhcPrelude ()
|
||||
|
||||
data OccName
|
469
ghc-toolkit/boot-libs/ghc/basicTypes/PatSyn.hs
Normal file
469
ghc-toolkit/boot-libs/ghc/basicTypes/PatSyn.hs
Normal file
@ -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)
|
13
ghc-toolkit/boot-libs/ghc/basicTypes/PatSyn.hs-boot
Normal file
13
ghc-toolkit/boot-libs/ghc/basicTypes/PatSyn.hs-boot
Normal file
@ -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
|
1406
ghc-toolkit/boot-libs/ghc/basicTypes/RdrName.hs
Normal file
1406
ghc-toolkit/boot-libs/ghc/basicTypes/RdrName.hs
Normal file
File diff suppressed because it is too large
Load Diff
690
ghc-toolkit/boot-libs/ghc/basicTypes/SrcLoc.hs
Normal file
690
ghc-toolkit/boot-libs/ghc/basicTypes/SrcLoc.hs
Normal file
@ -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
|
260
ghc-toolkit/boot-libs/ghc/basicTypes/UniqSupply.hs
Normal file
260
ghc-toolkit/boot-libs/ghc/basicTypes/UniqSupply.hs
Normal file
@ -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)
|
445
ghc-toolkit/boot-libs/ghc/basicTypes/Unique.hs
Normal file
445
ghc-toolkit/boot-libs/ghc/basicTypes/Unique.hs
Normal file
@ -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
|
684
ghc-toolkit/boot-libs/ghc/basicTypes/Var.hs
Normal file
684
ghc-toolkit/boot-libs/ghc/basicTypes/Var.hs
Normal file
@ -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
|
606
ghc-toolkit/boot-libs/ghc/basicTypes/VarEnv.hs
Normal file
606
ghc-toolkit/boot-libs/ghc/basicTypes/VarEnv.hs
Normal file
@ -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
|
350
ghc-toolkit/boot-libs/ghc/basicTypes/VarSet.hs
Normal file
350
ghc-toolkit/boot-libs/ghc/basicTypes/VarSet.hs
Normal file
@ -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
|
40
ghc-toolkit/boot-libs/ghc/cbits/genSym.c
Normal file
40
ghc-toolkit/boot-libs/ghc/cbits/genSym.c
Normal file
@ -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;
|
||||
}
|
134
ghc-toolkit/boot-libs/ghc/cmm/Bitmap.hs
Normal file
134
ghc-toolkit/boot-libs/ghc/cmm/Bitmap.hs
Normal file
@ -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
|
||||
|
46
ghc-toolkit/boot-libs/ghc/cmm/BlockId.hs
Normal file
46
ghc-toolkit/boot-libs/ghc/cmm/BlockId.hs
Normal file
@ -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
|
8
ghc-toolkit/boot-libs/ghc/cmm/BlockId.hs-boot
Normal file
8
ghc-toolkit/boot-libs/ghc/cmm/BlockId.hs-boot
Normal file
@ -0,0 +1,8 @@
|
||||
module BlockId (BlockId, mkBlockId) where
|
||||
|
||||
import Hoopl.Label (Label)
|
||||
import Unique (Unique)
|
||||
|
||||
type BlockId = Label
|
||||
|
||||
mkBlockId :: Unique -> BlockId
|
1436
ghc-toolkit/boot-libs/ghc/cmm/CLabel.hs
Normal file
1436
ghc-toolkit/boot-libs/ghc/cmm/CLabel.hs
Normal file
File diff suppressed because it is too large
Load Diff
230
ghc-toolkit/boot-libs/ghc/cmm/Cmm.hs
Normal file
230
ghc-toolkit/boot-libs/ghc/cmm/Cmm.hs
Normal file
@ -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))
|
||||
|
896
ghc-toolkit/boot-libs/ghc/cmm/CmmBuildInfoTables.hs
Normal file
896
ghc-toolkit/boot-libs/ghc/cmm/CmmBuildInfoTables.hs
Normal file
@ -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
|
212
ghc-toolkit/boot-libs/ghc/cmm/CmmCallConv.hs
Normal file
212
ghc-toolkit/boot-libs/ghc/cmm/CmmCallConv.hs
Normal file
@ -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)
|
321
ghc-toolkit/boot-libs/ghc/cmm/CmmCommonBlockElim.hs
Normal file
321
ghc-toolkit/boot-libs/ghc/cmm/CmmCommonBlockElim.hs
Normal file
@ -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
|
444
ghc-toolkit/boot-libs/ghc/cmm/CmmContFlowOpt.hs
Normal file
444
ghc-toolkit/boot-libs/ghc/cmm/CmmContFlowOpt.hs
Normal file
@ -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
|
604
ghc-toolkit/boot-libs/ghc/cmm/CmmExpr.hs
Normal file
604
ghc-toolkit/boot-libs/ghc/cmm/CmmExpr.hs
Normal file
@ -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
|
92
ghc-toolkit/boot-libs/ghc/cmm/CmmImplementSwitchPlans.hs
Normal file
92
ghc-toolkit/boot-libs/ghc/cmm/CmmImplementSwitchPlans.hs
Normal file
@ -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)
|
587
ghc-toolkit/boot-libs/ghc/cmm/CmmInfo.hs
Normal file
587
ghc-toolkit/boot-libs/ghc/cmm/CmmInfo.hs
Normal file
@ -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
|
1237
ghc-toolkit/boot-libs/ghc/cmm/CmmLayoutStack.hs
Normal file
1237
ghc-toolkit/boot-libs/ghc/cmm/CmmLayoutStack.hs
Normal file
File diff suppressed because it is too large
Load Diff
368
ghc-toolkit/boot-libs/ghc/cmm/CmmLex.x
Normal file
368
ghc-toolkit/boot-libs/ghc/cmm/CmmLex.x
Normal file
@ -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 } ()
|
||||
}
|
262
ghc-toolkit/boot-libs/ghc/cmm/CmmLint.hs
Normal file
262
ghc-toolkit/boot-libs/ghc/cmm/CmmLint.hs
Normal file
@ -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))
|
||||
-}
|
||||
|
93
ghc-toolkit/boot-libs/ghc/cmm/CmmLive.hs
Normal file
93
ghc-toolkit/boot-libs/ghc/cmm/CmmLive.hs
Normal file
@ -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) #-}
|
658
ghc-toolkit/boot-libs/ghc/cmm/CmmMachOp.hs
Normal file
658
ghc-toolkit/boot-libs/ghc/cmm/CmmMachOp.hs
Normal file
@ -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
|
59
ghc-toolkit/boot-libs/ghc/cmm/CmmMonad.hs
Normal file
59
ghc-toolkit/boot-libs/ghc/cmm/CmmMonad.hs
Normal file
@ -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
|
724
ghc-toolkit/boot-libs/ghc/cmm/CmmNode.hs
Normal file
724
ghc-toolkit/boot-libs/ghc/cmm/CmmNode.hs
Normal file
@ -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
|
427
ghc-toolkit/boot-libs/ghc/cmm/CmmOpt.hs
Normal file
427
ghc-toolkit/boot-libs/ghc/cmm/CmmOpt.hs
Normal file
@ -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
|
1444
ghc-toolkit/boot-libs/ghc/cmm/CmmParse.y
Normal file
1444
ghc-toolkit/boot-libs/ghc/cmm/CmmParse.y
Normal file
File diff suppressed because it is too large
Load Diff
360
ghc-toolkit/boot-libs/ghc/cmm/CmmPipeline.hs
Normal file
360
ghc-toolkit/boot-libs/ghc/cmm/CmmPipeline.hs
Normal file
@ -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
|
496
ghc-toolkit/boot-libs/ghc/cmm/CmmProcPoint.hs
Normal file
496
ghc-toolkit/boot-libs/ghc/cmm/CmmProcPoint.hs
Normal file
@ -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.
|
||||
-}
|
855
ghc-toolkit/boot-libs/ghc/cmm/CmmSink.hs
Normal file
855
ghc-toolkit/boot-libs/ghc/cmm/CmmSink.hs
Normal file
@ -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));
|
||||
-}
|
500
ghc-toolkit/boot-libs/ghc/cmm/CmmSwitch.hs
Normal file
500
ghc-toolkit/boot-libs/ghc/cmm/CmmSwitch.hs
Normal file
@ -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.
|
442
ghc-toolkit/boot-libs/ghc/cmm/CmmType.hs
Normal file
442
ghc-toolkit/boot-libs/ghc/cmm/CmmType.hs
Normal file
@ -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.
|
||||
|
||||
-}
|
||||
|
591
ghc-toolkit/boot-libs/ghc/cmm/CmmUtils.hs
Normal file
591
ghc-toolkit/boot-libs/ghc/cmm/CmmUtils.hs
Normal file
@ -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
|
550
ghc-toolkit/boot-libs/ghc/cmm/Debug.hs
Normal file
550
ghc-toolkit/boot-libs/ghc/cmm/Debug.hs
Normal file
@ -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)
|
328
ghc-toolkit/boot-libs/ghc/cmm/Hoopl/Block.hs
Normal file
328
ghc-toolkit/boot-libs/ghc/cmm/Hoopl/Block.hs
Normal file
@ -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)
|
||||
|
177
ghc-toolkit/boot-libs/ghc/cmm/Hoopl/Collections.hs
Normal file
177
ghc-toolkit/boot-libs/ghc/cmm/Hoopl/Collections.hs
Normal file
@ -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)
|
440
ghc-toolkit/boot-libs/ghc/cmm/Hoopl/Dataflow.hs
Normal file
440
ghc-toolkit/boot-libs/ghc/cmm/Hoopl/Dataflow.hs
Normal file
@ -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
|
185
ghc-toolkit/boot-libs/ghc/cmm/Hoopl/Graph.hs
Normal file
185
ghc-toolkit/boot-libs/ghc/cmm/Hoopl/Graph.hs
Normal file
@ -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
|
142
ghc-toolkit/boot-libs/ghc/cmm/Hoopl/Label.hs
Normal file
142
ghc-toolkit/boot-libs/ghc/cmm/Hoopl/Label.hs
Normal file
@ -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
|
484
ghc-toolkit/boot-libs/ghc/cmm/MkGraph.hs
Normal file
484
ghc-toolkit/boot-libs/ghc/cmm/MkGraph.hs
Normal file
@ -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
|
1381
ghc-toolkit/boot-libs/ghc/cmm/PprC.hs
Normal file
1381
ghc-toolkit/boot-libs/ghc/cmm/PprC.hs
Normal file
File diff suppressed because it is too large
Load Diff
311
ghc-toolkit/boot-libs/ghc/cmm/PprCmm.hs
Normal file
311
ghc-toolkit/boot-libs/ghc/cmm/PprCmm.hs
Normal file
@ -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
|
170
ghc-toolkit/boot-libs/ghc/cmm/PprCmmDecl.hs
Normal file
170
ghc-toolkit/boot-libs/ghc/cmm/PprCmmDecl.hs
Normal file
@ -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.
|
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue
Block a user