ghc 9.12.3 → 9.12.4

raw patch · 79 files changed

+3128/−1766 lines, 79 filesdep +rtsdep ~ghc-bootdep ~ghc-boot-thdep ~ghc-boot-th-nextPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: rts

Dependency ranges changed: ghc-boot, ghc-boot-th, ghc-boot-th-next, ghc-heap, ghci

API changes (from Hackage documentation)

Files

• Bytecodes.h +103/−0
• GHC/Builtin/primops.txt.pp +40/−0
• GHC/ByteCode/Asm.hs +165/−7
• GHC/ByteCode/Instr.hs +112/−1
• GHC/Cmm.hs +2/−2
• GHC/Cmm/Config.hs +0/−2
• GHC/Cmm/InitFini.hs +6/−5
• GHC/Cmm/Lexer.hs +2/−2
• GHC/Cmm/MachOp.hs +0/−15
• GHC/Cmm/Opt.hs +36/−565
• GHC/Cmm/Parser.hs +5/−0
• GHC/Cmm/Pipeline.hs +3/−6
• GHC/Cmm/Sink.hs +262/−209
• GHC/CmmToAsm/AArch64/Ppr.hs +23/−7
• GHC/CmmToAsm/PPC/CodeGen.hs +47/−63
• GHC/CmmToAsm/Ppr.hs +71/−13
• GHC/CmmToAsm/Reg/Graph.hs +3/−3
• GHC/CmmToAsm/Reg/Graph/Coalesce.hs +2/−4
• GHC/CmmToAsm/Reg/Graph/Spill.hs +3/−2
• GHC/CmmToAsm/Reg/Graph/SpillCost.hs +4/−4
• GHC/CmmToAsm/Reg/Linear.hs +185/−81
• GHC/CmmToAsm/Reg/Linear/Base.hs +43/−29
• GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs +66/−49
• GHC/CmmToAsm/Reg/Linear/StackMap.hs +18/−9
• GHC/CmmToAsm/Reg/Liveness.hs +156/−77
• GHC/CmmToAsm/Reg/Regs.hs +119/−0
• GHC/CmmToAsm/Reg/Target.hs +0/−6
• GHC/CmmToAsm/Wasm/FromCmm.hs +1/−1
• GHC/CmmToAsm/X86/CodeGen.hs +10/−1
• GHC/CmmToAsm/X86/Instr.hs +20/−8
• GHC/CmmToAsm/X86/Ppr.hs +17/−1
• GHC/CmmToC.hs +1/−1
• GHC/CmmToLlvm.hs +25/−3
• GHC/CmmToLlvm/Base.hs +1/−1
• GHC/CmmToLlvm/CodeGen.hs +98/−76
• GHC/CmmToLlvm/Data.hs +2/−2
• GHC/Core/Lint.hs +8/−1
• GHC/Core/Map/Type.hs +8/−8
• GHC/Core/Opt/CSE.hs +34/−13
• GHC/Core/Opt/OccurAnal.hs +48/−14
• GHC/Core/Opt/SetLevels.hs +45/−22
• GHC/Core/Opt/Simplify/Iteration.hs +50/−21
• GHC/Core/Opt/Simplify/Utils.hs +58/−35
• GHC/Core/Opt/Specialise.hs +63/−32
• GHC/Core/Opt/WorkWrap.hs +3/−2
• GHC/Core/Utils.hs +28/−27
• GHC/Driver/Config/Cmm.hs +0/−12
• GHC/Driver/Config/Core/Lint.hs +6/−0
• GHC/Driver/Flags.hs +1/−0
• GHC/Driver/Pipeline/Execute.hs +22/−5
• GHC/Driver/Session.hs +1/−0
• GHC/Hs/Doc.hs +2/−1
• GHC/Iface/Recomp.hs +13/−6
• GHC/Parser/HaddockLex.hs +2/−2
• GHC/Parser/Lexer.hs +2/−2
• GHC/Parser/Lexer/String.hs +2/−2
• GHC/Rename/Env.hs +36/−19
• GHC/Rename/Pat.hs +101/−9
• GHC/StgToByteCode.hs +339/−18
• GHC/StgToCmm/Prim.hs +33/−16
• GHC/StgToJS/Linker/Linker.hs +14/−6
• GHC/Tc/Deriv.hs +13/−14
• GHC/Tc/Errors/Ppr.hs +3/−3
• GHC/Tc/Errors/Types.hs +3/−3
• GHC/Tc/Gen/Default.hs +185/−86
• GHC/Tc/Gen/Expr.hs +27/−6
• GHC/Tc/Gen/HsType.hs +69/−43
• GHC/Tc/Instance/Class.hs +3/−2
• GHC/Tc/Solver.hs +93/−40
• GHC/Tc/Solver/Dict.hs +72/−25
• GHC/Tc/Types/Evidence.hs +2/−1
• GHC/Tc/Utils/Unify.hs +9/−1
• GHC/Types/DefaultEnv.hs +4/−0
• GHC/Types/Id/Info.hs +6/−1
• GHC/Types/Unique/FM.hs +31/−2
• GHC/Types/Unique/Set.hs +23/−3
• GHC/Types/Var/Env.hs +6/−1
• GHC/Unit/Info.hs +1/−1
• ghc.cabal +8/−6

