diff --git a/Bytecodes.h b/Bytecodes.h --- a/Bytecodes.h +++ b/Bytecodes.h @@ -112,6 +112,109 @@ #define bci_PRIMCALL 87 +#define bci_BCO_NAME 88 + +#define bci_OP_ADD_64 90 +#define bci_OP_SUB_64 91 +#define bci_OP_AND_64 92 +#define bci_OP_XOR_64 93 +#define bci_OP_NOT_64 94 +#define bci_OP_NEG_64 95 +#define bci_OP_MUL_64 96 +#define bci_OP_SHL_64 97 +#define bci_OP_ASR_64 98 +#define bci_OP_LSR_64 99 +#define bci_OP_OR_64 100 + +#define bci_OP_NEQ_64 110 +#define bci_OP_EQ_64 111 +#define bci_OP_U_GE_64 112 +#define bci_OP_U_GT_64 113 +#define bci_OP_U_LT_64 114 +#define bci_OP_U_LE_64 115 +#define bci_OP_S_GE_64 116 +#define bci_OP_S_GT_64 117 +#define bci_OP_S_LT_64 118 +#define bci_OP_S_LE_64 119 + + +#define bci_OP_ADD_32 130 +#define bci_OP_SUB_32 131 +#define bci_OP_AND_32 132 +#define bci_OP_XOR_32 133 +#define bci_OP_NOT_32 134 +#define bci_OP_NEG_32 135 +#define bci_OP_MUL_32 136 +#define bci_OP_SHL_32 137 +#define bci_OP_ASR_32 138 +#define bci_OP_LSR_32 139 +#define bci_OP_OR_32 140 + +#define bci_OP_NEQ_32 150 +#define bci_OP_EQ_32 151 +#define bci_OP_U_GE_32 152 +#define bci_OP_U_GT_32 153 +#define bci_OP_U_LT_32 154 +#define bci_OP_U_LE_32 155 +#define bci_OP_S_GE_32 156 +#define bci_OP_S_GT_32 157 +#define bci_OP_S_LT_32 158 +#define bci_OP_S_LE_32 159 + + +#define bci_OP_ADD_16 170 +#define bci_OP_SUB_16 171 +#define bci_OP_AND_16 172 +#define bci_OP_XOR_16 173 +#define bci_OP_NOT_16 174 +#define bci_OP_NEG_16 175 +#define bci_OP_MUL_16 176 +#define bci_OP_SHL_16 177 +#define bci_OP_ASR_16 178 +#define bci_OP_LSR_16 179 +#define bci_OP_OR_16 180 + +#define bci_OP_NEQ_16 190 +#define bci_OP_EQ_16 191 +#define bci_OP_U_GE_16 192 +#define bci_OP_U_GT_16 193 +#define bci_OP_U_LT_16 194 +#define bci_OP_U_LE_16 195 +#define bci_OP_S_GE_16 196 +#define bci_OP_S_GT_16 197 +#define bci_OP_S_LT_16 198 +#define bci_OP_S_LE_16 199 + + +#define bci_OP_ADD_08 200 +#define bci_OP_SUB_08 201 +#define bci_OP_AND_08 202 +#define bci_OP_XOR_08 203 +#define bci_OP_NOT_08 204 +#define bci_OP_NEG_08 205 +#define bci_OP_MUL_08 206 +#define bci_OP_SHL_08 207 +#define bci_OP_ASR_08 208 +#define bci_OP_LSR_08 209 +#define bci_OP_OR_08 210 + +#define bci_OP_NEQ_08 220 +#define bci_OP_EQ_08 221 +#define bci_OP_U_GE_08 222 +#define bci_OP_U_GT_08 223 +#define bci_OP_U_LT_08 224 +#define bci_OP_U_LE_08 225 +#define bci_OP_S_GE_08 226 +#define bci_OP_S_GT_08 227 +#define bci_OP_S_LT_08 228 +#define bci_OP_S_LE_08 229 + +#define bci_OP_INDEX_ADDR_08 240 +#define bci_OP_INDEX_ADDR_16 241 +#define bci_OP_INDEX_ADDR_32 242 +#define bci_OP_INDEX_ADDR_64 243 + + /* If you need to go past 255 then you will run into the flags */ /* If you need to go below 0x0100 then you will run into the instructions */ diff --git a/GHC/Builtin/primops.txt.pp b/GHC/Builtin/primops.txt.pp --- a/GHC/Builtin/primops.txt.pp +++ b/GHC/Builtin/primops.txt.pp @@ -147,6 +147,8 @@ fixity = Nothing vector = [] deprecated_msg = {} -- A non-empty message indicates deprecation + div_like = False -- Second argument expected to be non zero - used for tests + defined_bits = Nothing -- The number of bits the operation is defined for (if not all bits) -- Note [When do out-of-line primops go in primops.txt.pp] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -296,14 +298,18 @@ primop Int8QuotOp "quotInt8#" GenPrimOp Int8# -> Int8# -> Int8# with effect = CanFail + div_like = True primop Int8RemOp "remInt8#" GenPrimOp Int8# -> Int8# -> Int8# with effect = CanFail + div_like = True + primop Int8QuotRemOp "quotRemInt8#" GenPrimOp Int8# -> Int8# -> (# Int8#, Int8# #) with effect = CanFail + div_like = True primop Int8SllOp "uncheckedShiftLInt8#" GenPrimOp Int8# -> Int# -> Int8# primop Int8SraOp "uncheckedShiftRAInt8#" GenPrimOp Int8# -> Int# -> Int8# @@ -342,14 +348,17 @@ primop Word8QuotOp "quotWord8#" GenPrimOp Word8# -> Word8# -> Word8# with effect = CanFail + div_like = True primop Word8RemOp "remWord8#" GenPrimOp Word8# -> Word8# -> Word8# with effect = CanFail + div_like = True primop Word8QuotRemOp "quotRemWord8#" GenPrimOp Word8# -> Word8# -> (# Word8#, Word8# #) with effect = CanFail + div_like = True primop Word8AndOp "andWord8#" GenPrimOp Word8# -> Word8# -> Word8# with commutable = True @@ -400,14 +409,17 @@ primop Int16QuotOp "quotInt16#" GenPrimOp Int16# -> Int16# -> Int16# with effect = CanFail + div_like = True primop Int16RemOp "remInt16#" GenPrimOp Int16# -> Int16# -> Int16# with effect = CanFail + div_like = True primop Int16QuotRemOp "quotRemInt16#" GenPrimOp Int16# -> Int16# -> (# Int16#, Int16# #) with effect = CanFail + div_like = True primop Int16SllOp "uncheckedShiftLInt16#" GenPrimOp Int16# -> Int# -> Int16# primop Int16SraOp "uncheckedShiftRAInt16#" GenPrimOp Int16# -> Int# -> Int16# @@ -446,14 +458,17 @@ primop Word16QuotOp "quotWord16#" GenPrimOp Word16# -> Word16# -> Word16# with effect = CanFail + div_like = True primop Word16RemOp "remWord16#" GenPrimOp Word16# -> Word16# -> Word16# with effect = CanFail + div_like = True primop Word16QuotRemOp "quotRemWord16#" GenPrimOp Word16# -> Word16# -> (# Word16#, Word16# #) with effect = CanFail + div_like = True primop Word16AndOp "andWord16#" GenPrimOp Word16# -> Word16# -> Word16# with commutable = True @@ -504,14 +519,17 @@ primop Int32QuotOp "quotInt32#" GenPrimOp Int32# -> Int32# -> Int32# with effect = CanFail + div_like = True primop Int32RemOp "remInt32#" GenPrimOp Int32# -> Int32# -> Int32# with effect = CanFail + div_like = True primop Int32QuotRemOp "quotRemInt32#" GenPrimOp Int32# -> Int32# -> (# Int32#, Int32# #) with effect = CanFail + div_like = True primop Int32SllOp "uncheckedShiftLInt32#" GenPrimOp Int32# -> Int# -> Int32# primop Int32SraOp "uncheckedShiftRAInt32#" GenPrimOp Int32# -> Int# -> Int32# @@ -550,14 +568,17 @@ primop Word32QuotOp "quotWord32#" GenPrimOp Word32# -> Word32# -> Word32# with effect = CanFail + div_like = True primop Word32RemOp "remWord32#" GenPrimOp Word32# -> Word32# -> Word32# with effect = CanFail + div_like = True primop Word32QuotRemOp "quotRemWord32#" GenPrimOp Word32# -> Word32# -> (# Word32#, Word32# #) with effect = CanFail + div_like = True primop Word32AndOp "andWord32#" GenPrimOp Word32# -> Word32# -> Word32# with commutable = True @@ -608,10 +629,12 @@ primop Int64QuotOp "quotInt64#" GenPrimOp Int64# -> Int64# -> Int64# with effect = CanFail + div_like = True primop Int64RemOp "remInt64#" GenPrimOp Int64# -> Int64# -> Int64# with effect = CanFail + div_like = True primop Int64SllOp "uncheckedIShiftL64#" GenPrimOp Int64# -> Int# -> Int64# primop Int64SraOp "uncheckedIShiftRA64#" GenPrimOp Int64# -> Int# -> Int64# @@ -650,10 +673,12 @@ primop Word64QuotOp "quotWord64#" GenPrimOp Word64# -> Word64# -> Word64# with effect = CanFail + div_like = True primop Word64RemOp "remWord64#" GenPrimOp Word64# -> Word64# -> Word64# with effect = CanFail + div_like = True primop Word64AndOp "and64#" GenPrimOp Word64# -> Word64# -> Word64# with commutable = True @@ -737,6 +762,7 @@ zero. } with effect = CanFail + div_like = True primop IntRemOp "remInt#" GenPrimOp Int# -> Int# -> Int# @@ -744,11 +770,13 @@ behavior is undefined if the second argument is zero. } with effect = CanFail + div_like = True primop IntQuotRemOp "quotRemInt#" GenPrimOp Int# -> Int# -> (# Int#, Int# #) {Rounds towards zero.} with effect = CanFail + div_like = True primop IntAndOp "andI#" GenPrimOp Int# -> Int# -> Int# {Bitwise "and".} @@ -886,19 +914,23 @@ primop WordQuotOp "quotWord#" GenPrimOp Word# -> Word# -> Word# with effect = CanFail + div_like = True primop WordRemOp "remWord#" GenPrimOp Word# -> Word# -> Word# with effect = CanFail + div_like = True primop WordQuotRemOp "quotRemWord#" GenPrimOp Word# -> Word# -> (# Word#, Word# #) with effect = CanFail + div_like = True primop WordQuotRem2Op "quotRemWord2#" GenPrimOp Word# -> Word# -> Word# -> (# Word#, Word# #) { Takes high word of dividend, then low word of dividend, then divisor. Requires that high word < divisor.} with effect = CanFail + div_like = True primop WordAndOp "and#" GenPrimOp Word# -> Word# -> Word# with commutable = True @@ -1034,8 +1066,10 @@ primop BSwap16Op "byteSwap16#" GenPrimOp Word# -> Word# {Swap bytes in the lower 16 bits of a word. The higher bytes are undefined. } + with defined_bits = 16 primop BSwap32Op "byteSwap32#" GenPrimOp Word# -> Word# {Swap bytes in the lower 32 bits of a word. The higher bytes are undefined. } + with defined_bits = 32 primop BSwap64Op "byteSwap64#" GenPrimOp Word64# -> Word64# {Swap bytes in a 64 bits of a word.} primop BSwapOp "byteSwap#" GenPrimOp Word# -> Word# @@ -1043,10 +1077,13 @@ primop BRev8Op "bitReverse8#" GenPrimOp Word# -> Word# {Reverse the order of the bits in a 8-bit word.} + with defined_bits = 8 primop BRev16Op "bitReverse16#" GenPrimOp Word# -> Word# {Reverse the order of the bits in a 16-bit word.} + with defined_bits = 16 primop BRev32Op "bitReverse32#" GenPrimOp Word# -> Word# {Reverse the order of the bits in a 32-bit word.} + with defined_bits = 32 primop BRev64Op "bitReverse64#" GenPrimOp Word64# -> Word64# {Reverse the order of the bits in a 64-bit word.} primop BRevOp "bitReverse#" GenPrimOp Word# -> Word# @@ -4146,12 +4183,15 @@ { Rounds towards zero element-wise. } with effect = CanFail vector = INT_VECTOR_TYPES + div_like = True primop VecRemOp "rem#" GenPrimOp VECTOR -> VECTOR -> VECTOR { Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. } with effect = CanFail vector = INT_VECTOR_TYPES + div_like = True + primop VecNegOp "negate#" GenPrimOp VECTOR -> VECTOR diff --git a/GHC/ByteCode/Asm.hs b/GHC/ByteCode/Asm.hs --- a/GHC/ByteCode/Asm.hs +++ b/GHC/ByteCode/Asm.hs @@ -106,7 +106,7 @@ bcos' <- mallocStrings interp bcos return CompiledByteCode { bc_bcos = bcos' - , bc_itbls = itblenv + , bc_itbls = itblenv , bc_ffis = concatMap protoBCOFFIs proto_bcos , bc_strs = top_strs , bc_breaks = modbreaks @@ -178,11 +178,12 @@ return ubco' assembleBCO :: Platform -> ProtoBCO Name -> IO UnlinkedBCO -assembleBCO platform (ProtoBCO { protoBCOName = nm - , protoBCOInstrs = instrs - , protoBCOBitmap = bitmap - , protoBCOBitmapSize = bsize - , protoBCOArity = arity }) = do +assembleBCO platform + (ProtoBCO { protoBCOName = nm + , protoBCOInstrs = instrs + , protoBCOBitmap = bitmap + , protoBCOBitmapSize = bsize + , protoBCOArity = arity }) = do -- pass 1: collect up the offsets of the local labels. let asm = mapM_ (assembleI platform) instrs @@ -517,18 +518,175 @@ CCALL off m_addr i -> do np <- addr m_addr emit bci_CCALL [wOp off, Op np, SmallOp i] PRIMCALL -> emit bci_PRIMCALL [] + + OP_ADD w -> case w of + W64 -> emit bci_OP_ADD_64 [] + W32 -> emit bci_OP_ADD_32 [] + W16 -> emit bci_OP_ADD_16 [] + W8 -> emit bci_OP_ADD_08 [] + _ -> unsupported_width + OP_SUB w -> case w of + W64 -> emit bci_OP_SUB_64 [] + W32 -> emit bci_OP_SUB_32 [] + W16 -> emit bci_OP_SUB_16 [] + W8 -> emit bci_OP_SUB_08 [] + _ -> unsupported_width + OP_AND w -> case w of + W64 -> emit bci_OP_AND_64 [] + W32 -> emit bci_OP_AND_32 [] + W16 -> emit bci_OP_AND_16 [] + W8 -> emit bci_OP_AND_08 [] + _ -> unsupported_width + OP_XOR w -> case w of + W64 -> emit bci_OP_XOR_64 [] + W32 -> emit bci_OP_XOR_32 [] + W16 -> emit bci_OP_XOR_16 [] + W8 -> emit bci_OP_XOR_08 [] + _ -> unsupported_width + OP_OR w -> case w of + W64 -> emit bci_OP_OR_64 [] + W32 -> emit bci_OP_OR_32 [] + W16 -> emit bci_OP_OR_16 [] + W8 -> emit bci_OP_OR_08 [] + _ -> unsupported_width + OP_NOT w -> case w of + W64 -> emit bci_OP_NOT_64 [] + W32 -> emit bci_OP_NOT_32 [] + W16 -> emit bci_OP_NOT_16 [] + W8 -> emit bci_OP_NOT_08 [] + _ -> unsupported_width + OP_NEG w -> case w of + W64 -> emit bci_OP_NEG_64 [] + W32 -> emit bci_OP_NEG_32 [] + W16 -> emit bci_OP_NEG_16 [] + W8 -> emit bci_OP_NEG_08 [] + _ -> unsupported_width + OP_MUL w -> case w of + W64 -> emit bci_OP_MUL_64 [] + W32 -> emit bci_OP_MUL_32 [] + W16 -> emit bci_OP_MUL_16 [] + W8 -> emit bci_OP_MUL_08 [] + _ -> unsupported_width + OP_SHL w -> case w of + W64 -> emit bci_OP_SHL_64 [] + W32 -> emit bci_OP_SHL_32 [] + W16 -> emit bci_OP_SHL_16 [] + W8 -> emit bci_OP_SHL_08 [] + _ -> unsupported_width + OP_ASR w -> case w of + W64 -> emit bci_OP_ASR_64 [] + W32 -> emit bci_OP_ASR_32 [] + W16 -> emit bci_OP_ASR_16 [] + W8 -> emit bci_OP_ASR_08 [] + _ -> unsupported_width + OP_LSR w -> case w of + W64 -> emit bci_OP_LSR_64 [] + W32 -> emit bci_OP_LSR_32 [] + W16 -> emit bci_OP_LSR_16 [] + W8 -> emit bci_OP_LSR_08 [] + _ -> unsupported_width + + OP_NEQ w -> case w of + W64 -> emit bci_OP_NEQ_64 [] + W32 -> emit bci_OP_NEQ_32 [] + W16 -> emit bci_OP_NEQ_16 [] + W8 -> emit bci_OP_NEQ_08 [] + _ -> unsupported_width + OP_EQ w -> case w of + W64 -> emit bci_OP_EQ_64 [] + W32 -> emit bci_OP_EQ_32 [] + W16 -> emit bci_OP_EQ_16 [] + W8 -> emit bci_OP_EQ_08 [] + _ -> unsupported_width + + OP_U_LT w -> case w of + W64 -> emit bci_OP_U_LT_64 [] + W32 -> emit bci_OP_U_LT_32 [] + W16 -> emit bci_OP_U_LT_16 [] + W8 -> emit bci_OP_U_LT_08 [] + _ -> unsupported_width + OP_S_LT w -> case w of + W64 -> emit bci_OP_S_LT_64 [] + W32 -> emit bci_OP_S_LT_32 [] + W16 -> emit bci_OP_S_LT_16 [] + W8 -> emit bci_OP_S_LT_08 [] + _ -> unsupported_width + OP_U_GE w -> case w of + W64 -> emit bci_OP_U_GE_64 [] + W32 -> emit bci_OP_U_GE_32 [] + W16 -> emit bci_OP_U_GE_16 [] + W8 -> emit bci_OP_U_GE_08 [] + _ -> unsupported_width + OP_S_GE w -> case w of + W64 -> emit bci_OP_S_GE_64 [] + W32 -> emit bci_OP_S_GE_32 [] + W16 -> emit bci_OP_S_GE_16 [] + W8 -> emit bci_OP_S_GE_08 [] + _ -> unsupported_width + OP_U_GT w -> case w of + W64 -> emit bci_OP_U_GT_64 [] + W32 -> emit bci_OP_U_GT_32 [] + W16 -> emit bci_OP_U_GT_16 [] + W8 -> emit bci_OP_U_GT_08 [] + _ -> unsupported_width + OP_S_GT w -> case w of + W64 -> emit bci_OP_S_GT_64 [] + W32 -> emit bci_OP_S_GT_32 [] + W16 -> emit bci_OP_S_GT_16 [] + W8 -> emit bci_OP_S_GT_08 [] + _ -> unsupported_width + OP_U_LE w -> case w of + W64 -> emit bci_OP_U_LE_64 [] + W32 -> emit bci_OP_U_LE_32 [] + W16 -> emit bci_OP_U_LE_16 [] + W8 -> emit bci_OP_U_LE_08 [] + _ -> unsupported_width + OP_S_LE w -> case w of + W64 -> emit bci_OP_S_LE_64 [] + W32 -> emit bci_OP_S_LE_32 [] + W16 -> emit bci_OP_S_LE_16 [] + W8 -> emit bci_OP_S_LE_08 [] + _ -> unsupported_width + + OP_INDEX_ADDR w -> case w of + W64 -> emit bci_OP_INDEX_ADDR_64 [] + W32 -> emit bci_OP_INDEX_ADDR_32 [] + W16 -> emit bci_OP_INDEX_ADDR_16 [] + W8 -> emit bci_OP_INDEX_ADDR_08 [] + _ -> unsupported_width + BRK_FUN arr tick_mod tickx info_mod infox cc -> do p1 <- ptr (BCOPtrBreakArray arr) tick_addr <- addr tick_mod info_addr <- addr info_mod np <- addr cc + let -- cast that checks that round-tripping through + -- Word32 doesn't change the value + toW32 x = let r = fromIntegral x :: Word32 + in if fromIntegral r == x + then r + else pprPanic "schemeER_wrk: breakpoint tick/info index too large!" (ppr x) + tick32 = toW32 tickx + tick_hi = fromIntegral (tick32 `shiftR` 16) + tick_lo = fromIntegral (tick32 .&. 0xffff) + info32 = toW32 infox + info_hi = fromIntegral (info32 `shiftR` 16) + info_lo = fromIntegral (info32 .&. 0xffff) emit bci_BRK_FUN [ Op p1 , Op tick_addr, Op info_addr - , SmallOp tickx, SmallOp infox + , SmallOp tick_hi, SmallOp tick_lo + , SmallOp info_hi, SmallOp info_lo , Op np ] +#if MIN_VERSION_rts(1,0,3) + BCO_NAME name -> do np <- lit [BCONPtrStr name] + emit bci_BCO_NAME [Op np] +#endif + where + unsupported_width = panic "GHC.ByteCode.Asm: Unsupported Width" + literal (LitLabel fs _) = litlabel fs literal LitNullAddr = word 0 literal (LitFloat r) = float (fromRational r) diff --git a/GHC/ByteCode/Instr.hs b/GHC/ByteCode/Instr.hs --- a/GHC/ByteCode/Instr.hs +++ b/GHC/ByteCode/Instr.hs @@ -1,4 +1,4 @@ - +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# OPTIONS_GHC -funbox-strict-fields #-} @@ -14,6 +14,7 @@ import GHC.Prelude import GHC.ByteCode.Types +import GHC.Cmm.Type (Width) import GHCi.RemoteTypes import GHCi.FFI (C_ffi_cif) import GHC.StgToCmm.Layout ( ArgRep(..) ) @@ -27,6 +28,10 @@ import Data.Int import Data.Word +#if MIN_VERSION_rts(1,0,3) +import Data.ByteString (ByteString) +#endif + import GHC.Stack.CCS (CostCentre) import GHC.Stg.Syntax @@ -205,6 +210,39 @@ | PRIMCALL + -- Primops - The actual interpreter instructions are flattened into 64/32/16/8 wide + -- instructions. But for generating code it's handy to have the width as argument + -- to avoid duplication. + | OP_ADD !Width + | OP_SUB !Width + | OP_AND !Width + | OP_XOR !Width + | OP_MUL !Width + | OP_SHL !Width + | OP_ASR !Width + | OP_LSR !Width + | OP_OR !Width + + | OP_NOT !Width + | OP_NEG !Width + + | OP_NEQ !Width + | OP_EQ !Width + + | OP_U_LT !Width + | OP_U_GE !Width + | OP_U_GT !Width + | OP_U_LE !Width + + | OP_S_LT !Width + | OP_S_GE !Width + | OP_S_GT !Width + | OP_S_LE !Width + + -- Always puts at least a machine word on the stack. + -- We zero extend the result we put on the stack according to host byte order. + | OP_INDEX_ADDR !Width + -- For doing magic ByteArray passing to foreign calls | SWIZZLE !WordOff -- to the ptr N words down the stack, !Int -- add M @@ -224,6 +262,22 @@ !Word16 -- breakpoint info index (RemotePtr CostCentre) +#if MIN_VERSION_rts(1,0,3) + -- | A "meta"-instruction for recording the name of a BCO for debugging purposes. + -- These are ignored by the interpreter but helpfully printed by the disassmbler. + | BCO_NAME !ByteString +#endif + + +{- Note [BCO_NAME] + ~~~~~~~~~~~~~~~ + The BCO_NAME instruction is a debugging-aid enabled with the -fadd-bco-name flag. + When enabled the bytecode assembler will prepend a BCO_NAME instruction to every + generated bytecode object capturing the STG name of the binding the BCO implements. + This is then printed by the bytecode disassembler, allowing bytecode objects to be + readily correlated with their STG and Core source. + -} + -- ----------------------------------------------------------------------------- -- Printing bytecode instructions @@ -368,6 +422,32 @@ 0x2 -> text "(unsafe)" _ -> empty) ppr PRIMCALL = text "PRIMCALL" + + ppr (OP_ADD w) = text "OP_ADD_" <> ppr w + ppr (OP_SUB w) = text "OP_SUB_" <> ppr w + ppr (OP_AND w) = text "OP_AND_" <> ppr w + ppr (OP_XOR w) = text "OP_XOR_" <> ppr w + ppr (OP_OR w) = text "OP_OR_" <> ppr w + ppr (OP_NOT w) = text "OP_NOT_" <> ppr w + ppr (OP_NEG w) = text "OP_NEG_" <> ppr w + ppr (OP_MUL w) = text "OP_MUL_" <> ppr w + ppr (OP_SHL w) = text "OP_SHL_" <> ppr w + ppr (OP_ASR w) = text "OP_ASR_" <> ppr w + ppr (OP_LSR w) = text "OP_LSR_" <> ppr w + + ppr (OP_EQ w) = text "OP_EQ_" <> ppr w + ppr (OP_NEQ w) = text "OP_NEQ_" <> ppr w + ppr (OP_S_LT w) = text "OP_S_LT_" <> ppr w + ppr (OP_S_GE w) = text "OP_S_GE_" <> ppr w + ppr (OP_S_GT w) = text "OP_S_GT_" <> ppr w + ppr (OP_S_LE w) = text "OP_S_LE_" <> ppr w + ppr (OP_U_LT w) = text "OP_U_LT_" <> ppr w + ppr (OP_U_GE w) = text "OP_U_GE_" <> ppr w + ppr (OP_U_GT w) = text "OP_U_GT_" <> ppr w + ppr (OP_U_LE w) = text "OP_U_LE_" <> ppr w + + ppr (OP_INDEX_ADDR w) = text "OP_INDEX_ADDR_" <> ppr w + ppr (SWIZZLE stkoff n) = text "SWIZZLE " <+> text "stkoff" <+> ppr stkoff <+> text "by" <+> ppr n ppr ENTER = text "ENTER" @@ -378,6 +458,9 @@ <+> text "" <+> ppr tickx <+> text "" <+> ppr infox <+> text "" +#if MIN_VERSION_rts(1,0,3) + ppr (BCO_NAME nm) = text "BCO_NAME" <+> text (show nm) +#endif @@ -473,6 +556,31 @@ bciStackUse RETURN_TUPLE{} = 1 -- pushes stg_ret_t header bciStackUse CCALL{} = 0 bciStackUse PRIMCALL{} = 1 -- pushes stg_primcall +bciStackUse OP_ADD{} = 0 -- We overestimate, it's -1 actually ... +bciStackUse OP_SUB{} = 0 +bciStackUse OP_AND{} = 0 +bciStackUse OP_XOR{} = 0 +bciStackUse OP_OR{} = 0 +bciStackUse OP_NOT{} = 0 +bciStackUse OP_NEG{} = 0 +bciStackUse OP_MUL{} = 0 +bciStackUse OP_SHL{} = 0 +bciStackUse OP_ASR{} = 0 +bciStackUse OP_LSR{} = 0 + +bciStackUse OP_NEQ{} = 0 +bciStackUse OP_EQ{} = 0 +bciStackUse OP_S_LT{} = 0 +bciStackUse OP_S_GT{} = 0 +bciStackUse OP_S_LE{} = 0 +bciStackUse OP_S_GE{} = 0 +bciStackUse OP_U_LT{} = 0 +bciStackUse OP_U_GT{} = 0 +bciStackUse OP_U_LE{} = 0 +bciStackUse OP_U_GE{} = 0 + +bciStackUse OP_INDEX_ADDR{} = 0 + bciStackUse SWIZZLE{} = 0 bciStackUse BRK_FUN{} = 0 @@ -482,3 +590,6 @@ bciStackUse MKAP{} = 0 bciStackUse MKPAP{} = 0 bciStackUse PACK{} = 1 -- worst case is PACK 0 words +#if MIN_VERSION_rts(1,0,3) +bciStackUse BCO_NAME{} = 0 +#endif diff --git a/GHC/Cmm.hs b/GHC/Cmm.hs --- a/GHC/Cmm.hs +++ b/GHC/Cmm.hs @@ -288,8 +288,8 @@ deriving (Eq) -- | Should a data in this section be considered constant at runtime -sectionProtection :: Section -> SectionProtection -sectionProtection (Section t _) = case t of +sectionProtection :: SectionType -> SectionProtection +sectionProtection t = case t of Text -> ReadOnlySection ReadOnlyData -> ReadOnlySection RelocatableReadOnlyData -> WriteProtectedSection diff --git a/GHC/Cmm/Config.hs b/GHC/Cmm/Config.hs --- a/GHC/Cmm/Config.hs +++ b/GHC/Cmm/Config.hs @@ -24,8 +24,6 @@ , cmmExternalDynamicRefs :: !Bool -- ^ Generate code to link against dynamic libraries , cmmDoCmmSwitchPlans :: !Bool -- ^ Should the Cmm pass replace Stg switch statements , cmmSplitProcPoints :: !Bool -- ^ Should Cmm split proc points or not - , cmmAllowMul2 :: !Bool -- ^ Does this platform support mul2 - , cmmOptConstDivision :: !Bool -- ^ Should we optimize constant divisors } -- | retrieve the target Cmm platform diff --git a/GHC/Cmm/InitFini.hs b/GHC/Cmm/InitFini.hs --- a/GHC/Cmm/InitFini.hs +++ b/GHC/Cmm/InitFini.hs @@ -2,6 +2,7 @@ module GHC.Cmm.InitFini ( InitOrFini(..) , isInitOrFiniArray + , isInitOrFiniSection ) where import GHC.Prelude @@ -63,8 +64,8 @@ data InitOrFini = IsInitArray | IsFiniArray isInitOrFiniArray :: RawCmmDecl -> Maybe (InitOrFini, [CLabel]) -isInitOrFiniArray (CmmData sect (CmmStaticsRaw _ lits)) - | Just initOrFini <- isInitOrFiniSection sect +isInitOrFiniArray (CmmData (Section t _) (CmmStaticsRaw _ lits)) + | Just initOrFini <- isInitOrFiniSection t = Just (initOrFini, map get_label lits) where get_label :: CmmStatic -> CLabel @@ -72,7 +73,7 @@ get_label static = pprPanic "isInitOrFiniArray: invalid entry" (ppr static) isInitOrFiniArray _ = Nothing -isInitOrFiniSection :: Section -> Maybe InitOrFini -isInitOrFiniSection (Section InitArray _) = Just IsInitArray -isInitOrFiniSection (Section FiniArray _) = Just IsFiniArray +isInitOrFiniSection :: SectionType -> Maybe InitOrFini +isInitOrFiniSection InitArray = Just IsInitArray +isInitOrFiniSection FiniArray = Just IsFiniArray isInitOrFiniSection _ = Nothing diff --git a/GHC/Cmm/Lexer.hs b/GHC/Cmm/Lexer.hs --- a/GHC/Cmm/Lexer.hs +++ b/GHC/Cmm/Lexer.hs @@ -1,7 +1,7 @@ {-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-missing-signatures #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} -{-# LINE 13 "_build/source-dist/ghc-9.12.3-src/ghc-9.12.3/compiler/GHC/Cmm/Lexer.x" #-} +{-# LINE 13 "_build/source-dist/ghc-9.12.4-src/ghc-9.12.4/compiler/GHC/Cmm/Lexer.x" #-} module GHC.Cmm.Lexer ( CmmToken(..), cmmlex, ) where @@ -831,7 +831,7 @@ -- match when checking the right context, just -- the first match will do. #endif -{-# LINE 144 "_build/source-dist/ghc-9.12.3-src/ghc-9.12.3/compiler/GHC/Cmm/Lexer.x" #-} +{-# LINE 144 "_build/source-dist/ghc-9.12.4-src/ghc-9.12.4/compiler/GHC/Cmm/Lexer.x" #-} data CmmToken = CmmT_SpecChar Char | CmmT_DotDot diff --git a/GHC/Cmm/MachOp.hs b/GHC/Cmm/MachOp.hs --- a/GHC/Cmm/MachOp.hs +++ b/GHC/Cmm/MachOp.hs @@ -7,7 +7,6 @@ , pprMachOp, isCommutableMachOp, isAssociativeMachOp , isComparisonMachOp, maybeIntComparison, machOpResultType , machOpArgReps, maybeInvertComparison, isFloatComparison - , isCommutableCallishMachOp -- MachOp builders , mo_wordAdd, mo_wordSub, mo_wordEq, mo_wordNe,mo_wordMul, mo_wordSQuot @@ -846,17 +845,3 @@ MO_Memmove align -> Just align MO_Memcmp align -> Just align _ -> Nothing - -isCommutableCallishMachOp :: CallishMachOp -> Bool -isCommutableCallishMachOp op = - case op of - MO_x64_Add -> True - MO_x64_Mul -> True - MO_x64_Eq -> True - MO_x64_Ne -> True - MO_x64_And -> True - MO_x64_Or -> True - MO_x64_Xor -> True - MO_S_Mul2 _ -> True - MO_U_Mul2 _ -> True - _ -> False diff --git a/GHC/Cmm/Opt.hs b/GHC/Cmm/Opt.hs --- a/GHC/Cmm/Opt.hs +++ b/GHC/Cmm/Opt.hs @@ -5,53 +5,29 @@ -- (c) The University of Glasgow 2006 -- ----------------------------------------------------------------------------- -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE PatternSynonyms #-} module GHC.Cmm.Opt ( constantFoldNode, constantFoldExpr, cmmMachOpFold, - cmmMachOpFoldM, - Opt, runOpt + cmmMachOpFoldM ) where import GHC.Prelude -import GHC.Cmm.Dataflow.Block import GHC.Cmm.Utils import GHC.Cmm -import GHC.Cmm.Config -import GHC.Types.Unique.DSM - import GHC.Utils.Misc + import GHC.Utils.Panic import GHC.Utils.Outputable import GHC.Platform import Data.Maybe import GHC.Float -import Data.Word -import GHC.Exts (oneShot) -import Control.Monad -constantFoldNode :: CmmNode e x -> Opt (CmmNode e x) -constantFoldNode (CmmUnsafeForeignCall (PrimTarget op) res args) - = traverse constantFoldExprOpt args >>= cmmCallishMachOpFold op res -constantFoldNode node - = mapExpOpt constantFoldExprOpt node -constantFoldExprOpt :: CmmExpr -> Opt CmmExpr -constantFoldExprOpt e = wrapRecExpOpt f e - where - f (CmmMachOp op args) - = do - cfg <- getConfig - case cmmMachOpFold (cmmPlatform cfg) op args of - CmmMachOp op' args' -> fromMaybe (CmmMachOp op' args') <$> cmmMachOpFoldOptM cfg op' args' - e -> pure e - f (CmmRegOff r 0) = pure (CmmReg r) - f e = pure e +constantFoldNode :: Platform -> CmmNode e x -> CmmNode e x +constantFoldNode platform = mapExp (constantFoldExpr platform) constantFoldExpr :: Platform -> CmmExpr -> CmmExpr constantFoldExpr platform = wrapRecExp f @@ -354,7 +330,7 @@ maybe_comparison (MO_S_Le _) rep False = Just (MO_U_Le rep) maybe_comparison _ _ _ = Nothing --- We can often do something with constants of 0, 1 and (-1) ... +-- We can often do something with constants of 0 and 1 ... -- See Note [Comparison operators] cmmMachOpFoldM platform mop [x, y@(CmmLit (CmmInt 0 _))] @@ -425,8 +401,6 @@ MO_Mul rep | Just p <- exactLog2 n -> Just $! (cmmMachOpFold platform (MO_Shl rep) [x, CmmLit (CmmInt p $ wordWidth platform)]) - -- The optimization for division by power of 2 is technically duplicated, but since at least one other part of ghc uses - -- the pure `constantFoldExpr` this remains MO_U_Quot rep | Just p <- exactLog2 n -> Just $! (cmmMachOpFold platform (MO_U_Shr rep) [x, CmmLit (CmmInt p $ wordWidth platform)]) @@ -435,19 +409,46 @@ Just $! (cmmMachOpFold platform (MO_And rep) [x, CmmLit (CmmInt (n - 1) rep)]) MO_S_Quot rep | Just p <- exactLog2 n, - CmmReg _ <- x -> + CmmReg _ <- x -> -- We duplicate x in signedQuotRemHelper, hence require + -- it is a reg. FIXME: remove this restriction. Just $! (cmmMachOpFold platform (MO_S_Shr rep) - [signedQuotRemHelper platform n x rep p, CmmLit (CmmInt p $ wordWidth platform)]) + [signedQuotRemHelper rep p, CmmLit (CmmInt p $ wordWidth platform)]) MO_S_Rem rep | Just p <- exactLog2 n, - CmmReg _ <- x -> + 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 platform (MO_Sub rep) [x, cmmMachOpFold platform (MO_And rep) - [signedQuotRemHelper platform n x rep p, CmmLit (CmmInt (- n) 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 $ wordWidth platform)] + 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 @@ -481,533 +482,3 @@ isPicReg :: CmmExpr -> Bool isPicReg (CmmReg (CmmGlobal (GlobalRegUse PicBaseReg _))) = True isPicReg _ = False - -canOptimizeDivision :: CmmConfig -> Width -> Bool -canOptimizeDivision cfg rep = cmmOptConstDivision cfg && - -- we can either widen the arguments to simulate mul2 or use mul2 directly for the platform word size - (rep < wordWidth platform || (rep == wordWidth platform && cmmAllowMul2 cfg)) - where platform = cmmPlatform cfg - --- ----------------------------------------------------------------------------- --- Folding callish machops - -cmmCallishMachOpFold :: CallishMachOp -> [CmmFormal] -> [CmmActual] -> Opt (CmmNode O O) -cmmCallishMachOpFold op res args = - fromMaybe (CmmUnsafeForeignCall (PrimTarget op) res args) <$> (getConfig >>= \cfg -> cmmCallishMachOpFoldM cfg op res args) - -cmmCallishMachOpFoldM :: CmmConfig -> CallishMachOp -> [CmmFormal] -> [CmmActual] -> Opt (Maybe (CmmNode O O)) - --- If possible move the literals to the right, the following cases assume that to be the case -cmmCallishMachOpFoldM cfg op res [x@(CmmLit _),y] - | isCommutableCallishMachOp op && not (isLit y) = cmmCallishMachOpFoldM cfg op res [y,x] - --- Both arguments are literals, replace with the result -cmmCallishMachOpFoldM _ op res [CmmLit (CmmInt x _), CmmLit (CmmInt y _)] - = case op of - MO_S_Mul2 rep - | [rHiNeeded,rHi,rLo] <- res -> do - let resSz = widthInBits rep - resVal = (narrowS rep x) * (narrowS rep y) - high = resVal `shiftR` resSz - low = narrowS rep resVal - isHiNeeded = high /= low `shiftR` resSz - isHiNeededVal = if isHiNeeded then 1 else 0 - prependNode $! CmmAssign (CmmLocal rHiNeeded) (CmmLit $ CmmInt isHiNeededVal rep) - prependNode $! CmmAssign (CmmLocal rHi) (CmmLit $ CmmInt high rep) - pure . Just $! CmmAssign (CmmLocal rLo) (CmmLit $ CmmInt low rep) - MO_U_Mul2 rep - | [rHi,rLo] <- res -> do - let resSz = widthInBits rep - resVal = (narrowU rep x) * (narrowU rep y) - high = resVal `shiftR` resSz - low = narrowU rep resVal - prependNode $! CmmAssign (CmmLocal rHi) (CmmLit $ CmmInt high rep) - pure . Just $! CmmAssign (CmmLocal rLo) (CmmLit $ CmmInt low rep) - MO_S_QuotRem rep - | [rQuot, rRem] <- res, - y /= 0 -> do - let (q,r) = quotRem (narrowS rep x) (narrowS rep y) - prependNode $! CmmAssign (CmmLocal rQuot) (CmmLit $ CmmInt q rep) - pure . Just $! CmmAssign (CmmLocal rRem) (CmmLit $ CmmInt r rep) - MO_U_QuotRem rep - | [rQuot, rRem] <- res, - y /= 0 -> do - let (q,r) = quotRem (narrowU rep x) (narrowU rep y) - prependNode $! CmmAssign (CmmLocal rQuot) (CmmLit $ CmmInt q rep) - pure . Just $! CmmAssign (CmmLocal rRem) (CmmLit $ CmmInt r rep) - _ -> pure Nothing - --- 0, 1 or -1 as one of the constants - -cmmCallishMachOpFoldM _ op res [_, CmmLit (CmmInt 0 _)] - = case op of - -- x * 0 == 0 - MO_S_Mul2 rep - | [rHiNeeded, rHi, rLo] <- res -> do - prependNode $! CmmAssign (CmmLocal rHiNeeded) (CmmLit $ CmmInt 0 rep) - prependNode $! CmmAssign (CmmLocal rHi) (CmmLit $ CmmInt 0 rep) - pure . Just $! CmmAssign (CmmLocal rLo) (CmmLit $ CmmInt 0 rep) - -- x * 0 == 0 - MO_U_Mul2 rep - | [rHi, rLo] <- res -> do - prependNode $! CmmAssign (CmmLocal rHi) (CmmLit $ CmmInt 0 rep) - pure . Just $! CmmAssign (CmmLocal rLo) (CmmLit $ CmmInt 0 rep) - _ -> pure Nothing - -cmmCallishMachOpFoldM _ op res [CmmLit (CmmInt 0 _), _] - = case op of - -- 0 quotRem d == (0,0) - MO_S_QuotRem rep - | [rQuot, rRem] <- res -> do - prependNode $! CmmAssign (CmmLocal rQuot) (CmmLit $ CmmInt 0 rep) - pure . Just $! CmmAssign (CmmLocal rRem) (CmmLit $ CmmInt 0 rep) - -- 0 quotRem d == (0,0) - MO_U_QuotRem rep - | [rQuot,rRem] <- res -> do - prependNode $! CmmAssign (CmmLocal rQuot) (CmmLit $ CmmInt 0 rep) - pure . Just $! CmmAssign (CmmLocal rRem) (CmmLit $ CmmInt 0 rep) - _ -> pure Nothing - -cmmCallishMachOpFoldM cfg op res [x, CmmLit (CmmInt 1 _)] - = case op of - -- x * 1 == x -- Note: The high word needs to be a sign extension of the low word, so we use a sign extending shift - MO_S_Mul2 rep - | [rHiNeeded, rHi, rLo] <- res -> do - let platform = cmmPlatform cfg - wordRep = wordWidth platform - repInBits = toInteger $ widthInBits rep - prependNode $! CmmAssign (CmmLocal rHiNeeded) (CmmLit $ CmmInt 0 rep) - prependNode $! CmmAssign (CmmLocal rHi) (cmmMachOpFold platform (MO_S_Shr rep) [x, CmmLit $ CmmInt (repInBits - 1) wordRep]) - pure . Just $! CmmAssign (CmmLocal rLo) x - -- x * 1 == x - MO_U_Mul2 rep - | [rHi, rLo] <- res -> do - prependNode $! CmmAssign (CmmLocal rHi) (CmmLit $ CmmInt 0 rep) - pure . Just $! CmmAssign (CmmLocal rLo) x - -- x quotRem 1 == (x, 0) - MO_S_QuotRem rep - | [rQuot, rRem] <- res -> do - prependNode $! CmmAssign (CmmLocal rQuot) x - pure . Just $! CmmAssign (CmmLocal rRem) (CmmLit $ CmmInt 0 rep) - -- x quotRem 1 == (x, 0) - MO_U_QuotRem rep - | [rQuot, rRem] <- res -> do - prependNode $! CmmAssign (CmmLocal rQuot) x - pure . Just $! CmmAssign (CmmLocal rRem) (CmmLit $ CmmInt 0 rep) - _ -> pure Nothing - --- handle quotRem with a constant divisor - -cmmCallishMachOpFoldM cfg op res [n, CmmLit (CmmInt d' _)] - = case op of - MO_S_QuotRem rep - | Just p <- exactLog2 d, - [rQuot,rRem] <- res -> do - n' <- intoRegister n (cmmBits rep) - -- first prepend the optimized division by a power 2 - prependNode $! CmmAssign (CmmLocal rQuot) - (cmmMachOpFold platform (MO_S_Shr rep) - [signedQuotRemHelper platform d n' rep p, CmmLit (CmmInt p $ wordWidth platform)]) - -- then output an optimized remainder by a power of 2 - pure . Just $! CmmAssign (CmmLocal rRem) - (cmmMachOpFold platform (MO_Sub rep) - [n', cmmMachOpFold platform (MO_And rep) - [signedQuotRemHelper platform d n' rep p, CmmLit (CmmInt (- d) rep)]]) - | canOptimizeDivision cfg rep, - d /= (-1), d /= 0, d /= 1, - [rQuot,rRem] <- res -> do - -- we are definitely going to use n multiple times, so put it into a register - n' <- intoRegister n (cmmBits rep) - -- generate an optimized (signed) division of n by d - q <- generateDivisionBySigned platform cfg rep n' d - -- we also need the result multiple times to calculate the remainder - q' <- intoRegister q (cmmBits rep) - - prependNode $! CmmAssign (CmmLocal rQuot) q' - -- The remainder now becomes n - q * d - pure . Just $! CmmAssign (CmmLocal rRem) $ CmmMachOp (MO_Sub rep) [n', CmmMachOp (MO_Mul rep) [q', CmmLit $ CmmInt d rep]] - where - platform = cmmPlatform cfg - d = narrowS rep d' - MO_U_QuotRem rep - | Just p <- exactLog2 d, - [rQuot,rRem] <- res -> do - -- first prepend the optimized division by a power 2 - prependNode $! CmmAssign (CmmLocal rQuot) $ CmmMachOp (MO_U_Shr rep) [n, CmmLit (CmmInt p $ wordWidth platform)] - -- then output an optimized remainder by a power of 2 - pure . Just $! CmmAssign (CmmLocal rRem) $ CmmMachOp (MO_And rep) [n, CmmLit (CmmInt (d - 1) rep)] - | canOptimizeDivision cfg rep, - d /= 0, d /= 1, - [rQuot,rRem] <- res -> do - -- we are definitely going to use n multiple times, so put it into a register - n' <- intoRegister n (cmmBits rep) - -- generate an optimized (unsigned) division of n by d - q <- generateDivisionByUnsigned platform cfg rep n' d - -- we also need the result multiple times to calculate the remainder - q' <- intoRegister q (cmmBits rep) - - prependNode $! CmmAssign (CmmLocal rQuot) q' - -- The remainder now becomes n - q * d - pure . Just $! CmmAssign (CmmLocal rRem) $ CmmMachOp (MO_Sub rep) [n', CmmMachOp (MO_Mul rep) [q', CmmLit $ CmmInt d rep]] - where - platform = cmmPlatform cfg - d = narrowU rep d' - _ -> pure Nothing - -cmmCallishMachOpFoldM _ _ _ _ = pure Nothing - --- ----------------------------------------------------------------------------- --- Specialized constant folding for MachOps which sometimes need to expand into multiple nodes - -cmmMachOpFoldOptM :: CmmConfig -> MachOp -> [CmmExpr] -> Opt (Maybe CmmExpr) - -cmmMachOpFoldOptM cfg op [n, CmmLit (CmmInt d' _)] = - case op of - MO_S_Quot rep - -- recheck for power of 2 division. This may not be handled by cmmMachOpFoldM if n is not in a register - | Just p <- exactLog2 d -> do - n' <- intoRegister n (cmmBits rep) - pure . Just $! cmmMachOpFold platform (MO_S_Shr rep) - [ signedQuotRemHelper platform d n' rep p - , CmmLit (CmmInt p $ wordWidth platform) - ] - | canOptimizeDivision cfg rep, - d /= (-1), d /= 0, d /= 1 -> Just <$!> generateDivisionBySigned platform cfg rep n d - where d = narrowS rep d' - MO_S_Rem rep - -- recheck for power of 2 remainder. This may not be handled by cmmMachOpFoldM if n is not in a register - | Just p <- exactLog2 d -> do - n' <- intoRegister n (cmmBits rep) - pure . Just $! cmmMachOpFold platform (MO_Sub rep) - [ n' - , cmmMachOpFold platform (MO_And rep) - [ signedQuotRemHelper platform d n' rep p - , CmmLit (CmmInt (- d) rep) - ] - ] - | canOptimizeDivision cfg rep, - d /= (-1), d /= 0, d /= 1 -> do - n' <- intoRegister n (cmmBits rep) - -- first generate the division - q <- generateDivisionBySigned platform cfg rep n' d - -- then calculate the remainder by n - q * d - pure . Just $! CmmMachOp (MO_Sub rep) [n', CmmMachOp (MO_Mul rep) [q, CmmLit $ CmmInt d rep]] - where d = narrowS rep d' - MO_U_Quot rep - -- No need to recheck power of 2 division because cmmMachOpFoldM always handles that case - | canOptimizeDivision cfg rep, - d /= 0, d /= 1, Nothing <- exactLog2 d -> Just <$!> generateDivisionByUnsigned platform cfg rep n d - where d = narrowU rep d' - MO_U_Rem rep - -- No need to recheck power of 2 remainder because cmmMachOpFoldM always handles that case - | canOptimizeDivision cfg rep, - d /= 0, d /= 1, Nothing <- exactLog2 d -> do - n' <- intoRegister n (cmmBits rep) - -- first generate the division - q <- generateDivisionByUnsigned platform cfg rep n d - -- then calculate the remainder by n - q * d - pure . Just $! CmmMachOp (MO_Sub rep) [n', CmmMachOp (MO_Mul rep) [q, CmmLit $ CmmInt d rep]] - where d = narrowU rep d' - _ -> pure Nothing - where platform = cmmPlatform cfg - -cmmMachOpFoldOptM _ _ _ = pure Nothing - --- ----------------------------------------------------------------------------- --- Utils for prepending new nodes - --- Move an expression into a register to possibly use it multiple times -intoRegister :: CmmExpr -> CmmType -> Opt CmmExpr -intoRegister e@(CmmReg _) _ = pure e -intoRegister expr ty = do - u <- getUniqueM - let reg = LocalReg u ty - CmmReg (CmmLocal reg) <$ prependNode (CmmAssign (CmmLocal reg) expr) - -prependNode :: CmmNode O O -> Opt () -prependNode n = Opt $ \_ xs -> pure (xs ++ [n], ()) - --- ----------------------------------------------------------------------------- --- Division by constants utils - --- Helper for division by a power of 2 --- 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 optimize the divide by 2 case slightly, generating --- x1 = x >> word_size-1 (unsigned) --- return = x + x1 -signedQuotRemHelper :: Platform -> Integer -> CmmExpr -> Width -> Integer -> CmmExpr -signedQuotRemHelper platform n x 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 $ wordWidth platform)] - x2 = if p == 1 then x1 else - CmmMachOp (MO_And rep) [x1, CmmLit (CmmInt (n-1) rep)] - -{- Note: [Division by constants] - -Integer division is floor(n / d), the goal is to find m,p -such that floor((m * n) / 2^p) = floor(n / d). - -The idea being: n/d = n * (1/d). But we cannot store 1/d in an integer without -some error, so we choose some 2^p / d such that the error ends up small and -thus vanishes when we divide by 2^p again. - -The algorithm below to generate these numbers is taken from Hacker's Delight -Second Edition Chapter 10 "Integer division by constants". The chapter also -contains proof that this method does indeed produce correct results. - -However this is a much more literal interpretation of the algorithm, -which we can use because of the unbounded Integer type. Hacker's Delight -also provides a much more complex algorithm which computes these numbers -without the need to exceed the word size, but that is not necessary here. --} - -generateDivisionBySigned :: Platform -> CmmConfig -> Width -> CmmExpr -> Integer -> Opt CmmExpr - --- Sanity checks, division will generate incorrect results or undesirable code for these cases --- cmmMachOpFoldM and cmmMachOpFoldOptM should have already handled these cases! -generateDivisionBySigned _ _ _ _ 0 = panic "generate signed division with 0" -generateDivisionBySigned _ _ _ _ 1 = panic "generate signed division with 1" -generateDivisionBySigned _ _ _ _ (-1) = panic "generate signed division with -1" -generateDivisionBySigned _ _ _ _ d | Just _ <- exactLog2 d = panic $ "generate signed division with " ++ show d - -generateDivisionBySigned platform _cfg rep n divisor = do - -- We only duplicate n' if we actually need to add/subtract it, so we may not need it in a register - n' <- if sign == 0 then pure n else intoRegister n resRep - - -- Set up mul2 - (shift', qExpr) <- mul2 n' - - -- add/subtract n if necessary - let qExpr' = case sign of - 1 -> CmmMachOp (MO_Add rep) [qExpr, n'] - -1 -> CmmMachOp (MO_Sub rep) [qExpr, n'] - _ -> qExpr - - qExpr'' <- intoRegister (cmmMachOpFold platform (MO_S_Shr rep) [qExpr', CmmLit $ CmmInt shift' wordRep]) resRep - - -- Lastly add the sign of the quotient to correct for negative results - pure $! cmmMachOpFold platform - (MO_Add rep) [qExpr'', cmmMachOpFold platform (MO_U_Shr rep) [qExpr'', CmmLit $ CmmInt (toInteger $ widthInBits rep - 1) wordRep]] - where - resRep = cmmBits rep - wordRep = wordWidth platform - (magic, sign, shift) = divisionMagicS rep divisor - -- generate the multiply with the magic number - mul2 n - -- Using mul2 for sub-word sizes regresses for signed integers only - | rep == wordWidth platform = do - (r1, r2, r3) <- (,,) <$> getUniqueM <*> getUniqueM <*> getUniqueM - let rg1 = LocalReg r1 resRep - resReg = LocalReg r2 resRep - rg3 = LocalReg r3 resRep - res <- CmmReg (CmmLocal resReg) <$ prependNode (CmmUnsafeForeignCall (PrimTarget (MO_S_Mul2 rep)) [rg1, resReg, rg3] [n, CmmLit $ CmmInt magic rep]) - pure (shift, res) - -- widen the register and multiply without the MUL2 instruction - -- if we don't need an additional add after this we can combine the shifts - | otherwise = pure (if sign == 0 then 0 else shift, res) - where - wordRep = wordWidth platform - -- (n * magic) >> widthInBits + (if sign == 0 then shift else 0) -- With conversion in between to not overflow - res = cmmMachOpFold platform (MO_SS_Conv wordRep rep) - [ cmmMachOpFold platform (MO_S_Shr wordRep) - [ cmmMachOpFold platform (MO_Mul wordRep) - [ cmmMachOpFold platform (MO_SS_Conv rep wordRep) [n] - , CmmLit $ CmmInt magic wordRep - ] - -- Check if we need to generate an add/subtract later. If not we can combine this with the postshift - , CmmLit $ CmmInt ((if sign == 0 then toInteger shift else 0) + (toInteger $ widthInBits rep)) wordRep - ] - ] - --- See hackers delight for how and why this works (chapter in note [Division by constants]) -divisionMagicS :: Width -> Integer -> (Integer, Integer, Integer) -divisionMagicS rep divisor = (magic, sign, toInteger $ p - wSz) - where - sign = if divisor > 0 - then if magic < 0 then 1 else 0 - else if magic < 0 then 0 else -1 - wSz = widthInBits rep - ad = abs divisor - t = (1 `shiftL` (wSz - 1)) + if divisor > 0 then 0 else 1 - anc = t - 1 - rem t ad - go p' - | twoP > anc * (ad - rem twoP ad) = p' - | otherwise = go (p' + 1) - where twoP = 1 `shiftL` p' - p = go wSz - am = (twoP + ad - rem twoP ad) `quot` ad - where twoP = 1 `shiftL` p - magic = narrowS rep $ if divisor > 0 then am else -am - -generateDivisionByUnsigned :: Platform -> CmmConfig -> Width -> CmmExpr -> Integer -> Opt CmmExpr --- Sanity checks, division will generate incorrect results or undesirable code for these cases --- cmmMachOpFoldM and cmmMachOpFoldOptM should have already handled these cases! -generateDivisionByUnsigned _ _ _ _ 0 = panic "generate signed division with 0" -generateDivisionByUnsigned _ _ _ _ 1 = panic "generate signed division with 1" -generateDivisionByUnsigned _ _ _ _ d | Just _ <- exactLog2 d = panic $ "generate signed division with " ++ show d - -generateDivisionByUnsigned platform cfg rep n divisor = do - -- We only duplicate n' if we actually need to add/subtract it, so we may not need it in a register - n' <- if not needsAdd -- Invariant: We also never preshift if we need an add, thus we don't need n in a register - then pure $! cmmMachOpFold platform (MO_U_Shr rep) [n, CmmLit $ CmmInt preShift wordRep] - else intoRegister n resRep - - -- Set up mul2 - (postShift', qExpr) <- mul2 n' - - -- add/subtract n if necessary - let qExpr' = if needsAdd - -- This is qExpr + (n - qExpr) / 2 = (qExpr + n) / 2 but with a guarantee that it'll not overflow - then cmmMachOpFold platform (MO_Add rep) - [ cmmMachOpFold platform (MO_U_Shr rep) - [ cmmMachOpFold platform (MO_Sub rep) [n', qExpr] - , CmmLit $ CmmInt 1 wordRep - ] - , qExpr - ] - else qExpr - -- If we already divided by 2 in the add, remember to shift one bit less - -- Hacker's Delight, Edition 2 Page 234: postShift > 0 if we needed an add, except if the divisor - -- is 1, which we checked for above - finalShift = if needsAdd then postShift' - 1 else postShift' - - -- apply the final postShift - pure $! cmmMachOpFold platform (MO_U_Shr rep) [qExpr', CmmLit $ CmmInt finalShift wordRep] - where - resRep = cmmBits rep - wordRep = wordWidth platform - (preShift, magic, needsAdd, postShift) = - let withPre = divisionMagicU rep True divisor - noPre = divisionMagicU rep False divisor - in case (withPre, noPre) of - -- Use whatever does not cause us to take the expensive case - ((_, _, False, _), (_, _, True, _)) -> withPre - -- If we cannot avoid the expensive case, don't bother with the pre shift - _ -> noPre - -- generate the multiply with the magic number - mul2 n - | rep == wordWidth platform || (cmmAllowMul2 cfg && needsAdd) = do - (r1, r2) <- (,) <$> getUniqueM <*> getUniqueM - let rg1 = LocalReg r1 resRep - resReg = LocalReg r2 resRep - res <- CmmReg (CmmLocal resReg) <$ prependNode (CmmUnsafeForeignCall (PrimTarget (MO_U_Mul2 rep)) [resReg, rg1] [n, CmmLit $ CmmInt magic rep]) - pure (postShift, res) - | otherwise = do - pure (if needsAdd then postShift else 0, res) - where - wordRep = wordWidth platform - -- (n * magic) >> widthInBits + (if sign == 0 then shift else 0) -- With conversion in between to not overflow - res = cmmMachOpFold platform (MO_UU_Conv wordRep rep) - [ cmmMachOpFold platform (MO_U_Shr wordRep) - [ cmmMachOpFold platform (MO_Mul wordRep) - [ cmmMachOpFold platform (MO_UU_Conv rep wordRep) [n] - , CmmLit $ CmmInt magic wordRep - ] - -- Check if we need to generate an add later. If not we can combine this with the postshift - , CmmLit $ CmmInt ((if needsAdd then 0 else postShift) + (toInteger $ widthInBits rep)) wordRep - ] - ] - --- See hackers delight for how and why this works (chapter in note [Division by constants]) --- The preshift isn't described there, but the idea is: --- If a divisor d has n trailing zeros, then d is a multiple of 2^n. Since we want to divide x by d --- we can also calculate (x / 2^n) / (d / 2^n) which may then not require an extra addition. --- --- The addition performs: quotient + dividend, but we need to avoid overflows, so we actually need to --- calculate: quotient + (dividend - quotient) / 2 = (quotient + dividend) / 2 --- Thus if the preshift can avoid all of this, we have 1 operation in place of 3. --- --- The decision to use the preshift is made somewhere else, here we only report if the addition is needed -divisionMagicU :: Width -> Bool -> Integer -> (Integer, Integer, Bool, Integer) -divisionMagicU rep doPreShift divisor = (toInteger zeros, magic, needsAdd, toInteger $ p - wSz) - where - wSz = widthInBits rep - zeros = if doPreShift then countTrailingZeros $ fromInteger @Word64 divisor else 0 - d = divisor `shiftR` zeros - ones = ((1 `shiftL` wSz) - 1) `shiftR` zeros - nc = ones - rem (ones - d) d - go p' - | twoP > nc * (d - 1 - rem (twoP - 1) d) = p' - | otherwise = go (p' + 1) - where twoP = 1 `shiftL` p' - p = go wSz - m = (twoP + d - 1 - rem (twoP - 1) d) `quot` d - where twoP = 1 `shiftL` p - needsAdd = d < 1 `shiftL` (p - wSz) - magic = if needsAdd then m - (ones + 1) else m - --- ----------------------------------------------------------------------------- --- Opt monad - -newtype Opt a = OptI { runOptI :: CmmConfig -> [CmmNode O O] -> UniqDSM ([CmmNode O O], a) } - --- | Pattern synonym for 'Opt', as described in Note [The one-shot state --- monad trick]. -pattern Opt :: (CmmConfig -> [CmmNode O O] -> UniqDSM ([CmmNode O O], a)) -> Opt a -pattern Opt f <- OptI f - where Opt f = OptI . oneShot $ \cfg -> oneShot $ \out -> f cfg out -{-# COMPLETE Opt #-} - -runOpt :: CmmConfig -> Opt a -> UniqDSM ([CmmNode O O], a) -runOpt cf (Opt g) = g cf [] - -getConfig :: Opt CmmConfig -getConfig = Opt $ \cf xs -> pure (xs, cf) - -instance Functor Opt where - fmap f (Opt g) = Opt $ \cf xs -> fmap (fmap f) (g cf xs) - -instance Applicative Opt where - pure a = Opt $ \_ xs -> pure (xs, a) - ff <*> fa = do - f <- ff - f <$> fa - -instance Monad Opt where - Opt g >>= f = Opt $ \cf xs -> do - (ys, a) <- g cf xs - runOptI (f a) cf ys - -instance MonadGetUnique Opt where - getUniqueM = Opt $ \_ xs -> (xs,) <$> getUniqueDSM - -mapForeignTargetOpt :: (CmmExpr -> Opt CmmExpr) -> ForeignTarget -> Opt ForeignTarget -mapForeignTargetOpt exp (ForeignTarget e c) = flip ForeignTarget c <$> exp e -mapForeignTargetOpt _ m@(PrimTarget _) = pure m - -wrapRecExpOpt :: (CmmExpr -> Opt CmmExpr) -> CmmExpr -> Opt CmmExpr -wrapRecExpOpt f (CmmMachOp op es) = traverse (wrapRecExpOpt f) es >>= f . CmmMachOp op -wrapRecExpOpt f (CmmLoad addr ty align) = wrapRecExpOpt f addr >>= \newAddr -> f (CmmLoad newAddr ty align) -wrapRecExpOpt f e = f e - -mapExpOpt :: (CmmExpr -> Opt CmmExpr) -> CmmNode e x -> Opt (CmmNode e x) -mapExpOpt _ f@(CmmEntry{}) = pure f -mapExpOpt _ m@(CmmComment _) = pure m -mapExpOpt _ m@(CmmTick _) = pure m -mapExpOpt f (CmmUnwind regs) = CmmUnwind <$> traverse (traverse (traverse f)) regs -mapExpOpt f (CmmAssign r e) = CmmAssign r <$> f e -mapExpOpt f (CmmStore addr e align) = CmmStore <$> f addr <*> f e <*> pure align -mapExpOpt f (CmmUnsafeForeignCall tgt fs as) = CmmUnsafeForeignCall <$> mapForeignTargetOpt f tgt <*> pure fs <*> traverse f as -mapExpOpt _ l@(CmmBranch _) = pure l -mapExpOpt f (CmmCondBranch e ti fi l) = f e >>= \newE -> pure (CmmCondBranch newE ti fi l) -mapExpOpt f (CmmSwitch e ids) = flip CmmSwitch ids <$> f e -mapExpOpt f n@CmmCall {cml_target=tgt} = f tgt >>= \newTgt -> pure n{cml_target = newTgt} -mapExpOpt f (CmmForeignCall tgt fs as succ ret_args updfr intrbl) - = do - newTgt <- mapForeignTargetOpt f tgt - newAs <- traverse f as - pure $ CmmForeignCall newTgt fs newAs succ ret_args updfr intrbl diff --git a/GHC/Cmm/Parser.hs b/GHC/Cmm/Parser.hs --- a/GHC/Cmm/Parser.hs +++ b/GHC/Cmm/Parser.hs @@ -3230,6 +3230,7 @@ ( fsLit "PROF_HEADER_CREATE", \[e] -> profHeaderCreate e ), ( fsLit "PUSH_UPD_FRAME", \[sp,e] -> emitPushUpdateFrame sp e ), + ( fsLit "PUSH_BH_UPD_FRAME", \[sp,e] -> emitPushBHUpdateFrame sp e ), ( fsLit "SET_HDR", \[ptr,info,ccs] -> emitSetDynHdr ptr info ccs ), ( fsLit "TICK_ALLOC_PRIM", \[hdr,goods,slop] -> @@ -3244,6 +3245,10 @@ emitPushUpdateFrame :: CmmExpr -> CmmExpr -> FCode () emitPushUpdateFrame sp e = do emitUpdateFrame sp mkUpdInfoLabel e + +emitPushBHUpdateFrame :: CmmExpr -> CmmExpr -> FCode () +emitPushBHUpdateFrame sp e = do + emitUpdateFrame sp mkBHUpdInfoLabel e pushStackFrame :: [CmmParse CmmExpr] -> CmmParse () -> CmmParse () pushStackFrame fields body = do diff --git a/GHC/Cmm/Pipeline.hs b/GHC/Cmm/Pipeline.hs --- a/GHC/Cmm/Pipeline.hs +++ b/GHC/Cmm/Pipeline.hs @@ -137,12 +137,9 @@ dump Opt_D_dump_cmm_sp "Layout Stack" g ----------- Sink and inline assignments -------------------------------- - (g, dus) <- {-# SCC "sink" #-} -- See Note [Sinking after stack layout] - if cmmOptSink cfg - then pure $ runUniqueDSM dus $ cmmSink cfg g - else return (g, dus) - dump Opt_D_dump_cmm_sink "Sink assignments" g - + g <- {-# SCC "sink" #-} -- See Note [Sinking after stack layout] + condPass (cmmOptSink cfg) (cmmSink platform) g + Opt_D_dump_cmm_sink "Sink assignments" ------------- CAF analysis ---------------------------------------------- let cafEnv = {-# SCC "cafAnal" #-} cafAnal platform call_pps l g diff --git a/GHC/Cmm/Sink.hs b/GHC/Cmm/Sink.hs --- a/GHC/Cmm/Sink.hs +++ b/GHC/Cmm/Sink.hs @@ -20,85 +20,81 @@ import GHC.Platform import GHC.Types.Unique.FM -import GHC.Types.Unique.DSM -import GHC.Cmm.Config import Data.List (partition) import Data.Maybe import GHC.Exts (inline) --- ----------------------------------------------------------------------------- --- Sinking and inlining +-------------------------------------------------------------------------------- +{- Note [Sinking and inlining] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Sinking 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 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. +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 an 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. + (See Note [When does an assignment conflict?] for what it means for + A to conflict with 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. -- @@ -152,10 +148,9 @@ -- y = e2 -- x = e1 -cmmSink :: CmmConfig -> CmmGraph -> UniqDSM CmmGraph -cmmSink cfg graph = ofBlockList (g_entry graph) <$> sink mapEmpty blocks +cmmSink :: Platform -> CmmGraph -> CmmGraph +cmmSink platform graph = ofBlockList (g_entry graph) $ sink mapEmpty $ blocks where - platform = cmmPlatform cfg liveness = cmmLocalLivenessL platform graph getLive l = mapFindWithDefault emptyLRegSet l liveness @@ -163,41 +158,11 @@ join_pts = findJoinPoints blocks - sink :: LabelMap Assignments -> [CmmBlock] -> UniqDSM [CmmBlock] - sink _ [] = pure [] - sink sunk (b:bs) = do - -- Now sink and inline in this block - (prepend, last_fold) <- runOpt cfg $ constantFoldNode last - - (middle', assigs) <- walk cfg (ann_middles ++ annotate platform live_middle prepend) (mapFindWithDefault [] lbl sunk) - - let (final_last, assigs') = tryToInline platform live last_fold assigs - -- Now, drop any assignments that we will not sink any further. - (dropped_last, assigs'') = dropAssignments platform drop_if init_live_sets assigs' - drop_if :: (LocalReg, CmmExpr, AbsMem) - -> [LRegSet] -> (Bool, [LRegSet]) - drop_if a@(r,rhs,_) live_sets = (should_drop, live_sets') - where - should_drop = conflicts platform a final_last - || not (isTrivial platform rhs) && live_in_multi live_sets r - || r `elemLRegSet` live_in_joins - - live_sets' | should_drop = live_sets - | otherwise = map upd live_sets - - upd set | r `elemLRegSet` set = set `unionLRegSet` live_rhs - | otherwise = set - - live_rhs = foldRegsUsed platform (flip insertLRegSet) emptyLRegSet rhs - - final_middle = foldl' blockSnoc middle' dropped_last - - sunk' = mapUnion sunk $ - mapFromList [ (l, filterAssignments platform (getLive l) assigs'') - | l <- succs ] - - (blockJoin first final_middle final_last :) <$> sink sunk' bs - + 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 @@ -211,6 +176,11 @@ live_middle = gen_killL platform last live ann_middles = annotate platform live_middle (blockToList middle) + -- Now sink and inline in this block + (middle', assigs) = walk platform ann_middles (mapFindWithDefault [] lbl sunk) + fold_last = constantFoldNode platform last + (final_last, assigs') = tryToInline platform 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. @@ -228,6 +198,31 @@ (_one:_two:_) -> True _ -> False + -- Now, drop any assignments that we will not sink any further. + (dropped_last, assigs'') = dropAssignments platform drop_if init_live_sets assigs' + + drop_if :: (LocalReg, CmmExpr, AbsMem) + -> [LRegSet] -> (Bool, [LRegSet]) + drop_if a@(r,rhs,_) live_sets = (should_drop, live_sets') + where + should_drop = conflicts platform a final_last + || not (isTrivial platform rhs) && live_in_multi live_sets r + || r `elemLRegSet` live_in_joins + + live_sets' | should_drop = live_sets + | otherwise = map upd live_sets + + upd set | r `elemLRegSet` set = set `unionLRegSet` live_rhs + | otherwise = set + + live_rhs = foldRegsUsed platform (flip insertLRegSet) emptyLRegSet rhs + + final_middle = foldl' blockSnoc middle' dropped_last + + sunk' = mapUnion sunk $ + mapFromList [ (l, filterAssignments platform (getLive l) assigs'') + | l <- succs ] + {- TODO: enable this later, when we have some good tests in place to measure the effect and tune it. @@ -302,7 +297,7 @@ -- * a list of assignments that will be placed *after* that block. -- -walk :: CmmConfig +walk :: Platform -> [(LRegSet, CmmNode O O)] -- nodes of the block, annotated with -- the set of registers live *after* -- this node. @@ -312,40 +307,37 @@ -- Earlier assignments may refer -- to later ones. - -> UniqDSM ( Block CmmNode O O -- The new block - , Assignments -- Assignments to sink further - ) + -> ( Block CmmNode O O -- The new block + , Assignments -- Assignments to sink further + ) -walk cfg nodes assigs = go nodes emptyBlock assigs +walk platform nodes assigs = go nodes emptyBlock assigs where - platform = cmmPlatform cfg - go [] block as = pure (block, as) + go [] block as = (block, as) go ((live,node):ns) block as -- discard nodes representing dead assignment | shouldDiscard node live = go ns block as - | otherwise = do - (prepend, node1) <- runOpt cfg $ constantFoldNode node - if not (null prepend) - then go (annotate platform live (prepend ++ [node1]) ++ ns) block as - else do - let -- Inline assignments - (node2, as1) = tryToInline platform live node1 as - -- Drop any earlier assignments conflicting with node2 - (dropped, as') = dropAssignmentsSimple platform - (\a -> conflicts platform a node2) as1 - -- Walk over the rest of the block. Includes dropped assignments - block' = foldl' blockSnoc block dropped `blockSnoc` node2 + -- sometimes only after simplification we can tell we can discard the node. + -- See Note [Discard simplified nodes] + | noOpAssignment node2 = go ns block as + -- Pick up interesting assignments + | Just a <- shouldSink platform node2 = go ns block (a : as1) + -- Try inlining, drop assignments and move on + | otherwise = go ns block' as' + where + -- Simplify node + node1 = constantFoldNode platform node - (prepend2, node3) <- runOpt cfg $ constantFoldNode node2 - if | not (null prepend2) -> go (annotate platform live (prepend2 ++ [node3]) ++ ns) block as - -- sometimes only after simplification we can tell we can discard the node. - -- See Note [Discard simplified nodes] - | noOpAssignment node3 -> go ns block as - -- Pick up interesting assignments - | Just a <- shouldSink platform node3 -> go ns block (a : as1) - -- Try inlining, drop assignments and move on - | otherwise -> go ns block' as' + -- Inline assignments + (node2, as1) = tryToInline platform live node1 as + -- Drop any earlier assignments conflicting with node2 + (dropped, as') = dropAssignmentsSimple platform + (\a -> conflicts platform a node2) as1 + + -- Walk over the rest of the block. Includes dropped assignments + block' = foldl' blockSnoc block dropped `blockSnoc` node2 + {- Note [Discard simplified nodes] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider a sequence like this: @@ -654,110 +646,171 @@ -- ----------------------------------------------------------------------------- +{- Note [When does an assignment conflict?] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +An assignment 'A' conflicts with a statement 'N' if any of the following +conditions are satisfied: + + (C1) 'A' assigns to a register mentioned in 'N' + (C2) 'A' mentions a register assigned by 'N' + (C3) 'A' reads from memory written by 'N' + +In such a situation, it is not safe to commute 'A' past 'N'. For example, +it is not safe to commute + + A: r = 1 + N: s = r + +because 'r' may be undefined or hold a different value before 'A'. + +Remarks: + + (C3) includes all foreign calls, as they may modify the heap/stack. + + (C1) includes the following two situations: + + (C1a) 'N' defines the LHS register in the assignment 'A', for example: + + A: r = + N: r = + + (C1b) 'N' defines a register used in the RHS of 'A', for example: + + A: r = s + N: s = + + (C1c) 'suspendThread' clobbers every global register not backed by a + real register, as noted in #19237. + +Forgetting (C1a) led to bug #26550, in which we incorrectly commuted + + A: _c1rB::Fx2V128 = <0.0 :: W64, 0.0 :: W64> + N: _c1rB::Fx2V128 = %MO_VF_Insert_2_W64(<0.0 :: W64,0.0 :: W64>,%MO_F_Add_W64(F64[R1 + 7], 3.0 :: W64),0 :: W32) + +-} + -- | @conflicts (r,e) node@ is @False@ if and only if the assignment -- @r = e@ can be safely commuted past statement @node@. +-- +-- See Note [When does an assignment conflict?]. conflicts :: Platform -> Assignment -> CmmNode O x -> Bool -conflicts platform (r, rhs, addr) node +conflicts platform assig@(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 platform rhs node = True - | localRegistersConflict platform rhs node = True + -- (C1) node defines registers that are either the assigned register or + -- are used by the rhs of the assignment. + -- This catches assignments and all three kinds of calls. + -- See Note [Sinking and calls] + | globalRegistersConflict platform rhs node = True + | localRegistersConflict platform assig node = True - -- (2) node uses register defined by assignment + -- (C2) node uses register defined by assignment | foldRegsUsed platform (\b r' -> r == r' || b) False node = True - -- (3) a store to an address conflicts with a read of the same memory + -- (C3) Node writes to memory that is read by the assignment. + + -- (a) a store to an address conflicts with a read of the same memory | CmmStore addr' e _ <- node , memConflicts addr (loadAddr platform addr' (cmmExprWidth platform e)) = True - -- (4) an assignment to Hp/Sp conflicts with a heap/stack read respectively - | HeapMem <- addr, CmmAssign (CmmGlobal (GlobalRegUse Hp _)) _ <- node = True - | StackMem <- addr, CmmAssign (CmmGlobal (GlobalRegUse Sp _)) _ <- node = True - | SpMem{} <- addr, CmmAssign (CmmGlobal (GlobalRegUse Sp _)) _ <- node = True + -- (b) an assignment to Hp/Sp conflicts with a heap/stack read respectively + | CmmAssign (CmmGlobal (GlobalRegUse Hp _)) _ <- node + , memConflicts addr HeapMem + = True + | CmmAssign (CmmGlobal (GlobalRegUse Sp _)) _ <- node + , memConflicts addr StackMem + = True - -- (5) foreign calls clobber heap: see Note [Foreign calls clobber heap] + -- (c) foreign calls clobber heap: see Note [Foreign calls clobber heap] | CmmUnsafeForeignCall{} <- node, memConflicts addr AnyMem = True - -- (6) suspendThread clobbers every global register not backed by a real - -- register. It also clobbers heap and stack but this is handled by (5) + -- (d) native calls clobber any memory + | CmmCall{} <- node, memConflicts addr AnyMem = True + + -- (C1c) suspendThread clobbers every global register not backed by a real + -- register. (It also clobbers heap and stack, but this is handled by (C3)(c) above.) | CmmUnsafeForeignCall (PrimTarget MO_SuspendThread) _ _ <- node , foldRegsUsed platform (\b g -> globalRegMaybe platform g == Nothing || b) False rhs = True - -- (7) native calls clobber any memory - | CmmCall{} <- node, memConflicts addr AnyMem = True - - -- (8) otherwise, no conflict | otherwise = False {- Note [Inlining foldRegsDefd] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - foldRegsDefd is, after optimization, *not* a small function so - it's only marked INLINEABLE, but not INLINE. - - However in some specific cases we call it *very* often making it - important to avoid the overhead of allocating the folding function. +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +foldRegsDefd is, after optimization, *not* a small function so +it's only marked INLINEABLE, but not INLINE. - So we simply force inlining via the magic inline function. - For T3294 this improves allocation with -O by ~1%. +However in some specific cases we call it *very* often making it +important to avoid the overhead of allocating the folding function. +So we simply force inlining via the magic inline function. +For T3294 this improves allocation with -O by ~1%. -} --- Returns True if node defines any global registers that are used in the --- Cmm expression +-- | Returns @True@ if @node@ defines any global registers that are used in the +-- Cmm expression. +-- +-- See (C1) in Note [When does an assignment conflict?]. globalRegistersConflict :: Platform -> CmmExpr -> CmmNode e x -> Bool globalRegistersConflict platform expr node = -- See Note [Inlining foldRegsDefd] inline foldRegsDefd platform (\b r -> b || globalRegUsedIn platform (globalRegUse_reg r) expr) False node + -- NB: no need to worry about (C1a), as the LHS of an assignment is always + -- a local register, never a global register. --- Returns True if node defines any local registers that are used in the --- Cmm expression -localRegistersConflict :: Platform -> CmmExpr -> CmmNode e x -> Bool -localRegistersConflict platform expr node = +-- | Given an assignment @local_reg := expr@, return @True@ if @node@ defines any +-- local registers mentioned in the assignment. +-- +-- See (C1) in Note [When does an assignment conflict?]. +localRegistersConflict :: Platform -> Assignment -> CmmNode e x -> Bool +localRegistersConflict platform (r, expr, _) node = -- See Note [Inlining foldRegsDefd] - inline foldRegsDefd platform (\b r -> b || regUsedIn platform (CmmLocal r) expr) - False node + inline foldRegsDefd platform + (\b r' -> + b + || r' == r -- (C1a) + || regUsedIn platform (CmmLocal r') expr -- (C1b) + ) + 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. --- +{- 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 diff --git a/GHC/CmmToAsm/AArch64/Ppr.hs b/GHC/CmmToAsm/AArch64/Ppr.hs --- a/GHC/CmmToAsm/AArch64/Ppr.hs +++ b/GHC/CmmToAsm/AArch64/Ppr.hs @@ -20,6 +20,7 @@ import GHC.Cmm.BlockId import GHC.Cmm.CLabel +import GHC.Cmm.InitFini import GHC.Types.Unique ( pprUniqueAlways, getUnique ) import GHC.Platform @@ -29,9 +30,7 @@ pprNatCmmDecl :: IsDoc doc => NCGConfig -> NatCmmDecl RawCmmStatics Instr -> doc pprNatCmmDecl config (CmmData section dats) = - let platform = ncgPlatform config - in - pprSectionAlign config section $$ pprDatas platform dats + pprSectionAlign config section $$ pprDatas config dats pprNatCmmDecl config proc@(CmmProc top_info lbl _ (ListGraph blocks)) = let platform = ncgPlatform config @@ -92,9 +91,20 @@ pprSectionAlign :: IsDoc doc => NCGConfig -> Section -> doc pprSectionAlign _config (Section (OtherSection _) _) = panic "AArch64.Ppr.pprSectionAlign: unknown section" -pprSectionAlign config sec@(Section seg _) = +pprSectionAlign config sec@(Section seg suffix) = line (pprSectionHeader config sec) + $$ coffSplitSectionComdatKey $$ pprAlignForSection (ncgPlatform config) seg + where + platform = ncgPlatform config + -- See Note [Split sections on COFF objects] + coffSplitSectionComdatKey + | OSMinGW32 <- platformOS platform + , ncgSplitSections config + , Nothing <- isInitOrFiniSection seg + = line (pprCOFFComdatKey platform suffix <> colon) + | otherwise + = empty -- | Output the ELF .size directive. pprSizeDecl :: IsDoc doc => Platform -> CLabel -> doc @@ -137,20 +147,26 @@ (l@LOCATION{} : _) -> pprInstr platform l _other -> empty -pprDatas :: IsDoc doc => Platform -> RawCmmStatics -> doc +pprDatas :: IsDoc doc => NCGConfig -> RawCmmStatics -> doc -- See Note [emit-time elimination of static indirections] in "GHC.Cmm.CLabel". -pprDatas platform (CmmStaticsRaw alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _]) +pprDatas config (CmmStaticsRaw alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _]) | lbl == mkIndStaticInfoLabel , let labelInd (CmmLabelOff l _) = Just l labelInd (CmmLabel l) = Just l labelInd _ = Nothing , Just ind' <- labelInd ind , alias `mayRedirectTo` ind' + -- See Note [Split sections on COFF objects] + , not $ platformOS platform == OSMinGW32 && ncgSplitSections config = pprGloblDecl platform alias $$ line (text ".equiv" <+> pprAsmLabel platform alias <> comma <> pprAsmLabel platform ind') + where + platform = ncgPlatform config -pprDatas platform (CmmStaticsRaw lbl dats) +pprDatas config (CmmStaticsRaw lbl dats) = vcat (pprLabel platform lbl : map (pprData platform) dats) + where + platform = ncgPlatform config pprData :: IsDoc doc => Platform -> CmmStatic -> doc pprData _platform (CmmString str) = line (pprString str) diff --git a/GHC/CmmToAsm/PPC/CodeGen.hs b/GHC/CmmToAsm/PPC/CodeGen.hs --- a/GHC/CmmToAsm/PPC/CodeGen.hs +++ b/GHC/CmmToAsm/PPC/CodeGen.hs @@ -182,7 +182,7 @@ format = cmmTypeFormat ty CmmUnsafeForeignCall target result_regs args - -> genCCall target result_regs args + -> genCCall platform target result_regs args CmmBranch id -> genBranch id CmmCondBranch arg true false prediction -> do @@ -340,6 +340,8 @@ let Reg64 hi lo = localReg64 local_reg return (RegCode64 nilOL hi lo) +iselExpr64 regoff@(CmmRegOff _ _) = iselExpr64 $ mangleIndexTree regoff + iselExpr64 (CmmLit (CmmInt i _)) = do Reg64 rhi rlo <- getNewReg64 let @@ -469,48 +471,26 @@ return (Any II64 code) -- catch simple cases of zero- or sign-extended load -getRegister' _ _ (CmmMachOp (MO_UU_Conv W8 W32) [CmmLoad mem _ _]) = do - Amode addr addr_code <- getAmode D mem - return (Any II32 (\dst -> addr_code `snocOL` LD II8 dst addr)) - -getRegister' _ _ (CmmMachOp (MO_XX_Conv W8 W32) [CmmLoad mem _ _]) = do - Amode addr addr_code <- getAmode D mem - return (Any II32 (\dst -> addr_code `snocOL` LD II8 dst addr)) - -getRegister' _ _ (CmmMachOp (MO_UU_Conv W8 W64) [CmmLoad mem _ _]) = do - Amode addr addr_code <- getAmode D mem - return (Any II64 (\dst -> addr_code `snocOL` LD II8 dst addr)) - -getRegister' _ _ (CmmMachOp (MO_XX_Conv W8 W64) [CmmLoad mem _ _]) = do - Amode addr addr_code <- getAmode D mem - return (Any II64 (\dst -> addr_code `snocOL` LD II8 dst addr)) - --- Note: there is no Load Byte Arithmetic instruction, so no signed case here - -getRegister' _ _ (CmmMachOp (MO_UU_Conv W16 W32) [CmmLoad mem _ _]) = do - Amode addr addr_code <- getAmode D mem - return (Any II32 (\dst -> addr_code `snocOL` LD II16 dst addr)) - -getRegister' _ _ (CmmMachOp (MO_SS_Conv W16 W32) [CmmLoad mem _ _]) = do - Amode addr addr_code <- getAmode D mem - return (Any II32 (\dst -> addr_code `snocOL` LA II16 dst addr)) - -getRegister' _ _ (CmmMachOp (MO_UU_Conv W16 W64) [CmmLoad mem _ _]) = do - Amode addr addr_code <- getAmode D mem - return (Any II64 (\dst -> addr_code `snocOL` LD II16 dst addr)) - -getRegister' _ _ (CmmMachOp (MO_SS_Conv W16 W64) [CmmLoad mem _ _]) = do - Amode addr addr_code <- getAmode D mem - return (Any II64 (\dst -> addr_code `snocOL` LA II16 dst addr)) +getRegister' _ _ (CmmMachOp (MO_UU_Conv src tgt) [CmmLoad mem pk _]) + | src < tgt + , cmmTypeFormat pk == intFormat src = loadZeroExpand mem pk tgt -getRegister' _ _ (CmmMachOp (MO_UU_Conv W32 W64) [CmmLoad mem _ _]) = do - Amode addr addr_code <- getAmode D mem - return (Any II64 (\dst -> addr_code `snocOL` LD II32 dst addr)) +getRegister' _ _ (CmmMachOp (MO_XX_Conv src tgt) [CmmLoad mem pk _]) + | src < tgt + , cmmTypeFormat pk == intFormat src = loadZeroExpand mem pk tgt -getRegister' _ _ (CmmMachOp (MO_SS_Conv W32 W64) [CmmLoad mem _ _]) = do - -- lwa is DS-form. See Note [Power instruction format] - Amode addr addr_code <- getAmode DS mem - return (Any II64 (\dst -> addr_code `snocOL` LA II32 dst addr)) + -- XXX: This is ugly, refactor +getRegister' _ _ (CmmMachOp (MO_SS_Conv src tgt) [CmmLoad mem pk _]) + -- Note: there is no Load Byte Arithmetic instruction + | cmmTypeFormat pk /= II8 + , src < tgt = do + let format = cmmTypeFormat pk + -- lwa is DS-form. See Note [Power instruction format] + let form = if format >= II32 then DS else D + Amode addr addr_code <- getAmode form mem + let code dst = assert (format == intFormat src) + $ addr_code `snocOL` LA format dst addr + return (Any (intFormat tgt) code) getRegister' config platform (CmmMachOp (MO_RelaxedRead w) [e]) = getRegister' config platform (CmmLoad e (cmmBits w) NaturallyAligned) @@ -795,6 +775,12 @@ extendUExpr :: Width -> Width -> CmmExpr -> CmmExpr extendUExpr from to x = CmmMachOp (MO_UU_Conv from to) [x] +loadZeroExpand :: CmmExpr -> CmmType -> Width -> NatM Register +loadZeroExpand mem pk tgt = do + Amode addr addr_code <- getAmode D mem + let code dst = addr_code `snocOL` LD (cmmTypeFormat pk) dst addr + return (Any (intFormat tgt) code) + -- ----------------------------------------------------------------------------- -- The 'Amode' type: Memory addressing modes passed up the tree. @@ -1204,24 +1190,25 @@ -- @get_arg@, which moves the arguments to the correct registers/stack -- locations. Apart from that, the code is easy. -genCCall :: ForeignTarget -- function to call +genCCall :: Platform + -> ForeignTarget -- function to call -> [CmmFormal] -- where to put the result -> [CmmActual] -- arguments (of mixed type) -> NatM InstrBlock -genCCall (PrimTarget MO_AcquireFence) _ _ +genCCall _ (PrimTarget MO_AcquireFence) _ _ = return $ unitOL LWSYNC -genCCall (PrimTarget MO_ReleaseFence) _ _ +genCCall _ (PrimTarget MO_ReleaseFence) _ _ = return $ unitOL LWSYNC -genCCall (PrimTarget MO_SeqCstFence) _ _ +genCCall _ (PrimTarget MO_SeqCstFence) _ _ = return $ unitOL HWSYNC -genCCall (PrimTarget MO_Touch) _ _ +genCCall _ (PrimTarget MO_Touch) _ _ = return $ nilOL -genCCall (PrimTarget (MO_Prefetch_Data _)) _ _ +genCCall _ (PrimTarget (MO_Prefetch_Data _)) _ _ = return $ nilOL -genCCall (PrimTarget (MO_AtomicRMW width amop)) [dst] [addr, n] +genCCall _ (PrimTarget (MO_AtomicRMW width amop)) [dst] [addr, n] = do let fmt = intFormat width reg_dst = getLocalRegReg dst (instr, n_code) <- case amop of @@ -1271,7 +1258,7 @@ (n_reg, n_code) <- getSomeReg n return (op dst dst (RIReg n_reg), n_code) -genCCall (PrimTarget (MO_AtomicRead width _)) [dst] [addr] +genCCall _ (PrimTarget (MO_AtomicRead width _)) [dst] [addr] = do let fmt = intFormat width reg_dst = getLocalRegReg dst form = if widthInBits width == 64 then DS else D @@ -1298,12 +1285,12 @@ -- This is also what gcc does. -genCCall (PrimTarget (MO_AtomicWrite width _)) [] [addr, val] = do +genCCall _ (PrimTarget (MO_AtomicWrite width _)) [] [addr, val] = do code <- assignMem_IntCode (intFormat width) addr val return $ unitOL HWSYNC `appOL` code -genCCall (PrimTarget (MO_Cmpxchg width)) [dst] [addr, old, new] - | width == W32 || width == W64 +genCCall platform (PrimTarget (MO_Cmpxchg width)) [dst] [addr, old, new] + | width == W32 || (width == W64 && not (target32Bit platform)) = do (old_reg, old_code) <- getSomeReg old (new_reg, new_code) <- getSomeReg new @@ -1332,9 +1319,8 @@ format = intFormat width -genCCall (PrimTarget (MO_Clz width)) [dst] [src] - = do platform <- getPlatform - let reg_dst = getLocalRegReg dst +genCCall platform (PrimTarget (MO_Clz width)) [dst] [src] + = do let reg_dst = getLocalRegReg dst if target32Bit platform && width == W64 then do RegCode64 code vr_hi vr_lo <- iselExpr64 src @@ -1382,9 +1368,8 @@ let cntlz = unitOL (CNTLZ format reg_dst reg) return $ s_code `appOL` pre `appOL` cntlz `appOL` post -genCCall (PrimTarget (MO_Ctz width)) [dst] [src] - = do platform <- getPlatform - let reg_dst = getLocalRegReg dst +genCCall platform (PrimTarget (MO_Ctz width)) [dst] [src] + = do let reg_dst = getLocalRegReg dst if target32Bit platform && width == W64 then do let format = II32 @@ -1446,9 +1431,8 @@ , SUBFC dst r' (RIImm (ImmInt (format_bits))) ] -genCCall target dest_regs argsAndHints - = do platform <- getPlatform - case target of +genCCall platform target dest_regs argsAndHints + = do case target of PrimTarget (MO_S_QuotRem width) -> divOp1 True width dest_regs argsAndHints PrimTarget (MO_U_QuotRem width) -> divOp1 False width @@ -2446,8 +2430,8 @@ let op_len = max W32 width extend = if sgn then extendSExpr else extendUExpr (src1, code1) <- getSomeReg (extend width op_len x) - (src2, code2) <- getSomeReg (extendUExpr width op_len y) - -- Note: Shift amount `y` is unsigned + (src2, code2) <- getSomeReg y + let code dst = code1 `appOL` code2 `snocOL` instr (intFormat op_len) dst src1 (RIReg src2) return (Any (intFormat width) code) diff --git a/GHC/CmmToAsm/Ppr.hs b/GHC/CmmToAsm/Ppr.hs --- a/GHC/CmmToAsm/Ppr.hs +++ b/GHC/CmmToAsm/Ppr.hs @@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiWayIf #-} ----------------------------------------------------------------------------- -- @@ -15,6 +16,7 @@ pprASCII, pprString, pprFileEmbed, + pprCOFFComdatKey, pprSectionHeader ) @@ -24,6 +26,7 @@ import GHC.Utils.Asm import GHC.Cmm.CLabel +import GHC.Cmm.InitFini import GHC.Cmm import GHC.CmmToAsm.Config import GHC.Utils.Outputable as SDoc @@ -226,8 +229,8 @@ | otherwise -> text ".rodata" RelocatableReadOnlyData | OSMinGW32 <- platformOS platform -- Concept does not exist on Windows, - -- So map these to R/O data. - -> text ".rdata$rel.ro" + -- So map these to data. + -> text ".data" | otherwise -> text ".data.rel.ro" UninitialisedData -> text ".bss" InitArray @@ -244,19 +247,74 @@ | otherwise -> text ".rodata.str" OtherSection _ -> panic "PprBase.pprGNUSectionHeader: unknown section type" - flags = case t of - Text - | OSMinGW32 <- platformOS platform, splitSections - -> text ",\"xr\"" - | splitSections - -> text ",\"ax\"," <> sectionType platform "progbits" - CString - | OSMinGW32 <- platformOS platform - -> empty - | otherwise -> text ",\"aMS\"," <> sectionType platform "progbits" <> text ",1" - _ -> empty + flags + -- See + -- https://github.com/llvm/llvm-project/blob/llvmorg-21.1.8/lld/COFF/Chunks.cpp#L54 + -- and https://llvm.org/docs/Extensions.html#section-directive. + -- LLD COFF backend gc-sections only work on COMDAT sections so + -- we need to mark it as a COMDAT section. You can use clang64 + -- toolchain to compile small examples with + -- `-ffunction-sections -fdata-sections -S` to see these section + -- headers in the wild. Also see Note [Split sections on COFF objects] + -- below. + | OSMinGW32 <- platformOS platform, + splitSections = + if + | Just _ <- isInitOrFiniSection t -> text ",\"dw\"" + | otherwise -> + let coff_section_flags + | Text <- t = "xr" + | UninitialisedData <- t = "bw" + | ReadOnlySection <- sectionProtection t = "dr" + | otherwise = "dw" + in hcat + [ text ",\"", + text coff_section_flags, + text "\",one_only,", + pprCOFFComdatKey platform suffix + ] + | otherwise = + case t of + Text + | splitSections + -> text ",\"ax\"," <> sectionType platform "progbits" + CString + | OSMinGW32 <- platformOS platform + -> empty + | otherwise -> text ",\"aMS\"," <> sectionType platform "progbits" <> text ",1" + _ -> empty {-# SPECIALIZE pprGNUSectionHeader :: NCGConfig -> SectionType -> CLabel -> SDoc #-} {-# SPECIALIZE pprGNUSectionHeader :: NCGConfig -> SectionType -> CLabel -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + +-- | Note [Split sections on COFF objects] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- On Windows/COFF, LLD's gc-sections only works on COMDAT sections, +-- so we mark split sections as COMDAT and need to provide a unique +-- "key" symbol. +-- +-- Important: We must not use a dot-prefixed local label (e.g. +-- @.L...@) as the COMDAT key symbol, because LLVM's COFF assembler +-- treats dot-prefixed COMDAT key symbols specially and forces them to +-- have value 0 (the beginning of the section). That breaks +-- @tablesNextToCode@, where the info label is intentionally placed +-- after the info table data (at a non-zero offset). +-- +-- Therefore we generate a non-dot-prefixed key symbol derived from +-- the section suffix, and (see arch-specific 'pprSectionAlign') we +-- emit a label definition for it at the beginning of the section. +-- +-- ctor/dtor sections are specially treated; they must be emitted as +-- regular data sections, otherwise LLD will drop them. +-- +-- Note that we must not emit .equiv directives for COMDAT sections in +-- COFF objects, they seriously confuse LLD and we end up with access +-- violations at runtimes. +pprCOFFComdatKey :: IsLine doc => Platform -> CLabel -> doc +pprCOFFComdatKey platform suffix = + text "__ghc_coff_comdat_" <> pprAsmLabel platform suffix +{-# SPECIALIZE pprCOFFComdatKey :: Platform -> CLabel -> SDoc #-} +{-# SPECIALIZE pprCOFFComdatKey :: Platform -> CLabel -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- XCOFF doesn't support relocating label-differences, so we place all -- RO sections into .text[PR] sections diff --git a/GHC/CmmToAsm/Reg/Graph.hs b/GHC/CmmToAsm/Reg/Graph.hs --- a/GHC/CmmToAsm/Reg/Graph.hs +++ b/GHC/CmmToAsm/Reg/Graph.hs @@ -339,14 +339,14 @@ -- Conflicts between virtual and real regs are recorded as exclusions. graphAddConflictSet :: Platform - -> UniqSet RegWithFormat + -> Regs -> Color.Graph VirtualReg RegClass RealReg -> Color.Graph VirtualReg RegClass RealReg graphAddConflictSet platform regs graph = let arch = platformArch platform - virtuals = takeVirtualRegs regs - reals = takeRealRegs regs + virtuals = takeVirtualRegs $ getRegs regs + reals = takeRealRegs $ getRegs regs graph1 = Color.addConflicts virtuals (classOfVirtualReg arch) graph -- NB: we could add "arch" as argument to functions such as "addConflicts" diff --git a/GHC/CmmToAsm/Reg/Graph/Coalesce.hs b/GHC/CmmToAsm/Reg/Graph/Coalesce.hs --- a/GHC/CmmToAsm/Reg/Graph/Coalesce.hs +++ b/GHC/CmmToAsm/Reg/Graph/Coalesce.hs @@ -13,10 +13,8 @@ import GHC.Data.Bag import GHC.Data.Graph.Directed import GHC.Platform (Platform) -import GHC.Types.Unique (getUnique) import GHC.Types.Unique.FM import GHC.Types.Unique.Supply -import GHC.Types.Unique.Set -- | Do register coalescing on this top level thing -- @@ -88,8 +86,8 @@ slurpLI rs (LiveInstr _ Nothing) = rs slurpLI rs (LiveInstr instr (Just live)) | Just (r1, r2) <- takeRegRegMoveInstr platform instr - , elemUniqSet_Directly (getUnique r1) $ liveDieRead live - , elemUniqSet_Directly (getUnique r2) $ liveBorn live + , r1 `elemRegs` liveDieRead live + , r2 `elemRegs` liveBorn live -- only coalesce movs between two virtuals for now, -- else we end up with allocatable regs in the live diff --git a/GHC/CmmToAsm/Reg/Graph/Spill.hs b/GHC/CmmToAsm/Reg/Graph/Spill.hs --- a/GHC/CmmToAsm/Reg/Graph/Spill.hs +++ b/GHC/CmmToAsm/Reg/Graph/Spill.hs @@ -144,7 +144,7 @@ -- then record the fact that these slots are now live in those blocks -- in the given slotmap. patchLiveSlot - :: BlockMap IntSet -> BlockId -> UniqSet RegWithFormat-> BlockMap IntSet + :: BlockMap IntSet -> BlockId -> Regs -> BlockMap IntSet patchLiveSlot slotMap blockId regsLive = let @@ -154,7 +154,8 @@ moreSlotsLive = IntSet.fromList $ mapMaybe (lookupUFM regSlotMap . regWithFormat_reg) - $ nonDetEltsUniqSet regsLive + $ nonDetEltsUniqSet + $ getRegs regsLive -- See Note [Unique Determinism and code generation] slotMap' diff --git a/GHC/CmmToAsm/Reg/Graph/SpillCost.hs b/GHC/CmmToAsm/Reg/Graph/SpillCost.hs --- a/GHC/CmmToAsm/Reg/Graph/SpillCost.hs +++ b/GHC/CmmToAsm/Reg/Graph/SpillCost.hs @@ -101,7 +101,7 @@ countBlock info freqMap (BasicBlock blockId instrs) | LiveInfo _ _ blockLive _ <- info , Just rsLiveEntry <- mapLookup blockId blockLive - , rsLiveEntry_virt <- takeVirtualRegs rsLiveEntry + , rsLiveEntry_virt <- takeVirtualRegs $ getRegs rsLiveEntry = countLIs (ceiling $ blockFreq freqMap blockId) rsLiveEntry_virt instrs | otherwise @@ -135,9 +135,9 @@ mapM_ (incDefs scale) $ nub $ mapMaybe (takeVirtualReg . regWithFormat_reg) written -- Compute liveness for entry to next instruction. - let liveDieRead_virt = takeVirtualRegs (liveDieRead live) - let liveDieWrite_virt = takeVirtualRegs (liveDieWrite live) - let liveBorn_virt = takeVirtualRegs (liveBorn live) + let liveDieRead_virt = takeVirtualRegs $ getRegs (liveDieRead live) + let liveDieWrite_virt = takeVirtualRegs $ getRegs (liveDieWrite live) + let liveBorn_virt = takeVirtualRegs $ getRegs (liveBorn live) let rsLiveAcross = rsLiveEntry `minusUniqSet` liveDieRead_virt diff --git a/GHC/CmmToAsm/Reg/Linear.hs b/GHC/CmmToAsm/Reg/Linear.hs --- a/GHC/CmmToAsm/Reg/Linear.hs +++ b/GHC/CmmToAsm/Reg/Linear.hs @@ -209,7 +209,7 @@ :: forall instr. (Instruction instr) => NCGConfig -> [BlockId] -- ^ entry points - -> BlockMap (UniqSet RegWithFormat) + -> BlockMap Regs -- ^ live regs on entry to each basic block -> [SCC (LiveBasicBlock instr)] -- ^ instructions annotated with "deaths" @@ -248,7 +248,7 @@ => NCGConfig -> freeRegs -> [BlockId] -- ^ entry points - -> BlockMap (UniqSet RegWithFormat) -- ^ live regs on entry to each basic block + -> BlockMap Regs -- ^ live regs on entry to each basic block -> [SCC (LiveBasicBlock instr)] -- ^ instructions annotated with "deaths" -> UniqDSM ([NatBasicBlock instr], RegAllocStats, Int) @@ -262,7 +262,7 @@ linearRA_SCCs :: OutputableRegConstraint freeRegs instr => [BlockId] - -> BlockMap (UniqSet RegWithFormat) + -> BlockMap Regs -> [NatBasicBlock instr] -> [SCC (LiveBasicBlock instr)] -> RegM freeRegs [NatBasicBlock instr] @@ -297,7 +297,7 @@ process :: forall freeRegs instr. (OutputableRegConstraint freeRegs instr) => [BlockId] - -> BlockMap (UniqSet RegWithFormat) + -> BlockMap Regs -> [GenBasicBlock (LiveInstr instr)] -> RegM freeRegs [[NatBasicBlock instr]] process entry_ids block_live = @@ -336,7 +336,7 @@ -- processBlock :: OutputableRegConstraint freeRegs instr - => BlockMap (UniqSet RegWithFormat) -- ^ live regs on entry to each basic block + => BlockMap Regs -- ^ live regs on entry to each basic block -> LiveBasicBlock instr -- ^ block to do register allocation on -> RegM freeRegs [NatBasicBlock instr] -- ^ block with registers allocated @@ -353,7 +353,7 @@ -- | Load the freeregs and current reg assignment into the RegM state -- for the basic block with this BlockId. initBlock :: FR freeRegs - => BlockId -> BlockMap (UniqSet RegWithFormat) -> RegM freeRegs () + => BlockId -> BlockMap Regs -> RegM freeRegs () initBlock id block_live = do platform <- getPlatform block_assig <- getBlockAssigR @@ -370,7 +370,7 @@ setFreeRegsR (frInitFreeRegs platform) Just live -> setFreeRegsR $ foldl' (flip $ frAllocateReg platform) (frInitFreeRegs platform) - (nonDetEltsUniqSet $ takeRealRegs live) + (nonDetEltsUniqSet $ takeRealRegs $ getRegs live) -- See Note [Unique Determinism and code generation] setAssigR emptyRegMap @@ -383,7 +383,7 @@ -- | Do allocation for a sequence of instructions. linearRA :: forall freeRegs instr. (OutputableRegConstraint freeRegs instr) - => BlockMap (UniqSet RegWithFormat) -- ^ map of what vregs are live on entry to each block. + => BlockMap Regs -- ^ map of what vregs are live on entry to each block. -> BlockId -- ^ id of the current block, for debugging. -> [LiveInstr instr] -- ^ liveness annotated instructions in this block. -> RegM freeRegs @@ -408,7 +408,7 @@ -- | Do allocation for a single instruction. raInsn :: OutputableRegConstraint freeRegs instr - => BlockMap (UniqSet RegWithFormat) -- ^ map of what vregs are love on entry to each block. + => BlockMap Regs -- ^ map of what vregs are live on entry to each block. -> [instr] -- ^ accumulator for instructions already processed. -> BlockId -- ^ the id of the current block, for debugging -> LiveInstr instr -- ^ the instr to have its regs allocated, with liveness info. @@ -429,7 +429,7 @@ raInsn block_live new_instrs id (LiveInstr (Instr instr) (Just live)) = do platform <- getPlatform - assig <- getAssigR :: RegM freeRegs (UniqFM Reg Loc) + assig <- getAssigR -- If we have a reg->reg move between virtual registers, where the -- src register is not live after this instruction, and the dst @@ -439,12 +439,12 @@ -- (we can't eliminate it if the source register is on the stack, because -- we do not want to use one spill slot for different virtual registers) case takeRegRegMoveInstr platform instr of - Just (src,dst) | Just (RegWithFormat _ fmt) <- lookupUniqSet_Directly (liveDieRead live) (getUnique src), + Just (src,dst) | Just fmt <- lookupReg src (liveDieRead live), isVirtualReg dst, not (dst `elemUFM` assig), isRealReg src || isInReg src assig -> do case src of - RegReal rr -> setAssigR (addToUFM assig dst (InReg $ RealRegUsage rr fmt)) + RegReal rr -> setAssigR (addToUFM assig dst (Loc (InReg rr) fmt)) -- if src is a fixed reg, then we just map dest to this -- reg in the assignment. src must be an allocatable reg, -- otherwise it wouldn't be in r_dying. @@ -463,8 +463,8 @@ return (new_instrs, []) _ -> genRaInsn block_live new_instrs id instr - (map regWithFormat_reg $ nonDetEltsUniqSet $ liveDieRead live) - (map regWithFormat_reg $ nonDetEltsUniqSet $ liveDieWrite live) + (map regWithFormat_reg $ nonDetEltsUniqSet $ getRegs $ liveDieRead live) + (map regWithFormat_reg $ nonDetEltsUniqSet $ getRegs $ liveDieWrite live) -- See Note [Unique Determinism and code generation] raInsn _ _ _ instr @@ -487,13 +487,16 @@ isInReg :: Reg -> RegMap Loc -> Bool -isInReg src assig | Just (InReg _) <- lookupUFM assig src = True - | otherwise = False +isInReg src assig + | Just (Loc (InReg _) _) <- lookupUFM assig src + = True + | otherwise + = False genRaInsn :: forall freeRegs instr. (OutputableRegConstraint freeRegs instr) - => BlockMap (UniqSet RegWithFormat) + => BlockMap Regs -> [instr] -> BlockId -> instr @@ -506,8 +509,8 @@ platform <- getPlatform case regUsageOfInstr platform instr of { RU read written -> do - let real_written = [ rr | RegWithFormat {regWithFormat_reg = RegReal rr} <- written ] - let virt_written = [ VirtualRegWithFormat vr fmt | RegWithFormat (RegVirtual vr) fmt <- written ] + let real_written = [ rr | RegWithFormat {regWithFormat_reg = RegReal rr} <- written ] + let virt_written = [ VirtualRegWithFormat vr fmt | RegWithFormat (RegVirtual vr) fmt <- written ] -- we don't need to do anything with real registers that are -- only read by this instr. (the list is typically ~2 elements, @@ -645,14 +648,16 @@ loop assig !free (RegReal rr : rs) = loop assig (frReleaseReg platform rr free) rs loop assig !free (r:rs) = case lookupUFM assig r of - Just (InBoth real _) -> loop (delFromUFM assig r) - (frReleaseReg platform (realReg real) free) rs - Just (InReg real) -> loop (delFromUFM assig r) - (frReleaseReg platform (realReg real) free) rs - _ -> loop (delFromUFM assig r) free rs + Just (Loc (InBoth real _) _) -> + loop (delFromUFM assig r) + (frReleaseReg platform real free) rs + Just (Loc (InReg real) _) -> + loop (delFromUFM assig r) + (frReleaseReg platform real free) rs + _ -> + loop (delFromUFM assig r) free rs loop assig free regs - -- ----------------------------------------------------------------------------- -- Clobber real registers @@ -670,17 +675,18 @@ saveClobberedTemps :: forall instr freeRegs. (Instruction instr, FR freeRegs) - => [RealReg] -- real registers clobbered by this instruction - -> [Reg] -- registers which are no longer live after this insn - -> RegM freeRegs [instr] -- return: instructions to spill any temps that will - -- be clobbered. + => [RealReg] -- ^ real registers clobbered by this instruction + -> [Reg] -- ^ registers which are no longer live after this instruction, + -- because read for the last time + -> RegM freeRegs [instr] -- return: instructions to spill any temps that will + -- be clobbered. saveClobberedTemps [] _ = return [] saveClobberedTemps clobbered dying = do - assig <- getAssigR :: RegM freeRegs (UniqFM Reg Loc) + assig <- getAssigR (assig',instrs) <- nonDetStrictFoldUFM_DirectlyM maybe_spill (assig,[]) assig setAssigR assig' return $ -- mkComment (text "") ++ @@ -689,19 +695,21 @@ where -- Unique represents the VirtualReg -- Here we separate the cases which we do want to spill from these we don't. - maybe_spill :: Unique -> (RegMap Loc,[instr]) -> (Loc) -> RegM freeRegs (RegMap Loc,[instr]) + maybe_spill :: Unique + -> (RegMap Loc,[instr]) + -> Loc + -> RegM freeRegs (RegMap Loc,[instr]) maybe_spill !temp !(assig,instrs) !loc = case loc of -- This is non-deterministic but we do not -- currently support deterministic code-generation. -- See Note [Unique Determinism and code generation] - InReg reg - | any (realRegsAlias $ realReg reg) clobbered + Loc (InReg reg) fmt + | any (realRegsAlias reg) clobbered , temp `notElem` map getUnique dying - -> clobber temp (assig,instrs) reg + -> clobber temp (assig,instrs) (RealRegUsage reg fmt) _ -> return (assig,instrs) - -- See Note [UniqFM and the register allocator] clobber :: Unique -> (RegMap Loc,[instr]) -> RealRegUsage -> RegM freeRegs (RegMap Loc,[instr]) clobber temp (assig,instrs) (RealRegUsage reg fmt) @@ -720,7 +728,7 @@ (my_reg : _) -> do setFreeRegsR (frAllocateReg platform my_reg freeRegs) - let new_assign = addToUFM_Directly assig temp (InReg (RealRegUsage my_reg fmt)) + let new_assign = addToUFM_Directly assig temp (Loc (InReg my_reg) fmt) let instr = mkRegRegMoveInstr config fmt (RegReal reg) (RegReal my_reg) @@ -728,12 +736,13 @@ -- (2) no free registers: spill the value [] -> do + (spill, slot) <- spillR (RegWithFormat (RegReal reg) fmt) temp -- record why this reg was spilled for profiling recordSpill (SpillClobber temp) - let new_assign = addToUFM_Directly assig temp (InBoth (RealRegUsage reg fmt) slot) + let new_assign = addToUFM_Directly assig temp (Loc (InBoth reg slot) fmt) return (new_assign, (spill ++ instrs)) @@ -781,9 +790,9 @@ clobber assig [] = assig - clobber assig ((temp, InBoth reg slot) : rest) - | any (realRegsAlias $ realReg reg) clobbered - = clobber (addToUFM_Directly assig temp (InMem slot)) rest + clobber assig ((temp, Loc (InBoth reg slot) regFmt) : rest) + | any (realRegsAlias reg) clobbered + = clobber (addToUFM_Directly assig temp (Loc (InMem slot) regFmt)) rest clobber assig (_:rest) = clobber assig rest @@ -792,9 +801,9 @@ -- allocateRegsAndSpill -- Why are we performing a spill? -data SpillLoc = ReadMem StackSlot -- reading from register only in memory - | WriteNew -- writing to a new variable - | WriteMem -- writing to register only in memory +data SpillLoc = ReadMem StackSlot Format -- reading from register only in memory + | WriteNew -- writing to a new variable + | WriteMem -- writing to register only in memory -- Note that ReadNew is not valid, since you don't want to be reading -- from an uninitialized register. We also don't need the location of -- the register in memory, since that will be invalidated by the write. @@ -820,28 +829,36 @@ allocateRegsAndSpill _ _ spills alloc [] = return (spills, reverse alloc) -allocateRegsAndSpill reading keep spills alloc (r@(VirtualRegWithFormat vr _fmt):rs) +allocateRegsAndSpill reading keep spills alloc (r@(VirtualRegWithFormat vr vrFmt):rs) = do assig <- toVRegMap <$> getAssigR -- pprTraceM "allocateRegsAndSpill:assig" (ppr (r:rs) $$ ppr assig) -- See Note [UniqFM and the register allocator] let doSpill = allocRegsAndSpill_spill reading keep spills alloc r rs assig case lookupUFM assig vr of -- case (1a): already in a register - Just (InReg my_reg) -> - allocateRegsAndSpill reading keep spills (realReg my_reg:alloc) rs + Just (Loc (InReg my_reg) in_reg_fmt) -> do + -- (RF1) from Note [Allocated register formats]: + -- writes redefine the format the register is used at. + when (not reading && vrFmt /= in_reg_fmt) $ + setAssigR $ toRegMap $ + addToUFM assig vr (Loc (InReg my_reg) vrFmt) + allocateRegsAndSpill reading keep spills (my_reg:alloc) rs -- case (1b): already in a register (and memory) - -- NB1. if we're writing this register, update its assignment to be - -- InReg, because the memory value is no longer valid. - -- NB2. This is why we must process written registers here, even if they - -- are also read by the same instruction. - Just (InBoth my_reg _) - -> do when (not reading) (setAssigR $ toRegMap (addToUFM assig vr (InReg my_reg))) - allocateRegsAndSpill reading keep spills (realReg my_reg:alloc) rs + Just (Loc (InBoth my_reg _) _) -> do + -- NB1. if we're writing this register, update its assignment to be + -- InReg, because the memory value is no longer valid. + -- NB2. This is why we must process written registers here, even if they + -- are also read by the same instruction. + when (not reading) $ + setAssigR $ toRegMap $ + addToUFM assig vr (Loc (InReg my_reg) vrFmt) + allocateRegsAndSpill reading keep spills (my_reg:alloc) rs -- Not already in a register, so we need to find a free one... - Just (InMem slot) | reading -> doSpill (ReadMem slot) - | otherwise -> doSpill WriteMem + Just (Loc (InMem slot) memFmt) + | reading -> doSpill (ReadMem slot memFmt) + | otherwise -> doSpill WriteMem Nothing | reading -> pprPanic "allocateRegsAndSpill: Cannot read from uninitialized register" (ppr vr) -- NOTE: if the input to the NCG contains some @@ -877,7 +894,7 @@ -> UniqFM VirtualReg Loc -> SpillLoc -> RegM freeRegs ([instr], [RealReg]) -allocRegsAndSpill_spill reading keep spills alloc r@(VirtualRegWithFormat vr fmt) rs assig spill_loc +allocRegsAndSpill_spill reading keep spills alloc r@(VirtualRegWithFormat vr vrFmt) rs assig spill_loc = do platform <- getPlatform freeRegs <- getFreeRegsR let regclass = classOfVirtualReg (platformArch platform) vr @@ -899,7 +916,7 @@ spills' <- loadTemp r spill_loc final_reg spills setAssigR $ toRegMap - $ (addToUFM assig vr $! newLocation spill_loc $ RealRegUsage final_reg fmt) + $ (addToUFM assig vr $! newLocation spill_loc $ RealRegUsage final_reg vrFmt) setFreeRegsR $ frAllocateReg platform final_reg freeRegs allocateRegsAndSpill reading keep spills' (final_reg : alloc) rs @@ -913,7 +930,7 @@ let candidates' :: UniqFM VirtualReg Loc candidates' = flip delListFromUFM (fmap virtualRegWithFormat_reg keep) $ - filterUFM inRegOrBoth $ + filterUFM (inRegOrBoth . locWithFormat_loc) $ assig -- This is non-deterministic but we do not -- currently support deterministic code-generation. @@ -926,50 +943,54 @@ == regclass candidates_inBoth :: [(Unique, RealRegUsage, StackSlot)] candidates_inBoth - = [ (temp, reg, mem) - | (temp, InBoth reg mem) <- candidates - , compat (realReg reg) ] + = [ (temp, RealRegUsage reg fmt, mem) + | (temp, Loc (InBoth reg mem) fmt) <- candidates + , compat reg ] -- the vregs we could kick out that are only in a reg -- this would require writing the reg to a new slot before using it. let candidates_inReg - = [ (temp, reg) - | (temp, InReg reg) <- candidates - , compat (realReg reg) ] + = [ (temp, RealRegUsage reg fmt) + | (temp, Loc (InReg reg) fmt) <- candidates + , compat reg ] let result -- we have a temporary that is in both register and mem, -- just free up its register for use. - | (temp, (RealRegUsage my_reg _old_fmt), slot) : _ <- candidates_inBoth - = do spills' <- loadTemp r spill_loc my_reg spills - let assig1 = addToUFM_Directly assig temp (InMem slot) - let assig2 = addToUFM assig1 vr $! newLocation spill_loc (RealRegUsage my_reg fmt) + | (temp, (RealRegUsage cand_reg old_fmt), slot) : _ <- candidates_inBoth + = do spills' <- loadTemp r spill_loc cand_reg spills + let assig1 = addToUFM_Directly assig temp $ Loc (InMem slot) old_fmt + let assig2 = addToUFM assig1 vr $! newLocation spill_loc (RealRegUsage cand_reg vrFmt) setAssigR $ toRegMap assig2 - allocateRegsAndSpill reading keep spills' (my_reg:alloc) rs + allocateRegsAndSpill reading keep spills' (cand_reg:alloc) rs -- otherwise, we need to spill a temporary that currently -- resides in a register. - | (temp_to_push_out, RealRegUsage my_reg fmt) : _ + | (temp_to_push_out, RealRegUsage cand_reg old_reg_fmt) : _ <- candidates_inReg = do - (spill_store, slot) <- spillR (RegWithFormat (RegReal my_reg) fmt) temp_to_push_out + -- Spill what's currently in the register, with the format of what's in the register. + (spill_store, slot) <- spillR (RegWithFormat (RegReal cand_reg) old_reg_fmt) temp_to_push_out -- record that this temp was spilled recordSpill (SpillAlloc temp_to_push_out) - -- update the register assignment - let assig1 = addToUFM_Directly assig temp_to_push_out (InMem slot) - let assig2 = addToUFM assig1 vr $! newLocation spill_loc (RealRegUsage my_reg fmt) + -- Update the register assignment: + -- - the old data is now only in memory, + -- - the new data is now allocated to this register; + -- make sure to use the new format (#26542) + let assig1 = addToUFM_Directly assig temp_to_push_out $ Loc (InMem slot) old_reg_fmt + let assig2 = addToUFM assig1 vr $! newLocation spill_loc (RealRegUsage cand_reg vrFmt) setAssigR $ toRegMap assig2 -- if need be, load up a spilled temp into the reg we've just freed up. - spills' <- loadTemp r spill_loc my_reg spills + spills' <- loadTemp r spill_loc cand_reg spills allocateRegsAndSpill reading keep (spill_store ++ spills') - (my_reg:alloc) rs + (cand_reg:alloc) rs -- there wasn't anything to spill, so we're screwed. @@ -978,7 +999,7 @@ $ vcat [ text "allocating vreg: " <> text (show vr) , text "assignment: " <> ppr assig - , text "format: " <> ppr fmt + , text "format: " <> ppr vrFmt , text "freeRegs: " <> text (showRegs freeRegs) , text "initFreeRegs: " <> text (showRegs (frInitFreeRegs platform `asTypeOf` freeRegs)) ] @@ -990,9 +1011,12 @@ -- | Calculate a new location after a register has been loaded. newLocation :: SpillLoc -> RealRegUsage -> Loc -- if the tmp was read from a slot, then now its in a reg as well -newLocation (ReadMem slot) my_reg = InBoth my_reg slot +newLocation (ReadMem slot memFmt) (RealRegUsage r _regFmt) = + -- See Note [Use spilled format when reloading] + Loc (InBoth r slot) memFmt + -- writes will always result in only the register being available -newLocation _ my_reg = InReg my_reg +newLocation _ (RealRegUsage r regFmt) = Loc (InReg r) regFmt -- | Load up a spilled temporary if we need to (read from memory). loadTemp @@ -1003,11 +1027,91 @@ -> [instr] -> RegM freeRegs [instr] -loadTemp (VirtualRegWithFormat vreg fmt) (ReadMem slot) hreg spills +loadTemp (VirtualRegWithFormat vreg _fmt) (ReadMem slot memFmt) hreg spills = do - insn <- loadR (RegWithFormat (RegReal hreg) fmt) slot + -- See Note [Use spilled format when reloading] + insn <- loadR (RegWithFormat (RegReal hreg) memFmt) slot recordSpill (SpillLoad $ getUnique vreg) return $ {- mkComment (text "spill load") : -} insn ++ spills loadTemp _ _ _ spills = return spills + +{- Note [Allocated register formats] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We uphold the following principle for the format at which we keep track of +alllocated registers: + + RF1. Writes redefine the format. + + When we write to a register 'r' at format 'fmt', we consider the register + to hold that format going forwards. + + (In cases where a partial write is desired, the move instruction should + specify that the destination format is the full register, even if, say, + the instruction only writes to the low 64 bits of the register. + See also Wrinkle [Don't allow scalar partial writes] in + Note [Register formats in liveness analysis] in GHC.CmmToAsm.Reg.Liveness.) + + RF2. Reads from a register do not redefine its format. + + Generally speaking, as explained in Note [Register formats in liveness analysis] + in GHC.CmmToAsm.Reg.Liveness, when computing the used format from a collection + of reads, we take a least upper bound. + +It is particularly important to get (RF1) correct, as otherwise we can end up in +the situation of T26411b, where code such as + + movsd .Ln6m(%rip),%v1 + shufpd $0,%v1,%v1 + +we start off with %v1 :: F64, but after shufpd (which broadcasts the low part +to the high part) we must consider that %v1 :: F64x2. If we fail to do that, +then we will silently discard the top bits in spill/reload operations. +-} + +{- Note [Use spilled format when reloading] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We always reload at the full format that a register was spilled at. The rationale +is as follows: + + 1. If later instructions only need the lower 64 bits of an XMM register, + then we should have only spilled the lower 64 bits in the first place. + (Whether this is true currently is another question.) + 2. If later instructions need say 128 bits, then we should immediately load + the entire 128 bits, as this avoids multiple load instructions. + +For (2), consider the situation of #26526, where we need to spill around a C +call (because we are using the System V ABI with no callee saved XMM registers). +Before register allocation, we have: + + vmovupd %v1 %v0 + call ... + movsd %v0 %v3 + movhlps %v0 %v4 + +The contents of %v0 need to be preserved across the call. We must spill %v0 at +format F64x2 (as later instructions need the entire 128 bits), and reload it +later. We thus expect something like: + + vmovupd %xmm1 %xmm0 + vmovupd %xmm0 72(%rsp) -- spill to preserve + call ... + vmovupd 72(%rsp) %xmm0 -- restore + movsd %xmm0 %xmm3 + movhlps %xmm0 %xmm4 + +This is certainly better than doing two loads from the stack, e.g. + + call ... + movsd 72(%rsp) %xmm0 -- restore only lower 64 bits + movsd %xmm0 %xmm3 + vmovupd 72(%rsp) %xmm0 -- restore the full 128 bits + movhlps %xmm0 %xmm4 + +The latter being especially risky because we don't want to believe %v0 is 'InBoth' +with format F64. The risk is that, when allocating registers for the 'VMOVUPD' +instruction, we think our data is already in a register and thus doesn't need to +be reloaded from memory, when in fact we have only loaded the lower 64 bits of +the data. +-} diff --git a/GHC/CmmToAsm/Reg/Linear/Base.hs b/GHC/CmmToAsm/Reg/Linear/Base.hs --- a/GHC/CmmToAsm/Reg/Linear/Base.hs +++ b/GHC/CmmToAsm/Reg/Linear/Base.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} -- | Put common type definitions here to break recursive module dependencies. @@ -9,7 +10,7 @@ emptyBlockAssignment, updateBlockAssignment, - Loc(..), + VLoc(..), Loc(..), IgnoreFormat(..), regsOfLoc, RealRegUsage(..), @@ -39,8 +40,6 @@ import GHC.CmmToAsm.Reg.Utils import GHC.CmmToAsm.Format -import Data.Function ( on ) - data ReadingOrWriting = Reading | Writing deriving (Eq,Ord) -- | Used to store the register assignment on entry to a basic block. @@ -70,8 +69,13 @@ -> BlockAssignment freeRegs -> BlockAssignment freeRegs updateBlockAssignment dest (freeRegs, regMap) (BlockAssignment {..}) = - BlockAssignment (mapInsert dest (freeRegs, regMap) blockMap) - (mergeUFM combWithExisting id (mapMaybeUFM fromLoc) (firstUsed) (toVRegMap regMap)) + BlockAssignment + (mapInsert dest (freeRegs, regMap) blockMap) + (mergeUFM combWithExisting id + (mapMaybeUFM (fromVLoc . locWithFormat_loc)) + firstUsed + (toVRegMap regMap) + ) where -- The blocks are processed in dependency order, so if there's already an -- entry in the map then keep that assignment rather than writing the new @@ -79,13 +83,14 @@ combWithExisting :: RealReg -> Loc -> Maybe RealReg combWithExisting old_reg _ = Just $ old_reg - fromLoc :: Loc -> Maybe RealReg - fromLoc (InReg rr) = Just $ realReg rr - fromLoc (InBoth rr _) = Just $ realReg rr - fromLoc _ = Nothing - + fromVLoc :: VLoc -> Maybe RealReg + fromVLoc (InReg rr) = Just rr + fromVLoc (InBoth rr _) = Just rr + fromVLoc _ = Nothing --- | Where a vreg is currently stored +-- | Where a vreg is currently stored. +-- +-- -- A temporary can be marked as living in both a register and memory -- (InBoth), for example if it was recently loaded from a spill location. -- This makes it cheap to spill (no save instruction required), but we @@ -96,22 +101,41 @@ -- save it in a spill location, but mark it as InBoth because the current -- instruction might still want to read it. -- -data Loc +data VLoc -- | vreg is in a register - = InReg {-# UNPACK #-} !RealRegUsage + = InReg {-# UNPACK #-} !RealReg -- | vreg is held in stack slots - | InMem {-# UNPACK #-} !StackSlot - + | InMem {-# UNPACK #-} !StackSlot -- | vreg is held in both a register and stack slots - | InBoth {-# UNPACK #-} !RealRegUsage - {-# UNPACK #-} !StackSlot + | InBoth {-# UNPACK #-} !RealReg + {-# UNPACK #-} !StackSlot deriving (Eq, Ord, Show) -instance Outputable Loc where +-- | Where a virtual register is stored, together with the format it is stored at. +-- +-- See 'VLoc'. +data Loc + = Loc + { locWithFormat_loc :: {-# UNPACK #-} !VLoc + , locWithFormat_format :: Format + } + +-- | A newtype used to hang off 'Eq' and 'Ord' instances for 'Loc' which +-- ignore the format, as used in 'GHC.CmmToAsm.Reg.Linear.JoinToTargets'. +newtype IgnoreFormat a = IgnoreFormat a +instance Eq (IgnoreFormat Loc) where + IgnoreFormat (Loc l1 _) == IgnoreFormat (Loc l2 _) = l1 == l2 +instance Ord (IgnoreFormat Loc) where + compare (IgnoreFormat (Loc l1 _)) (IgnoreFormat (Loc l2 _)) = compare l1 l2 + +instance Outputable VLoc where ppr l = text (show l) +instance Outputable Loc where + ppr (Loc loc fmt) = parens (ppr loc <+> dcolon <+> ppr fmt) + -- | A 'RealReg', together with the specific 'Format' it is used at. data RealRegUsage = RealRegUsage @@ -122,21 +146,11 @@ instance Outputable RealRegUsage where ppr (RealRegUsage r fmt) = ppr r <> dcolon <+> ppr fmt --- NB: these instances only compare the underlying 'RealReg', as that is what --- is important for register allocation. --- --- (It would nonetheless be a good idea to remove these instances.) -instance Eq RealRegUsage where - (==) = (==) `on` realReg -instance Ord RealRegUsage where - compare = compare `on` realReg - -- | Get the reg numbers stored in this Loc. -regsOfLoc :: Loc -> [RealRegUsage] +regsOfLoc :: VLoc -> [RealReg] regsOfLoc (InReg r) = [r] regsOfLoc (InBoth r _) = [r] regsOfLoc (InMem _) = [] - -- | Reasons why instructions might be inserted by the spiller. -- Used when generating stats for -ddrop-asm-stats. diff --git a/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs b/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs --- a/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs +++ b/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs @@ -34,12 +34,14 @@ import GHC.CmmToAsm.Format import GHC.Types.Unique.Set +import Data.Coerce (coerce) + -- | For a jump instruction at the end of a block, generate fixup code so its -- vregs are in the correct regs for its destination. -- joinToTargets :: (FR freeRegs, Instruction instr) - => BlockMap (UniqSet RegWithFormat) -- ^ maps the unique of the blockid to the set of vregs + => BlockMap Regs -- ^ maps the unique of the blockid to the set of vregs -- that are known to be live on the entry to each block. -> BlockId -- ^ id of the current block @@ -63,7 +65,7 @@ ----- joinToTargets' :: (FR freeRegs, Instruction instr) - => BlockMap (UniqSet RegWithFormat) -- ^ maps the unique of the blockid to the set of vregs + => BlockMap Regs -- ^ maps the unique of the blockid to the set of vregs -- that are known to be live on the entry to each block. -> [NatBasicBlock instr] -- ^ acc blocks of fixup code. @@ -91,23 +93,23 @@ -- adjust the current assignment to remove any vregs that are not live -- on entry to the destination block. let Just live_set = mapLookup dest block_live - let still_live uniq _ = uniq `elemUniqSet_Directly` live_set + let still_live uniq _ = uniq `elemUniqSet_Directly` getRegs live_set let adjusted_assig = filterUFM_Directly still_live assig -- and free up those registers which are now free. let to_free = - [ r | (reg, loc) <- nonDetUFMToList assig + [ r | (reg, Loc loc _locFmt) <- nonDetUFMToList assig -- This is non-deterministic but we do not -- currently support deterministic code-generation. -- See Note [Unique Determinism and code generation] - , not (elemUniqSet_Directly reg live_set) + , not (elemUniqSet_Directly reg $ getRegs live_set) , r <- regsOfLoc loc ] case lookupBlockAssignment dest block_assig of Nothing -> joinToTargets_first block_live new_blocks block_id instr dest dests - block_assig adjusted_assig $ map realReg to_free + block_assig adjusted_assig to_free Just (_, dest_assig) -> joinToTargets_again @@ -117,7 +119,7 @@ -- this is the first time we jumped to this block. joinToTargets_first :: (FR freeRegs, Instruction instr) - => BlockMap (UniqSet RegWithFormat) + => BlockMap Regs -> [NatBasicBlock instr] -> BlockId -> instr @@ -143,10 +145,9 @@ joinToTargets' block_live new_blocks block_id instr dests - -- we've jumped to this block before joinToTargets_again :: (Instruction instr, FR freeRegs) - => BlockMap (UniqSet RegWithFormat) + => BlockMap Regs -> [NatBasicBlock instr] -> BlockId -> instr @@ -160,7 +161,9 @@ src_assig dest_assig -- the assignments already match, no problem. - | nonDetUFMToList dest_assig == nonDetUFMToList src_assig + | equalIgnoringFormats + (nonDetUFMToList dest_assig) + (nonDetUFMToList src_assig) -- This is non-deterministic but we do not -- currently support deterministic code-generation. -- See Note [Unique Determinism and code generation] @@ -184,7 +187,7 @@ -- -- We need to do the R2 -> R3 move before R1 -> R2. -- - let sccs = stronglyConnCompFromEdgedVerticesOrdR graph + let sccs = movementGraphSCCs graph -- debugging {- @@ -268,30 +271,36 @@ -- expandNode :: a - -> Loc -- ^ source of move - -> Loc -- ^ destination of move - -> [Node Loc a ] - -expandNode vreg loc@(InReg src) (InBoth dst mem) - | src == dst = [DigraphNode vreg loc [InMem mem]] - | otherwise = [DigraphNode vreg loc [InReg dst, InMem mem]] - -expandNode vreg loc@(InMem src) (InBoth dst mem) - | src == mem = [DigraphNode vreg loc [InReg dst]] - | otherwise = [DigraphNode vreg loc [InReg dst, InMem mem]] - -expandNode _ (InBoth _ src) (InMem dst) - | src == dst = [] -- guaranteed to be true - -expandNode _ (InBoth src _) (InReg dst) - | src == dst = [] - -expandNode vreg (InBoth src _) dst - = expandNode vreg (InReg src) dst - -expandNode vreg src dst - | src == dst = [] - | otherwise = [DigraphNode vreg src [dst]] + -> Loc -- ^ source of move + -> Loc -- ^ destination of move + -> [Node Loc a] +expandNode vreg src@(Loc srcLoc srcFmt) dst@(Loc dstLoc dstFmt) = + case (srcLoc, dstLoc) of + (InReg srcReg, InBoth dstReg dstMem) + | srcReg == dstReg + -> [DigraphNode vreg src [Loc (InMem dstMem) dstFmt]] + | otherwise + -> [DigraphNode vreg src [Loc (InReg dstReg) dstFmt + ,Loc (InMem dstMem) dstFmt]] + (InMem srcMem, InBoth dstReg dstMem) + | srcMem == dstMem + -> [DigraphNode vreg src [Loc (InReg dstReg) dstFmt]] + | otherwise + -> [DigraphNode vreg src [Loc (InReg dstReg) dstFmt + ,Loc (InMem dstMem) dstFmt]] + (InBoth _ srcMem, InMem dstMem) + | srcMem == dstMem + -> [] -- guaranteed to be true + (InBoth srcReg _, InReg dstReg) + | srcReg == dstReg + -> [] + (InBoth srcReg _, _) + -> expandNode vreg (Loc (InReg srcReg) srcFmt) dst + _ + | srcLoc == dstLoc + -> [] + | otherwise + -> [DigraphNode vreg src [dst]] -- | Generate fixup code for a particular component in the move graph @@ -328,7 +337,7 @@ -- require a fixup. -- handleComponent delta instr - (CyclicSCC ((DigraphNode vreg (InReg (RealRegUsage sreg scls)) ((InReg (RealRegUsage dreg dcls): _))) : rest)) + (CyclicSCC ((DigraphNode vreg (Loc (InReg sreg) scls) ((Loc (InReg dreg) dcls: _))) : rest)) -- dest list may have more than one element, if the reg is also InMem. = do -- spill the source into its slot @@ -339,7 +348,7 @@ instrLoad <- loadR (RegWithFormat (RegReal dreg) dcls) slot remainingFixUps <- mapM (handleComponent delta instr) - (stronglyConnCompFromEdgedVerticesOrdR rest) + (movementGraphSCCs rest) -- make sure to do all the reloads after all the spills, -- so we don't end up clobbering the source values. @@ -348,29 +357,37 @@ handleComponent _ _ (CyclicSCC _) = panic "Register Allocator: handleComponent cyclic" +-- Helper functions that use the @Ord (IgnoreFormat Loc)@ instance. +equalIgnoringFormats :: [(Unique, Loc)] -> [(Unique, Loc)] -> Bool +equalIgnoringFormats = + coerce $ (==) @[(Unique, IgnoreFormat Loc)] +movementGraphSCCs :: [Node Loc Unique] -> [SCC (Node Loc Unique)] +movementGraphSCCs = + coerce $ stronglyConnCompFromEdgedVerticesOrdR @(IgnoreFormat Loc) @Unique + -- | Move a vreg between these two locations. -- makeMove :: Instruction instr - => Int -- ^ current C stack delta. - -> Unique -- ^ unique of the vreg that we're moving. - -> Loc -- ^ source location. - -> Loc -- ^ destination location. - -> RegM freeRegs [instr] -- ^ move instruction. + => Int -- ^ current C stack delta + -> Unique -- ^ unique of the vreg that we're moving + -> Loc -- ^ source location + -> Loc -- ^ destination location + -> RegM freeRegs [instr] -- ^ move instruction -makeMove delta vreg src dst +makeMove delta vreg (Loc src _srcFmt) (Loc dst dstFmt) = do config <- getConfig case (src, dst) of - (InReg (RealRegUsage s _), InReg (RealRegUsage d fmt)) -> + (InReg s, InReg d) -> do recordSpill (SpillJoinRR vreg) - return $ [mkRegRegMoveInstr config fmt (RegReal s) (RegReal d)] - (InMem s, InReg (RealRegUsage d cls)) -> + return $ [mkRegRegMoveInstr config dstFmt (RegReal s) (RegReal d)] + (InMem s, InReg d) -> do recordSpill (SpillJoinRM vreg) - return $ mkLoadInstr config (RegWithFormat (RegReal d) cls) delta s - (InReg (RealRegUsage s cls), InMem d) -> + return $ mkLoadInstr config (RegWithFormat (RegReal d) dstFmt) delta s + (InReg s, InMem d) -> do recordSpill (SpillJoinRM vreg) - return $ mkSpillInstr config (RegWithFormat (RegReal s) cls) delta d + return $ mkSpillInstr config (RegWithFormat (RegReal s) dstFmt) delta d _ -> -- we don't handle memory to memory moves. -- they shouldn't happen because we don't share diff --git a/GHC/CmmToAsm/Reg/Linear/StackMap.hs b/GHC/CmmToAsm/Reg/Linear/StackMap.hs --- a/GHC/CmmToAsm/Reg/Linear/StackMap.hs +++ b/GHC/CmmToAsm/Reg/Linear/StackMap.hs @@ -37,7 +37,11 @@ -- See Note [UniqFM and the register allocator] -- | Assignment of vregs to stack slots. - , stackMapAssignment :: UniqFM Unique StackSlot } + -- + -- We record not just the slot, but also how many stack slots the vreg + -- takes up, in order to avoid re-using a stack slot for a register + -- that has grown but already had a stack slot (#26668). + , stackMapAssignment :: UniqFM Unique (StackSlot, Int) } -- | An empty stack map, with all slots available. @@ -50,14 +54,19 @@ -- getStackSlotFor :: StackMap -> Format -> Unique -> (StackMap, Int) -getStackSlotFor fs@(StackMap _ reserved) _fmt regUnique - | Just slot <- lookupUFM reserved regUnique = (fs, slot) - -getStackSlotFor (StackMap freeSlot reserved) fmt regUnique = - let - nbSlots = (formatInBytes fmt + 7) `div` 8 - in - (StackMap (freeSlot+nbSlots) (addToUFM reserved regUnique freeSlot), freeSlot) +getStackSlotFor fs@(StackMap freeSlot reserved) fmt regUnique + -- The register already has a stack slot; try to re-use it. + | Just (slot, nbSlots) <- lookupUFM reserved regUnique + -- Make sure the slot is big enough for this format, in case the register + -- has grown (#26668). + , nbNeededSlots <= nbSlots + = (fs, slot) + | otherwise + = (StackMap (freeSlot+nbNeededSlots) (addToUFM reserved regUnique (freeSlot, nbNeededSlots)), freeSlot) + -- NB: this can create fragmentation if a register keeps growing. + -- That's probably OK, as this is only happens very rarely. + where + !nbNeededSlots = (formatInBytes fmt + 7) `div` 8 -- | Return the number of stack slots that were allocated getStackUse :: StackMap -> Int diff --git a/GHC/CmmToAsm/Reg/Liveness.hs b/GHC/CmmToAsm/Reg/Liveness.hs --- a/GHC/CmmToAsm/Reg/Liveness.hs +++ b/GHC/CmmToAsm/Reg/Liveness.hs @@ -33,7 +33,9 @@ patchRegsLiveInstr, reverseBlocksInTops, regLiveness, - cmmTopLiveness + cmmTopLiveness, + + module GHC.CmmToAsm.Reg.Regs ) where import GHC.Prelude @@ -44,13 +46,14 @@ import GHC.CmmToAsm.Format import GHC.CmmToAsm.Types import GHC.CmmToAsm.Utils +import GHC.CmmToAsm.Reg.Regs import GHC.Cmm.BlockId import GHC.Cmm.Dataflow.Label import GHC.Cmm -import GHC.CmmToAsm.Reg.Target import GHC.Data.Graph.Directed +import GHC.Data.OrdList import GHC.Utils.Monad import GHC.Utils.Outputable import GHC.Utils.Panic @@ -191,9 +194,9 @@ data Liveness = Liveness - { liveBorn :: UniqSet RegWithFormat -- ^ registers born in this instruction (written to for first time). - , liveDieRead :: UniqSet RegWithFormat -- ^ registers that died because they were read for the last time. - , liveDieWrite :: UniqSet RegWithFormat} -- ^ registers that died because they were clobbered by something. + { liveBorn :: Regs -- ^ registers born in this instruction (written to for first time). + , liveDieRead :: Regs -- ^ registers that died because they were read for the last time. + , liveDieWrite :: Regs } -- ^ registers that died because they were clobbered by something. -- | Stash regs live on entry to each basic block in the info part of the cmm code. @@ -202,7 +205,7 @@ (LabelMap RawCmmStatics) -- cmm info table static stuff [BlockId] -- entry points (first one is the -- entry point for the proc). - (BlockMap (UniqSet RegWithFormat)) -- argument locals live on entry to this block + (BlockMap Regs) -- argument locals live on entry to this block (BlockMap IntSet) -- stack slots live on entry to this block @@ -248,8 +251,8 @@ , pprRegs (text "# w_dying: ") (liveDieWrite live) ] $+$ space) - where pprRegs :: SDoc -> UniqSet RegWithFormat -> SDoc - pprRegs name regs + where pprRegs :: SDoc -> Regs -> SDoc + pprRegs name ( Regs regs ) | isEmptyUniqSet regs = empty | otherwise = name <> (pprUFM (getUniqSet regs) (hcat . punctuate space . map ppr)) @@ -332,7 +335,7 @@ :: Instruction instr => Platform -> LiveCmmDecl statics instr - -> (Bag (UniqSet RegWithFormat), Bag (Reg, Reg)) + -> (Bag Regs, Bag (Reg, Reg)) slurpConflicts platform live = slurpCmm (emptyBag, emptyBag) live @@ -366,23 +369,22 @@ = let -- regs that die because they are read for the last time at the start of an instruction -- are not live across it. - rsLiveAcross = rsLiveEntry `minusUniqSet` (liveDieRead live) + rsLiveAcross = rsLiveEntry `minusRegs` (liveDieRead live) -- regs live on entry to the next instruction. -- be careful of orphans, make sure to delete dying regs _after_ unioning -- in the ones that are born here. - rsLiveNext = (rsLiveAcross `unionUniqSets` (liveBorn live)) - `minusUniqSet` (liveDieWrite live) + rsLiveNext = (rsLiveAcross `unionRegsMaxFmt` (liveBorn live)) + `minusCoveredRegs` (liveDieWrite live) -- orphan vregs are the ones that die in the same instruction they are born in. -- these are likely to be results that are never used, but we still -- need to assign a hreg to them.. - rsOrphans = intersectUniqSets + rsOrphans = intersectRegsMaxFmt (liveBorn live) - (unionUniqSets (liveDieWrite live) (liveDieRead live)) + (unionRegsMaxFmt (liveDieWrite live) (liveDieRead live)) - -- - rsConflicts = unionUniqSets rsLiveNext rsOrphans + rsConflicts = unionRegsMaxFmt rsLiveNext rsOrphans in case takeRegRegMoveInstr platform instr of Just rr -> slurpLIs rsLiveNext @@ -566,30 +568,26 @@ = BasicBlock i instrs' where (instrs', _) - = runState (spillNat [] lis) 0 + = runState (spillNat nilOL lis) 0 - -- spillNat :: [instr] -> [LiveInstr instr] -> State Int [instr] - spillNat :: Instruction instr => [instr] -> [LiveInstr instr] -> State Int [instr] + spillNat :: Instruction instr => OrdList instr -> [LiveInstr instr] -> State Int [instr] spillNat acc [] - = return (reverse acc) + = return (fromOL acc) - -- The SPILL/RELOAD cases do not appear to be exercised by our codegens - -- spillNat acc (LiveInstr (SPILL reg slot) _ : instrs) = do delta <- get - spillNat (mkSpillInstr config reg delta slot ++ acc) instrs + spillNat (acc `appOL` toOL (mkSpillInstr config reg delta slot)) instrs spillNat acc (LiveInstr (RELOAD slot reg) _ : instrs) = do delta <- get - spillNat (mkLoadInstr config reg delta slot ++ acc) instrs + spillNat (acc `appOL` toOL (mkLoadInstr config reg delta slot)) instrs spillNat acc (LiveInstr (Instr instr) _ : instrs) | Just i <- takeDeltaInstr instr = do put i spillNat acc instrs - - spillNat acc (LiveInstr (Instr instr) _ : instrs) - = spillNat (instr : acc) instrs + | otherwise + = spillNat (acc `snocOL` instr) instrs -- | Erase Delta instructions. @@ -626,7 +624,7 @@ | LiveInfo static id blockMap mLiveSlots <- info = let -- See Note [Unique Determinism and code generation] - blockMap' = mapMap (mapRegFormatSet patchF) blockMap + blockMap' = mapMap (mapRegs patchF) blockMap info' = LiveInfo static id blockMap' mLiveSlots in CmmProc info' label live $ map patchSCC sccs @@ -655,8 +653,8 @@ | r1 == r2 = True -- destination reg is never used - | elemUniqSet_Directly (getUnique r2) (liveBorn live) - , elemUniqSet_Directly (getUnique r2) (liveDieRead live) || elemUniqSet_Directly (getUnique r2) (liveDieWrite live) + | r2 `elemRegs` liveBorn live + , r2 `elemRegs` liveDieRead live || r2 `elemRegs` liveDieWrite live = True | otherwise = False @@ -680,9 +678,9 @@ (patchRegsOfInstr platform instr patchF) (Just live { -- WARNING: have to go via lists here because patchF changes the uniq in the Reg - liveBorn = mapRegFormatSet patchF $ liveBorn live - , liveDieRead = mapRegFormatSet patchF $ liveDieRead live - , liveDieWrite = mapRegFormatSet patchF $ liveDieWrite live }) + liveBorn = mapRegs patchF $ liveBorn live + , liveDieRead = mapRegs patchF $ liveDieRead live + , liveDieWrite = mapRegs patchF $ liveDieWrite live }) -- See Note [Unique Determinism and code generation] -------------------------------------------------------------------------------- @@ -872,7 +870,7 @@ -> [SCC (LiveBasicBlock instr)] -> ([SCC (LiveBasicBlock instr)], -- instructions annotated with list of registers -- which are "dead after this instruction". - BlockMap (UniqSet RegWithFormat)) -- blocks annotated with set of live registers + BlockMap Regs) -- blocks annotated with set of live registers -- on entry to the block. computeLiveness platform sccs @@ -887,11 +885,11 @@ livenessSCCs :: Instruction instr => Platform - -> BlockMap (UniqSet RegWithFormat) + -> BlockMap Regs -> [SCC (LiveBasicBlock instr)] -- accum -> [SCC (LiveBasicBlock instr)] -> ( [SCC (LiveBasicBlock instr)] - , BlockMap (UniqSet RegWithFormat)) + , BlockMap Regs) livenessSCCs _ blockmap done [] = (done, blockmap) @@ -920,13 +918,14 @@ linearLiveness :: Instruction instr - => BlockMap (UniqSet RegWithFormat) -> [LiveBasicBlock instr] - -> (BlockMap (UniqSet RegWithFormat), [LiveBasicBlock instr]) + => BlockMap Regs -> [LiveBasicBlock instr] + -> (BlockMap Regs, [LiveBasicBlock instr]) linearLiveness = mapAccumL (livenessBlock platform) -- probably the least efficient way to compare two -- BlockMaps for equality. + equalBlockMaps :: BlockMap Regs -> BlockMap Regs -> Bool equalBlockMaps a b = a' == b' where a' = mapToList a @@ -940,14 +939,14 @@ livenessBlock :: Instruction instr => Platform - -> BlockMap (UniqSet RegWithFormat) + -> BlockMap Regs -> LiveBasicBlock instr - -> (BlockMap (UniqSet RegWithFormat), LiveBasicBlock instr) + -> (BlockMap Regs, LiveBasicBlock instr) livenessBlock platform blockmap (BasicBlock block_id instrs) = let (regsLiveOnEntry, instrs1) - = livenessBack platform emptyUniqSet blockmap [] (reverse instrs) + = livenessBack platform noRegs blockmap [] (reverse instrs) blockmap' = mapInsert block_id regsLiveOnEntry blockmap instrs2 = livenessForward platform regsLiveOnEntry instrs1 @@ -962,23 +961,26 @@ livenessForward :: Instruction instr => Platform - -> UniqSet RegWithFormat -- regs live on this instr + -> Regs -- regs live on this instr -> [LiveInstr instr] -> [LiveInstr instr] livenessForward _ _ [] = [] livenessForward platform rsLiveEntry (li@(LiveInstr instr mLive) : lis) | Just live <- mLive = let - RU _ written = regUsageOfInstr platform instr + RU _ rsWritten = regUsageOfInstr platform instr -- Regs that are written to but weren't live on entry to this instruction -- are recorded as being born here. - rsBorn = mkUniqSet - $ filter (\ r -> not $ elemUniqSet_Directly (getUnique r) rsLiveEntry) - $ written + rsBorn = mkRegsMaxFmt + [ reg + | reg@( RegWithFormat r _ ) <- rsWritten + , not $ r `elemRegs` rsLiveEntry + ] - rsLiveNext = (rsLiveEntry `unionUniqSets` rsBorn) - `minusUniqSet` (liveDieRead live) - `minusUniqSet` (liveDieWrite live) + -- See Note [Register formats in liveness analysis] + rsLiveNext = (rsLiveEntry `addRegsMaxFmt` rsWritten) + `minusRegs` (liveDieRead live) -- (FmtFwd1) + `minusRegs` (liveDieWrite live) -- (FmtFwd2) in LiveInstr instr (Just live { liveBorn = rsBorn }) : livenessForward platform rsLiveNext lis @@ -993,11 +995,11 @@ livenessBack :: Instruction instr => Platform - -> UniqSet RegWithFormat -- regs live on this instr - -> BlockMap (UniqSet RegWithFormat) -- regs live on entry to other BBs - -> [LiveInstr instr] -- instructions (accum) - -> [LiveInstr instr] -- instructions - -> (UniqSet RegWithFormat, [LiveInstr instr]) + -> Regs -- ^ regs live on this instr + -> BlockMap Regs -- ^ regs live on entry to other BBs + -> [LiveInstr instr] -- ^ instructions (accum) + -> [LiveInstr instr] -- ^ instructions + -> (Regs, [LiveInstr instr]) livenessBack _ liveregs _ done [] = (liveregs, done) @@ -1005,15 +1007,14 @@ = let !(!liveregs', instr') = liveness1 platform liveregs blockmap instr in livenessBack platform liveregs' blockmap (instr' : acc) instrs - -- don't bother tagging comments or deltas with liveness liveness1 :: Instruction instr => Platform - -> UniqSet RegWithFormat - -> BlockMap (UniqSet RegWithFormat) + -> Regs + -> BlockMap Regs -> LiveInstr instr - -> (UniqSet RegWithFormat, LiveInstr instr) + -> (Regs, LiveInstr instr) liveness1 _ liveregs _ (LiveInstr instr _) | isMetaInstr instr @@ -1024,14 +1025,14 @@ | not_a_branch = (liveregs1, LiveInstr instr (Just $ Liveness - { liveBorn = emptyUniqSet + { liveBorn = noRegs , liveDieRead = r_dying , liveDieWrite = w_dying })) | otherwise = (liveregs_br, LiveInstr instr (Just $ Liveness - { liveBorn = emptyUniqSet + { liveBorn = noRegs , liveDieRead = r_dying_br , liveDieWrite = w_dying })) @@ -1040,21 +1041,22 @@ -- registers that were written here are dead going backwards. -- registers that were read here are live going backwards. - liveregs1 = (liveregs `delListFromUniqSet` written) - `addListToUniqSet` read + -- As for the formats, see Note [Register formats in liveness analysis] + liveregs1 = (liveregs `minusCoveredRegs` mkRegsMaxFmt written) -- (FmtBwd2) + `addRegsMaxFmt` read -- (FmtBwd1) - -- registers that are not live beyond this point, are recorded - -- as dying here. - r_dying = mkUniqSet + -- registers that are not live beyond this point are recorded + -- as dying here. + r_dying = mkRegsMaxFmt [ reg | reg@(RegWithFormat r _) <- read , not $ any (\ w -> getUnique w == getUnique r) written - , not (elementOfUniqSet reg liveregs) ] + , not $ r `elemRegs` liveregs ] - w_dying = mkUniqSet + w_dying = mkRegsMaxFmt [ reg - | reg <- written - , not (elementOfUniqSet reg liveregs) ] + | reg@(RegWithFormat r _) <- written + , not $ r `elemRegs` liveregs ] -- union in the live regs from all the jump destinations of this -- instruction. @@ -1064,14 +1066,91 @@ targetLiveRegs target = case mapLookup target blockmap of Just ra -> ra - Nothing -> emptyUniqSet - - live_from_branch = unionManyUniqSets (map targetLiveRegs targets) - - liveregs_br = liveregs1 `unionUniqSets` live_from_branch + Nothing -> noRegs -- registers that are live only in the branch targets should -- be listed as dying here. - live_branch_only = live_from_branch `minusUniqSet` liveregs - r_dying_br = (r_dying `unionUniqSets` live_branch_only) - -- See Note [Unique Determinism and code generation] + live_from_branch = unionManyRegsMaxFmt (map targetLiveRegs targets) + liveregs_br = liveregs1 `unionRegsMaxFmt` live_from_branch + live_branch_only = live_from_branch `minusRegs` liveregs + r_dying_br = r_dying `unionRegsMaxFmt` live_branch_only + -- NB: we treat registers live in branches similar to any other + -- registers read by the instruction, so the logic here matches + -- the logic in the definition of 'r_dying' above. + +{- Note [Register formats in liveness analysis] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We keep track of which format each virtual register is live at, and make use +of this information during liveness analysis. + +First, we do backwards liveness analysis: + + (FmtBwd1) Take the larger format when computing registers live going backwards. + + Suppose for example that we have: + + + movps %v0 %v1 + movupd %v0 %v2 + + Here we read %v0 both at format F64 and F64x2, so we must consider it live + at format F64x2, going backwards, in the previous instructions. + Not doing so caused #26411. + + (FmtBwd2) Only consider fully clobbered registers to be dead going backwards. + + Consider for example the liveness of %v0 going backwards in the following + instruction block: + + movlhps %v5 %v0 -- write the upper F64 of %v0 + movupd %v1 %v2 -- some unrelated instruction + movsd %v3 %v0 -- write the lower F64 of %v0 + movupd %v0 %v4 -- read %v0 at format F64x2 + + We must not consider %v0 to be dead going backwards from 'movsd %v3 %v0'. + If we do, that means we think %v0 is dead during 'movupd %v1 %v2', and thus + that we can assign both %v0 and %v2 to the same real register. However, this + would be catastrophic, as 'movupd %v1 %v2' would then clobber the data + written to '%v0' in 'movlhps %v5 %v0'. + + Wrinkle [Don't allow scalar partial writes] + + We don't allow partial writes within scalar registers, for many reasons: + + - partial writes can cause partial register stalls, which can have + disastrous performance implications (as seen in #20405) + - partial writes makes register allocation more difficult, as they can + require preserving the contents of a register across many instructions, + as in: + + mulw %v0 -- 32-bit write to %rax + + mulb %v1 -- 16-bit partial write to %rax + + The current register allocator is not equipped for spilling real + registers (only virtual registers), which means that e.g. on i386 we + end up with only 2 allocatable real GP registers for , + which is insufficient for instructions that require 3 registers. + + We could allow this to be customised depending on the architecture, but + currently we simply never allow scalar partial writes. + +The forwards analysis is a bit simpler: + + (FmtFwd1) Remove without considering format when dead going forwards. + + If a register is no longer read after an instruction, then it is dead + going forwards. The format doesn't matter. + + (FmtFwd2) Consider all writes as making a register dead going forwards. + + If we write to the lower 64 bits of a 128 bit register, we don't currently + have a way to say "the lower 64 bits are dead but the top 64 bits are still live". + We would need a notion of partial register, similar to 'VirtualRegHi' for + the top 32 bits of a I32x2 virtual register. + + As a result, the current approach is to consider the entire register to + be dead. This might cause us to unnecessarily spill/reload an entire vector + register to avoid its lower bits getting clobbered even though later + instructions might only care about its upper bits. +-} diff --git a/GHC/CmmToAsm/Reg/Regs.hs b/GHC/CmmToAsm/Reg/Regs.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/Reg/Regs.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE DerivingStrategies #-} + +module GHC.CmmToAsm.Reg.Regs ( + Regs(..), + noRegs, + addRegMaxFmt, addRegsMaxFmt, + mkRegsMaxFmt, + minusCoveredRegs, + minusRegs, + unionRegsMaxFmt, + unionManyRegsMaxFmt, + intersectRegsMaxFmt, + shrinkingRegs, + mapRegs, + elemRegs, lookupReg, + + ) where + +import GHC.Prelude + +import GHC.Platform.Reg ( Reg ) +import GHC.CmmToAsm.Format ( Format, RegWithFormat(..), isVecFormat ) + +import GHC.Utils.Outputable ( Outputable ) +import GHC.Types.Unique ( Uniquable(..) ) +import GHC.Types.Unique.Set + +import Data.Coerce ( coerce ) + +----------------------------------------------------------------------------- + +-- | A set of registers, with their respective formats, mostly for use in +-- register liveness analysis. See Note [Register formats in liveness analysis] +-- in GHC.CmmToAsm.Reg.Liveness. +newtype Regs = Regs { getRegs :: UniqSet RegWithFormat } + deriving newtype (Eq, Outputable) + +maxRegWithFormat :: RegWithFormat -> RegWithFormat -> RegWithFormat +maxRegWithFormat r1@(RegWithFormat _ fmt1) r2@(RegWithFormat _ fmt2) + = if fmt1 >= fmt2 + then r1 + else r2 + -- Re-using one of the arguments avoids allocating a new 'RegWithFormat', + -- compared with returning 'RegWithFormat r1 (max fmt1 fmt2)'. + +noRegs :: Regs +noRegs = Regs emptyUniqSet + +addRegsMaxFmt :: Regs -> [RegWithFormat] -> Regs +addRegsMaxFmt = foldl' addRegMaxFmt + +mkRegsMaxFmt :: [RegWithFormat] -> Regs +mkRegsMaxFmt = addRegsMaxFmt noRegs + +addRegMaxFmt :: Regs -> RegWithFormat -> Regs +addRegMaxFmt = coerce $ strictAddOneToUniqSet_C maxRegWithFormat + -- Don't build up thunks when combining with 'maxRegWithFormat' + +-- | Remove 2nd argument registers from the 1st argument, but only +-- if the format in the second argument is at least as large as the format +-- in the first argument. +minusCoveredRegs :: Regs -> Regs -> Regs +minusCoveredRegs = coerce $ minusUniqSet_C f + where + f :: RegWithFormat -> RegWithFormat -> Maybe RegWithFormat + f r1@(RegWithFormat _ fmt1) (RegWithFormat _ fmt2) = + if fmt2 >= fmt1 + || + not ( isVecFormat fmt1 ) + -- See Wrinkle [Don't allow scalar partial writes] + -- in Note [Register formats in liveness analysis] in GHC.CmmToAsm.Reg.Liveness. + then Nothing + else Just r1 + +-- | Remove 2nd argument registers from the 1st argument, regardless of format. +-- +-- See also 'minusCoveredRegs', which looks at the formats. +minusRegs :: Regs -> Regs -> Regs +minusRegs = coerce $ minusUniqSet @RegWithFormat + +unionRegsMaxFmt :: Regs -> Regs -> Regs +unionRegsMaxFmt = coerce $ strictUnionUniqSets_C maxRegWithFormat + -- Don't build up thunks when combining with 'maxRegWithFormat' + +unionManyRegsMaxFmt :: [Regs] -> Regs +unionManyRegsMaxFmt = coerce $ strictUnionManyUniqSets_C maxRegWithFormat + -- Don't build up thunks when combining with 'maxRegWithFormat' + +intersectRegsMaxFmt :: Regs -> Regs -> Regs +intersectRegsMaxFmt = coerce $ strictIntersectUniqSets_C maxRegWithFormat + -- Don't build up thunks when combining with 'maxRegWithFormat' + +-- | Computes the set of registers in both arguments whose size is smaller in +-- the second argument than in the first. +shrinkingRegs :: Regs -> Regs -> Regs +shrinkingRegs = coerce $ minusUniqSet_C f + where + f :: RegWithFormat -> RegWithFormat -> Maybe RegWithFormat + f (RegWithFormat _ fmt1) r2@(RegWithFormat _ fmt2) + | fmt2 < fmt1 + = Just r2 + | otherwise + = Nothing + +-- | Map a function that may change the 'Unique' of the register, +-- which entails going via lists. +-- +-- See Note [UniqSet invariant] in GHC.Types.Unique.Set. +mapRegs :: (Reg -> Reg) -> Regs -> Regs +mapRegs f (Regs live) = + Regs $ + mapUniqSet (\ (RegWithFormat r fmt) -> RegWithFormat (f r) fmt) live + +elemRegs :: Reg -> Regs -> Bool +elemRegs r (Regs live) = elemUniqSet_Directly (getUnique r) live + +lookupReg :: Reg -> Regs -> Maybe Format +lookupReg r (Regs live) = + regWithFormat_format <$> lookupUniqSet_Directly live (getUnique r) diff --git a/GHC/CmmToAsm/Reg/Target.hs b/GHC/CmmToAsm/Reg/Target.hs --- a/GHC/CmmToAsm/Reg/Target.hs +++ b/GHC/CmmToAsm/Reg/Target.hs @@ -15,7 +15,6 @@ targetMkVirtualReg, targetRegDotColor, targetClassOfReg, - mapRegFormatSet, ) where @@ -27,10 +26,8 @@ import GHC.CmmToAsm.Format import GHC.Utils.Outputable -import GHC.Utils.Misc import GHC.Utils.Panic import GHC.Types.Unique -import GHC.Types.Unique.Set import GHC.Platform import qualified GHC.CmmToAsm.X86.Regs as X86 @@ -141,6 +138,3 @@ = case reg of RegVirtual vr -> classOfVirtualReg (platformArch platform) vr RegReal rr -> targetClassOfRealReg platform rr - -mapRegFormatSet :: HasDebugCallStack => (Reg -> Reg) -> UniqSet RegWithFormat -> UniqSet RegWithFormat -mapRegFormatSet f = mapUniqSet (\ ( RegWithFormat r fmt ) -> RegWithFormat ( f r ) fmt) diff --git a/GHC/CmmToAsm/Wasm/FromCmm.hs b/GHC/CmmToAsm/Wasm/FromCmm.hs --- a/GHC/CmmToAsm/Wasm/FromCmm.hs +++ b/GHC/CmmToAsm/Wasm/FromCmm.hs @@ -113,7 +113,7 @@ -- | Calculate a data section's kind, see haddock docs of -- 'DataSectionKind' for more explanation. dataSectionKindFromCmmSection :: Section -> DataSectionKind -dataSectionKindFromCmmSection s = case sectionProtection s of +dataSectionKindFromCmmSection (Section t _) = case sectionProtection t of ReadWriteSection -> SectionData _ -> SectionROData diff --git a/GHC/CmmToAsm/X86/CodeGen.hs b/GHC/CmmToAsm/X86/CodeGen.hs --- a/GHC/CmmToAsm/X86/CodeGen.hs +++ b/GHC/CmmToAsm/X86/CodeGen.hs @@ -59,7 +59,9 @@ import GHC.CmmToAsm.Format import GHC.CmmToAsm.Config import GHC.Platform.Reg +import GHC.CmmToAsm.Reg.Target (targetClassOfReg) import GHC.Platform +import GHC.Platform.Reg.Class.Unified (RegClass(..)) -- Our intermediate code: import GHC.Types.Basic @@ -3523,7 +3525,14 @@ -- It's not safe to omit this assignment, even if the number -- of SSE2 regs in use is zero. If %al is larger than 8 -- on entry to a varargs function, seg faults ensue. - nb_sse_regs_used = count (isFloatFormat . regWithFormat_format) arg_regs_used + is_sse_reg (RegWithFormat r _) = + -- NB: use 'targetClassOfRealReg' to compute whether this is an SSE + -- register or not, as we may have decided to e.g. store a 64-bit + -- integer in an xmm register. + case targetClassOfReg platform r of + RcFloatOrVector -> True + RcInteger -> False + nb_sse_regs_used = count is_sse_reg arg_regs_used assign_eax_sse_regs = unitOL (MOV II32 (OpImm (ImmInt nb_sse_regs_used)) (OpReg eax)) -- Note: we do this on Windows as well. It's not entirely clear why diff --git a/GHC/CmmToAsm/X86/Instr.hs b/GHC/CmmToAsm/X86/Instr.hs --- a/GHC/CmmToAsm/X86/Instr.hs +++ b/GHC/CmmToAsm/X86/Instr.hs @@ -115,9 +115,12 @@ -- | X86 scalar move instruction. -- - -- When used at a vector format, only moves the lower 64 bits of data; - -- the rest of the data in the destination may either be zeroed or - -- preserved, depending on the specific format and operands. + -- The format is the format the destination is written to. For an XMM + -- register, using a scalar format means that we don't care about the + -- upper bits, while using a vector format means that we care about the + -- upper bits, even though we are only writing to the lower bits. + -- + -- See also Note [Allocated register formats] in GHC.CmmToAsm.Reg.Linear. | MOV Format Operand Operand -- N.B. Due to AT&T assembler quirks, when used with 'II64' -- 'Format' immediate source and memory target operand, the source @@ -364,18 +367,27 @@ regUsageOfInstr :: Platform -> Instr -> RegUsage regUsageOfInstr platform instr = case instr of - MOV fmt src dst + + -- Recall that MOV is always a scalar move instruction, but when the destination + -- is an XMM register, we make the distinction between: + -- + -- - a scalar format, meaning that from now on we no longer care about the top bits + -- of the register, and + -- - a vector format, meaning that we still care about what's in the high bits. + -- + -- See Note [Allocated register formats] in GHC.CmmToAsm.Reg.Linear. + MOV dst_fmt src dst -- MOVSS/MOVSD preserve the upper half of vector registers, -- but only for reg-2-reg moves - | VecFormat _ sFmt <- fmt + | VecFormat _ sFmt <- dst_fmt , isFloatScalarFormat sFmt , OpReg {} <- src , OpReg {} <- dst - -> usageRM fmt src dst + -> usageRM dst_fmt src dst -- other MOV instructions zero any remaining upper part of the destination -- (largely to avoid partial register stalls) | otherwise - -> usageRW fmt src dst + -> usageRW dst_fmt src dst MOVD fmt1 fmt2 src dst -> -- NB: MOVD and MOVQ always zero any remaining upper part of destination, -- so the destination is "written" not "modified". @@ -391,7 +403,7 @@ IMUL fmt src dst -> usageRM fmt src dst -- Result of IMULB will be in just in %ax - IMUL2 II8 src -> mkRU (mk II8 eax:use_R II8 src []) [mk II8 eax] + IMUL2 II8 src -> mkRU (mk II8 eax:use_R II8 src []) [mk II16 eax] -- Result of IMUL for wider values, will be split between %dx/%edx/%rdx and -- %ax/%eax/%rax. IMUL2 fmt src -> mkRU (mk fmt eax:use_R fmt src []) [mk fmt eax,mk fmt edx] diff --git a/GHC/CmmToAsm/X86/Ppr.hs b/GHC/CmmToAsm/X86/Ppr.hs --- a/GHC/CmmToAsm/X86/Ppr.hs +++ b/GHC/CmmToAsm/X86/Ppr.hs @@ -35,6 +35,7 @@ import GHC.Cmm.Dataflow.Label import GHC.Cmm.BlockId import GHC.Cmm.CLabel +import GHC.Cmm.InitFini import GHC.Cmm.DebugBlock (pprUnwindTable) import GHC.Types.Basic (Alignment, mkAlignment, alignmentBytes) @@ -199,8 +200,12 @@ labelInd _ = Nothing , Just ind' <- labelInd ind , alias `mayRedirectTo` ind' + -- See Note [Split sections on COFF objects] + , not $ platformOS platform == OSMinGW32 && ncgSplitSections config = pprGloblDecl (ncgPlatform config) alias $$ line (text ".equiv" <+> pprAsmLabel (ncgPlatform config) alias <> comma <> pprAsmLabel (ncgPlatform config) ind') + where + platform = ncgPlatform config pprDatas config (align, (CmmStaticsRaw lbl dats)) = vcat (pprAlign platform align : pprLabel platform lbl : map (pprData config) dats) @@ -532,9 +537,20 @@ pprSectionAlign :: IsDoc doc => NCGConfig -> Section -> doc pprSectionAlign _config (Section (OtherSection _) _) = panic "X86.Ppr.pprSectionAlign: unknown section" -pprSectionAlign config sec@(Section seg _) = +pprSectionAlign config sec@(Section seg suffix) = line (pprSectionHeader config sec) $$ + coffSplitSectionComdatKey $$ pprAlignForSection (ncgPlatform config) seg + where + platform = ncgPlatform config + -- See Note [Split sections on COFF objects] + coffSplitSectionComdatKey + | OSMinGW32 <- platformOS platform + , ncgSplitSections config + , Nothing <- isInitOrFiniSection seg + = line (pprCOFFComdatKey platform suffix <> colon) + | otherwise + = empty -- | Print appropriate alignment for the given section type. pprAlignForSection :: IsDoc doc => Platform -> SectionType -> doc diff --git a/GHC/CmmToC.hs b/GHC/CmmToC.hs --- a/GHC/CmmToC.hs +++ b/GHC/CmmToC.hs @@ -124,7 +124,7 @@ pprDataExterns platform lits $$ pprWordArray platform (isSecConstant section) lbl lits where - isSecConstant section = case sectionProtection section of + isSecConstant (Section t _) = case sectionProtection t of ReadOnlySection -> True WriteProtectedSection -> True _ -> False diff --git a/GHC/CmmToLlvm.hs b/GHC/CmmToLlvm.hs --- a/GHC/CmmToLlvm.hs +++ b/GHC/CmmToLlvm.hs @@ -222,7 +222,12 @@ case platformArch platform of ArchX86_64 | llvmCgAvxEnabled cfg -> [mkStackAlignmentMeta 32] _ -> [] - module_flags_metas <- mkModuleFlagsMeta stack_alignment_metas + let codel_model_metas = + case platformArch platform of + -- FIXME: We should not rely on LLVM + ArchLoongArch64 -> [mkCodeModelMeta CMMedium] + _ -> [] + module_flags_metas <- mkModuleFlagsMeta (stack_alignment_metas ++ codel_model_metas) let metas = tbaa_metas ++ module_flags_metas cfg <- getConfig renderLlvm (ppLlvmMetas cfg metas) @@ -245,7 +250,16 @@ mkStackAlignmentMeta alignment = ModuleFlag MFBError "override-stack-alignment" (MetaLit $ LMIntLit alignment i32) +-- LLVM's @LLVM::CodeModel::Model@ enumeration +data CodeModel = CMMedium +-- Pass -mcmodel=medium option to LLVM on LoongArch64 +mkCodeModelMeta :: CodeModel -> ModuleFlag +mkCodeModelMeta codemodel = + ModuleFlag MFBError "Code Model" (MetaLit $ LMIntLit n i32) + where + n = case codemodel of CMMedium -> 3 -- as of LLVM 8 + -- ----------------------------------------------------------------------------- -- | Marks variables as used where necessary -- @@ -257,15 +271,23 @@ -- used if we didn't provide these hints. This will generate a -- definition of the form -- - -- @llvm.used = appending global [42 x i8*] [i8* bitcast to i8*, ...] + -- @llvm.compiler.used = appending global [42 x i8*] [i8* bitcast to i8*, ...] -- -- Which is the LLVM way of protecting them against getting removed. + -- + -- We used to emit @llvm.used, but it's too strong and results in + -- SHF_GNU_RETAIN section flag in the object, which prevents linker + -- gc-sections from working properly for LLVM backend (#26770). + -- @llvm.compiler.used serves a similar purpose that protects the + -- variable from being dropped by llc/opt, but it allows linker + -- gc-sections to work. See + -- https://llvm.org/docs/LangRef.html#the-llvm-compiler-used-global-variable ivars <- getUsedVars let cast x = LMBitc (LMStaticPointer (pVarLift x)) i8Ptr ty = LMArray (length ivars) i8Ptr usedArray = LMStaticArray (map cast ivars) ty sectName = Just $ fsLit "llvm.metadata" - lmUsedVar = LMGlobalVar (fsLit "llvm.used") ty Appending sectName Nothing Constant + lmUsedVar = LMGlobalVar (fsLit "llvm.compiler.used") ty Appending sectName Nothing Constant lmUsed = LMGlobal lmUsedVar (Just usedArray) if null ivars then return () diff --git a/GHC/CmmToLlvm/Base.hs b/GHC/CmmToLlvm/Base.hs --- a/GHC/CmmToLlvm/Base.hs +++ b/GHC/CmmToLlvm/Base.hs @@ -286,7 +286,7 @@ , envUniqMeta :: UniqFM Unique MetaId -- ^ Global metadata nodes , envFunMap :: LlvmEnvMap -- ^ Global functions so far, with type , envAliases :: UniqSet LMString -- ^ Globals that we had to alias, see [Llvm Forward References] - , envUsedVars :: [LlvmVar] -- ^ Pointers to be added to llvm.used (see @cmmUsedLlvmGens@) + , envUsedVars :: [LlvmVar] -- ^ Pointers to be added to llvm.compiler.used (see @cmmUsedLlvmGens@) -- the following get cleared for every function (see @withClearVars@) , envVarMap :: LlvmEnvMap -- ^ Local variables so far, with type diff --git a/GHC/CmmToLlvm/CodeGen.hs b/GHC/CmmToLlvm/CodeGen.hs --- a/GHC/CmmToLlvm/CodeGen.hs +++ b/GHC/CmmToLlvm/CodeGen.hs @@ -229,23 +229,35 @@ statement $ Expr $ Call StdCall fptr (argVars' ++ argSuffix) [] | otherwise = panic $ "prefetch locality level integer must be between 0 and 3, given: " ++ (show localityInt) --- Handle PopCnt, Clz, Ctz, and BSwap that need to only convert arg --- and return types -genCall t@(PrimTarget (MO_PopCnt w)) dsts args = - genCallSimpleCast w t dsts args - -genCall t@(PrimTarget (MO_Pdep w)) dsts args = - genCallSimpleCast2 w t dsts args -genCall t@(PrimTarget (MO_Pext w)) dsts args = - genCallSimpleCast2 w t dsts args -genCall t@(PrimTarget (MO_Clz w)) dsts args = - genCallSimpleCast w t dsts args -genCall t@(PrimTarget (MO_Ctz w)) dsts args = - genCallSimpleCast w t dsts args -genCall t@(PrimTarget (MO_BSwap w)) dsts args = - genCallSimpleCast w t dsts args -genCall t@(PrimTarget (MO_BRev w)) dsts args = - genCallSimpleCast w t dsts args +-- Handle Clz, Ctz, BRev, BSwap, Pdep, Pext, and PopCnt that need to only +-- convert arg and return types +genCall (PrimTarget op@(MO_Clz w)) [dst] args = + genCallSimpleCast w op dst args +genCall (PrimTarget op@(MO_Ctz w)) [dst] args = + genCallSimpleCast w op dst args +genCall (PrimTarget op@(MO_BRev w)) [dst] args = + genCallSimpleCast w op dst args +genCall (PrimTarget op@(MO_BSwap w)) [dst] args = + genCallSimpleCast w op dst args +genCall (PrimTarget op@(MO_PopCnt w)) [dst] args = + genCallSimpleCast w op dst args +{- Note [LLVM PDep/PExt intrinsics] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Since x86 PDep/PExt instructions only exist for 32/64 bit widths +we use the 32bit variant to compute the 8/16bit primops. +To do so we extend/truncate the argument/result around the +call. +-} +genCall (PrimTarget op@(MO_Pdep w)) [dst] args = do + cfg <- getConfig + if llvmCgBmiVersion cfg >= Just BMI2 + then genCallMinimumTruncationCast W32 w op dst args + else genCallSimpleCast w op dst args +genCall (PrimTarget op@(MO_Pext w)) [dst] args = do + cfg <- getConfig + if llvmCgBmiVersion cfg >= Just BMI2 + then genCallMinimumTruncationCast W32 w op dst args + else genCallSimpleCast w op dst args genCall (PrimTarget (MO_AtomicRMW width amop)) [dst] [addr, n] = runStmtsDecls $ do addrVar <- exprToVarW addr @@ -611,64 +623,36 @@ -- since GHC only really has i32 and i64 types and things like Word8 are backed -- by an i32 and just present a logical i8 range. So we must handle conversions -- from i32 to i8 explicitly as LLVM is strict about types. -genCallSimpleCast :: Width -> ForeignTarget -> [CmmFormal] -> [CmmActual] - -> LlvmM StmtData -genCallSimpleCast w t@(PrimTarget op) [dst] args = do - let width = widthToLlvmInt w - dstTy = cmmToLlvmType $ localRegType dst - - fname <- cmmPrimOpFunctions op - (fptr, _, top3) <- getInstrinct fname width [width] +genCallSimpleCast :: Width -> CallishMachOp -> CmmFormal -> [CmmActual] + -> LlvmM StmtData +genCallSimpleCast w = genCallMinimumTruncationCast w w - (dstV, _dst_ty) <- getCmmReg (CmmLocal dst) +-- Given the minimum machine bit-width to use and the logical bit-width of the +-- value range, perform a type-cast truncation and extension before and after the +-- specified operation, respectively. +genCallMinimumTruncationCast :: Width -> Width -> CallishMachOp -> CmmFormal + -> [CmmActual] -> LlvmM StmtData +genCallMinimumTruncationCast minW specW op dst args = do + let width = widthToLlvmInt $ max minW specW + argsW = const width <$> args + dstType = cmmToLlvmType $ localRegType dst + signage = cmmPrimOpRetValSignage op - let (_, arg_hints) = foreignTargetHints t - let args_hints = zip args arg_hints - (argsV, stmts2, top2) <- arg_vars args_hints ([], nilOL, []) - (argsV', stmts4) <- castVars Signed $ zip argsV [width] - (retV, s1) <- doExpr width $ Call StdCall fptr argsV' [] - (retVs', stmts5) <- castVars (cmmPrimOpRetValSignage op) [(retV,dstTy)] - let retV' = singletonPanic "genCallSimpleCast" retVs' - let s2 = Store retV' dstV Nothing [] + fname <- cmmPrimOpFunctions op + (fptr, _, top3) <- getInstrinct fname width argsW + (dstV, _dst_ty) <- getCmmReg (CmmLocal dst) + let (_, arg_hints) = foreignTargetHints $ PrimTarget op + let args_hints = zip args arg_hints + (argsV, stmts2, top2) <- arg_vars args_hints ([], nilOL, []) + (argsV', stmts4) <- castVars signage $ zip argsV argsW + (retV, s1) <- doExpr width $ Call StdCall fptr argsV' [] + (retV', stmts5) <- castVar signage retV dstType + let s2 = Store retV' dstV Nothing [] let stmts = stmts2 `appOL` stmts4 `snocOL` - s1 `appOL` stmts5 `snocOL` s2 + s1 `snocOL` stmts5 `snocOL` s2 return (stmts, top2 ++ top3) -genCallSimpleCast _ _ dsts _ = - panic ("genCallSimpleCast: " ++ show (length dsts) ++ " dsts") --- Handle simple function call that only need simple type casting, of the form: --- truncate arg >>= \a -> call(a) >>= zext --- --- since GHC only really has i32 and i64 types and things like Word8 are backed --- by an i32 and just present a logical i8 range. So we must handle conversions --- from i32 to i8 explicitly as LLVM is strict about types. -genCallSimpleCast2 :: Width -> ForeignTarget -> [CmmFormal] -> [CmmActual] - -> LlvmM StmtData -genCallSimpleCast2 w t@(PrimTarget op) [dst] args = do - let width = widthToLlvmInt w - dstTy = cmmToLlvmType $ localRegType dst - - fname <- cmmPrimOpFunctions op - (fptr, _, top3) <- getInstrinct fname width (const width <$> args) - - (dstV, _dst_ty) <- getCmmReg (CmmLocal dst) - - let (_, arg_hints) = foreignTargetHints t - let args_hints = zip args arg_hints - (argsV, stmts2, top2) <- arg_vars args_hints ([], nilOL, []) - (argsV', stmts4) <- castVars Signed $ zip argsV (const width <$> argsV) - (retV, s1) <- doExpr width $ Call StdCall fptr argsV' [] - (retVs', stmts5) <- castVars (cmmPrimOpRetValSignage op) [(retV,dstTy)] - let retV' = singletonPanic "genCallSimpleCast2" retVs' - let s2 = Store retV' dstV Nothing [] - - let stmts = stmts2 `appOL` stmts4 `snocOL` - s1 `appOL` stmts5 `snocOL` s2 - return (stmts, top2 ++ top3) -genCallSimpleCast2 _ _ dsts _ = - panic ("genCallSimpleCast2: " ++ show (length dsts) ++ " dsts") - -- | Create a function pointer from a target. getFunPtrW :: (LMString -> LlvmType) -> ForeignTarget -> WriterT LlvmAccum LlvmM LlvmVar @@ -782,11 +766,47 @@ Signed -> LM_Sext Unsigned -> LM_Zext - cmmPrimOpRetValSignage :: CallishMachOp -> Signage cmmPrimOpRetValSignage mop = case mop of - MO_Pdep _ -> Unsigned - MO_Pext _ -> Unsigned + -- Some bit-wise operations /must/ always treat the input and output values + -- as 'Unsigned' in order to return the expected result values when pre/post- + -- operation bit-width truncation and/or extension occur. For example, + -- consider the Bit-Reverse operation: + -- + -- If the result of a Bit-Reverse is treated as signed, + -- an positive input can result in an negative output, i.e.: + -- + -- identity(0x03) = 0x03 = 00000011 + -- breverse(0x03) = 0xC0 = 11000000 + -- + -- Now if an extension is performed after the operation to + -- promote a smaller bit-width value into a larger bit-width + -- type, it is expected that the /bit-wise/ operations will + -- not be treated /numerically/ as signed. + -- + -- To illustrate the difference, consider how a signed extension + -- for the type i16 to i32 differs for out values above: + -- ext_zeroed(i32, breverse(0x03)) = 0x00C0 = 0000000011000000 + -- ext_signed(i32, breverse(0x03)) = 0xFFC0 = 1111111111000000 + -- + -- Here we can see that the former output is the expected result + -- of a bit-wise operation which needs to be promoted to a larger + -- bit-width type. The latter output is not desirable when we must + -- constraining a value into a range of i16 within an i32 type. + -- + -- Hence we always treat the "signage" as unsigned for Bit-Reverse! + -- + -- The same reasoning applied to Bit-Reverse above applies to the other + -- bit-wise operations; do not sign extend a possibly negated number! + MO_BRev _ -> Unsigned + MO_BSwap _ -> Unsigned + MO_Clz _ -> Unsigned + MO_Ctz _ -> Unsigned + MO_Pdep _ -> Unsigned + MO_Pext _ -> Unsigned + MO_PopCnt _ -> Unsigned + + -- All other cases, default to preserving the numeric sign when extending. _ -> Signed -- | Decide what C function to use to implement a CallishMachOp @@ -916,9 +936,10 @@ W256 -> fsLit "llvm.cttz.i256" W512 -> fsLit "llvm.cttz.i512" MO_Pdep w + -- See Note [LLVM PDep/PExt intrinsics] | isBmi2Enabled -> case w of - W8 -> fsLit "llvm.x86.bmi.pdep.8" - W16 -> fsLit "llvm.x86.bmi.pdep.16" + W8 -> fsLit "llvm.x86.bmi.pdep.32" + W16 -> fsLit "llvm.x86.bmi.pdep.32" W32 -> fsLit "llvm.x86.bmi.pdep.32" W64 -> fsLit "llvm.x86.bmi.pdep.64" W128 -> fsLit "llvm.x86.bmi.pdep.128" @@ -934,8 +955,9 @@ W512 -> fsLit "hs_pdep512" MO_Pext w | isBmi2Enabled -> case w of - W8 -> fsLit "llvm.x86.bmi.pext.8" - W16 -> fsLit "llvm.x86.bmi.pext.16" + -- See Note [LLVM PDep/PExt intrinsics] + W8 -> fsLit "llvm.x86.bmi.pext.32" + W16 -> fsLit "llvm.x86.bmi.pext.32" W32 -> fsLit "llvm.x86.bmi.pext.32" W64 -> fsLit "llvm.x86.bmi.pext.64" W128 -> fsLit "llvm.x86.bmi.pext.128" diff --git a/GHC/CmmToLlvm/Data.hs b/GHC/CmmToLlvm/Data.hs --- a/GHC/CmmToLlvm/Data.hs +++ b/GHC/CmmToLlvm/Data.hs @@ -74,7 +74,7 @@ IsFiniArray -> fsLit "llvm.global_dtors" in genGlobalLabelArray var clbls -genLlvmData (sec, CmmStaticsRaw lbl xs) = do +genLlvmData (sec@(Section t _), CmmStaticsRaw lbl xs) = do label <- strCLabel_llvm lbl static <- mapM genData xs lmsec <- llvmSection sec @@ -91,7 +91,7 @@ then Just 2 else Just 1 Section Data _ -> Just $ platformWordSizeInBytes platform _ -> Nothing - const = if sectionProtection sec == ReadOnlySection + const = if sectionProtection t == ReadOnlySection then Constant else Global varDef = LMGlobalVar label tyAlias link lmsec align const globDef = LMGlobal varDef struct diff --git a/GHC/Core/Lint.hs b/GHC/Core/Lint.hs --- a/GHC/Core/Lint.hs +++ b/GHC/Core/Lint.hs @@ -467,8 +467,15 @@ lintCoreBindings' cfg binds = initL cfg $ addLoc TopLevelBindings $ - do { checkL (null dups) (dupVars dups) + do { -- Check that all top-level binders are distinct + -- We do not allow [NonRec x=1, NonRec y=x, NonRec x=2] + -- because of glomming; see Note [Glomming] in GHC.Core.Opt.OccurAnal + checkL (null dups) (dupVars dups) + + -- Check for External top level binders with the same M.n name ; checkL (null ext_dups) (dupExtVars ext_dups) + + -- Typecheck the bindings ; lintRecBindings TopLevel all_pairs $ \_ -> return () } where diff --git a/GHC/Core/Map/Type.hs b/GHC/Core/Map/Type.hs --- a/GHC/Core/Map/Type.hs +++ b/GHC/Core/Map/Type.hs @@ -47,7 +47,7 @@ import GHC.Types.Name.Env import GHC.Types.Var import GHC.Types.Var.Env -import GHC.Types.Unique.FM +import GHC.Types.Unique.DFM import GHC.Utils.Outputable import GHC.Utils.Panic @@ -364,14 +364,14 @@ ------------------------ data TyLitMap a = TLM { tlm_number :: Map.Map Integer a - , tlm_string :: UniqFM FastString a + , tlm_string :: UniqDFM FastString a , tlm_char :: Map.Map Char a } -- TODO(22292): derive instance Functor TyLitMap where fmap f TLM { tlm_number = tn, tlm_string = ts, tlm_char = tc } = TLM - { tlm_number = Map.map f tn, tlm_string = mapUFM f ts, tlm_char = Map.map f tc } + { tlm_number = Map.map f tn, tlm_string = mapUDFM f ts, tlm_char = Map.map f tc } instance TrieMap TyLitMap where type Key TyLitMap = TyLit @@ -382,30 +382,30 @@ filterTM = filterTyLit emptyTyLitMap :: TyLitMap a -emptyTyLitMap = TLM { tlm_number = Map.empty, tlm_string = emptyUFM, tlm_char = Map.empty } +emptyTyLitMap = TLM { tlm_number = Map.empty, tlm_string = emptyUDFM, tlm_char = Map.empty } lkTyLit :: TyLit -> TyLitMap a -> Maybe a lkTyLit l = case l of NumTyLit n -> tlm_number >.> Map.lookup n - StrTyLit n -> tlm_string >.> (`lookupUFM` n) + StrTyLit n -> tlm_string >.> (`lookupUDFM` n) CharTyLit n -> tlm_char >.> Map.lookup n xtTyLit :: TyLit -> XT a -> TyLitMap a -> TyLitMap a xtTyLit l f m = case l of NumTyLit n -> m { tlm_number = Map.alter f n (tlm_number m) } - StrTyLit n -> m { tlm_string = alterUFM f (tlm_string m) n } + StrTyLit n -> m { tlm_string = alterUDFM f (tlm_string m) n } CharTyLit n -> m { tlm_char = Map.alter f n (tlm_char m) } foldTyLit :: (a -> b -> b) -> TyLitMap a -> b -> b -foldTyLit l m = flip (nonDetFoldUFM l) (tlm_string m) +foldTyLit l m = flip (foldUDFM l) (tlm_string m) . flip (Map.foldr l) (tlm_number m) . flip (Map.foldr l) (tlm_char m) filterTyLit :: (a -> Bool) -> TyLitMap a -> TyLitMap a filterTyLit f (TLM { tlm_number = tn, tlm_string = ts, tlm_char = tc }) - = TLM { tlm_number = Map.filter f tn, tlm_string = filterUFM f ts, tlm_char = Map.filter f tc } + = TLM { tlm_number = Map.filter f tn, tlm_string = filterUDFM f ts, tlm_char = Map.filter f tc } ------------------------------------------------- -- | @TypeMap a@ is a map from 'Type' to @a@. If you are a client, this diff --git a/GHC/Core/Opt/CSE.hs b/GHC/Core/Opt/CSE.hs --- a/GHC/Core/Opt/CSE.hs +++ b/GHC/Core/Opt/CSE.hs @@ -9,7 +9,7 @@ import GHC.Prelude import GHC.Core.Subst -import GHC.Types.Var.Env ( mkInScopeSet ) +import GHC.Types.Var.Env ( mkInScopeSet, mkInScopeSetList ) import GHC.Types.Id import GHC.Core.Utils ( mkAltExpr , exprIsTickedString @@ -379,14 +379,21 @@ -} cseProgram :: CoreProgram -> CoreProgram -cseProgram binds = snd (mapAccumL (cseBind TopLevel) emptyCSEnv binds) +cseProgram binds + = snd (mapAccumL (cseBind TopLevel) init_env binds) + where + init_env = emptyCSEnv $ + mkInScopeSetList (bindersOfBinds binds) + -- Put all top-level binders into scope; it is possible to have + -- forward references. See Note [Glomming] in GHC.Core.Opt.OccurAnal + -- Missing this caused #25468 cseBind :: TopLevelFlag -> CSEnv -> CoreBind -> (CSEnv, CoreBind) cseBind toplevel env (NonRec b e) = (env2, NonRec b2 e2) where -- See Note [Separate envs for let rhs and body] - (env1, b1) = addBinder env b + (env1, b1) = addNonRecBinder toplevel env b (env2, (b2, e2)) = cse_bind toplevel env env1 (b,e) b1 cseBind toplevel env (Rec [(in_id, rhs)]) @@ -404,7 +411,7 @@ = (extendCSRecEnv env1 out_id rhs'' id_expr', Rec [(zapped_id, rhs')]) where - (env1, Identity out_id) = addRecBinders env (Identity in_id) + (env1, Identity out_id) = addRecBinders toplevel env (Identity in_id) rhs' = cseExpr env1 rhs rhs'' = stripTicksE tickishFloatable rhs' ticks = stripTicksT tickishFloatable rhs' @@ -414,7 +421,7 @@ cseBind toplevel env (Rec pairs) = (env2, Rec pairs') where - (env1, bndrs1) = addRecBinders env (map fst pairs) + (env1, bndrs1) = addRecBinders toplevel env (map fst pairs) (env2, pairs') = mapAccumL do_one env1 (zip pairs bndrs1) do_one env (pr, b1) = cse_bind toplevel env env pr b1 @@ -692,7 +699,8 @@ -- as a convenient entry point for users of the GHC API. cseOneExpr :: InExpr -> OutExpr cseOneExpr e = cseExpr env e - where env = emptyCSEnv {cs_subst = mkEmptySubst (mkInScopeSet (exprFreeVars e)) } + where + env = emptyCSEnv (mkInScopeSet (exprFreeVars e)) cseExpr :: CSEnv -> InExpr -> OutExpr cseExpr env (Type t) = Type (substTyUnchecked (csEnvSubst env) t) @@ -858,9 +866,11 @@ -- See Note [CSE for recursive bindings] } -emptyCSEnv :: CSEnv -emptyCSEnv = CS { cs_map = emptyCoreMap, cs_rec_map = emptyCoreMap - , cs_subst = emptySubst } +emptyCSEnv :: InScopeSet -> CSEnv +emptyCSEnv in_scope + = CS { cs_map = emptyCoreMap + , cs_rec_map = emptyCoreMap + , cs_subst = mkEmptySubst in_scope } lookupCSEnv :: CSEnv -> OutExpr -> Maybe OutExpr lookupCSEnv (CS { cs_map = csmap }) expr @@ -905,8 +915,19 @@ where (sub', vs') = substBndrs (cs_subst cse) vs -addRecBinders :: Traversable f => CSEnv -> f Id -> (CSEnv, f Id) -addRecBinders = \ cse vs -> - let (sub', vs') = substRecBndrs (cs_subst cse) vs - in (cse { cs_subst = sub' }, vs') +addNonRecBinder :: TopLevelFlag -> CSEnv -> Var -> (CSEnv, Var) +-- Don't clone at top level +addNonRecBinder top_lvl cse v + | isTopLevel top_lvl = (cse, v) + | otherwise = (cse { cs_subst = sub' }, v') + where + (sub', v') = substBndr (cs_subst cse) v + +addRecBinders :: Traversable f => TopLevelFlag -> CSEnv -> f Id -> (CSEnv, f Id) +-- Don't clone at top level +addRecBinders top_lvl cse vs + | isTopLevel top_lvl = (cse, vs) + | otherwise = (cse { cs_subst = sub' }, vs') + where + (sub', vs') = substRecBndrs (cs_subst cse) vs {-# INLINE addRecBinders #-} diff --git a/GHC/Core/Opt/OccurAnal.hs b/GHC/Core/Opt/OccurAnal.hs --- a/GHC/Core/Opt/OccurAnal.hs +++ b/GHC/Core/Opt/OccurAnal.hs @@ -9,7 +9,9 @@ -- many /other/ arguments the function has. Inconsistent unboxing is very -- bad for performance, so I increased the limit to allow it to unbox -- consistently. +-- AK: Seems we no longer unbox OccEnv now anyway so it might be redundant. + {- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 @@ -967,6 +969,12 @@ -> ([CoreBind] -> r -> r) -- How to combine the scope with new binds -> WithUsageDetails r -- Of the whole let(rec) +-- AK: While not allocating any less inlining occAnalBind turns calls to the +-- passed functions into known calls with all the benefits that brings. +-- On a version of T26425 with 6k alternatives this improved compile +-- by 10-20% with -O. +{-# INLINE occAnalBind #-} + occAnalBind env lvl ire (Rec pairs) thing_inside combine = addInScopeList env (map fst pairs) $ \env -> let WUD body_uds body' = thing_inside env @@ -984,7 +992,7 @@ = -- Analyse the RHS and /then/ the body let -- Analyse the rhs first, generating rhs_uds !(rhs_uds_s, bndr', rhs') = occAnalNonRecRhs env lvl ire mb_join bndr rhs - rhs_uds = foldr1 orUDs rhs_uds_s -- NB: orUDs. See (W4) of + rhs_uds = foldl1' orUDs rhs_uds_s -- NB: orUDs. See (W4) of -- Note [Occurrence analysis for join points] -- Now analyse the body, adding the join point @@ -1049,6 +1057,7 @@ -- Match join arity O from mb_join_arity with manifest join arity M as -- returned by of occAnalLamTail. It's totally OK for them to mismatch; -- hence adjust the UDs from the RHS + WUD adj_rhs_uds final_rhs = adjustNonRecRhs mb_join $ occAnalLamTail rhs_env rhs final_bndr_with_rules @@ -2054,6 +2063,18 @@ was a loop breaker last time round Hence the is_lb field of NodeScore + +Note [Strictness in the occurrence analyser] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +By carefully making the occurrence analyser strict in some places, we can +dramatically reduce its memory residency. Among other things we: +* Evaluate the result of `tagLamBinder` and friends, so that the binder (or its + OccInfo) does not retain the entire `UsageDetails`. Also use `strictMap` in `tagLamBinders`. +* In `combineUsageDetailsWith`, the fields of the data constructor are strict, and we use + `strictPlusVarEnv` on the maps that are bound to be needed later on to avoid thunks being + stored in the values. + +These measures reduced residency for test T26425 by a factor of at least 5x. -} {- ********************************************************************* @@ -2188,7 +2209,9 @@ go env rev_bndrs body = addInScope env rev_bndrs $ \env -> let !(WUD usage body') = occ_anal_lam_tail env body - wrap_lam body bndr = Lam (tagLamBinder usage bndr) body + -- See Note [Strictness in the occurrence analyser] + wrap_lam !body !bndr = let !bndr' = tagLamBinder usage bndr + in Lam bndr' body in WUD (usage `addLamCoVarOccs` rev_bndrs) (foldl' wrap_lam body' rev_bndrs) @@ -2541,7 +2564,8 @@ let alt_env = addBndrSwap scrut' bndr $ setTailCtxt env -- Kill off OccRhs WUD alts_usage alts' = do_alts alt_env alts - tagged_bndr = tagLamBinder alts_usage bndr + !tagged_bndr = tagLamBinder alts_usage bndr + -- See Note [Strictness in the occurrence analyser] in WUD alts_usage (tagged_bndr, alts') total_usage = markAllNonTail scrut_usage `andUDs` alts_usage @@ -2559,11 +2583,13 @@ do_alt !env (Alt con bndrs rhs) = addInScopeList env bndrs $ \ env -> let WUD rhs_usage rhs' = occAnal env rhs - tagged_bndrs = tagLamBinders rhs_usage bndrs + !tagged_bndrs = tagLamBinders rhs_usage bndrs + -- See Note [Strictness in the occurrence analyser] in -- See Note [Binders in case alternatives] WUD rhs_usage (Alt con tagged_bndrs rhs') occAnal env (Let bind body) + -- TODO: Would be nice to use a strict version of mkLets here = occAnalBind env NotTopLevel noImpRuleEdges bind (\env -> occAnal env body) mkLets @@ -2644,10 +2670,12 @@ | fun `hasKey` runRWKey , [t1, t2, arg] <- args , WUD usage arg' <- adjustNonRecRhs (JoinPoint 1) $ occAnalLamTail env arg - = WUD usage (mkTicks ticks $ mkApps (Var fun) [t1, t2, arg']) + = let app_out = mkTicks ticks $ mkApps (Var fun) [t1, t2, arg'] + in WUD usage app_out occAnalApp env (Var fun_id, args, ticks) - = WUD all_uds (mkTicks ticks app') + = let app_out = mkTicks ticks app' + in WUD all_uds app_out where -- Lots of banged bindings: this is a very heavily bit of code, -- so it pays not to make lots of thunks here, all of which @@ -2692,8 +2720,9 @@ -- See Note [Sources of one-shot information], bullet point A'] occAnalApp env (fun, args, ticks) - = WUD (markAllNonTail (fun_uds `andUDs` args_uds)) - (mkTicks ticks app') + = let app_out = mkTicks ticks app' + in WUD (markAllNonTail (fun_uds `andUDs` args_uds)) app_out + where !(WUD args_uds app') = occAnalArgs env fun' args [] !(WUD fun_uds fun') = occAnal (addAppCtxt env args) fun @@ -3640,8 +3669,8 @@ ------------------- -- UsageDetails API -andUDs, orUDs - :: UsageDetails -> UsageDetails -> UsageDetails +andUDs:: UsageDetails -> UsageDetails -> UsageDetails +orUDs :: UsageDetails -> UsageDetails -> UsageDetails andUDs = combineUsageDetailsWith andLocalOcc orUDs = combineUsageDetailsWith orLocalOcc @@ -3756,10 +3785,13 @@ | isEmptyVarEnv env1 = uds2 | isEmptyVarEnv env2 = uds1 | otherwise - = UD { ud_env = plusVarEnv_C plus_occ_info env1 env2 - , ud_z_many = plusVarEnv z_many1 z_many2 + -- See Note [Strictness in the occurrence analyser] + -- Using strictPlusVarEnv here speeds up the test T26425 by about 10% by avoiding + -- intermediate thunks. + = UD { ud_env = strictPlusVarEnv_C plus_occ_info env1 env2 + , ud_z_many = strictPlusVarEnv z_many1 z_many2 , ud_z_in_lam = plusVarEnv z_in_lam1 z_in_lam2 - , ud_z_tail = plusVarEnv z_tail1 z_tail2 } + , ud_z_tail = strictPlusVarEnv z_tail1 z_tail2 } lookupLetOccInfo :: UsageDetails -> Id -> OccInfo -- Don't use locally-generated occ_info for exported (visible-elsewhere) @@ -3837,7 +3869,8 @@ -> [Id] -- Binders -> [IdWithOccInfo] -- Tagged binders tagLamBinders usage binders - = map (tagLamBinder usage) binders + -- See Note [Strictness in the occurrence analyser] + = strictMap (tagLamBinder usage) binders tagLamBinder :: UsageDetails -- Of scope -> Id -- Binder @@ -3846,6 +3879,7 @@ -- No-op on TyVars -- A lambda binder never has an unfolding, so no need to look for that tagLamBinder usage bndr + -- See Note [Strictness in the occurrence analyser] = setBinderOcc (markNonTail occ) bndr -- markNonTail: don't try to make an argument into a join point where diff --git a/GHC/Core/Opt/SetLevels.hs b/GHC/Core/Opt/SetLevels.hs --- a/GHC/Core/Opt/SetLevels.hs +++ b/GHC/Core/Opt/SetLevels.hs @@ -91,6 +91,7 @@ import GHC.Core.Opt.Arity ( exprBotStrictness_maybe, isOneShotBndr ) import GHC.Core.FVs -- all of it import GHC.Core.Subst +import GHC.Core.TyCo.Subst( lookupTyVar ) import GHC.Core.Make ( sortQuantVars ) import GHC.Core.Type ( Type, tyCoVarsOfType , mightBeUnliftedType, closeOverKindsDSet @@ -466,8 +467,8 @@ ty' = substTyUnchecked (le_subst env) ty incd_lvl = incMinorLvl (le_ctxt_lvl env) - dest_lvl = maxFvLevel (const True) env scrut_fvs - -- Don't abstract over type variables, hence const True + dest_lvl = maxFvLevel includeTyVars env scrut_fvs + -- Don't abstract over type variables, hence includeTyVars lvl_alt alts_env (AnnAlt con bs rhs) = do { rhs' <- lvlMFE new_env True rhs @@ -718,9 +719,12 @@ -- (In the latter case it won't be a join point any more.) -- Not treating top-level ones specially had a massive effect -- on nofib/minimax/Prog.prog -hasFreeJoin env fvs - = not (maxFvLevel isJoinId env fvs == tOP_LEVEL) +hasFreeJoin env fvs = anyDVarSet bad_join fvs + where + bad_join v = isJoinId v && + maxIn True env v tOP_LEVEL /= tOP_LEVEL + {- Note [Saving work] ~~~~~~~~~~~~~~~~~~~~~ The key idea in let-floating is to @@ -1565,10 +1569,10 @@ | otherwise = max_fv_id_level where - max_fv_id_level = maxFvLevel isId env fvs -- Max over Ids only; the - -- tyvars will be abstracted + max_fv_id_level = maxFvLevel idsOnly env fvs -- Max over Ids only; the + -- tyvars will be abstracted - as_far_as_poss = maxFvLevel' isId env fvs_ty + as_far_as_poss = maxFvLevel' idsOnly env fvs_ty -- See Note [Floating and kind casts] {- Note [Floating and kind casts] @@ -1726,28 +1730,47 @@ , le_env = add_id id_env (case_bndr, scrut_var) } extendCaseBndrEnv env _ _ = env -maxFvLevel :: (Var -> Bool) -> LevelEnv -> DVarSet -> Level -maxFvLevel max_me env var_set - = nonDetStrictFoldDVarSet (maxIn max_me env) tOP_LEVEL var_set +includeTyVars, idsOnly :: Bool +idsOnly = False +includeTyVars = True + +maxFvLevel :: Bool -> LevelEnv -> DVarSet -> Level +maxFvLevel include_tyvars env var_set + = nonDetStrictFoldDVarSet (maxIn include_tyvars env) tOP_LEVEL var_set -- It's OK to use a non-deterministic fold here because maxIn commutes. -maxFvLevel' :: (Var -> Bool) -> LevelEnv -> TyCoVarSet -> Level +maxFvLevel' :: Bool -> LevelEnv -> TyCoVarSet -> Level -- Same but for TyCoVarSet -maxFvLevel' max_me env var_set - = nonDetStrictFoldUniqSet (maxIn max_me env) tOP_LEVEL var_set +maxFvLevel' include_tyvars env var_set + = nonDetStrictFoldUniqSet (maxIn include_tyvars env) tOP_LEVEL var_set -- It's OK to use a non-deterministic fold here because maxIn commutes. -maxIn :: (Var -> Bool) -> LevelEnv -> InVar -> Level -> Level -maxIn max_me (LE { le_lvl_env = lvl_env, le_env = id_env }) in_var lvl +maxIn :: Bool -> LevelEnv -> InVar -> Level -> Level +-- True <=> include tyvars +maxIn include_tyvars env@(LE { le_subst = subst, le_env = id_env }) in_var lvl + | isId in_var = case lookupVarEnv id_env in_var of + Nothing -> maxOut env in_var lvl Just (abs_vars, _) -> foldr max_out lvl abs_vars - Nothing -> max_out in_var lvl - where - max_out out_var lvl - | max_me out_var = case lookupVarEnv lvl_env out_var of - Just lvl' -> maxLvl lvl' lvl - Nothing -> lvl - | otherwise = lvl -- Ignore some vars depending on max_me + where + max_out out_var lvl + | isTyVar out_var && not include_tyvars + = lvl + | otherwise = maxOut env out_var lvl + + | include_tyvars -- TyVars + = case lookupTyVar subst in_var of + Just ty -> nonDetStrictFoldVarSet (maxOut env) lvl (tyCoVarsOfType ty) + Nothing -> maxOut env in_var lvl + + | otherwise -- Ignore free tyvars + = lvl + +maxOut :: LevelEnv -> OutVar -> Level -> Level +maxOut (LE { le_lvl_env = lvl_env }) out_var lvl + = case lookupVarEnv lvl_env out_var of + Just lvl' -> maxLvl lvl' lvl + Nothing -> lvl lookupVar :: LevelEnv -> Id -> LevelledExpr lookupVar le v = case lookupVarEnv (le_env le) v of diff --git a/GHC/Core/Opt/Simplify/Iteration.hs b/GHC/Core/Opt/Simplify/Iteration.hs --- a/GHC/Core/Opt/Simplify/Iteration.hs +++ b/GHC/Core/Opt/Simplify/Iteration.hs @@ -474,14 +474,14 @@ Wrinkles -1. We must /not/ do cast w/w on +(CWW1) We must /not/ do cast w/w on f = g |> co otherwise it'll just keep repeating forever! You might think this is avoided because the call to tryCastWorkerWrapper is guarded by - preInlineUnconditinally, but I'm worried that a loop-breaker or an - exported Id might say False to preInlineUnonditionally. + preInlineUnconditionally, but I'm worried that a loop-breaker or an + exported Id might say False to preInlineUnconditionally. -2. We need to be careful with inline/noinline pragmas: +(CWW2) We need to be careful with inline/noinline pragmas: rec { {-# NOINLINE f #-} f = (...g...) |> co ; g = ...f... } @@ -496,15 +496,15 @@ f = $wf |> co ; g = ...f... } and that is bad: the whole point is that we want to inline that - cast! We want to transfer the pagma to $wf: + cast! We want to transfer the pragma to $wf: rec { {-# NOINLINE $wf #-} $wf = ...g... ; f = $wf |> co ; g = ...f... } c.f. Note [Worker/wrapper for NOINLINE functions] in GHC.Core.Opt.WorkWrap. -3. We should still do cast w/w even if `f` is INLINEABLE. E.g. - {- f: Stable unfolding = -} +(CWW3) We should still do cast w/w even if `f` is INLINEABLE. E.g. + {- f: Stable unfolding (arity 2) = -} f = (\xy. ) |> co Then we want to w/w to {- $wf: Stable unfolding = |> sym co -} @@ -513,16 +513,44 @@ Notice that the stable unfolding moves to the worker! Now demand analysis will work fine on $wf, whereas it has trouble with the original f. c.f. Note [Worker/wrapper for INLINABLE functions] in GHC.Core.Opt.WorkWrap. - This point also applies to strong loopbreakers with INLINE pragmas, see - wrinkle (4). -4. We should /not/ do cast w/w for non-loop-breaker INLINE functions (hence - hasInlineUnfolding in tryCastWorkerWrapper, which responds False to - loop-breakers) because they'll definitely be inlined anyway, cast and - all. And if we do cast w/w for an INLINE function with arity zero, we get +(CWW4) We should /not/ do cast w/w for INLINE functions (hence `hasInlineUnfolding` + in `tryCastWorkerWrapper`) because they'll definitely be inlined anyway, cast + and all. + + Moreover, if we do cast w/w for an INLINE function with arity zero, we get something really silly: we inline that "worker" right back into the wrapper! - Worse than a no-op, because we have then lost the stable unfolding. + In fact it is Much Worse than a no-op, because we have then lost the stable + unfolding --- aargh (see #26903). E.g. similar example to (CWW3) + {- g: Stable unfolding (arity 0) = -} NB arity 0! + g = (\xy. ) |> co + If we w/w to this: + {- $wg: Stable unfolding (arity 0) = |> sym co -} + $wg = \xy. + g = $wg |> co + then we'll inline $wg at the call site in `g` giving + {- $wg: Stable unfolding (arity 0) = |> sym co -} + $wg = \xy. + g = ( |> sym co) |> co + and now we'll drop `$wg` as dead and we have lost the unfolding on `g`. + (We could /also/ give the binding `g = $wf |> co` a stable unfolding. Then + things would work right; but there is also no point in doing the cast + worker/wrapper in the first place.) + NB: you might wonder about a loop-breaker with an INLINE pragma; after all, a + loop breaker won't "definitely be inlined anyway", so arguably we should not + disable cast w/w/ for it. But a Rec group can /look/ recursive at an early + stage, and subsequently /become/ non-recursive after some simplification. + (This is common in instance decls; see Note [Checking for INLINE loop breakers] + in GHC.Core.Lint.) So the danger is that we'll permanently lose that stable + unfolding that we specifically wanted (#26903). Simple solution: disable cast + w/w for /any/ INLINE function. See the defn + of `GHC.Types.Id.Info.hasInlineUnfolding`. + + The danger is that an INLINE pragma on a genuninely-recursive function + will kill worker-wrapper. Well, so be it. They are pretty suspicious anyway; + see Note [Checking for INLINE loop breakers]. + All these wrinkles are exactly like worker/wrapper for strictness analysis: f is the wrapper and must inline like crazy $wf is the worker and must carry f's original pragma @@ -586,11 +614,11 @@ | BC_Let top_lvl is_rec <- bind_cxt -- Not join points , not (isDFunId bndr) -- nor DFuns; cast w/w is no help, and we can't transform -- a DFunUnfolding in mk_worker_unfolding - , not (exprIsTrivial rhs) -- Not x = y |> co; Wrinkle 1 - , not (hasInlineUnfolding info) -- Not INLINE things: Wrinkle 4 - , typeHasFixedRuntimeRep work_ty -- Don't peel off a cast if doing so would - -- lose the underlying runtime representation. - -- See Note [Preserve RuntimeRep info in cast w/w] + , not (exprIsTrivial rhs) -- Not x = y |> co; see (CWW1) + , not (hasInlineUnfolding info) -- Not INLINE things: see (CWW4) + , typeHasFixedRuntimeRep work_ty -- Don't peel off a cast if doing so would + -- lose the underlying runtime representation. + -- See Note [Preserve RuntimeRep info in cast w/w] , not (isOpaquePragma (idInlinePragma old_bndr)) -- Not for OPAQUE bindings -- See Note [OPAQUE pragma] = do { uniq <- getUniqueM @@ -637,13 +665,13 @@ `setArityInfo` work_arity -- We do /not/ want to transfer OccInfo, Rules -- Note [Preserve strictness in cast w/w] - -- and Wrinkle 2 of Note [Cast worker/wrapper] + -- and (CWW2) of Note [Cast worker/wrapper] ----------- Worker unfolding ----------- -- Stable case: if there is a stable unfolding we have to compose with (Sym co); -- the next round of simplification will do the job -- Non-stable case: use work_rhs - -- Wrinkle 3 of Note [Cast worker/wrapper] + -- See (CWW4) of Note [Cast worker/wrapper] mk_worker_unfolding top_lvl work_id work_rhs = case realUnfoldingInfo info of -- NB: the real one, even for loop-breakers unf@(CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src }) @@ -1703,6 +1731,7 @@ , sc_hole_ty = coercionLKind co }) } -- NB! As the cast goes past, the -- type of the hole changes (#16312) + -- (f |> co) e ===> (f (e |> co1)) |> co2 -- where co :: (s1->s2) ~ (t1->t2) -- co1 :: t1 ~ s1 diff --git a/GHC/Core/Opt/Simplify/Utils.hs b/GHC/Core/Opt/Simplify/Utils.hs --- a/GHC/Core/Opt/Simplify/Utils.hs +++ b/GHC/Core/Opt/Simplify/Utils.hs @@ -73,6 +73,7 @@ import GHC.Types.Demand import GHC.Types.Var.Set import GHC.Types.Basic +import GHC.Types.Name.Env import GHC.Data.OrdList ( isNilOL ) import GHC.Data.FastString ( fsLit ) @@ -82,9 +83,9 @@ import GHC.Utils.Outputable import GHC.Utils.Panic -import Control.Monad ( when ) +import Control.Monad ( guard, when ) import Data.List ( sortBy ) -import GHC.Types.Name.Env +import Data.Maybe import Data.Graph {- ********************************************************************* @@ -2471,8 +2472,28 @@ True -> True; False -> False -and similar friends. +and similar friends. There are some tricky wrinkles: +(EIC1) Casts. We've seen this: + case e of x { _ -> x `cast` c } + And we definitely want to eliminate this case, to give + e `cast` c +(EIC2) Ticks. Similarly + case e of x { _ -> Tick t x } + At least if the tick is 'floatable' we want to eliminate the case + to give + Tick t e + +So `check_eq` strips off enclosing casts and ticks from the RHS of the +alternative, returning a wrapper function that will rebuild them around +the scrutinee if case-elim is successful. + +(EIC3) What if there are many alternatives, all identities. If casts + are involved they must be the same cast, to make the types line up. + In principle there could be different ticks in each RHS, but we just + pick the ticks from the first alternative. (In the common case there + is only one alternative.) + Note [Scrutinee Constant Folding] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ case x op# k# of _ { ===> case x of _ { @@ -2665,44 +2686,46 @@ -- See Note [Eliminate Identity Case] -------------------------------------------------- -mkCase1 _mode scrut case_bndr _ alts@(Alt _ _ rhs1 : alts') -- Identity case - | all identity_alt alts +mkCase1 _mode scrut case_bndr _ (alt1 : alts) -- Identity case + | Just wrap <- identity_alt alt1 -- `wrap`: see (EIC1) and (EIC2) + , all (isJust . identity_alt) alts -- See (EIC3) in Note [Eliminate Identity Case] = do { tick (CaseIdentity case_bndr) - ; return (mkTicks ticks $ re_cast scrut rhs1) } + ; return (wrap scrut) } where - ticks = concatMap (\(Alt _ _ rhs) -> stripTicksT tickishFloatable rhs) alts' - identity_alt (Alt con args rhs) = check_eq rhs con args + identity_alt :: CoreAlt -> Maybe (CoreExpr -> CoreExpr) + identity_alt (Alt con args rhs) = check_eq con args rhs - check_eq (Cast rhs co) con args -- See Note [RHS casts] - = not (any (`elemVarSet` tyCoVarsOfCo co) args) && check_eq rhs con args - check_eq (Tick t e) alt args - = tickishFloatable t && check_eq e alt args + check_eq :: AltCon -> [Var] -> CoreExpr -> Maybe (CoreExpr -> CoreExpr) + -- (check_eq con args e) return True if + -- e looks like (Tick (Cast (Tick (con args)))) + -- where (con args) is the LHS of the alternative + -- In that case it returns (\e. Tick (Cast (Tick e))), + -- a wrapper function that can rebuild the tick/cast stuff + -- See (EIC1) and (EIC2) in Note [Eliminate Identity Case] + check_eq alt_con args (Cast e co) -- See (EIC1) + = do { guard (not (any (`elemVarSet` tyCoVarsOfCo co) args)) + ; wrap <- check_eq alt_con args e + ; return (flip mkCast co . wrap) } + check_eq alt_con args (Tick t e) -- See (EIC2) + = do { guard (tickishFloatable t) + ; wrap <- check_eq alt_con args e + ; return (Tick t . wrap) } + check_eq alt_con args e + | is_id alt_con args e = Just (\e -> e) + | otherwise = Nothing - check_eq (Lit lit) (LitAlt lit') _ = lit == lit' - check_eq (Var v) _ _ | v == case_bndr = True - check_eq (Var v) (DataAlt con) args - | null arg_tys, null args = v == dataConWorkId con - -- Optimisation only - check_eq rhs (DataAlt con) args = cheapEqExpr' tickishFloatable rhs $ - mkConApp2 con arg_tys args - check_eq _ _ _ = False + is_id :: AltCon -> [Var] -> CoreExpr -> Bool + is_id _ _ (Var v) | v == case_bndr = True + is_id (LitAlt lit') _ (Lit lit) = lit == lit' + is_id (DataAlt con) args rhs + | Var v <- rhs -- Optimisation only + , null arg_tys + , null args = v == dataConWorkId con + | otherwise = cheapEqExpr' tickishFloatable rhs $ + mkConApp2 con arg_tys args + is_id _ _ _ = False arg_tys = tyConAppArgs (idType case_bndr) - - -- Note [RHS casts] - -- ~~~~~~~~~~~~~~~~ - -- We've seen this: - -- case e of x { _ -> x `cast` c } - -- And we definitely want to eliminate this case, to give - -- e `cast` c - -- So we throw away the cast from the RHS, and reconstruct - -- it at the other end. All the RHS casts must be the same - -- if (all identity_alt alts) holds. - -- - -- Don't worry about nested casts, because the simplifier combines them - - re_cast scrut (Cast rhs co) = Cast (re_cast scrut rhs) co - re_cast scrut _ = scrut mkCase1 mode scrut bndr alts_ty alts = mkCase2 mode scrut bndr alts_ty alts diff --git a/GHC/Core/Opt/Specialise.hs b/GHC/Core/Opt/Specialise.hs --- a/GHC/Core/Opt/Specialise.hs +++ b/GHC/Core/Opt/Specialise.hs @@ -652,9 +652,7 @@ -- Easiest thing is to do it all at once, as if all the top-level -- decls were mutually recursive ; let top_env = SE { se_subst = Core.mkEmptySubst $ - mkInScopeSetBndrs binds - -- mkInScopeSetList $ - -- bindersOfBinds binds + mkInScopeSetBndrs binds , se_module = this_mod , se_rules = rule_env , se_dflags = dflags } @@ -814,9 +812,12 @@ go :: SpecEnv -> [CallInfoSet] -> CoreM (SpecEnv, [CoreRule], [CoreBind]) go env [] = return (env, [], []) go env (cis : other_calls) - = do { -- debugTraceMsg (text "specImport {" <+> ppr cis) + = do { +-- debugTraceMsg (text "specImport {" <+> vcat [ ppr cis +-- , text "callers" <+> ppr callers +-- , text "dict_binds" <+> ppr dict_binds ]) ; (env, rules1, spec_binds1) <- spec_import env callers dict_binds cis - ; -- debugTraceMsg (text "specImport }" <+> ppr cis) +-- ; debugTraceMsg (text "specImport }" <+> ppr cis) ; (env, rules2, spec_binds2) <- go env other_calls ; return (env, rules1 ++ rules2, spec_binds1 ++ spec_binds2) } @@ -833,13 +834,18 @@ , [CoreBind] ) -- Specialised bindings spec_import env callers dict_binds cis@(CIS fn _) | isIn "specImport" fn callers - = return (env, [], []) -- No warning. This actually happens all the time - -- when specialising a recursive function, because - -- the RHS of the specialised function contains a recursive - -- call to the original function + = do { +-- debugTraceMsg (text "specImport1-bad" <+> (ppr fn $$ text "callers" <+> ppr callers)) + ; return (env, [], []) } + -- No warning. This actually happens all the time + -- when specialising a recursive function, because + -- the RHS of the specialised function contains a recursive + -- call to the original function | null good_calls - = return (env, [], []) + = do { +-- debugTraceMsg (text "specImport1-no-good" <+> (ppr cis $$ text "dict_binds" <+> ppr dict_binds)) + ; return (env, [], []) } | Just rhs <- canSpecImport dflags fn = do { -- Get rules from the external package state @@ -888,7 +894,10 @@ ; return (env, rules2 ++ rules1, final_binds) } | otherwise - = do { tryWarnMissingSpecs dflags callers fn good_calls + = do { +-- debugTraceMsg (hang (text "specImport1-missed") +-- 2 (vcat [ppr cis, text "can-spec" <+> ppr (canSpecImport dflags fn)])) + ; tryWarnMissingSpecs dflags callers fn good_calls ; return (env, [], [])} where @@ -1500,7 +1509,9 @@ ; (fn4, spec_defns, body_uds1) <- specDefn env body_uds fn3 rhs - ; let (free_uds, dump_dbs, float_all) = dumpBindUDs [fn4] body_uds1 + ; let can_float_this_one = exprIsTopLevelBindable rhs (idType fn) + -- exprIsTopLevelBindable: see Note [Care with unlifted bindings] + (free_uds, dump_dbs, float_all) = dumpBindUDs can_float_this_one [fn4] body_uds1 all_free_uds = free_uds `thenUDs` rhs_uds pairs = spec_defns ++ [(fn4, rhs')] @@ -1516,10 +1527,8 @@ = [mkDB $ NonRec b r | (b,r) <- pairs] ++ fromOL dump_dbs - can_float_this_one = exprIsTopLevelBindable rhs (idType fn) - -- exprIsTopLevelBindable: see Note [Care with unlifted bindings] - ; if float_all && can_float_this_one then + ; if float_all then -- Rather than discard the calls mentioning the bound variables -- we float this (dictionary) binding along with the others return ([], body', all_free_uds `snocDictBinds` final_binds) @@ -1554,7 +1563,7 @@ <- specDefns rec_env uds2 (bndrs2 `zip` rhss) ; return (bndrs3, spec_defns3 ++ spec_defns2, uds3) } - ; let (final_uds, dumped_dbs, float_all) = dumpBindUDs bndrs1 uds3 + ; let (final_uds, dumped_dbs, float_all) = dumpBindUDs True bndrs1 uds3 final_bind = recWithDumpedDicts (spec_defns3 ++ zip bndrs3 rhss') dumped_dbs @@ -1937,7 +1946,17 @@ the non-top-level in-scope binders are) and rare (since the binding must satisfy Note [Core let-can-float invariant] in GHC.Core). +Arguably we'd be better off if we had left that `x` in the RHS of `n`, thus + f x = let n::Natural = let x::ByteArray# = in + NB x + in wombat @192827 (n |> co) +Now we could float `n` happily. But that's in conflict with exposing the `NB` +data constructor in the body of the `let`, so I'm leaving this unresolved. +Another case came up in #26682, where the binding had an unlifted sum type +(# Word# | ByteArray# #), itself arising from an UNPACK pragma. Test case +T26682. + Note [Specialising Calls] ~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose we have a function with a complicated type: @@ -2975,7 +2994,8 @@ instance Outputable CallInfo where ppr (CI { ci_key = key, ci_fvs = _fvs }) - = text "CI" <> braces (sep (map ppr key)) + = text "CI" <> braces (text "fvs" <+> ppr _fvs + $$ sep (map ppr key)) unionCalls :: CallDetails -> CallDetails -> CallDetails unionCalls c1 c2 = plusDVarEnv_C unionCallInfoSet c1 c2 @@ -3286,7 +3306,7 @@ ---------------------- dumpUDs :: [CoreBndr] -> UsageDetails -> (UsageDetails, OrdList DictBind) --- Used at a lambda or case binder; just dump anything mentioning the binder +-- Used at binder; just dump anything mentioning the binder dumpUDs bndrs uds@(MkUD { ud_binds = orig_dbs, ud_calls = orig_calls }) | null bndrs = (uds, nilOL) -- Common in case alternatives | otherwise = -- pprTrace "dumpUDs" (ppr bndrs $$ ppr free_uds $$ ppr dump_dbs) $ @@ -3295,25 +3315,36 @@ free_uds = uds { ud_binds = free_dbs, ud_calls = free_calls } bndr_set = mkVarSet bndrs (free_dbs, dump_dbs, dump_set) = splitDictBinds orig_dbs bndr_set - free_calls = deleteCallsMentioning dump_set $ -- Drop calls mentioning bndr_set on the floor - deleteCallsFor bndrs orig_calls -- Discard calls for bndr_set; there should be - -- no calls for any of the dicts in dump_dbs -dumpBindUDs :: [CoreBndr] -> UsageDetails -> (UsageDetails, OrdList DictBind, Bool) + -- Delete calls: + -- * For any binder in `bndrs` + -- * That mention a dictionary bound in `dump_set` + -- These variables aren't in scope "above" the binding and the `dump_dbs`, + -- so no call should mention them. (See #26682.) + free_calls = deleteCallsMentioning dump_set $ + deleteCallsFor bndrs orig_calls + +dumpBindUDs :: Bool -- Main binding can float to top + -> [CoreBndr] -> UsageDetails + -> (UsageDetails, OrdList DictBind, Bool) -- Used at a let(rec) binding. --- We return a boolean indicating whether the binding itself is mentioned, --- directly or indirectly, by any of the ud_calls; in that case we want to --- float the binding itself; --- See Note [Floated dictionary bindings] -dumpBindUDs bndrs (MkUD { ud_binds = orig_dbs, ud_calls = orig_calls }) - = -- pprTrace "dumpBindUDs" (ppr bndrs $$ ppr free_uds $$ ppr dump_dbs $$ ppr float_all) $ - (free_uds, dump_dbs, float_all) +-- We return a boolean indicating whether the binding itself +-- is mentioned, directly or indirectly, by any of the ud_calls; +-- in that case we want to float the binding itself. +-- See Note [Floated dictionary bindings] +-- If the boolean is True, then the returned ud_calls can mention `bndrs`; +-- if False, then returned ud_calls must not mention `bndrs` +dumpBindUDs can_float_bind bndrs (MkUD { ud_binds = orig_dbs, ud_calls = orig_calls }) + = ( MkUD { ud_binds = free_dbs, ud_calls = free_calls2 } + , dump_dbs + , can_float_bind && calls_mention_bndrs ) where - free_uds = MkUD { ud_binds = free_dbs, ud_calls = free_calls } bndr_set = mkVarSet bndrs (free_dbs, dump_dbs, dump_set) = splitDictBinds orig_dbs bndr_set - free_calls = deleteCallsFor bndrs orig_calls - float_all = dump_set `intersectsVarSet` callDetailsFVs free_calls + free_calls1 = deleteCallsFor bndrs orig_calls + calls_mention_bndrs = dump_set `intersectsVarSet` callDetailsFVs free_calls1 + free_calls2 | can_float_bind = free_calls1 + | otherwise = deleteCallsMentioning dump_set free_calls1 callsForMe :: Id -> UsageDetails -> (UsageDetails, [CallInfo]) callsForMe fn uds@MkUD { ud_binds = orig_dbs, ud_calls = orig_calls } diff --git a/GHC/Core/Opt/WorkWrap.hs b/GHC/Core/Opt/WorkWrap.hs --- a/GHC/Core/Opt/WorkWrap.hs +++ b/GHC/Core/Opt/WorkWrap.hs @@ -176,8 +176,9 @@ mischief.) Notice that we refrain from w/w'ing an INLINE function even if it is -in a recursive group. It might not be the loop breaker. (We could -test for loop-breaker-hood, but I'm not sure that ever matters.) +in a recursive group. It might not be the loop breaker. (We used to +test for loop-breaker-hood, but see (CWW4) in Note [Cast worker/wrapper] +in GHC.Core.Opt.Simplify.Iteration.) Note [Worker/wrapper for INLINABLE functions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/GHC/Core/Utils.hs b/GHC/Core/Utils.hs --- a/GHC/Core/Utils.hs +++ b/GHC/Core/Utils.hs @@ -251,7 +251,7 @@ mkCastMCo :: CoreExpr -> MCoercionR -> CoreExpr mkCastMCo e MRefl = e -mkCastMCo e (MCo co) = Cast e co +mkCastMCo e (MCo co) = mkCast e co -- We are careful to use (MCo co) only when co is not reflexive -- Hence (Cast e co) rather than (mkCast e co) @@ -302,40 +302,41 @@ -- | Wraps the given expression in the source annotation, dropping the -- annotation if possible. mkTick :: CoreTickish -> CoreExpr -> CoreExpr -mkTick t orig_expr = mkTick' id id orig_expr +mkTick t orig_expr = mkTick' id orig_expr where -- Some ticks (cost-centres) can be split in two, with the -- non-counting part having laxer placement properties. canSplit = tickishCanSplit t && tickishPlace (mkNoCount t) /= tickishPlace t + -- mkTick' handles floating of ticks *into* the expression. - -- In this function, `top` is applied after adding the tick, and `rest` before. - -- This will result in applications that look like (top $ Tick t $ rest expr). - -- If we want to push the tick deeper, we pre-compose `top` with a function - -- adding the tick. - mkTick' :: (CoreExpr -> CoreExpr) -- apply after adding tick (float through) - -> (CoreExpr -> CoreExpr) -- apply before adding tick (float with) - -> CoreExpr -- current expression + mkTick' :: (CoreExpr -> CoreExpr) -- Apply before adding tick (float with) + -- Always a composition of (Tick t) wrappers + -> CoreExpr -- Current expression -> CoreExpr - mkTick' top rest expr = case expr of + -- So in the call (mkTick' rest e), the expression + -- (rest e) + -- has the same type as e + -- Returns an expression equivalent to (Tick t (rest e)) + mkTick' rest expr = case expr of -- Float ticks into unsafe coerce the same way we would do with a cast. Case scrut bndr ty alts@[Alt ac abs _rhs] | Just rhs <- isUnsafeEqualityCase scrut bndr alts - -> top $ mkTick' (\e -> Case scrut bndr ty [Alt ac abs e]) rest rhs + -> Case scrut bndr ty [Alt ac abs (mkTick' rest rhs)] -- Cost centre ticks should never be reordered relative to each -- other. Therefore we can stop whenever two collide. Tick t2 e - | ProfNote{} <- t2, ProfNote{} <- t -> top $ Tick t $ rest expr + | ProfNote{} <- t2, ProfNote{} <- t -> Tick t $ rest expr -- Otherwise we assume that ticks of different placements float -- through each other. - | tickishPlace t2 /= tickishPlace t -> mkTick' (top . Tick t2) rest e + | tickishPlace t2 /= tickishPlace t -> Tick t2 $ mkTick' rest e -- For annotations this is where we make sure to not introduce -- redundant ticks. - | tickishContains t t2 -> mkTick' top rest e - | tickishContains t2 t -> orig_expr - | otherwise -> mkTick' top (rest . Tick t2) e + | tickishContains t t2 -> mkTick' rest e -- Drop t2 + | tickishContains t2 t -> rest e -- Drop t + | otherwise -> mkTick' (rest . Tick t2) e -- Ticks don't care about types, so we just float all ticks -- through them. Note that it's not enough to check for these @@ -343,14 +344,14 @@ -- expressions below ticks, such constructs can be the result of -- unfoldings. We therefore make an effort to put everything into -- the right place no matter what we start with. - Cast e co -> mkTick' (top . flip Cast co) rest e - Coercion co -> Coercion co + Cast e co -> mkCast (mkTick' rest e) co + Coercion co -> Tick t $ rest (Coercion co) Lam x e -- Always float through type lambdas. Even for non-type lambdas, -- floating is allowed for all but the most strict placement rule. | not (isRuntimeVar x) || tickishPlace t /= PlaceRuntime - -> mkTick' (top . Lam x) rest e + -> Lam x $ mkTick' rest e -- If it is both counting and scoped, we split the tick into its -- two components, often allowing us to keep the counting tick on @@ -359,25 +360,25 @@ -- floated, and the lambda may then be in a position to be -- beta-reduced. | canSplit - -> top $ Tick (mkNoScope t) $ rest $ Lam x $ mkTick (mkNoCount t) e + -> Tick (mkNoScope t) $ rest $ Lam x $ mkTick (mkNoCount t) e App f arg -- Always float through type applications. | not (isRuntimeArg arg) - -> mkTick' (top . flip App arg) rest f + -> App (mkTick' rest f) arg -- We can also float through constructor applications, placement -- permitting. Again we can split. | isSaturatedConApp expr && (tickishPlace t==PlaceCostCentre || canSplit) -> if tickishPlace t == PlaceCostCentre - then top $ rest $ tickHNFArgs t expr - else top $ Tick (mkNoScope t) $ rest $ tickHNFArgs (mkNoCount t) expr + then rest $ tickHNFArgs t expr + else Tick (mkNoScope t) $ rest $ tickHNFArgs (mkNoCount t) expr Var x | notFunction && tickishPlace t == PlaceCostCentre - -> orig_expr + -> rest expr -- Drop t | notFunction && canSplit - -> top $ Tick (mkNoScope t) $ rest expr + -> Tick (mkNoScope t) $ rest expr where -- SCCs can be eliminated on variables provided the variable -- is not a function. In these cases the SCC makes no difference: @@ -389,10 +390,10 @@ Lit{} | tickishPlace t == PlaceCostCentre - -> orig_expr + -> rest expr -- Drop t -- Catch-all: Annotate where we stand - _any -> top $ Tick t $ rest expr + _any -> Tick t $ rest expr mkTicks :: [CoreTickish] -> CoreExpr -> CoreExpr mkTicks ticks expr = foldr mkTick expr ticks diff --git a/GHC/Driver/Config/Cmm.hs b/GHC/Driver/Config/Cmm.hs --- a/GHC/Driver/Config/Cmm.hs +++ b/GHC/Driver/Config/Cmm.hs @@ -24,17 +24,5 @@ , cmmDoCmmSwitchPlans = not (backendHasNativeSwitch (backend dflags)) , cmmSplitProcPoints = not (backendSupportsUnsplitProcPoints (backend dflags)) || not (platformTablesNextToCode platform) - , cmmAllowMul2 = (ncg && x86ish) || llvm - , cmmOptConstDivision = not llvm } where platform = targetPlatform dflags - -- Copied from StgToCmm - (ncg, llvm) = case backendPrimitiveImplementation (backend dflags) of - GenericPrimitives -> (False, False) - NcgPrimitives -> (True, False) - LlvmPrimitives -> (False, True) - JSPrimitives -> (False, False) - x86ish = case platformArch platform of - ArchX86 -> True - ArchX86_64 -> True - _ -> False diff --git a/GHC/Driver/Config/Core/Lint.hs b/GHC/Driver/Config/Core/Lint.hs --- a/GHC/Driver/Config/Core/Lint.hs +++ b/GHC/Driver/Config/Core/Lint.hs @@ -147,6 +147,12 @@ check_lbs = case pass of CoreDesugar -> False CoreDesugarOpt -> False + + -- Disable Lint warnings on the first simplifier pass, because + -- there may be some INLINE knots still tied, which is tiresomely noisy + CoreDoSimplify cfg + | InitialPhase <- sm_phase (so_mode cfg) + -> False _ -> True -- See Note [Checking StaticPtrs] diff --git a/GHC/Driver/Flags.hs b/GHC/Driver/Flags.hs --- a/GHC/Driver/Flags.hs +++ b/GHC/Driver/Flags.hs @@ -572,6 +572,7 @@ | Opt_DoAsmLinting | Opt_DoAnnotationLinting | Opt_DoBoundsChecking + | Opt_AddBcoName | Opt_NoLlvmMangler -- hidden flag | Opt_FastLlvm -- hidden flag | Opt_NoTypeableBinds diff --git a/GHC/Driver/Pipeline/Execute.hs b/GHC/Driver/Pipeline/Execute.hs --- a/GHC/Driver/Pipeline/Execute.hs +++ b/GHC/Driver/Pipeline/Execute.hs @@ -42,6 +42,7 @@ import GHC.Utils.TmpFs import GHC.Platform import Data.List (intercalate, isInfixOf) +import qualified Data.List.NonEmpty as NE import GHC.Unit.Env import GHC.Utils.Error import Data.Maybe @@ -68,6 +69,7 @@ import GHC.Platform.Ways import GHC.Driver.LlvmConfigCache (readLlvmConfigCache) import GHC.CmmToLlvm.Config (LlvmTarget (..), LlvmConfig (..)) +import GHC.CmmToLlvm.Version.Type (LlvmVersion (..)) import {-# SOURCE #-} GHC.Driver.Pipeline (compileForeign, compileEmptyStub) import GHC.Settings import System.IO @@ -228,8 +230,9 @@ 1 -> "-O1" _ -> "-O2" - defaultOptions = map GHC.SysTools.Option . concatMap words . snd - $ unzip (llvmOptions llvm_config dflags) + llvm_version <- figureLlvmVersion logger dflags + let defaultOptions = map GHC.SysTools.Option . concatMap words . snd + $ unzip (llvmOptions llvm_config llvm_version dflags) optFlag = if null (getOpts dflags opt_lc) then map GHC.SysTools.Option $ words llvmOpts else [] @@ -264,8 +267,9 @@ Nothing -> panic ("runPhase LlvmOpt: llvm-passes file " ++ "is missing passes for level " ++ show optIdx) - defaultOptions = map GHC.SysTools.Option . concat . fmap words . fst - $ unzip (llvmOptions llvm_config dflags) + llvm_version <- figureLlvmVersion logger dflags + let defaultOptions = map GHC.SysTools.Option . concat . fmap words . fst + $ unzip (llvmOptions llvm_config llvm_version dflags) -- don't specify anything if user has specified commands. We do this -- for opt but not llc since opt is very specifically for optimisation @@ -958,12 +962,21 @@ -- | LLVM Options. These are flags to be passed to opt and llc, to ensure -- consistency we list them in pairs, so that they form groups. llvmOptions :: LlvmConfig + -> Maybe LlvmVersion -> DynFlags -> [(String, String)] -- ^ pairs of (opt, llc) arguments -llvmOptions llvm_config dflags = +llvmOptions llvm_config llvm_version dflags = [("-relocation-model=" ++ rmodel ,"-relocation-model=" ++ rmodel) | not (null rmodel)] + -- Both llc/opt need these flags for split sections + ++ [ ("--data-sections", "--data-sections") + | gopt Opt_SplitSections dflags + ] + ++ [ ("--function-sections", "--function-sections") + | gopt Opt_SplitSections dflags + ] + -- Additional llc flags ++ [("", "-mcpu=" ++ mcpu) | not (null mcpu) , not (any (isInfixOf "-mcpu") (getOpts dflags opt_lc)) ] @@ -997,6 +1010,10 @@ ++ ["+sse2" | isSse2Enabled platform ] ++ ["+sse" | isSseEnabled platform ] ++ ["+avx512f" | isAvx512fEnabled dflags ] + ++ ["+evex512" | isAvx512fEnabled dflags + , maybe False (>= LlvmVersion (18 NE.:| [])) llvm_version ] + -- +evex512 is recognized by LLVM 18 or newer and needed on macOS (#26410). + -- It may become deprecated in a future LLVM version, though. ++ ["+avx2" | isAvx2Enabled dflags ] ++ ["+avx" | isAvxEnabled dflags ] ++ ["+avx512cd"| isAvx512cdEnabled dflags ] diff --git a/GHC/Driver/Session.hs b/GHC/Driver/Session.hs --- a/GHC/Driver/Session.hs +++ b/GHC/Driver/Session.hs @@ -2531,6 +2531,7 @@ flagSpec "catch-nonexhaustive-cases" Opt_CatchNonexhaustiveCases, flagSpec "alignment-sanitisation" Opt_AlignmentSanitisation, flagSpec "check-prim-bounds" Opt_DoBoundsChecking, + flagSpec "add-bco-name" Opt_AddBcoName, flagSpec "num-constant-folding" Opt_NumConstantFolding, flagSpec "core-constant-folding" Opt_CoreConstantFolding, flagSpec "fast-pap-calls" Opt_FastPAPCalls, diff --git a/GHC/Hs/Doc.hs b/GHC/Hs/Doc.hs --- a/GHC/Hs/Doc.hs +++ b/GHC/Hs/Doc.hs @@ -50,6 +50,7 @@ import GHC.Hs.Extension import GHC.Types.Unique.Map import Data.List (sortBy) +import Data.Function import GHC.Hs.DocString @@ -88,7 +89,7 @@ instance Binary a => Binary (WithHsDocIdentifiers a GhcRn) where put_ bh (WithHsDocIdentifiers s ids) = do put_ bh s - put_ bh $ BinLocated <$> ids + put_ bh $ BinLocated <$> (sortBy (stableNameCmp `on` getName) ids) get bh = liftA2 WithHsDocIdentifiers (get bh) (fmap unBinLocated <$> get bh) diff --git a/GHC/Iface/Recomp.hs b/GHC/Iface/Recomp.hs --- a/GHC/Iface/Recomp.hs +++ b/GHC/Iface/Recomp.hs @@ -1508,10 +1508,12 @@ IfaceClass{ifBody = IfConcreteClass { ifSigs=sigs, ifATs=ats }} -> IfaceClassExtras (fix_fn n) insts (ann_fn n) meths defms where - insts = (map ifDFun $ (concatMap at_extras ats) - ++ lookupOccEnvL inst_env n) - -- Include instances of the associated types - -- as well as instances of the class (#5147) + insts = + let (atFamInsts, atClsInsts) = foldMap at_extras ats + in (ifFamInstAxiom <$> atFamInsts) ++ (ifDFun <$> atClsInsts) + ++ (ifDFun <$> lookupOccEnvL inst_env n) + -- Include instances and axioms of the associated types + -- as well as instances of the class (#5147) (#26183) meths = [id_extras (getOccName op) | IfaceClassOp op _ _ <- sigs] -- Names of all the default methods (see Note [default method Name]) defms = [ dmName @@ -1521,13 +1523,18 @@ IfaceSynonym{} -> IfaceSynonymExtras (fix_fn n) (ann_fn n) IfaceFamily{} -> IfaceFamilyExtras (fix_fn n) - (map ifFamInstAxiom (lookupOccEnvL fi_env n)) + (map ifFamInstAxiom (lookupOccEnvL fi_env n) + ++ map ifDFun (lookupOccEnvL inst_env n) + ) (ann_fn n) _other -> IfaceOtherDeclExtras where n = getOccName decl id_extras occ = IdExtras (fix_fn occ) (lookupOccEnvL rule_env occ) (ann_fn occ) - at_extras (IfaceAT decl _) = lookupOccEnvL inst_env (getOccName decl) + at_extras (IfaceAT decl _) = + ( lookupOccEnvL fi_env (getOccName decl) -- Axioms + , lookupOccEnvL inst_env (getOccName decl) -- Class instances + ) {- Note [default method Name] (see also #15970) diff --git a/GHC/Parser/HaddockLex.hs b/GHC/Parser/HaddockLex.hs --- a/GHC/Parser/HaddockLex.hs +++ b/GHC/Parser/HaddockLex.hs @@ -1,7 +1,7 @@ {-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-missing-signatures #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} -{-# LINE 1 "_build/source-dist/ghc-9.12.3-src/ghc-9.12.3/compiler/GHC/Parser/HaddockLex.x" #-} +{-# LINE 1 "_build/source-dist/ghc-9.12.4-src/ghc-9.12.4/compiler/GHC/Parser/HaddockLex.x" #-} {-# OPTIONS_GHC -funbox-strict-fields #-} module GHC.Parser.HaddockLex (lexHsDoc, lexStringLiteral) where @@ -353,7 +353,7 @@ -- match when checking the right context, just -- the first match will do. #endif -{-# LINE 85 "_build/source-dist/ghc-9.12.3-src/ghc-9.12.3/compiler/GHC/Parser/HaddockLex.x" #-} +{-# LINE 85 "_build/source-dist/ghc-9.12.4-src/ghc-9.12.4/compiler/GHC/Parser/HaddockLex.x" #-} data AlexInput = AlexInput { alexInput_position :: !RealSrcLoc , alexInput_string :: !ByteString diff --git a/GHC/Parser/Lexer.hs b/GHC/Parser/Lexer.hs --- a/GHC/Parser/Lexer.hs +++ b/GHC/Parser/Lexer.hs @@ -1,7 +1,7 @@ {-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-missing-signatures #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} -{-# LINE 43 "_build/source-dist/ghc-9.12.3-src/ghc-9.12.3/compiler/GHC/Parser/Lexer.x" #-} +{-# LINE 43 "_build/source-dist/ghc-9.12.4-src/ghc-9.12.4/compiler/GHC/Parser/Lexer.x" #-} {-# LANGUAGE CPP #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE LambdaCase #-} @@ -1118,7 +1118,7 @@ -- match when checking the right context, just -- the first match will do. #endif -{-# LINE 762 "_build/source-dist/ghc-9.12.3-src/ghc-9.12.3/compiler/GHC/Parser/Lexer.x" #-} +{-# LINE 762 "_build/source-dist/ghc-9.12.4-src/ghc-9.12.4/compiler/GHC/Parser/Lexer.x" #-} -- Operator whitespace occurrence. See Note [Whitespace-sensitive operator parsing]. data OpWs = OpWsPrefix -- a !b diff --git a/GHC/Parser/Lexer/String.hs b/GHC/Parser/Lexer/String.hs --- a/GHC/Parser/Lexer/String.hs +++ b/GHC/Parser/Lexer/String.hs @@ -1,7 +1,7 @@ {-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-missing-signatures #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} -{-# LINE 1 "_build/source-dist/ghc-9.12.3-src/ghc-9.12.3/compiler/GHC/Parser/Lexer/String.x" #-} +{-# LINE 1 "_build/source-dist/ghc-9.12.4-src/ghc-9.12.4/compiler/GHC/Parser/Lexer/String.x" #-} {- | This module defines lex states for strings. @@ -346,7 +346,7 @@ -- match when checking the right context, just -- the first match will do. #endif -{-# LINE 91 "_build/source-dist/ghc-9.12.3-src/ghc-9.12.3/compiler/GHC/Parser/Lexer/String.x" #-} +{-# LINE 91 "_build/source-dist/ghc-9.12.4-src/ghc-9.12.4/compiler/GHC/Parser/Lexer/String.x" #-} -- | Dummy action that should never be called. Should only be used in lex states -- that are manually lexed in tok_string_multi. string_multi_content_action :: a diff --git a/GHC/Rename/Env.hs b/GHC/Rename/Env.hs --- a/GHC/Rename/Env.hs +++ b/GHC/Rename/Env.hs @@ -115,7 +115,7 @@ import Control.Monad import Data.Either ( partitionEithers ) import Data.Function ( on ) -import Data.List ( find, partition, groupBy, sortBy ) +import Data.List ( find, partition, sortBy ) import qualified Data.List.NonEmpty as NE import qualified Data.Semigroup as Semi import System.IO.Unsafe ( unsafePerformIO ) @@ -1481,6 +1481,12 @@ do { let (env_fld_gres, env_var_gres) = partition isRecFldGRE $ lookupGRE env (LookupRdrName rdr (RelevantGREsFOS WantBoth)) + -- Make sure to use 'LookupRdrName': if a record update contains + -- a qualified field name, only look up GREs which are in scope + -- with that same qualification. + -- + -- See Wrinkle [Qualified names in record updates] + -- in Note [Disambiguating record updates] in GHC.Rename.Pat. -- Handle implicit qualified imports in GHCi. See T10439. ; ghci_gres <- lookupQualifiedNameGHCi WantBoth rdr @@ -1553,10 +1559,10 @@ -> RnM (NE.NonEmpty (HsRecUpdParent GhcRn)) lookupRecUpdFields flds -- See Note [Disambiguating record updates] in GHC.Rename.Pat. - = do { -- Retrieve the possible GlobalRdrElts that each field could refer to. + = do { -- (1) Retrieve the possible GlobalRdrElts that each field could refer to. ; gre_env <- getGlobalRdrEnv ; fld1_gres NE.:| other_flds_gres <- mapM (lookupFieldGREs gre_env . getFieldUpdLbl) flds - -- Take an intersection: we are only interested in constructors + -- (2) Take an intersection: we are only interested in constructors -- which have all of the fields. ; let possible_GREs = intersect_by_cons fld1_gres other_flds_gres @@ -1567,15 +1573,16 @@ ; case possible_GREs of - -- There is at least one parent: we can proceed. + -- (3) (a) There is at least one parent: we can proceed. -- The typechecker might be able to finish disambiguating. -- See Note [Type-directed record disambiguation] in GHC.Rename.Pat. { p1:ps -> return (p1 NE.:| ps) - -- There are no possible parents for the record update: compute - -- a minimum set of fields which does not belong to any data constructor, - -- to report an informative error to the user. - ; _ -> + -- (3) (b) There are no possible parents for the record update: + -- compute a minimal set of fields which does not belong to any + -- data constructor, to report an informative error to the user. + ; _ -> do + hsc_env <- getTopEnv let -- The constructors which have the first field. fld1_cons :: UniqSet ConLikeName @@ -1585,9 +1592,9 @@ -- The field labels of the constructors which have the first field. fld1_cons_fields :: UniqFM ConLikeName [FieldLabel] fld1_cons_fields - = fmap (lkp_con_fields gre_env) + = fmap (lkp_con_fields hsc_env gre_env) $ getUniqSet fld1_cons - in failWithTc $ badFieldsUpd (NE.toList flds) fld1_cons_fields } } + failWithTc $ badFieldsUpd (NE.toList flds) fld1_cons_fields } } where intersect_by_cons :: NE.NonEmpty FieldGlobalRdrElt @@ -1606,13 +1613,22 @@ , not $ isEmptyUniqSet both_cons ] - lkp_con_fields :: GlobalRdrEnv -> ConLikeName -> [FieldLabel] - lkp_con_fields gre_env con = + -- Look up all in-scope fields of a 'ConLike'. + lkp_con_fields :: HscEnv -> GlobalRdrEnv -> ConLikeName -> [FieldLabel] + lkp_con_fields hsc_env gre_env con = [ fl - | let nm = conLikeName_Name con - , gre <- maybeToList $ lookupGRE_Name gre_env nm - , con_info <- maybeToList $ recFieldConLike_maybe gre - , fl <- conInfoFields con_info ] + | let con_nm = conLikeName_Name con + gre_info = + (greInfo <$> lookupGRE_Name gre_env con_nm) + `orElse` + lookupGREInfo hsc_env con_nm + -- See Wrinkle [Out of scope constructors] + -- in Note [Disambiguating record updates] in GHC.Rename.Pat. + , IAmConLike con_info <- [ gre_info ] + , fl <- conInfoFields con_info + , isJust $ lookupGRE_FieldLabel gre_env fl + -- Ensure the fields are in scope. + ] {-********************************************************************** * * @@ -1636,8 +1652,9 @@ -- aren't really relevant to the problem. -- -- NB: this error message should only be triggered when all the field names --- are in scope (i.e. each individual field name does belong to some --- constructor in scope). +-- are in scope. It's OK if the constructors themselves are not in scope +-- (see Wrinkle [Out of scope constructors] in Note [Disambiguating record updates] +-- in GHC.Rename.Pat). badFieldsUpd :: (OutputableBndrId p) => [LHsRecUpdField (GhcPass p) q] @@ -1670,7 +1687,7 @@ in -- Fields that don't change the membership status of the set -- are redundant and can be dropped. - map (fst . head) $ groupBy ((==) `on` snd) growingSets + map (fst . NE.head) $ NE.groupBy ((==) `on` snd) growingSets aMember = assert (not (null members) ) fst (head members) (members, nonMembers) = partition (or . snd) membership diff --git a/GHC/Rename/Pat.hs b/GHC/Rename/Pat.hs --- a/GHC/Rename/Pat.hs +++ b/GHC/Rename/Pat.hs @@ -1084,25 +1084,117 @@ the parent datatype by computing the parents (TyCon/PatSyn) which have at least one constructor (DataCon/PatSyn) with all of the fields. -For example, in the (non-overloaded) record update +To do this, given the (non-empty) set of fields in the record update, +lookupRecUpdFields proceeds as follows: - r { fld1 = 3, fld2 = 'x' } + (1) For each field, retrieve all the in-scope GREs that it could possibly + refer to. -only the TyCon R contains at least one DataCon which has both of the fields -being updated: in this case, MkR1 and MkR2 have both of the updated fields. -The TyCon S also has both fields fld1 and fld2, but no single constructor -has both of those fields, so S is not a valid parent for this record update. + (2) Take an intersection to compute the possible parent data constructors. + For example, for an update -Note that this check is namespace-aware, so that a record update such as + r { fld1 = 3, fld2 = 'x' } + the possible parents for each field are: + + fld1: [MkR1 |-> R.fld1, MkR2 |-> R.fld1, MkS1 |> S.fld1] + fld2: [MkR1 |-> R.fld2, MkR2 |-> R.fld2, MkS2 |> S.fld2] + + after intersecting by constructor, we get: + + fld1: [MkR1 |-> R.fld1, MkR2 |-> R.fld1] + fld2: [MkR1 |-> R.fld2, MkR2 |-> R.fld2] + + This reflects the fact that only the TyCon R contains at least one DataCon + which has both of the fields being updated: MkR1 and MkR2. + The TyCon S also has both fields fld1 and fld2, but no single constructor + has both of those fields, so S is not a valid parent for this record update. + + (3) + (a) + If there is at least one possible parent TyCon, succeed. The typechecker + might still be able to disambiguate if there remains more than one + candidate parent TyCon (see Note [Type-directed record disambiguation]). + (b) + Otherwise, report an error saying "No constructor has all these fields". + This is the job of GHC.Rename.Env.badFieldsUpd. This function tries + to report a minimal set of fields, so that in a record update like + + r { fld1 = x1, fld2 = x2, [...], fld99 = x99 } + + we don't report a massive error message saying "No constructor has all + the fields fld1, ..., fld99" and instead report e.g. "No constructor + has all the fields { fld3, fld17 }". + + +Note that (1) takes into account qualified names, so that a record update such +as + import qualified M ( R (fld1, fld2) ) f r = r { M.fld1 = 3 } -is unambiguous, as only R contains the field fld1 in the M namespace. +is unambiguous, as only R contains the field fld1 with the M qualifier. (See however #22122 for issues relating to the usage of exact Names in record fields.) -See also Note [Type-directed record disambiguation] in GHC.Tc.Gen.Expr. + The function that looks up the GREs for the record update is 'lookupFieldGREs', + which uses 'lookupGRE env (LookupRdrName ...)', ensuring that we correctly + filter the GREs with the correct module qualification (with 'pickGREs'). + + (See however #22122 for issues relating to the usage of exact Names in + record fields.) + +Wrinkle [Out of scope constructors] + + For (3)(b), we have an invalid record update because no constructor has + all of the fields of the record update. The 'badFieldsUpd' then tries to + compute a minimal set of fields which are not children of any single + constructor. The way this is done is explained in + Note [Finding the conflicting fields] in GHC.Rename.Env, but in short that + function needs a mapping from ConLike to all of its fields to do its business. + (You may remark that we did not need such a mapping for step (2).) + + This means we need to look up each constructor and find its fields; this + information is stored in the GREInfo field of a constructor GRE. + We need this information even if the constructor itself is not in scope, so + we proceed as follows: + + 1. First look up the constructor in the GlobalRdrEnv, using lookupGRE_Name. + This handles constructors defined in the current module being renamed, + as well as in-scope imported constructors. + 2. If that fails (e.g. the field is imported but the constructor is not), + then look up the GREInfo of the constructor in the TypeEnv, using + lookupGREInfo. This makes sure we give the right error message even when + the constructors are not in scope (#26391). + + Note that we do need (1), as (2) does not handle constructors defined in the + current module being renamed (as those have not yet been added to the TypeEnv). + +Wrinkle [Out of scope constructors] + + For (3)(b), we have an invalid record update because no constructor has + all of the fields of the record update. The 'badFieldsUpd' then tries to + compute a minimal set of fields which are not children of any single + constructor. The way this is done is explained in + Note [Finding the conflicting fields] in GHC.Rename.Env, but in short that + function needs a mapping from ConLike to all of its fields to do its business. + (You may remark that we did not need such a mapping for step (2).) + + This means we need to look up each constructor and find its fields; this + information is stored in the GREInfo field of a constructor GRE. + We need this information even if the constructor itself is not in scope, so + we proceed as follows: + + 1. First look up the constructor in the GlobalRdrEnv, using lookupGRE_Name. + This handles constructors defined in the current module being renamed, + as well as in-scope imported constructors. + 2. If that fails (e.g. the field is imported but the constructor is not), + then look up the GREInfo of the constructor in the TypeEnv, using + lookupGREInfo. This makes sure we give the right error message even when + the constructors are not in scope (#26391). + + Note that we do need (1), as (2) does not handle constructors defined in the + current module being renamed (as those have not yet been added to the TypeEnv). Note [Using PatSyn FreeVars] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/GHC/StgToByteCode.hs b/GHC/StgToByteCode.hs --- a/GHC/StgToByteCode.hs +++ b/GHC/StgToByteCode.hs @@ -1,4 +1,4 @@ - +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RecordWildCards #-} @@ -56,6 +56,7 @@ import GHC.Data.FastString import GHC.Utils.Panic import GHC.Utils.Exception (evaluate) +import GHC.CmmToAsm.Config (platformWordWidth) import GHC.StgToCmm.Closure ( NonVoid(..), fromNonVoid, idPrimRepU, addIdReps, addArgReps, assertNonVoidIds, assertNonVoidStgArgs ) @@ -81,6 +82,9 @@ import Data.Array import Data.Coerce (coerce) import Data.ByteString (ByteString) +#if MIN_VERSION_rts(1,0,3) +import qualified Data.ByteString.Char8 as BS +#endif import Data.Map (Map) import Data.IntMap (IntMap) import qualified Data.Map as Map @@ -236,7 +240,10 @@ -- Create a BCO and do a spot of peephole optimisation on the insns -- at the same time. mkProtoBCO - :: Platform + :: (Outputable name) + => Platform + -> Bool -- ^ True <=> label with @BCO_NAME@ instruction + -- see Note [BCO_NAME] -> name -> BCInstrList -> Either [CgStgAlt] (CgStgRhs) @@ -247,10 +254,10 @@ -> Bool -- ^ True <=> is a return point, rather than a function -> [FFIInfo] -> ProtoBCO name -mkProtoBCO platform nm instrs_ordlist origin arity bitmap_size bitmap is_ret ffis +mkProtoBCO platform _add_bco_name nm instrs_ordlist origin arity bitmap_size bitmap is_ret ffis = ProtoBCO { protoBCOName = nm, - protoBCOInstrs = maybe_with_stack_check, + protoBCOInstrs = maybe_add_bco_name $ maybe_add_stack_check peep_d, protoBCOBitmap = bitmap, protoBCOBitmapSize = fromIntegral bitmap_size, protoBCOArity = arity, @@ -258,6 +265,14 @@ protoBCOFFIs = ffis } where +#if MIN_VERSION_rts(1,0,3) + maybe_add_bco_name instrs + | _add_bco_name = BCO_NAME str : instrs + where + str = BS.pack $ showSDocOneLine defaultSDocContext (ppr nm) +#endif + maybe_add_bco_name instrs = instrs + -- Overestimate the stack usage (in words) of this BCO, -- and if >= iNTERP_STACK_CHECK_THRESH, add an explicit -- stack check. (The interpreter always does a stack check @@ -265,17 +280,17 @@ -- BCO anyway, so we only need to add an explicit one in the -- (hopefully rare) cases when the (overestimated) stack use -- exceeds iNTERP_STACK_CHECK_THRESH. - maybe_with_stack_check - | is_ret && stack_usage < fromIntegral (pc_AP_STACK_SPLIM (platformConstants platform)) = peep_d + maybe_add_stack_check instrs + | is_ret && stack_usage < fromIntegral (pc_AP_STACK_SPLIM (platformConstants platform)) = instrs -- don't do stack checks at return points, -- everything is aggregated up to the top BCO -- (which must be a function). -- That is, unless the stack usage is >= AP_STACK_SPLIM, -- see bug #1466. | stack_usage >= fromIntegral iNTERP_STACK_CHECK_THRESH - = STKCHECK stack_usage : peep_d + = STKCHECK stack_usage : instrs | otherwise - = peep_d -- the supposedly common case + = instrs -- the supposedly common case -- We assume that this sum doesn't wrap stack_usage = sum (map bciStackUse peep_d) @@ -308,6 +323,7 @@ | Just data_con <- isDataConWorkId_maybe id, isNullaryRepDataCon data_con = do platform <- profilePlatform <$> getProfile + add_bco_name <- shouldAddBcoName -- Special case for the worker of a nullary data con. -- It'll look like this: Nil = /\a -> Nil a -- If we feed it into schemeR, we'll get @@ -316,7 +332,8 @@ -- by just re-using the single top-level definition. So -- for the worker itself, we must allocate it directly. -- ioToBc (putStrLn $ "top level BCO") - emitBc (mkProtoBCO platform (getName id) (toOL [PACK data_con 0, RETURN P]) + emitBc (mkProtoBCO platform add_bco_name + (getName id) (toOL [PACK data_con 0, RETURN P]) (Right rhs) 0 0 [{-no bitmap-}] False{-not alts-}) | otherwise @@ -358,6 +375,7 @@ -> BcM (ProtoBCO Name) schemeR_wrk fvs nm original_body (args, body) = do + add_bco_name <- shouldAddBcoName profile <- getProfile let platform = profilePlatform profile @@ -379,7 +397,7 @@ bitmap = mkBitmap platform bits body_code <- schemeER_wrk sum_szsb_args p_init body - emitBc (mkProtoBCO platform nm body_code (Right original_body) + emitBc (mkProtoBCO platform add_bco_name nm body_code (Right original_body) arity bitmap_size bitmap False{-not alts-}) -- | Introduce break instructions for ticked expressions. @@ -561,8 +579,7 @@ -- Compile code to apply the given expression to the remaining args -- on the stack, returning a HNF. -schemeE - :: StackDepth -> Sequel -> BCEnv -> CgStgExpr -> BcM BCInstrList +schemeE :: StackDepth -> Sequel -> BCEnv -> CgStgExpr -> BcM BCInstrList schemeE d s p (StgLit lit) = returnUnliftedAtom d s p (StgLitArg lit) schemeE d s p (StgApp x []) | isUnliftedType (idType x) = returnUnliftedAtom d s p (StgVarArg x) @@ -714,8 +731,14 @@ then generateCCall d s p ccall_spec result_ty args else unsupportedCConvException -schemeT d s p (StgOpApp (StgPrimOp op) args _ty) - = doTailCall d s p (primOpId op) (reverse args) +schemeT d s p (StgOpApp (StgPrimOp op) args _ty) = do + profile <- getProfile + let platform = profilePlatform profile + case doPrimOp platform op d s p args of + -- Can we do this right in the interpreter? + Just prim_code -> prim_code + -- Otherwise we have to do a call to the primop wrapper instead :( + _ -> doTailCall d s p (primOpId op) (reverse args) schemeT d s p (StgOpApp (StgPrimCallOp (PrimCall label unit)) args result_ty) = generatePrimCall d s p label (Just unit) result_ty args @@ -810,6 +833,300 @@ (final_d, more_push_code) <- push_seq (d + sz) args return (final_d, push_code `appOL` more_push_code) +doPrimOp :: Platform + -> PrimOp + -> StackDepth + -> Sequel + -> BCEnv + -> [StgArg] + -> Maybe (BcM BCInstrList) +doPrimOp platform op init_d s p args = + case op of + IntAddOp -> sizedPrimOp OP_ADD + Int64AddOp -> only64bit $ sizedPrimOp OP_ADD + Int32AddOp -> sizedPrimOp OP_ADD + Int16AddOp -> sizedPrimOp OP_ADD + Int8AddOp -> sizedPrimOp OP_ADD + WordAddOp -> sizedPrimOp OP_ADD + Word64AddOp -> only64bit $ sizedPrimOp OP_ADD + Word32AddOp -> sizedPrimOp OP_ADD + Word16AddOp -> sizedPrimOp OP_ADD + Word8AddOp -> sizedPrimOp OP_ADD + AddrAddOp -> sizedPrimOp OP_ADD + + IntMulOp -> sizedPrimOp OP_MUL + Int64MulOp -> only64bit $ sizedPrimOp OP_MUL + Int32MulOp -> sizedPrimOp OP_MUL + Int16MulOp -> sizedPrimOp OP_MUL + Int8MulOp -> sizedPrimOp OP_MUL + WordMulOp -> sizedPrimOp OP_MUL + Word64MulOp -> only64bit $ sizedPrimOp OP_MUL + Word32MulOp -> sizedPrimOp OP_MUL + Word16MulOp -> sizedPrimOp OP_MUL + Word8MulOp -> sizedPrimOp OP_MUL + + IntSubOp -> sizedPrimOp OP_SUB + WordSubOp -> sizedPrimOp OP_SUB + Int64SubOp -> only64bit $ sizedPrimOp OP_SUB + Int32SubOp -> sizedPrimOp OP_SUB + Int16SubOp -> sizedPrimOp OP_SUB + Int8SubOp -> sizedPrimOp OP_SUB + Word64SubOp -> only64bit $ sizedPrimOp OP_SUB + Word32SubOp -> sizedPrimOp OP_SUB + Word16SubOp -> sizedPrimOp OP_SUB + Word8SubOp -> sizedPrimOp OP_SUB + AddrSubOp -> sizedPrimOp OP_SUB + + IntAndOp -> sizedPrimOp OP_AND + WordAndOp -> sizedPrimOp OP_AND + Word64AndOp -> only64bit $ sizedPrimOp OP_AND + Word32AndOp -> sizedPrimOp OP_AND + Word16AndOp -> sizedPrimOp OP_AND + Word8AndOp -> sizedPrimOp OP_AND + + IntNotOp -> sizedPrimOp OP_NOT + WordNotOp -> sizedPrimOp OP_NOT + Word64NotOp -> only64bit $ sizedPrimOp OP_NOT + Word32NotOp -> sizedPrimOp OP_NOT + Word16NotOp -> sizedPrimOp OP_NOT + Word8NotOp -> sizedPrimOp OP_NOT + + IntXorOp -> sizedPrimOp OP_XOR + WordXorOp -> sizedPrimOp OP_XOR + Word64XorOp -> only64bit $ sizedPrimOp OP_XOR + Word32XorOp -> sizedPrimOp OP_XOR + Word16XorOp -> sizedPrimOp OP_XOR + Word8XorOp -> sizedPrimOp OP_XOR + + IntOrOp -> sizedPrimOp OP_OR + WordOrOp -> sizedPrimOp OP_OR + Word64OrOp -> only64bit $ sizedPrimOp OP_OR + Word32OrOp -> sizedPrimOp OP_OR + Word16OrOp -> sizedPrimOp OP_OR + Word8OrOp -> sizedPrimOp OP_OR + + WordSllOp -> sizedPrimOp OP_SHL + Word64SllOp -> only64bit $ sizedPrimOp OP_SHL -- check 32bit platform + Word32SllOp -> sizedPrimOp OP_SHL + Word16SllOp -> sizedPrimOp OP_SHL + Word8SllOp -> sizedPrimOp OP_SHL + IntSllOp -> sizedPrimOp OP_SHL + Int64SllOp -> only64bit $ sizedPrimOp OP_SHL + Int32SllOp -> sizedPrimOp OP_SHL + Int16SllOp -> sizedPrimOp OP_SHL + Int8SllOp -> sizedPrimOp OP_SHL + + WordSrlOp -> sizedPrimOp OP_LSR + Word64SrlOp -> only64bit $ sizedPrimOp OP_LSR + Word32SrlOp -> sizedPrimOp OP_LSR + Word16SrlOp -> sizedPrimOp OP_LSR + Word8SrlOp -> sizedPrimOp OP_LSR + IntSrlOp -> sizedPrimOp OP_LSR + Int64SrlOp -> only64bit $ sizedPrimOp OP_LSR -- check 32bit platform + Int32SrlOp -> sizedPrimOp OP_LSR + Int16SrlOp -> sizedPrimOp OP_LSR + Int8SrlOp -> sizedPrimOp OP_LSR + + IntSraOp -> sizedPrimOp OP_ASR + Int64SraOp -> only64bit $ sizedPrimOp OP_ASR -- check 32bit platform + Int32SraOp -> sizedPrimOp OP_ASR + Int16SraOp -> sizedPrimOp OP_ASR + Int8SraOp -> sizedPrimOp OP_ASR + + + IntNeOp -> sizedPrimOp OP_NEQ + Int64NeOp -> only64bit $ sizedPrimOp OP_NEQ + Int32NeOp -> sizedPrimOp OP_NEQ + Int16NeOp -> sizedPrimOp OP_NEQ + Int8NeOp -> sizedPrimOp OP_NEQ + WordNeOp -> sizedPrimOp OP_NEQ + Word64NeOp -> only64bit $ sizedPrimOp OP_NEQ + Word32NeOp -> sizedPrimOp OP_NEQ + Word16NeOp -> sizedPrimOp OP_NEQ + Word8NeOp -> sizedPrimOp OP_NEQ + AddrNeOp -> sizedPrimOp OP_NEQ + + IntEqOp -> sizedPrimOp OP_EQ + Int64EqOp -> only64bit $ sizedPrimOp OP_EQ + Int32EqOp -> sizedPrimOp OP_EQ + Int16EqOp -> sizedPrimOp OP_EQ + Int8EqOp -> sizedPrimOp OP_EQ + WordEqOp -> sizedPrimOp OP_EQ + Word64EqOp -> only64bit $ sizedPrimOp OP_EQ + Word32EqOp -> sizedPrimOp OP_EQ + Word16EqOp -> sizedPrimOp OP_EQ + Word8EqOp -> sizedPrimOp OP_EQ + AddrEqOp -> sizedPrimOp OP_EQ + CharEqOp -> sizedPrimOp OP_EQ + + IntLtOp -> sizedPrimOp OP_S_LT + Int64LtOp -> only64bit $ sizedPrimOp OP_S_LT + Int32LtOp -> sizedPrimOp OP_S_LT + Int16LtOp -> sizedPrimOp OP_S_LT + Int8LtOp -> sizedPrimOp OP_S_LT + WordLtOp -> sizedPrimOp OP_U_LT + Word64LtOp -> only64bit $ sizedPrimOp OP_U_LT + Word32LtOp -> sizedPrimOp OP_U_LT + Word16LtOp -> sizedPrimOp OP_U_LT + Word8LtOp -> sizedPrimOp OP_U_LT + AddrLtOp -> sizedPrimOp OP_U_LT + CharLtOp -> sizedPrimOp OP_U_LT + + IntGeOp -> sizedPrimOp OP_S_GE + Int64GeOp -> only64bit $ sizedPrimOp OP_S_GE + Int32GeOp -> sizedPrimOp OP_S_GE + Int16GeOp -> sizedPrimOp OP_S_GE + Int8GeOp -> sizedPrimOp OP_S_GE + WordGeOp -> sizedPrimOp OP_U_GE + Word64GeOp -> only64bit $ sizedPrimOp OP_U_GE + Word32GeOp -> sizedPrimOp OP_U_GE + Word16GeOp -> sizedPrimOp OP_U_GE + Word8GeOp -> sizedPrimOp OP_U_GE + AddrGeOp -> sizedPrimOp OP_U_GE + CharGeOp -> sizedPrimOp OP_U_GE + + IntGtOp -> sizedPrimOp OP_S_GT + Int64GtOp -> only64bit $ sizedPrimOp OP_S_GT + Int32GtOp -> sizedPrimOp OP_S_GT + Int16GtOp -> sizedPrimOp OP_S_GT + Int8GtOp -> sizedPrimOp OP_S_GT + WordGtOp -> sizedPrimOp OP_U_GT + Word64GtOp -> only64bit $ sizedPrimOp OP_U_GT + Word32GtOp -> sizedPrimOp OP_U_GT + Word16GtOp -> sizedPrimOp OP_U_GT + Word8GtOp -> sizedPrimOp OP_U_GT + AddrGtOp -> sizedPrimOp OP_U_GT + CharGtOp -> sizedPrimOp OP_U_GT + + IntLeOp -> sizedPrimOp OP_S_LE + Int64LeOp -> only64bit $ sizedPrimOp OP_S_LE + Int32LeOp -> sizedPrimOp OP_S_LE + Int16LeOp -> sizedPrimOp OP_S_LE + Int8LeOp -> sizedPrimOp OP_S_LE + WordLeOp -> sizedPrimOp OP_U_LE + Word64LeOp -> only64bit $ sizedPrimOp OP_U_LE + Word32LeOp -> sizedPrimOp OP_U_LE + Word16LeOp -> sizedPrimOp OP_U_LE + Word8LeOp -> sizedPrimOp OP_U_LE + AddrLeOp -> sizedPrimOp OP_U_LE + CharLeOp -> sizedPrimOp OP_U_LE + + IntNegOp -> sizedPrimOp OP_NEG + Int64NegOp -> only64bit $ sizedPrimOp OP_NEG + Int32NegOp -> sizedPrimOp OP_NEG + Int16NegOp -> sizedPrimOp OP_NEG + Int8NegOp -> sizedPrimOp OP_NEG + + IntToWordOp -> mk_conv (platformWordWidth platform) + WordToIntOp -> mk_conv (platformWordWidth platform) + Int8ToWord8Op -> mk_conv W8 + Word8ToInt8Op -> mk_conv W8 + Int16ToWord16Op -> mk_conv W16 + Word16ToInt16Op -> mk_conv W16 + Int32ToWord32Op -> mk_conv W32 + Word32ToInt32Op -> mk_conv W32 + Int64ToWord64Op -> only64bit $ mk_conv W64 + Word64ToInt64Op -> only64bit $ mk_conv W64 + IntToAddrOp -> mk_conv (platformWordWidth platform) + AddrToIntOp -> mk_conv (platformWordWidth platform) + ChrOp -> mk_conv (platformWordWidth platform) -- Int# and Char# are rep'd the same + OrdOp -> mk_conv (platformWordWidth platform) + + -- Memory primops, expand the ghci-mem-primops test if you add more. + IndexOffAddrOp_Word8 -> primOpWithRep (OP_INDEX_ADDR W8) W8 + IndexOffAddrOp_Word16 -> primOpWithRep (OP_INDEX_ADDR W16) W16 + IndexOffAddrOp_Word32 -> primOpWithRep (OP_INDEX_ADDR W32) W32 + IndexOffAddrOp_Word64 -> only64bit $ primOpWithRep (OP_INDEX_ADDR W64) W64 + + _ -> Nothing + where + only64bit = if platformWordWidth platform == W64 then id else const Nothing + primArg1Width :: StgArg -> Width + primArg1Width arg + | rep <- (stgArgRepU arg) + = case rep of + AddrRep -> platformWordWidth platform + IntRep -> platformWordWidth platform + WordRep -> platformWordWidth platform + + Int64Rep -> W64 + Word64Rep -> W64 + + Int32Rep -> W32 + Word32Rep -> W32 + + Int16Rep -> W16 + Word16Rep -> W16 + + Int8Rep -> W8 + Word8Rep -> W8 + + FloatRep -> unexpectedRep + DoubleRep -> unexpectedRep + + BoxedRep{} -> unexpectedRep + VecRep{} -> unexpectedRep + where + unexpectedRep = panic "doPrimOp: Unexpected argument rep" + + + -- TODO: The slides for the result need to be two words on 32bit for 64bit ops. + mkNReturn width + | W64 <- width = RETURN L -- L works for 64 bit on any platform + | otherwise = RETURN N -- <64bit width, fits in word on all platforms + + mkSlideWords width = if platformWordWidth platform < width then 2 else 1 + + -- Push args, execute primop, slide, return_N + -- Decides width of operation based on first argument. + sizedPrimOp op_inst = Just $ do + let width = primArg1Width (head args) + prim_code <- mkPrimOpCode init_d s p (op_inst width) $ args + let slide = mkSlideW (mkSlideWords width) (bytesToWords platform $ init_d - s) `snocOL` mkNReturn width + return $ prim_code `appOL` slide + + -- primOpWithRep op w => operation @op@ resulting in result @w@ wide. + primOpWithRep :: BCInstr -> Width -> Maybe (BcM (OrdList BCInstr)) + primOpWithRep op_inst result_width = Just $ do + prim_code <- mkPrimOpCode init_d s p op_inst $ args + let slide = mkSlideW (mkSlideWords result_width) (bytesToWords platform $ init_d - s) `snocOL` mkNReturn result_width + return $ prim_code `appOL` slide + + -- Coerce the argument, requires them to be the same size + mk_conv :: Width -> Maybe (BcM (OrdList BCInstr)) + mk_conv target_width = Just $ do + let width = primArg1Width (head args) + massert (width == target_width) + (push_code, _bytes) <- pushAtom init_d p (head args) + let slide = mkSlideW (mkSlideWords target_width) (bytesToWords platform $ init_d - s) `snocOL` mkNReturn target_width + return $ push_code `appOL` slide + +-- Push the arguments on the stack and emit the given instruction +-- Pushes at least one word per non void arg. +mkPrimOpCode + :: StackDepth + -> Sequel + -> BCEnv + -> BCInstr -- The operator + -> [StgArg] -- Args, in *reverse* order (must be fully applied) + -> BcM BCInstrList +mkPrimOpCode orig_d _ p op_inst args = app_code + where + app_code = do + profile <- getProfile + let _platform = profilePlatform profile + + do_pushery :: StackDepth -> [StgArg] -> BcM BCInstrList + do_pushery !d (arg : args) = do + (push,arg_bytes) <- pushAtom d p arg + more_push_code <- do_pushery (d + arg_bytes) args + return (push `appOL` more_push_code) + do_pushery !_d [] = do + return (unitOL op_inst) + + -- Push on the stack in the reverse order. + do_pushery orig_d (reverse args) + -- v. similar to CgStackery.findMatch, ToDo: merge findPushSeq :: [ArgRep] -> (BCInstr, Int, [ArgRep]) findPushSeq (P: P: P: P: P: P: rest) @@ -1069,9 +1386,10 @@ | ubx_tuple_frame = SLIDE 0 2 `consOL` alt_final0 | otherwise = alt_final0 + add_bco_name <- shouldAddBcoName let alt_bco_name = getName bndr - alt_bco = mkProtoBCO platform alt_bco_name alt_final (Left alts) + alt_bco = mkProtoBCO platform add_bco_name alt_bco_name alt_final (Left alts) 0{-no arity-} bitmap_size bitmap True{-is alts-} scrut_code <- schemeE (d + ret_frame_size_b + save_ccs_size_b) (d + ret_frame_size_b + save_ccs_size_b) @@ -1379,7 +1697,7 @@ tupleBCO :: Platform -> NativeCallInfo -> [(PrimRep, ByteOff)] -> [FFIInfo] -> ProtoBCO Name tupleBCO platform args_info args = - mkProtoBCO platform invented_name body_code (Left []) + mkProtoBCO platform False invented_name body_code (Left []) 0{-no arity-} bitmap_size bitmap False{-is alts-} where {- @@ -1398,9 +1716,9 @@ body_code = mkSlideW 0 1 -- pop frame header `snocOL` RETURN_TUPLE -- and add it again -primCallBCO :: Platform -> NativeCallInfo -> [(PrimRep, ByteOff)] -> [FFIInfo] -> ProtoBCO Name +primCallBCO :: Platform -> NativeCallInfo -> [(PrimRep, ByteOff)] -> [FFIInfo] -> ProtoBCO Name primCallBCO platform args_info args = - mkProtoBCO platform invented_name body_code (Left []) + mkProtoBCO platform False invented_name body_code (Left []) 0{-no arity-} bitmap_size bitmap False{-is alts-} where {- @@ -2341,6 +2659,9 @@ getProfile :: BcM Profile getProfile = targetProfile <$> getDynFlags + +shouldAddBcoName :: BcM Bool +shouldAddBcoName = gopt Opt_AddBcoName <$> getDynFlags emitBc :: ([FFIInfo] -> ProtoBCO Name) -> BcM (ProtoBCO Name) emitBc bco diff --git a/GHC/StgToCmm/Prim.hs b/GHC/StgToCmm/Prim.hs --- a/GHC/StgToCmm/Prim.hs +++ b/GHC/StgToCmm/Prim.hs @@ -1571,28 +1571,28 @@ CastDoubleToWord64Op -> translateBitcasts (MO_FW_Bitcast W64) CastWord64ToDoubleOp -> translateBitcasts (MO_WF_Bitcast W64) - IntQuotRemOp -> opCallishHandledLater $ - if allowQuotRem + IntQuotRemOp -> \args -> flip opCallishHandledLater args $ + if allowQuotRem && not (quotRemCanBeOptimized args) then Left (MO_S_QuotRem (wordWidth platform)) else Right (genericIntQuotRemOp (wordWidth platform)) - Int8QuotRemOp -> opCallishHandledLater $ - if allowQuotRem + Int8QuotRemOp -> \args -> flip opCallishHandledLater args $ + if allowQuotRem && not (quotRemCanBeOptimized args) then Left (MO_S_QuotRem W8) else Right (genericIntQuotRemOp W8) - Int16QuotRemOp -> opCallishHandledLater $ - if allowQuotRem + Int16QuotRemOp -> \args -> flip opCallishHandledLater args $ + if allowQuotRem && not (quotRemCanBeOptimized args) then Left (MO_S_QuotRem W16) else Right (genericIntQuotRemOp W16) - Int32QuotRemOp -> opCallishHandledLater $ - if allowQuotRem + Int32QuotRemOp -> \args -> flip opCallishHandledLater args $ + if allowQuotRem && not (quotRemCanBeOptimized args) then Left (MO_S_QuotRem W32) else Right (genericIntQuotRemOp W32) - WordQuotRemOp -> opCallishHandledLater $ - if allowQuotRem + WordQuotRemOp -> \args -> flip opCallishHandledLater args $ + if allowQuotRem && not (quotRemCanBeOptimized args) then Left (MO_U_QuotRem (wordWidth platform)) else Right (genericWordQuotRemOp (wordWidth platform)) @@ -1601,18 +1601,18 @@ then Left (MO_U_QuotRem2 (wordWidth platform)) else Right (genericWordQuotRem2Op platform) - Word8QuotRemOp -> opCallishHandledLater $ - if allowQuotRem + Word8QuotRemOp -> \args -> flip opCallishHandledLater args $ + if allowQuotRem && not (quotRemCanBeOptimized args) then Left (MO_U_QuotRem W8) else Right (genericWordQuotRemOp W8) - Word16QuotRemOp -> opCallishHandledLater $ - if allowQuotRem + Word16QuotRemOp -> \args -> flip opCallishHandledLater args $ + if allowQuotRem && not (quotRemCanBeOptimized args) then Left (MO_U_QuotRem W16) else Right (genericWordQuotRemOp W16) - Word32QuotRemOp -> opCallishHandledLater $ - if allowQuotRem + Word32QuotRemOp -> \args -> flip opCallishHandledLater args $ + if allowQuotRem && not (quotRemCanBeOptimized args) then Left (MO_U_QuotRem W32) else Right (genericWordQuotRemOp W32) @@ -1835,6 +1835,23 @@ pure $ map (CmmReg . CmmLocal) regs alwaysExternal = \_ -> PrimopCmmEmit_External + -- Note [QuotRem optimization] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- `quot` and `rem` with constant divisor can be implemented with fast bit-ops + -- (shift, .&.). + -- + -- Currently we only support optimization (performed in GHC.Cmm.Opt) when the + -- constant is a power of 2. #9041 tracks the implementation of the general + -- optimization. + -- + -- `quotRem` can be optimized in the same way. However as it returns two values, + -- it is implemented as a "callish" primop which is harder to match and + -- to transform later on. For simplicity, the current implementation detects cases + -- that can be optimized (see `quotRemCanBeOptimized`) and converts STG quotRem + -- primop into two CMM quot and rem primops. + quotRemCanBeOptimized = \case + [_, CmmLit (CmmInt n _) ] -> isJust (exactLog2 n) + _ -> False allowQuotRem = stgToCmmAllowQuotRemInstr cfg allowQuotRem2 = stgToCmmAllowQuotRem2 cfg diff --git a/GHC/StgToJS/Linker/Linker.hs b/GHC/StgToJS/Linker/Linker.hs --- a/GHC/StgToJS/Linker/Linker.hs +++ b/GHC/StgToJS/Linker/Linker.hs @@ -2,6 +2,7 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE BlockArguments #-} +{-# LANGUAGE MultiWayIf #-} ----------------------------------------------------------------------------- -- | @@ -654,12 +655,19 @@ getPackageArchives :: StgToJSConfig -> UnitEnv -> [UnitId] -> IO [FilePath] -getPackageArchives cfg unit_env units = - filterM doesFileExist [ ST.unpack p "lib" ++ ST.unpack l ++ profSuff <.> "a" - | u <- units - , p <- getInstalledPackageLibDirs ue_state u - , l <- getInstalledPackageHsLibs ue_state u - ] +getPackageArchives cfg unit_env units = do + fmap concat $ forM units $ \u -> do + let archives = [ ST.unpack p "lib" ++ ST.unpack l ++ profSuff <.> "a" + | p <- getInstalledPackageLibDirs ue_state u + , l <- getInstalledPackageHsLibs ue_state u + ] + foundArchives <- filterM doesFileExist archives + if | not (null archives) + , null foundArchives + -> do + throwGhcExceptionIO (InstallationError $ "Could not find any library archives for unit-id: " <> (renderWithContext (csContext cfg) $ ppr u)) + | otherwise + -> pure foundArchives where ue_state = ue_units unit_env diff --git a/GHC/Tc/Deriv.hs b/GHC/Tc/Deriv.hs --- a/GHC/Tc/Deriv.hs +++ b/GHC/Tc/Deriv.hs @@ -575,21 +575,20 @@ , text "deriv_pred" <+> ppr deriv_pred , text "mb_lderiv_strat" <+> ppr mb_lderiv_strat , text "via_tvs" <+> ppr via_tvs ] - (cls_tvs, cls, cls_tys, cls_arg_kinds) <- tcHsDeriv deriv_pred - when (cls_arg_kinds `lengthIsNot` 1) $ - failWithTc (TcRnNonUnaryTypeclassConstraint DerivClauseCtxt deriv_pred) - let [cls_arg_kind] = cls_arg_kinds - mb_deriv_strat = fmap unLoc mb_lderiv_strat - if (className cls == typeableClassName) - then do warnUselessTypeable - return Nothing - else let deriv_tvs = via_tvs ++ cls_tvs in - Just <$> deriveTyData tc tys mb_deriv_strat - deriv_tvs cls cls_tys cls_arg_kind + mb_cls_minus1 <- tcHsDeriv deriv_pred + case mb_cls_minus1 of + Nothing -> return Nothing + Just (cls, cls_tvs, arg_tys, arg_kind) -> + do let mb_deriv_strat = fmap unLoc mb_lderiv_strat + if className cls == typeableClassName + then do warnUselessTypeable + return Nothing + else let deriv_tvs = via_tvs ++ cls_tvs in + Just <$> deriveTyData tc tys mb_deriv_strat + deriv_tvs cls arg_tys arg_kind -{- -Note [Don't typecheck too much in DerivingVia] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +{- Note [Don't typecheck too much in DerivingVia] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider the following example: data D = ... diff --git a/GHC/Tc/Errors/Ppr.hs b/GHC/Tc/Errors/Ppr.hs --- a/GHC/Tc/Errors/Ppr.hs +++ b/GHC/Tc/Errors/Ppr.hs @@ -991,11 +991,11 @@ TcRnIllegalDerivingItem hs_ty -> mkSimpleDecorated $ text "Illegal deriving item" <+> quotes (ppr hs_ty) - TcRnIllegalDefaultClass hs_ty + TcRnIllegalDefaultClass nm -> mkSimpleDecorated $ - quotes (ppr hs_ty) <+> text "is not a class" + text "Illegal named default declaration for non-class" <+> quotes (ppr nm) TcRnIllegalNamedDefault hs_decl - -> mkSimpleDecorated $ text "Illegal use of default class name:" <+> quotes (ppr hs_decl) + -> mkSimpleDecorated $ text "Illegal named default declaration" <+> quotes (ppr hs_decl) TcRnUnexpectedAnnotation ty bang -> mkSimpleDecorated $ let err = case bang of diff --git a/GHC/Tc/Errors/Types.hs b/GHC/Tc/Errors/Types.hs --- a/GHC/Tc/Errors/Types.hs +++ b/GHC/Tc/Errors/Types.hs @@ -1496,7 +1496,7 @@ Test cases: typecheck/should_fail/T11974b -} - TcRnBadDefaultType :: Type -> NE.NonEmpty Class -> TcRnMessage + TcRnBadDefaultType :: LHsType GhcRn -> NE.NonEmpty Class -> TcRnMessage {-| TcRnPatSynBundledWithNonDataCon is an error that occurs when a module's export list bundles a pattern synonym with a type that is not a proper @@ -1834,7 +1834,7 @@ deriving/should_fail/drvfail009 deriving/should_fail/drvfail006 -} - TcRnNonUnaryTypeclassConstraint :: !UserTypeCtxt -> !(LHsSigType GhcRn) -> TcRnMessage + TcRnNonUnaryTypeclassConstraint :: !UserTypeCtxt -> !TypedThing -> TcRnMessage {-| TcRnPartialTypeSignatures is a warning (controlled by -Wpartial-type-signatures) that occurs when a wildcard '_' is found in place of a type in a signature or a @@ -2240,7 +2240,7 @@ Test cases: default/fail01 -} - TcRnIllegalDefaultClass :: !(LHsSigType GhcRn) -> TcRnMessage + TcRnIllegalDefaultClass :: !Name -> TcRnMessage {-| TcRnIllegalNamedDefault is an error for specifying an explicit default class name without @-XNamedDefaults@. diff --git a/GHC/Tc/Gen/Default.hs b/GHC/Tc/Gen/Default.hs --- a/GHC/Tc/Gen/Default.hs +++ b/GHC/Tc/Gen/Default.hs @@ -3,39 +3,48 @@ (c) The AQUA Project, Glasgow University, 1993-1998 -} +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE TypeFamilies #-} -- | Typechecking @default@ declarations module GHC.Tc.Gen.Default ( tcDefaults ) where import GHC.Prelude - import GHC.Hs + +import GHC.Builtin.Names import GHC.Core.Class -import GHC.Core.Type( typeKind ) +import GHC.Core.Predicate ( Pred (..), classifyPredType ) -import GHC.Types.Var( tyVarKind ) +import GHC.Data.Maybe ( firstJusts ) + import GHC.Tc.Errors.Types -import GHC.Tc.Utils.Monad -import GHC.Tc.Utils.Env import GHC.Tc.Gen.HsType -import GHC.Tc.Zonk.Type -import GHC.Tc.Solver -import GHC.Tc.Validity +import GHC.Tc.Solver ( solveWanteds ) +import GHC.Tc.Solver.Monad ( runTcS ) +import GHC.Tc.Types.Constraint ( isEmptyWC, andWC, mkSimpleWC ) +import GHC.Tc.Types.Origin ( CtOrigin(DefaultOrigin) ) +import GHC.Tc.Utils.Env +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.TcMType ( newWanted ) import GHC.Tc.Utils.TcType -import GHC.Builtin.Names + +import GHC.Types.Basic ( TypeOrKind(..) ) import GHC.Types.DefaultEnv ( DefaultEnv, ClassDefaults (..), defaultEnv ) import GHC.Types.Error import GHC.Types.SrcLoc import GHC.Unit.Types (Module, bignumUnit, ghcInternalUnit, moduleUnit, primUnit) + import GHC.Utils.Misc (fstOf3, sndOf3) import GHC.Utils.Outputable + import qualified GHC.LanguageExtensions as LangExt -import Control.Monad (void) import Data.Function (on) import Data.List.NonEmpty ( NonEmpty (..), groupBy ) import qualified Data.List.NonEmpty as NE +import Data.Maybe (fromMaybe) +import Data.Traversable ( for ) {- Note [Named default declarations] @@ -140,99 +149,189 @@ -- defaultDefaultTys tcDefaults decls - = do { ovl_str <- xoptM LangExt.OverloadedStrings - ; ext_deflt <- xoptM LangExt.ExtendedDefaultRules - ; deflt_str <- if ovl_str - then mapM tcLookupClass [isStringClassName] - else return [] - ; deflt_interactive <- if ext_deflt - then mapM tcLookupClass interactiveClassNames - else return [] - ; tcg_env <- getGblEnv - ; let extra_clss = deflt_str ++ deflt_interactive - here = tcg_mod tcg_env - is_internal_unit = moduleUnit here `elem` [bignumUnit, ghcInternalUnit, primUnit] - ; decls' <- case (is_internal_unit, decls) of + = do { tcg_env <- getGblEnv + ; let + here = tcg_mod tcg_env + is_internal_unit = moduleUnit here `elem` [bignumUnit, ghcInternalUnit, primUnit] + ; case (is_internal_unit, decls) of -- Some internal GHC modules contain @default ()@ to declare that no defaults can take place -- in the module. -- We shortcut the treatment of such a default declaration with no class nor types: we won't -- try to point 'cd_class' to 'Num' since it may not even exist yet. - (True, [L _ (DefaultDecl _ Nothing [])]) -> pure [] + { (True, [L _ (DefaultDecl _ Nothing [])]) + -> return $ defaultEnv [] -- Otherwise we take apart the declaration into the class constructor and its default types. - _ -> mapM (declarationParts extra_clss) decls - ; defaultEnv . concat <$> mapM (reportDuplicates here extra_clss) (groupBy ((==) `on` sndOf3) decls') } + ; _ -> + do { h2010_dflt_clss <- getH2010DefaultClasses + ; decls' <- mapMaybeM (declarationParts h2010_dflt_clss) decls + ; let + -- Find duplicate default declarations + decl_tag (mb_cls, _, _) = + case mb_cls of + Nothing -> Nothing + Just cls -> if cls `elem` h2010_dflt_clss + then Nothing + else Just cls + decl_groups = groupBy ((==) `on` decl_tag) decls' + ; decls_without_dups <- mapM (reportDuplicates here h2010_dflt_clss) decl_groups + ; return $ defaultEnv (concat decls_without_dups) + } } } where - declarationParts :: [Class] -> LDefaultDecl GhcRn -> TcM (LDefaultDecl GhcRn, Class, [Type]) - reportDuplicates :: Module -> [Class] -> NonEmpty (LDefaultDecl GhcRn, Class, [Type]) -> TcM [ClassDefaults] - declarationParts extra_clss decl@(L locn (DefaultDecl _ cls_tyMaybe mono_tys)) - = addErrCtxt defaultDeclCtxt $ - setSrcSpan (locA locn) $ - do { tau_tys <- mapAndReportM tc_default_ty mono_tys - ; def_clsCon <- case cls_tyMaybe of - Nothing -> - do { numTyCls <- tcLookupClass numClassName - ; let classTyConAndArgKinds cls = (cls, [], tyVarKind <$> classTyVars cls) - tyConsAndArgKinds = (numTyCls, [], [liftedTypeKind]) :| map classTyConAndArgKinds extra_clss - ; void $ mapAndReportM (check_instance_any tyConsAndArgKinds) tau_tys - ; return numTyCls } - Just cls_name -> - do { named_deflt <- xoptM LangExt.NamedDefaults - ; checkErr named_deflt (TcRnIllegalNamedDefault decl) - ; let cls_ty = noLocA (HsSig { sig_ext = noExtField - , sig_bndrs = HsOuterImplicit{hso_ximplicit = []} - , sig_body = noLocA $ HsTyVar noAnn NotPromoted cls_name}) - ; (_cls_tvs, cls, cls_tys, cls_arg_kinds) <- tcHsDefault cls_ty - ; case cls_arg_kinds - of [k] -> void $ mapAndReportM (check_instance_any (NE.singleton (cls, cls_tys, [k]))) tau_tys - _ -> addErrTc (TcRnNonUnaryTypeclassConstraint DefaultDeclCtxt cls_ty) - ; return cls } - ; return (decl, def_clsCon, tau_tys) } - reportDuplicates here extra_clss ((_, clsCon, tys) :| []) - = pure [ ClassDefaults{cd_class = c, cd_types = tys, cd_module = Just here, cd_warn = Nothing} - | c <- clsCon : extra_clss ] + getH2010DefaultClasses :: TcM (NonEmpty Class) + -- All the classes subject to defaulting with a Haskell 2010 default + -- declaration, of the form: + -- + -- default (Int, Bool, Float) + -- + -- Specifically: + -- No extensions: Num + -- OverloadedStrings: add IsString + -- ExtendedDefaults: add Show, Eq, Ord, Foldable, Traversable + getH2010DefaultClasses + = do { num_cls <- tcLookupClass numClassName + ; ovl_str <- xoptM LangExt.OverloadedStrings + ; ext_deflt <- xoptM LangExt.ExtendedDefaultRules + ; deflt_str <- if ovl_str + then mapM tcLookupClass [isStringClassName] + else return [] + ; deflt_interactive <- if ext_deflt + then mapM tcLookupClass interactiveClassNames + else return [] + ; let extra_clss = deflt_str ++ deflt_interactive + ; return $ num_cls :| extra_clss + } + declarationParts :: NonEmpty Class -> LDefaultDecl GhcRn -> TcM (Maybe (Maybe Class, LDefaultDecl GhcRn, [Type])) + declarationParts h2010_dflt_clss decl@(L locn (DefaultDecl _ mb_cls_name dflt_hs_tys)) + = setSrcSpan (locA locn) $ + case mb_cls_name of + -- Haskell 98 default declaration + Nothing -> + do { tau_tys <- addErrCtxt defaultDeclCtxt + $ mapMaybeM (check_instance_any h2010_dflt_clss) dflt_hs_tys + ; return $ Just (Nothing, decl, tau_tys) } + -- Named default declaration + Just cls_name -> + do { named_deflt <- xoptM LangExt.NamedDefaults + ; checkErr named_deflt (TcRnIllegalNamedDefault decl) + ; mb_cls <- addErrCtxt defaultDeclClassCtxt + $ tcDefaultDeclClass cls_name + ; for mb_cls $ \ cls -> + do { tau_tys <- addErrCtxt defaultDeclCtxt + $ mapMaybeM (check_instance_any (NE.singleton cls)) dflt_hs_tys + ; return (Just cls, decl, tau_tys) + } } + + reportDuplicates :: Module -> NonEmpty Class -> NonEmpty (Maybe Class, LDefaultDecl GhcRn, [Type]) -> TcM [ClassDefaults] + reportDuplicates here h2010_dflt_clss ((mb_cls, _, tys) :| []) + = pure [ ClassDefaults{cd_class = c, cd_types = tys, cd_module = Just here, cd_warn = Nothing } + | c <- case mb_cls of + Nothing -> NE.toList h2010_dflt_clss + Just cls -> [cls] + ] -- Report an error on multiple default declarations for the same class in the same module. -- See Note [Disambiguation of multiple default declarations] in GHC.Tc.Module - reportDuplicates _ _ decls@((L locn _, cls, _) :| _) - = setSrcSpan (locA locn) (addErrTc $ dupDefaultDeclErr cls (fstOf3 <$> decls)) + reportDuplicates _ (num_cls :| _) decls@((_, L locn _, _) :| _) + = setSrcSpan (locA locn) (addErrTc $ dupDefaultDeclErr cls (sndOf3 <$> decls)) >> pure [] - -tc_default_ty :: LHsType GhcRn -> TcM Type -tc_default_ty hs_ty - = do { ty <- solveEqualities "tc_default_ty" $ - tcInferLHsType hs_ty - ; ty <- zonkTcTypeToType ty -- establish Type invariants - ; checkValidType DefaultDeclCtxt ty - ; return ty } + where + cls = fromMaybe num_cls $ firstJusts (fmap fstOf3 decls) --- Check that the type is an instance of at least one of the default classes. --- Beside the class type constructor, we take the already-supplied type --- parameters and the expected kinds of the remaining parameters. We report --- an error unless there's only one remaining parameter to fill and the given --- type has the expected kind. -check_instance_any :: NonEmpty (Class, [Type], [Kind]) -> Type -> TcM () +-- | Check that the type is an instance of at least one of the default classes. +-- +-- See Note [Instance check for default declarations] +check_instance_any :: NonEmpty Class + -- ^ classes, all assumed to be unary + -> LHsType GhcRn + -- ^ default type + -> TcM (Maybe Type) check_instance_any deflt_clss ty - = do { oks <- mapM (check_instance ty) deflt_clss - ; checkTc (or oks) (TcRnBadDefaultType ty (NE.map fstOf3 deflt_clss)) + = do { oks <- mapM (\ cls -> simplifyDefault cls ty) deflt_clss + ; case firstJusts oks of + Nothing -> + do { addErrTc $ TcRnBadDefaultType ty deflt_clss + ; return Nothing } + Just ty -> + return $ Just ty } -check_instance :: Type -> (Class, [Type], [Kind]) -> TcM Bool --- Check that ty is an instance of cls --- We only care about whether it worked or not; return a boolean --- This checks that cls :: k -> Constraint --- with just one argument and no polymorphism; if we need to add --- polymorphism we can make it more complicated. For now we are --- concerned with classes like --- Num :: Type -> Constraint --- Foldable :: (Type->Type) -> Constraint -check_instance ty (cls, clsArgs, [cls_argKind]) - | cls_argKind `tcEqType` typeKind ty - = simplifyDefault [mkTyConApp (classTyCon cls) (clsArgs ++ [ty])] -check_instance _ _ - = return False +-- | Given a class @C@ and a type @ty@, is @C ty@ soluble? +-- +-- Used to check that a type is an instance of a class in a default +-- declaration. +-- +-- See Note [Instance check for default declarations] in GHC.Tc.Solver.Default. +simplifyDefault + :: Class -- ^ class, assumed to be unary,i.e. it takes some invisible arguments + -- and then a single (final) visible argument + -> LHsType GhcRn -- ^ default type + -> TcM (Maybe Type) +simplifyDefault cls dflt_ty@(L l _) + = do { let app_ty :: LHsType GhcRn + app_ty = L l $ HsAppTy noExtField (nlHsTyVar NotPromoted (className cls)) dflt_ty + ; (inst_pred, wtds) <- captureConstraints $ tcCheckLHsType app_ty constraintKind + ; wtd_inst <- newWanted DefaultOrigin (Just TypeLevel) inst_pred + ; let all_wanteds = wtds `andWC` mkSimpleWC [wtd_inst] + ; (unsolved, _) <- runTcS $ solveWanteds all_wanteds + ; traceTc "simplifyDefault" $ + vcat [ text "cls:" <+> ppr cls + , text "dflt_ty:" <+> ppr dflt_ty + , text "inst_pred:" <+> ppr inst_pred + , text "all_wanteds " <+> ppr all_wanteds + , text "unsolved:" <+> ppr unsolved ] + ; let is_instance = isEmptyWC unsolved + ; return $ + if | is_instance + , ClassPred _ tys <- classifyPredType inst_pred + -- inst_pred looks like (C @k1 .. @kn t); + -- we want the final (visible) argument `t` + , Just tys_ne <- NE.nonEmpty tys + -> Just $ NE.last tys_ne + | otherwise + -> Nothing + } defaultDeclCtxt :: SDoc defaultDeclCtxt = text "When checking the types in a default declaration" +defaultDeclClassCtxt :: SDoc +defaultDeclClassCtxt = text "When checking the class at the head of a named default declaration" + dupDefaultDeclErr :: Class -> NonEmpty (LDefaultDecl GhcRn) -> TcRnMessage dupDefaultDeclErr cls (L _ DefaultDecl {} :| dup_things) = TcRnMultipleDefaultDeclarations cls dup_things + +{- Note [Instance check for default declarations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we see a named default declaration, such as: + + default C(ty_1, ..., ty_n) + +we must check that each of the types 'ty1', ..., 'ty_n' is an instance of +the class 'C'. For each individual type 'ty', the strategy is thus: + + - Create a new Wanted constraint 'C ty', and run the solver on it. + The default declaration 'default C(ty)' is valid iff the solver succeeds + in solving this constraint (with no residual unsolved Wanteds). + +This is implemented in GHC.Tc.Gen.Default.check_instance, and tested in T25882. + +The only slightly subtle point is that we want to allow classes such as + + Typeable :: forall k. k -> Constraint + +which take invisible arguments and a (single) visible argument. The function +GHC.Tc.Gen.HsType.tcDefaultDeclClass checks that the class 'C' takes a single +visible parameter. + +Note that Haskell98 default declarations, of the form + + default (ty_1, ..., ty_n) + +work similarly, except that instead of checking for a single class, we check +whether each type is an instance of: + + - only the Num class, by default + - ... or the IsString class, with -XOverloadedStrings + - ... or any of the Show, Eq, Ord, Foldable, and Traversable classes, + with -XExtendedDefaultRules +-} diff --git a/GHC/Tc/Gen/Expr.hs b/GHC/Tc/Gen/Expr.hs --- a/GHC/Tc/Gen/Expr.hs +++ b/GHC/Tc/Gen/Expr.hs @@ -1153,13 +1153,34 @@ Note [Type-directed record disambiguation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -GHC currently supports an additional type-directed disambiguation -mechanism, which is deprecated and scheduled for removal as part of -GHC proposal #366 https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0366-no-ambiguous-field-access.rst. +Deprecation notice: + The type-directed disambiguation mechanism for record updates described in + this Note is deprecated, as per GHC proposal #366 (https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0366-no-ambiguous-field-access.rst). + The removal of type-directed disambiguation for record updates is tracked + in GHC ticket #19461, but progress towards this goal has stalled. -To perform this disambiguation, when there are multiple possible parents for -a record update, the renamer defers to the typechecker. -See GHC.Tc.Gen.Expr.disambiguateRecordBinds, and in particular the auxiliary + Why? There are several suggested replacement mechanisms, such as: + 1. using module qualification to disambiguate, + 2. using OverloadedRecordUpdate for type-directed disambiguation + (as described in Note [Overview of record dot syntax] in GHC.Hs.Expr). + However, these solutions do not work in all situations: + 1. Module qualification doesn't work for fields defined in the current module, + nor to disambiguate between constructors of different data family instances + of a given parent data family TyCon. + 2. OverloadedRecordUpdate does not allow for type-changing record update, + nor can it deal with fields with existentials or polytypes. + There are also some avenues to improve the renamer's ability to disambiguate: + - GHC ticket #23032 suggests using as-patterns to disambiguate in the renamer. + - GHC proposal https://github.com/ghc-proposals/ghc-proposals/pull/537 + suggests a syntactic form of type-directed disambiguation that could be + carried out in the renamer. + Neither of these have been accepted/implemented at the time of writing (Sept 2025). + This means that removal of type-directed disambiguation is currently stalled. + +GHC tries to disambiguate record updates in the renamer, as described in +Note [Disambiguating record updates] in GHC.Rename.Pat. However, if the renamer +is unable to disambiguate, the renamer will defer to the typechecker: see +GHC.Tc.Gen.Expr.disambiguateRecordBinds, and in particular the auxiliary function identifyParentLabels, which picks a parent for the record update using the following additional mechanisms: diff --git a/GHC/Tc/Gen/HsType.hs b/GHC/Tc/Gen/HsType.hs --- a/GHC/Tc/Gen/HsType.hs +++ b/GHC/Tc/Gen/HsType.hs @@ -25,7 +25,7 @@ funsSigCtxt, addSigCtxt, pprSigCtxt, tcHsClsInstType, - tcHsDefault, tcHsDeriv, tcDerivStrategy, + tcDefaultDeclClass, tcHsDeriv, tcDerivStrategy, tcHsTypeApp, UserTypeCtxt(..), bindImplicitTKBndrs_Tv, bindImplicitTKBndrs_Skol, @@ -630,53 +630,77 @@ where skol_info_anon = SigTypeSkol ctxt -tcClassConstraint :: Type -> TcM (Either (Maybe TyCon) ([TyVar], Class, [Type], [Kind])) --- Like tcHsSigType, but for a simple class constraint of form ( C ty1 ty2 ) --- Returns the C, [ty1, ty2], and the kinds of C's remaining arguments --- E.g. class C (a::*) (b::k->k) --- tcClassConstraint ( C Int ) returns Right ([k], C, [k, Int], [k->k]) --- Return values are fully zonked -tcClassConstraint ty - = do { let (tvs, pred) = splitForAllTyCoVars ty - (kind_args, _) = splitFunTys (typeKind pred) - -- Checking that `pred` a is type class application - ; case splitTyConApp_maybe pred of - Just (tyCon, tyConArgs) -> - case tyConClass_maybe tyCon of - Just clas -> - return (Right (tvs, clas, tyConArgs, map scaledThing kind_args)) - Nothing -> return (Left (Just tyCon)) - Nothing -> return (Left Nothing) } +-- | Typecheck the class in a default declaration, checking that: +-- +-- - it is indeed a class (not e.g. a type family), +-- - that the class expects some invisible arguments followed +-- by a single visible argument. +tcDefaultDeclClass :: LIdP GhcRn -> TcM (Maybe Class) +tcDefaultDeclClass l_nm + = setSrcSpan (locA l_nm) $ + do { let nm = unLoc l_nm + ; thing <- tcLookupGlobal nm + ; case thing of + ATyCon tc + | Just cls <- tyConClass_maybe tc + -> if is_unary (tyConBinders tc) + then return $ Just cls + else + do { addErrTc $ TcRnNonUnaryTypeclassConstraint DefaultDeclCtxt (NameThing nm) + ; return Nothing } -tcHsDefault :: LHsSigType GhcRn -> TcM ([TyVar], Class, [Type], [Kind]) --- Like tcHsSigType, but for the default ( C ty1 ty2 ) (ty1', ty2', ...) declaration --- See Note [Named default declarations] in GHC.Tc.Gen.Default -tcHsDefault hs_ty - = tcTopLHsType DefaultDeclCtxt hs_ty - >>= tcClassConstraint - >>= either (const $ failWithTc $ TcRnIllegalDefaultClass hs_ty) return + _ -> do { addErrTc $ TcRnIllegalDefaultClass nm + ; return Nothing } + } + where + is_unary :: [TyConBinder] -> Bool + is_unary = ( `lengthIs` 1 ) . dropWhile isInvisibleTyConBinder ----------------- -tcHsDeriv :: LHsSigType GhcRn -> TcM ([TyVar], Class, [Type], [Kind]) --- Like tcHsSigType, but for the ...deriving( C ty1 ty2 ) clause --- Returns the C, [ty1, ty2], and the kinds of C's remaining arguments --- E.g. class C (a::*) (b::k->k) --- data T a b = ... deriving( C Int ) --- returns ([k], C, [k, Int], [k->k]) +tcHsDeriv :: LHsSigType GhcRn -> TcM (Maybe (Class, [TyCoVar], [Type], Kind)) +-- ^ Like tcHsSigType, but for the @...deriving( C ty1 ty2 )@ clause +-- +-- Returns a class constraint with the last argument missing, and the +-- expected kind of the remaining argument. +-- +-- E.g.: +-- +-- @class C (a::*) (b::k->k)@ +-- @data T a b = ... deriving( C Int )@ +-- +-- This function returns @(C, [k], [k, Int], k->k)@. +-- -- Return values are fully zonked tcHsDeriv hs_ty = do { ty <- tcTopLHsType DerivClauseCtxt hs_ty - ; constrained <- tcClassConstraint ty - ; case constrained of - Left Nothing -> failWithTc (TcRnIllegalDerivingItem hs_ty) - Left (Just tyCon) -> - failWithTc $ TcRnIllegalInstance - $ IllegalClassInstance (TypeThing ty) - $ IllegalInstanceHead - $ InstHeadNonClass - $ Just tyCon - Right result -> return result } + ; let (tvs, pred) = splitForAllTyCoVars ty + (kind_args, _) = splitFunTys (typeKind pred) + -- Checking that `pred` a is type class application + + ; case splitTyConApp_maybe pred of + Just (tc, tc_args) -> + case tyConClass_maybe tc of + Just cls -> + case kind_args of + [Scaled _ last_kind] -> + return $ Just $ + (cls, tvs, tc_args, last_kind) + _ -> + do { addErrTc $ TcRnNonUnaryTypeclassConstraint DerivClauseCtxt (TypeThing pred) + ; return Nothing + } + Nothing -> + do { addErrTc $ TcRnIllegalInstance + $ IllegalClassInstance (TypeThing ty) + $ IllegalInstanceHead + $ InstHeadNonClass + $ Just tc + ; return Nothing } + Nothing -> + do { addErrTc $ TcRnIllegalDerivingItem hs_ty; return Nothing } + } + -- | Typecheck a deriving strategy. For most deriving strategies, this is a -- no-op, but for the @via@ strategy, this requires typechecking the @via@ type. tcDerivStrategy :: Maybe (LDerivStrategy GhcRn) @@ -1242,8 +1266,10 @@ = checkExpKind rn_ty liftedTypeKind liftedTypeKind exp_kind --------- Literals -tcHsType _ rn_ty@(HsTyLit _ (HsNumTy _ n)) exp_kind - = do { checkWiredInTyCon naturalTyCon +tcHsType _ rn_ty@(HsTyLit _ (HsNumTy x n)) exp_kind + = do { when (n < 0) $ + addErr $ TcRnNegativeNumTypeLiteral (HsNumTy x n) + ; checkWiredInTyCon naturalTyCon ; checkExpKind rn_ty (mkNumLitTy n) naturalTy exp_kind } tcHsType _ rn_ty@(HsTyLit _ (HsStrTy _ s)) exp_kind diff --git a/GHC/Tc/Instance/Class.hs b/GHC/Tc/Instance/Class.hs --- a/GHC/Tc/Instance/Class.hs +++ b/GHC/Tc/Instance/Class.hs @@ -47,6 +47,7 @@ import GHC.Core.DataCon import GHC.Core.TyCon import GHC.Core.Class +import GHC.Core.Utils( mkCast ) import GHC.Core ( Expr(..) ) @@ -456,7 +457,7 @@ mkCoreLams [ runtimeRep1TyVar, openAlphaTyVar, sv, k ] $ Var k `App` - (Var sv `Cast` mkTransCo (mkSubCo co2) (mkSymCo co)) + (Var sv `mkCast` mkTransCo (mkSubCo co2) (mkSymCo co)) ; tc <- tcLookupTyCon withDictClassName ; let Just withdict_data_con @@ -935,7 +936,7 @@ dataToTagDataCon = tyConSingleDataCon (classTyCon dataToTagClass) mk_ev _ = evDataConApp dataToTagDataCon [levity, dty] - [methodRep `Cast` methodCo] + [methodRep `mkCast` methodCo] -> addUsedDataCons rdr_env repTyCon -- See wrinkles DTW2 and DTW3 $> OneInst { cir_new_theta = [] -- (Ignore stupid theta.) , cir_mk_ev = mk_ev diff --git a/GHC/Tc/Solver.hs b/GHC/Tc/Solver.hs --- a/GHC/Tc/Solver.hs +++ b/GHC/Tc/Solver.hs @@ -4,7 +4,6 @@ InferMode(..), simplifyInfer, findInferredDiff, growThetaTyVars, simplifyAmbiguityCheck, - simplifyDefault, simplifyTop, simplifyTopImplic, simplifyInteractive, solveEqualities, @@ -93,7 +92,7 @@ import Control.Monad.Trans.Class ( lift ) import Control.Monad.Trans.State.Strict ( StateT(runStateT), put ) import Data.Foldable ( toList, traverse_ ) -import Data.List ( partition, intersect ) +import Data.List ( partition ) import Data.List.NonEmpty ( NonEmpty(..), nonEmpty ) import qualified Data.List.NonEmpty as NE import GHC.Data.Maybe ( isJust, mapMaybe, catMaybes ) @@ -1186,15 +1185,6 @@ simplifyTop wanteds ------------------ -simplifyDefault :: ThetaType -- Wanted; has no type variables in it - -> TcM Bool -- Return if the constraint is soluble -simplifyDefault theta - = do { traceTc "simplifyDefault" empty - ; wanteds <- newWanteds DefaultOrigin theta - ; (unsolved, _) <- runTcS (solveWanteds (mkSimpleWC wanteds)) - ; return (isEmptyWC unsolved) } - ------------------- {- Note [Pattern match warnings with insoluble Givens] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ A pattern match on a GADT can introduce new type-level information, which needs @@ -3755,33 +3745,75 @@ constraints like (Num alpha), where `alpha` is a unification variable. We want to pick a default for `alpha`, such as `alpha := Int` to resolve the ambiguity. -Type-class defaulting is guided by the `DefaultEnv`: see Note [Named default declarations] -in GHC.Tc.Gen.Default +The function 'tryTypeClassDefaulting' implements type-class defaulting. The +algorithm for defaulting depends on whether certain extensions are enabled, +such as -XOverloadedStrings or -XExtendedDefaultRules. To explain this, let us +define the following: -The entry point for defaulting the unsolved constraints is `applyDefaultingRules`, -which depends on `disambigGroup`, which in turn depends on workhorse -`disambigProposalSequences`. The latter is also used by defaulting plugins through -`disambigMultiGroup` (see Note [Defaulting plugins] below). + Unary typeclass: + a typeclass with a single visible type argument. -The algorithm works as follows. Let S be the complete set of unsolved -constraints, and initialize Sx to an empty set of constraints. For every type -variable `v` that is free in S: + Examples: -1. Define Cv = { Ci v | Ci v ∈ S }, the subset of S consisting of all constraints in S of - form (Ci v), where Ci is a single-parameter type class. (We do no defaulting for - multi-parameter type classes.) + Num :: Type -> Constraint + Eq :: Type -> Constraint + Foldable :: (Type -> Type) -> Constraint + Typeable :: forall k. k -> Constraint -- NB: also has an /invisible/ argument -2. Define Dv, by extending Cv with the superclasses of every Ci in Cv + Non-examples: -3. Define Ev, by filtering Dv to contain only classes with a default declaration. + Nullary :: Constraint + Binary :: Type -> Type -> Constraint + Binary2 :: forall k -> k -> Constraint -- Two visible arguments -4. For each Ci in Ev, if Ci has a non-empty default list in the `DefaultEnv`, find the first - type T in the default list for Ci for which, for every (Ci v) in Cv, the constraint (Ci T) - is soluble. + Defaultable class + a typeclass which has at least one in-scope default declaration -5. If there is precisely one type T in the resulting type set, resolve the ambiguity by adding - a constraint (v~ Ti) constraint to a set Sx; otherwise report a static error. + This includes the two different categories of default declarations: + - Haskell 98 default declarations such as 'default (Integer, Float)'. + + - `Num` is always defaultable; either the user says 'default( Integer, Float )' + or (absent such a declaration) the system fills in a fallback default declaration. + See Section 4.3.4 in https://www.haskell.org/onlinereport/haskell2010/haskellch4.html + + - With `OverloadedStrings`, the class `IsString` is defaultable + - With `ExtendedDefaultRules`, the classes `Show`, `Eq`, `Ord`, `Foldable` and `Traversable` + are defaultable + + - Named default declarations, which apply to the named class, e.g. + 'default Cls(X, Y)' applies precisely to 'Cls'. + Note that these may be locally defined, or they may be imported. + + Standard class: + a class defined in the Prelude or the standard library, as defined + by the Haskell 98 report (section 4.3.4) + + These are defined in GHC.Builtin.Names.standardClassKeys. + +The rules for defaulting a collection 'S' of unsolved constraints are as follows: + + 1. For each metavariable 'v' appearing in 'S', define + + U_v = { C v | C v ∈ U, C is a unary typeclass } + + We then process each 'U_v' in turn, in order to find a defaulting + assignment 'v := ty' that solves all of 'U_v'. + + 2. Unless -XExtendedDefaultRules is in effect, give up if 'v' appears: + + - in any constraint that isn't a unary class constraint + - in a class constraint which is non-standard and does not have + a default declaration in scope. + + 3. Compute candidate assignments: for each unary typeclass 'C' in 'U_v' which + has a default declaration in scope, find the first type 'ty' in the list + of in-scope default types for 'C' for which all of 'U_v' is soluble. + + 4. If there is precisely one type candidate type assignment 'ty' that allows + all of 'U_v' to be solved, we default 'v := ty'. Otherwise, do nothing + ('v' remains ambiguous). + Note [Defaulting plugins] ~~~~~~~~~~~~~~~~~~~~~~~~~ Defaulting plugins enable extending or overriding the defaulting @@ -3919,8 +3951,8 @@ -- Finds unary type-class constraints -- But take account of polykinded classes like Typeable, - -- which may look like (Typeable * (a:*)) (#8931) - -- step (1) in Note [How type-class constraints are defaulted] + -- which may look like (Typeable Type (a:Type)) (#8931) + -- See step (1) in Note [How type-class constraints are defaulted] find_unary :: Ct -> Either (Ct, Class, TyVar) Ct find_unary cc | Just (cls,tys) <- getClassPredTys_maybe (ctPred cc) @@ -3932,22 +3964,43 @@ = Left (cc, cls, tv) find_unary cc = Right cc -- Non unary or non dictionary - bad_tvs :: TcTyCoVarSet -- TyVars mentioned by non-unaries - bad_tvs = mapUnionVarSet tyCoVarsOfCt non_unaries + nonunary_tvs :: TcTyCoVarSet -- TyVars mentioned by non-unaries + nonunary_tvs = mapUnionVarSet tyCoVarsOfCt non_unaries cmp_tv (_,_,tv1) (_,_,tv2) = tv1 `compare` tv2 defaultable_tyvar :: TcTyVar -> Bool defaultable_tyvar tv = let b1 = isTyConableTyVar tv -- Note [Avoiding spurious errors] - b2 = not (tv `elemVarSet` bad_tvs) + b2 = not (tv `elemVarSet` nonunary_tvs) in b1 && (b2 || extended_defaults) -- Note [Multi-parameter defaults] - -- Determines if any of the given type class constructors is in default_tys - -- step (3) in Note [How type-class constraints are defaulted] + -- Determines whether the collection of class constraints permits defaulting. + -- See step (2) in Note [How type-class constraints are defaulted] defaultable_classes :: [Class] -> Bool - defaultable_classes clss = not . null . intersect clss $ map cd_class default_tys + defaultable_classes clss = + -- One of the classes has a default declaration in scope + -- (this includes 'Num', and e.g. 'IsString' with -XOverloadedStrings) + any (`elementOfUniqSet` classes_with_defaults) clss + && + -- AND, either: + -- - ExtendedDefaultRules is in effect, or + -- - all the classes are standard or have a default declaration in scope + (extended_defaults || all is_std_or_has_default clss) + is_std_or_has_default :: Class -> Bool + is_std_or_has_default cls = + (getUnique cls `elem` standardClassKeys) + || + (cls `elementOfUniqSet` classes_with_defaults) + -- All classes with a default declaration in scope; either: + -- + -- - a named default declaration such as 'default C(Double, Bool)', or + -- - a Haskell 98 default declaration such as 'default(Int, Float)', + -- which adds defaults for Num, for IsString with OverloadedStrings, + -- and for Foldable/Traversable/... with ExtendedDefaultRules + classes_with_defaults = mkUniqSet $ map cd_class default_tys + ------------------------------ -- | 'Proposal's to be tried in sequence until the first one that succeeds @@ -3996,14 +4049,14 @@ = do { traverse_ (traverse_ reportInvalidDefaultedTyVars . getProposalSequence) proposalSequences ; fake_ev_binds_var <- TcS.newTcEvBinds ; tclvl <- TcS.getTcLevel - -- Step (4) in Note [How type-class constraints are defaulted] + -- Step (3) in Note [How type-class constraints are defaulted] ; successes <- fmap catMaybes $ nestImplicTcS fake_ev_binds_var (pushTcLevel tclvl) $ mapM firstSuccess proposalSequences ; traceTcS "disambigProposalSequences" (vcat [ ppr wanteds , ppr proposalSequences , ppr successes ]) - -- Step (5) in Note [How type-class constraints are defaulted] + -- Step (4) in Note [How type-class constraints are defaulted] ; case successes of success@(tvs, subst) : rest | allConsistent (success :| rest) diff --git a/GHC/Tc/Solver/Dict.hs b/GHC/Tc/Solver/Dict.hs --- a/GHC/Tc/Solver/Dict.hs +++ b/GHC/Tc/Solver/Dict.hs @@ -102,29 +102,54 @@ ; stopWithStage (dictCtEvidence dict_ct) "Kept inert DictCt" } updInertDicts :: DictCt -> TcS () -updInertDicts dict_ct@(DictCt { di_cls = cls, di_ev = ev, di_tys = tys }) - = do { traceTcS "Adding inert dict" (ppr dict_ct $$ ppr cls <+> ppr tys) +updInertDicts dict_ct + = do { traceTcS "Adding inert dict" (ppr dict_ct) - ; if | isGiven ev, Just (str_ty, _) <- isIPPred_maybe cls tys - -> -- See (SIP1) and (SIP2) in Note [Shadowing of implicit parameters] - -- Update /both/ inert_cans /and/ inert_solved_dicts. - updInertSet $ \ inerts@(IS { inert_cans = ics, inert_solved_dicts = solved }) -> - inerts { inert_cans = updDicts (filterDicts (does_not_mention_ip_for str_ty)) ics - , inert_solved_dicts = filterDicts (does_not_mention_ip_for str_ty) solved } - | otherwise - -> return () + -- For Given implicit parameters (only), delete any existing + -- Givens for the same implicit parameter. + -- See Note [Shadowing of implicit parameters] + ; deleteGivenIPs dict_ct -- Add the new constraint to the inert set ; updInertCans (updDicts (addDict dict_ct)) } + +deleteGivenIPs :: DictCt -> TcS () +-- Special magic when adding a Given implicit parameter to the inert set +-- For [G] ?x::ty, remove any existing /Givens/ mentioning ?x, +-- from /both/ inert_cans /and/ inert_solved_dicts (#23761) +-- See Note [Shadowing of implicit parameters] +deleteGivenIPs (DictCt { di_cls = cls, di_ev = ev, di_tys = tys }) + | isGiven ev + , Just (str_ty, _) <- isIPPred_maybe cls tys + = updInertSet $ \ inerts@(IS { inert_cans = ics, inert_solved_dicts = solved }) -> + inerts { inert_cans = updDicts (filterDicts (keep_can str_ty)) ics + , inert_solved_dicts = filterDicts (keep_solved str_ty) solved } + | otherwise + = return () where - -- Does this class constraint or any of its superclasses mention - -- an implicit parameter (?str :: ty) for the given 'str' and any type 'ty'? - does_not_mention_ip_for :: Type -> DictCt -> Bool - does_not_mention_ip_for str_ty (DictCt { di_cls = cls, di_tys = tys }) - = not $ mentionsIP (not . typesAreApart str_ty) (const True) cls tys - -- See Note [Using typesAreApart when calling mentionsIP] - -- in GHC.Core.Predicate + keep_can, keep_solved :: Type -> DictCt -> Bool + -- keep_can: we keep an inert dictionary UNLESS + -- (1) it is a Given + -- (2) it binds an implicit parameter (?str :: ty) for the given 'str' + -- regardless of 'ty', possibly via its superclasses + -- The test is a bit conservative, hence `mentionsIP` and `typesAreApart` + -- See Note [Using typesAreApart when calling mentionsIP] + -- in GHC.Core.Predicate + -- + -- keep_solved: same as keep_can, but for /all/ constraints not just Givens + -- + -- Why two functions? See (SIP3) in Note [Shadowing of implicit parameters] + keep_can str (DictCt { di_ev = ev, di_cls = cls, di_tys = tys }) + = not (isGiven ev -- (1) + && mentions_ip str cls tys) -- (2) + keep_solved str (DictCt { di_cls = cls, di_tys = tys }) + = not (mentions_ip str cls tys) + -- mentions_ip: the inert constraint might provide evidence + -- for an implicit parameter (?str :: ty) for the given 'str' + mentions_ip str cls tys + = mentionsIP (not . typesAreApart str) (const True) cls tys + canDictCt :: CtEvidence -> Class -> [Type] -> SolverStage DictCt -- Once-only processing of Dict constraints: -- * expand superclasses @@ -220,7 +245,9 @@ * In `updInertDicts`, in this module, when adding [G] (?x :: ty), remove any existing [G] (?x :: ty'), regardless of ty'. -* Wrinkle (SIP1): we must be careful of superclasses. Consider +There are wrinkles: + +* Wrinkle (SIP1): we must be careful of superclasses (#14218). Consider f,g :: (?x::Int, C a) => a -> a f v = let ?x = 4 in g v @@ -228,24 +255,31 @@ We must /not/ solve this from the Given (?x::Int, C a), because of the intervening binding for (?x::Int). #14218. - We deal with this by arranging that when we add [G] (?x::ty) we delete + We deal with this by arranging that when we add [G] (?x::ty) we /delete/ * from the inert_cans, and * from the inert_solved_dicts any existing [G] (?x::ty) /and/ any [G] D tys, where (D tys) has a superclass with (?x::ty). See Note [Local implicit parameters] in GHC.Core.Predicate. - An important special case is constraint tuples like [G] (% ?x::ty, Eq a %). - But it could happen for `class xx => D xx where ...` and the constraint D - (?x :: int). This corner (constraint-kinded variables instantiated with - implicit parameter constraints) is not well explored. + An very important special case is constraint tuples like [G] (% ?x::ty, Eq a %). - Example in #14218, and #23761 + But it could also happen for `class xx => D xx where ...` and the constraint + D (?x :: int); again see Note [Local implicit parameters]. This corner + (constraint-kinded variables instantiated with implicit parameter constraints) + is not well explored. + You might worry about whether deleting an /entire/ constraint just because + a distant superclass has an implicit parameter might make another Wanted for + that constraint un-solvable. Indeed so. But for constraint tuples it doesn't + matter -- their entire payload is their superclasses. And the other case is + the ill-explored corner above. + The code that accounts for (SIP1) is in updInertDicts; in particular the call to GHC.Core.Predicate.mentionsIP. * Wrinkle (SIP2): we must apply this update semantics for `inert_solved_dicts` - as well as `inert_cans`. + as well as `inert_cans` (#23761). + You might think that wouldn't be necessary, because an element of `inert_solved_dicts` is never an implicit parameter (see Note [Solved dictionaries] in GHC.Tc.Solver.InertSet). @@ -257,6 +291,19 @@ Now (C (?x::Int)) has a superclass (?x::Int). This may look exotic, but it happens particularly for constraint tuples, like `(% ?x::Int, Eq a %)`. + +* Wrinkle (SIP3) + - Note that for the inert dictionaries, `inert_cans`, we must /only/ delete + existing /Givens/! Deleting an existing Wanted led to #26451; we just never + solved it! + + - In contrast, the solved dictionaries, `inert_solved_dicts`, are really like + Givens; they may be "inherited" from outer scopes, so we must delete any + solved dictionaries for this implicit parameter for /both/ Givens /and/ + Wanteds. + + Otherwise the new Given doesn't properly shadow those inherited solved + dictionaries. Test T23761 showed this up. Example 1: diff --git a/GHC/Tc/Types/Evidence.hs b/GHC/Tc/Types/Evidence.hs --- a/GHC/Tc/Types/Evidence.hs +++ b/GHC/Tc/Types/Evidence.hs @@ -56,6 +56,7 @@ import GHC.Types.Id( idScaledType ) import GHC.Core.Coercion.Axiom import GHC.Core.Coercion +import GHC.Core.Utils( mkCast ) import GHC.Core.Ppr () -- Instance OutputableBndr TyVar import GHC.Tc.Utils.TcType import GHC.Core.Type @@ -528,7 +529,7 @@ -- | d |> co evCast :: EvExpr -> TcCoercion -> EvTerm evCast et tc | isReflCo tc = EvExpr et - | otherwise = EvExpr (Cast et tc) + | otherwise = EvExpr (mkCast et tc) -- Dictionary instance application evDFunApp :: DFunId -> [Type] -> [EvExpr] -> EvTerm diff --git a/GHC/Tc/Utils/Unify.hs b/GHC/Tc/Utils/Unify.hs --- a/GHC/Tc/Utils/Unify.hs +++ b/GHC/Tc/Utils/Unify.hs @@ -775,7 +775,15 @@ ; result <- thing_inside (map ExpFunPatTy arg_tys) res_ty ; arg_tys <- mapM (\(Scaled m t) -> Scaled m <$> readExpType t) arg_tys ; res_ty <- readExpType res_ty - ; co <- fillInferResult (mkScaledFunTys arg_tys res_ty) inf_res + -- Remarks: + -- 1. use tcMkScaledFunTys rather than mkScaledFunTys, as we might + -- have res_ty :: kappa[tau] for a meta ty-var kappa, in which case + -- mkScaledFunTys would crash. See #26277. + -- 2. tcMkScaledFunTys arg_tys res_ty does not contain any foralls + -- (even nested ones), so no need to instantiate. + -- NOTE: we do not backport fillInferResultNoInst so this stays + -- fillInferResult on the backported patch + ; co <- fillInferResult (tcMkScaledFunTys arg_tys res_ty) inf_res ; return (mkWpCastN co, result) } matchExpectedFunTys herald ctx arity (Check top_ty) thing_inside diff --git a/GHC/Types/DefaultEnv.hs b/GHC/Types/DefaultEnv.hs --- a/GHC/Types/DefaultEnv.hs +++ b/GHC/Types/DefaultEnv.hs @@ -31,9 +31,13 @@ import Data.Function (on) -- See Note [Named default declarations] in GHC.Tc.Gen.Default + -- | Default environment mapping class name @Name@ to their default type lists +-- +-- NB: this includes Haskell98 default declarations, at the 'Num' key. type DefaultEnv = NameEnv ClassDefaults +-- | Defaulting type assignments for the given class. data ClassDefaults = ClassDefaults { cd_class :: Class -- ^ The class whose defaults are being defined , cd_types :: [Type] diff --git a/GHC/Types/Id/Info.hs b/GHC/Types/Id/Info.hs --- a/GHC/Types/Id/Info.hs +++ b/GHC/Types/Id/Info.hs @@ -568,7 +568,12 @@ -- ^ True of a /non-loop-breaker/ Id that has a /stable/ unfolding that is -- (a) always inlined; that is, with an `UnfWhen` guidance, or -- (b) a DFunUnfolding which never needs to be inlined -hasInlineUnfolding info = isInlineUnfolding (unfoldingInfo info) +-- +-- Very important that this work with `realUnfoldingInfo` and so returns +-- True even for a loop-breaker that has an INLINE pragma. +-- See (CWW4) in Note [Cast worker/wrapper] in GHC.Core.Opt.Simplify.Iteration +-- for discussion, and #26903 for the dire consequences of getting this wrong. +hasInlineUnfolding info = isInlineUnfolding (realUnfoldingInfo info) setArityInfo :: IdInfo -> ArityInfo -> IdInfo setArityInfo info ar = diff --git a/GHC/Types/Unique/FM.hs b/GHC/Types/Unique/FM.hs --- a/GHC/Types/Unique/FM.hs +++ b/GHC/Types/Unique/FM.hs @@ -41,6 +41,7 @@ listToUFM_C, listToIdentityUFM, addToUFM,addToUFM_C,addToUFM_Acc,addToUFM_L, + strictAddToUFM_C, addListToUFM,addListToUFM_C, addToUFM_Directly, addListToUFM_Directly, @@ -51,7 +52,9 @@ delListFromUFM, delListFromUFM_Directly, plusUFM, + strictPlusUFM, plusUFM_C, + strictPlusUFM_C, plusUFM_CD, plusUFM_CD2, mergeUFM, @@ -63,6 +66,7 @@ minusUFM_C, intersectUFM, intersectUFM_C, + strictIntersectUFM_C, disjointUFM, equalKeysUFM, diffUFM, @@ -179,6 +183,16 @@ addToUFM_C f (UFM m) k v = UFM (M.insertWith (flip f) (getKey $ getUnique k) v m) +strictAddToUFM_C + :: Uniquable key + => (elt -> elt -> elt) -- ^ old -> new -> result + -> UniqFM key elt -- ^ old + -> key -> elt -- ^ new + -> UniqFM key elt -- ^ result +-- Arguments of combining function of MS.insertWith and strictAddToUFM_C are flipped. +strictAddToUFM_C f (UFM m) k v = + UFM (MS.insertWith (flip f) (getKey $ getUnique k) v m) + addToUFM_Acc :: Uniquable key => (elt -> elts -> elts) -- Add to existing @@ -249,16 +263,24 @@ delFromUFM_Directly :: UniqFM key elt -> Unique -> UniqFM key elt delFromUFM_Directly (UFM m) u = UFM (M.delete (getKey u) m) --- Bindings in right argument shadow those in the left +-- | Bindings in right argument shadow those in the left. +-- +-- Unlike containers this union is right-biased for historic reasons. plusUFM :: UniqFM key elt -> UniqFM key elt -> UniqFM key elt --- M.union is left-biased, plusUFM should be right-biased. plusUFM (UFM x) (UFM y) = UFM (M.union y x) -- Note (M.union y x), with arguments flipped -- M.union is left-biased, plusUFM should be right-biased. +-- | Right biased +strictPlusUFM :: UniqFM key elt -> UniqFM key elt -> UniqFM key elt +strictPlusUFM (UFM x) (UFM y) = UFM (MS.union y x) + plusUFM_C :: (elt -> elt -> elt) -> UniqFM key elt -> UniqFM key elt -> UniqFM key elt plusUFM_C f (UFM x) (UFM y) = UFM (M.unionWith f x y) +strictPlusUFM_C :: (elt -> elt -> elt) -> UniqFM key elt -> UniqFM key elt -> UniqFM key elt +strictPlusUFM_C f (UFM x) (UFM y) = UFM (MS.unionWith f x y) + -- | `plusUFM_CD f m1 d1 m2 d2` merges the maps using `f` as the -- combinding function and `d1` resp. `d2` as the default value if -- there is no entry in `m1` reps. `m2`. The domain is the union of @@ -368,6 +390,13 @@ -> UniqFM key elt2 -> UniqFM key elt3 intersectUFM_C f (UFM x) (UFM y) = UFM (M.intersectionWith f x y) + +strictIntersectUFM_C + :: (elt1 -> elt2 -> elt3) + -> UniqFM key elt1 + -> UniqFM key elt2 + -> UniqFM key elt3 +strictIntersectUFM_C f (UFM x) (UFM y) = UFM (MS.intersectionWith f x y) disjointUFM :: UniqFM key elt1 -> UniqFM key elt2 -> Bool disjointUFM (UFM x) (UFM y) = M.disjoint x y diff --git a/GHC/Types/Unique/Set.hs b/GHC/Types/Unique/Set.hs --- a/GHC/Types/Unique/Set.hs +++ b/GHC/Types/Unique/Set.hs @@ -21,12 +21,14 @@ emptyUniqSet, unitUniqSet, mkUniqSet, - addOneToUniqSet, addListToUniqSet, + addOneToUniqSet, addListToUniqSet, strictAddOneToUniqSet_C, delOneFromUniqSet, delOneFromUniqSet_Directly, delListFromUniqSet, delListFromUniqSet_Directly, unionUniqSets, unionManyUniqSets, - minusUniqSet, uniqSetMinusUFM, uniqSetMinusUDFM, - intersectUniqSets, + strictUnionUniqSets_C, strictUnionManyUniqSets_C, + minusUniqSet, minusUniqSet_C, + uniqSetMinusUFM, uniqSetMinusUDFM, + intersectUniqSets, strictIntersectUniqSets_C, disjointUniqSets, restrictUniqSetToUFM, uniqSetAny, uniqSetAll, @@ -110,6 +112,10 @@ addListToUniqSet = foldl' addOneToUniqSet {-# INLINEABLE addListToUniqSet #-} +strictAddOneToUniqSet_C :: Uniquable a => (a -> a -> a) -> UniqSet a -> a -> UniqSet a +strictAddOneToUniqSet_C f (UniqSet set) x = + UniqSet (strictAddToUFM_C f set x x) + delOneFromUniqSet :: Uniquable a => UniqSet a -> a -> UniqSet a delOneFromUniqSet (UniqSet s) a = UniqSet (delFromUFM s a) @@ -128,14 +134,28 @@ unionUniqSets :: UniqSet a -> UniqSet a -> UniqSet a unionUniqSets (UniqSet s) (UniqSet t) = UniqSet (plusUFM s t) +strictUnionUniqSets_C :: (a -> a -> a) -> UniqSet a -> UniqSet a -> UniqSet a +strictUnionUniqSets_C f (UniqSet s) (UniqSet t) = + UniqSet (strictPlusUFM_C f s t) + unionManyUniqSets :: [UniqSet a] -> UniqSet a unionManyUniqSets = foldl' (flip unionUniqSets) emptyUniqSet +strictUnionManyUniqSets_C :: (a -> a -> a) -> [UniqSet a] -> UniqSet a +strictUnionManyUniqSets_C f = foldl' (flip (strictUnionUniqSets_C f)) emptyUniqSet + minusUniqSet :: UniqSet a -> UniqSet a -> UniqSet a minusUniqSet (UniqSet s) (UniqSet t) = UniqSet (minusUFM s t) +minusUniqSet_C :: (a -> a -> Maybe a) -> UniqSet a -> UniqSet a -> UniqSet a +minusUniqSet_C f (UniqSet s) (UniqSet t) = UniqSet (minusUFM_C f s t) + intersectUniqSets :: UniqSet a -> UniqSet a -> UniqSet a intersectUniqSets (UniqSet s) (UniqSet t) = UniqSet (intersectUFM s t) + +strictIntersectUniqSets_C :: (a -> a -> a) -> UniqSet a -> UniqSet a -> UniqSet a +strictIntersectUniqSets_C f (UniqSet s) (UniqSet t) = + UniqSet (strictIntersectUFM_C f s t) disjointUniqSets :: UniqSet a -> UniqSet a -> Bool disjointUniqSets (UniqSet s) (UniqSet t) = disjointUFM s t diff --git a/GHC/Types/Var/Env.hs b/GHC/Types/Var/Env.hs --- a/GHC/Types/Var/Env.hs +++ b/GHC/Types/Var/Env.hs @@ -12,7 +12,8 @@ elemVarEnv, disjointVarEnv, anyVarEnv, extendVarEnv, extendVarEnv_C, extendVarEnv_Acc, extendVarEnvList, - plusVarEnv, plusVarEnv_C, plusVarEnv_CD, plusMaybeVarEnv_C, + strictPlusVarEnv, plusVarEnv, plusVarEnv_C, strictPlusVarEnv_C, + plusVarEnv_CD, plusMaybeVarEnv_C, plusVarEnvList, alterVarEnv, delVarEnvList, delVarEnv, minusVarEnv, @@ -510,6 +511,7 @@ extendVarEnv_C :: (a->a->a) -> VarEnv a -> Var -> a -> VarEnv a extendVarEnv_Acc :: (a->b->b) -> (a->b) -> VarEnv b -> Var -> a -> VarEnv b plusVarEnv :: VarEnv a -> VarEnv a -> VarEnv a +strictPlusVarEnv :: VarEnv a -> VarEnv a -> VarEnv a plusVarEnvList :: [VarEnv a] -> VarEnv a extendVarEnvList :: VarEnv a -> [(Var, a)] -> VarEnv a varEnvDomain :: VarEnv elt -> UnVarSet @@ -521,6 +523,7 @@ delVarEnv :: VarEnv a -> Var -> VarEnv a minusVarEnv :: VarEnv a -> VarEnv b -> VarEnv a plusVarEnv_C :: (a -> a -> a) -> VarEnv a -> VarEnv a -> VarEnv a +strictPlusVarEnv_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 @@ -547,12 +550,14 @@ extendVarEnv_Acc = addToUFM_Acc extendVarEnvList = addListToUFM plusVarEnv_C = plusUFM_C +strictPlusVarEnv_C = strictPlusUFM_C plusVarEnv_CD = plusUFM_CD plusMaybeVarEnv_C = plusMaybeUFM_C delVarEnvList = delListFromUFM delVarEnv = delFromUFM minusVarEnv = minusUFM plusVarEnv = plusUFM +strictPlusVarEnv = strictPlusUFM plusVarEnvList = plusUFMList -- lookupVarEnv is very hot (in part due to being called by substTyVar), -- if it's not inlined than the mere allocation of the Just constructor causes diff --git a/GHC/Unit/Info.hs b/GHC/Unit/Info.hs --- a/GHC/Unit/Info.hs +++ b/GHC/Unit/Info.hs @@ -236,7 +236,7 @@ -- This change elevates the need to add custom hooks -- and handling specifically for the `rts` package. addSuffix rts@"HSrts" = rts ++ (expandTag rts_tag) - addSuffix rts@"HSrts-1.0.2" = rts ++ (expandTag rts_tag) + addSuffix rts@"HSrts-1.0.3" = rts ++ (expandTag rts_tag) addSuffix other_lib = other_lib ++ (expandTag tag) expandTag t | null t = "" diff --git a/ghc.cabal b/ghc.cabal --- a/ghc.cabal +++ b/ghc.cabal @@ -3,7 +3,7 @@ -- ./configure. Make sure you are editing ghc.cabal.in, not ghc.cabal. Name: ghc -Version: 9.12.3 +Version: 9.12.4 License: BSD-3-Clause License-File: LICENSE Author: The GHC Team @@ -130,16 +130,17 @@ exceptions == 0.10.*, semaphore-compat, stm, - ghc-boot == 9.12.3, - ghc-heap == 9.12.3, - ghci == 9.12.3 + rts, + ghc-boot == 9.12.4, + ghc-heap == 9.12.4, + ghci == 9.12.4 if flag(bootstrap) Build-Depends: - ghc-boot-th-next == 9.12.3 + ghc-boot-th-next == 9.12.4 else Build-Depends: - ghc-boot-th == 9.12.3 + ghc-boot-th == 9.12.4 if os(windows) Build-Depends: Win32 >= 2.3 && < 2.15 @@ -314,6 +315,7 @@ GHC.CmmToAsm.Reg.Linear.X86 GHC.CmmToAsm.Reg.Linear.X86_64 GHC.CmmToAsm.Reg.Liveness + GHC.CmmToAsm.Reg.Regs GHC.CmmToAsm.Reg.Target GHC.CmmToAsm.Reg.Utils GHC.CmmToAsm.RV64