@@ -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 */

@@ -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

@@ -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)

@@ -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 "<tick_module>" <+> ppr tickx                                <+> text "<info_module>" <+> ppr infox                                <+> text "<cc>"+#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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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 = <expr>+      N: r = <other_expr>++    (C1b) 'N' defines a register used in the RHS of 'A', for example:++      A: r = s+      N: s = <expr>++    (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

@@ -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)

@@ -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)

@@ -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

@@ -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"

@@ -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

@@ -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'

@@ -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

@@ -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 "<saveClobberedTemps>") ++@@ -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.+-}

@@ -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.

@@ -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

@@ -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

@@ -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:++      <previous instructions>+      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+            <many instructions>+            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 <many instructions>,+          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.+-}

@@ -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)

@@ -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)

@@ -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 

@@ -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

@@ -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]

@@ -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

@@ -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

@@ -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 <var> to i8*, ...]+  --   @llvm.compiler.used = appending global [42 x i8*] [i8* bitcast <var> 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 ()

@@ -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

@@ -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"

@@ -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

@@ -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

@@ -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

@@ -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 #-}

@@ -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

@@ -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

@@ -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 = <stable-big> -}+(CWW3) We should still do cast w/w even if `f` is INLINEABLE.  E.g.+      {- f: Stable unfolding (arity 2) = <stable-big> -}       f = (\xy. <big-body>) |> co    Then we want to w/w to       {- $wf: Stable unfolding = <stable-big> |> 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) = <stable-big> -}   NB arity 0!+      g = (\xy. <big-body>) |> co+   If we w/w to this:+      {- $wg: Stable unfolding (arity 0) = <stable-big> |> sym co -}+      $wg = \xy. <big-body>+      g = $wg |> co+   then we'll inline $wg at the call site in `g` giving+      {- $wg: Stable unfolding (arity 0) = <stable-big> |> sym co -}+      $wg = \xy. <big-body>+      g = (<stable-big> |> 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

@@ -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 

@@ -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# = <some literal> 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 }

@@ -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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

@@ -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

@@ -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

@@ -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]

@@ -572,6 +572,7 @@    | Opt_DoAsmLinting    | Opt_DoAnnotationLinting    | Opt_DoBoundsChecking+   | Opt_AddBcoName    | Opt_NoLlvmMangler                  -- hidden flag    | Opt_FastLlvm                       -- hidden flag    | Opt_NoTypeableBinds

@@ -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 ]

@@ -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,

@@ -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) 

@@ -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)

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~

@@ -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

@@ -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

@@ -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 

@@ -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 = ...

@@ -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

@@ -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@.

@@ -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+-}

@@ -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: 

@@ -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

@@ -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

@@ -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)