ghc 9.4.5 → 9.4.6

raw patch · 75 files changed

+2356/−1215 lines, 75 filesdep ~ghc-bootdep ~ghc-heapdep ~ghciPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

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

API changes (from Hackage documentation)

Files

• Bytecodes.h +20/−2
• GHC/ByteCode/Asm.hs +118/−60
• GHC/ByteCode/Instr.hs +80/−21
• GHC/ByteCode/Linker.hs +31/−30
• GHC/ByteCode/Types.hs +37/−17
• GHC/Cmm/CLabel.hs +6/−2
• GHC/Cmm/CallConv.hs +105/−8
• GHC/Cmm/Lexer.hs +2/−2
• GHC/Cmm/Parser.hs +2/−2
• GHC/CmmToAsm/AArch64/CodeGen.hs +6/−2
• GHC/Core.hs +49/−23
• GHC/Core/Coercion.hs +7/−3
• GHC/Core/Coercion/Axiom.hs +28/−14
• GHC/Core/DataCon.hs +29/−12
• GHC/Core/FamInstEnv.hs +12/−11
• GHC/Core/Lint.hs +8/−52
• GHC/Core/Opt/Arity.hs +1/−1
• GHC/Core/Opt/DmdAnal.hs +124/−87
• GHC/Core/Opt/Simplify.hs +8/−4
• GHC/Core/Opt/Simplify/Utils.hs +23/−12
• GHC/Core/Opt/SpecConstr.hs +8/−7
• GHC/Core/Opt/Specialise.hs +83/−41
• GHC/Core/Ppr.hs +14/−9
• GHC/Core/Rules.hs +13/−7
• GHC/Core/Seq.hs +5/−4
• GHC/Core/SimpleOpt.hs +1/−1
• GHC/Core/Tidy.hs +7/−6
• GHC/Core/Unfold.hs +18/−11
• GHC/Core/Unfold/Make.hs +48/−38
• GHC/Core/Utils.hs +3/−4
• GHC/CoreToIface.hs +5/−4
• GHC/CoreToStg/Prep.hs +1/−1
• GHC/Driver/CodeOutput.hs +1/−1
• GHC/Driver/Config/Stg/Pipeline.hs +1/−0
• GHC/Driver/Pipeline.hs +6/−6
• GHC/Iface/Rename.hs +2/−2
• GHC/Iface/Syntax.hs +33/−8
• GHC/Iface/Tidy.hs +2/−2
• GHC/IfaceToCore.hs +46/−3
• GHC/Linker/Loader.hs +35/−41
• GHC/Linker/Types.hs +47/−11
• GHC/Parser/HaddockLex.hs +2/−2
• GHC/Parser/Lexer.hs +2/−2
• GHC/Stg/InferTags.hs +52/−20
• GHC/Stg/InferTags/Rewrite.hs +5/−10
• GHC/Stg/InferTags/Types.hs +19/−6
• GHC/Stg/Pipeline.hs +2/−1
• GHC/Stg/Syntax.hs +1/−1
• GHC/Stg/Unarise.hs +2/−0
• GHC/StgToByteCode.hs +353/−167
• GHC/StgToCmm/Closure.hs +111/−10
• GHC/StgToCmm/Env.hs +2/−2
• GHC/StgToCmm/Foreign.hs +34/−18
• GHC/StgToCmm/Monad.hs +4/−2
• GHC/StgToCmm/Prim.hs +181/−111
• GHC/StgToCmm/Types.hs +47/−1
• GHC/Tc/Deriv/Generate.hs +3/−2
• GHC/Tc/Errors/Ppr.hs +10/−0
• GHC/Tc/Errors/Types.hs +10/−0
• GHC/Tc/Gen/Bind.hs +22/−2
• GHC/Tc/Gen/Head.hs +1/−1
• GHC/Tc/Solver/Canonical.hs +2/−1
• GHC/Tc/Solver/Interact.hs +48/−47
• GHC/Tc/Solver/Monad.hs +24/−24
• GHC/Tc/TyCl/Class.hs +66/−7
• GHC/Tc/TyCl/Utils.hs +7/−4
• GHC/Tc/Utils/TcMType.hs +52/−9
• GHC/Tc/Utils/Unify.hs +22/−23
• GHC/Tc/Utils/Zonk.hs +5/−1
• GHC/Types/Demand.hs +173/−162
• GHC/Types/Id.hs +2/−0
• GHC/Types/Id/Info.hs +2/−1
• GHC/Utils/Binary.hs +2/−2
• GHC/Utils/Outputable.hs +9/−0
• ghc.cabal +4/−4

@@ -34,7 +34,6 @@ #define bci_PUSH16_W                    9 #define bci_PUSH32_W                    10 #define bci_PUSH_G                      11-#define bci_PUSH_ALTS                   12 #define bci_PUSH_ALTS_P                 13 #define bci_PUSH_ALTS_N                 14 #define bci_PUSH_ALTS_F                 15@@ -81,7 +80,6 @@ #define bci_CCALL                       56 #define bci_SWIZZLE                     57 #define bci_ENTER                       58-#define bci_RETURN                      59 #define bci_RETURN_P                    60 #define bci_RETURN_N                    61 #define bci_RETURN_F                    62@@ -94,6 +92,26 @@  #define bci_RETURN_T                    69 #define bci_PUSH_ALTS_T                 70++#define bci_TESTLT_I64                  71+#define bci_TESTEQ_I64                  72+#define bci_TESTLT_I32                  73+#define bci_TESTEQ_I32                  74+#define bci_TESTLT_I16                  75+#define bci_TESTEQ_I16                  76+#define bci_TESTLT_I8                   77+#define bci_TESTEQ_I8                   78+#define bci_TESTLT_W64                  79+#define bci_TESTEQ_W64                  80+#define bci_TESTLT_W32                  81+#define bci_TESTEQ_W32                  82+#define bci_TESTLT_W16                  83+#define bci_TESTEQ_W16                  84+#define bci_TESTLT_W8                   85+#define bci_TESTEQ_W8                   86++#define bci_PRIMCALL                    87+ /* 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 */

@@ -12,7 +12,7 @@         bcoFreeNames,         SizedSeq, sizeSS, ssElts,         iNTERP_STACK_CHECK_THRESH,-        mkTupleInfoLit+        mkNativeCallInfoLit   ) where  import GHC.Prelude@@ -32,7 +32,6 @@  import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Utils.Panic.Plain  import GHC.Core.TyCon import GHC.Data.FastString@@ -40,7 +39,7 @@  import GHC.StgToCmm.Layout     ( ArgRep(..) ) import GHC.Cmm.Expr-import GHC.Cmm.CallConv        ( tupleRegsCover )+import GHC.Cmm.CallConv        ( allArgRegsCover ) import GHC.Platform import GHC.Platform.Profile @@ -98,7 +97,7 @@   -> Profile   -> [ProtoBCO Name]   -> [TyCon]-  -> [RemotePtr ()]+  -> AddrEnv   -> Maybe ModBreaks   -> IO CompiledByteCode assembleBCOs interp profile proto_bcos tycons top_strs modbreaks = do@@ -106,27 +105,40 @@   -- fixed for an interpreter   itblenv <- mkITbls interp profile tycons   bcos    <- mapM (assembleBCO (profilePlatform profile)) proto_bcos-  (bcos',ptrs) <- mallocStrings interp bcos+  bcos'   <- mallocStrings interp bcos   return CompiledByteCode     { bc_bcos = bcos'     , bc_itbls =  itblenv     , bc_ffis = concatMap protoBCOFFIs proto_bcos-    , bc_strs = top_strs ++ ptrs+    , bc_strs = top_strs     , bc_breaks = modbreaks     } --- Find all the literal strings and malloc them together.  We want to--- do this because:+-- Note [Allocating string literals]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- Our strategy for handling top-level string literal bindings is described in+-- Note [Generating code for top-level string literal bindings] in GHC.StgToByteCode,+-- but not all Addr# literals in a program are guaranteed to be lifted to the+-- top level. Our strategy for handling local Addr# literals is somewhat simpler:+-- after assembling, we find all the BCONPtrStr arguments in the program, malloc+-- memory for them, and bake the resulting addresses into the instruction stream+-- in the form of BCONPtrWord arguments. -----  a) It should be done when we compile the module, not each time we relink it---  b) For -fexternal-interpreter It's more efficient to malloc the strings---     as a single batch message, especially when compiling in parallel.+-- Since we do this when assembling, we only allocate the memory when we compile+-- the module, not each time we relink it. However, we do want to take care to+-- malloc the memory all in one go, since that is more efficient with+-- -fexternal-interpreter, especially when compiling in parallel. ---mallocStrings :: Interp -> [UnlinkedBCO] -> IO ([UnlinkedBCO], [RemotePtr ()])+-- Note that, as with top-level string literal bindings, this memory is never+-- freed, so it just leaks if the BCO is unloaded. See Note [Generating code for+-- top-level string literal bindings] in GHC.StgToByteCode for some discussion+-- about why.+--+mallocStrings :: Interp -> [UnlinkedBCO] -> IO [UnlinkedBCO] mallocStrings interp ulbcos = do   let bytestrings = reverse (execState (mapM_ collect ulbcos) [])   ptrs <- interpCmd interp (MallocStrings bytestrings)-  return (evalState (mapM splice ulbcos) ptrs, ptrs)+  return (evalState (mapM splice ulbcos) ptrs)  where   splice bco@UnlinkedBCO{..} = do     lits <- mapM spliceLit unlinkedBCOLits@@ -163,7 +175,7 @@   -- TODO: the profile should be bundled with the interpreter: the rts ways are   -- fixed for an interpreter   ubco <- assembleBCO (profilePlatform profile) pbco-  ([ubco'], _ptrs) <- mallocStrings interp [ubco]+  [ubco'] <- mallocStrings interp [ubco]   return ubco'  assembleBCO :: Platform -> ProtoBCO Name -> IO UnlinkedBCO@@ -202,7 +214,8 @@   (final_insns, final_lits, final_ptrs) <- flip execStateT initial_state $ runAsm platform long_jumps env asm    -- precomputed size should be equal to final size-  massert (n_insns == sizeSS final_insns)+  massertPpr (n_insns == sizeSS final_insns)+             (text "bytecode instruction count mismatch")    let asm_insns = ssElts final_insns       insns_arr = Array.listArray (0, fromIntegral n_insns - 1) asm_insns@@ -351,7 +364,9 @@            fromIntegral (w `shiftR` 32),            fromIntegral (w `shiftR` 16),            fromIntegral w]-   PW4 -> [fromIntegral (w `shiftR` 16),+   PW4 -> assertPpr (w < fromIntegral (maxBound :: Word32))+                    (text "largeArg too big:" <+> ppr w) $+          [fromIntegral (w `shiftR` 16),            fromIntegral w]  largeArg16s :: Platform -> Word@@ -380,21 +395,18 @@   PUSH_BCO proto           -> do let ul_bco = assembleBCO platform proto                                  p <- ioptr (liftM BCOPtrBCO ul_bco)                                  emit bci_PUSH_G [Op p]-  PUSH_ALTS proto          -> do let ul_bco = assembleBCO platform proto-                                 p <- ioptr (liftM BCOPtrBCO ul_bco)-                                 emit bci_PUSH_ALTS [Op p]-  PUSH_ALTS_UNLIFTED proto pk+  PUSH_ALTS proto pk                            -> do let ul_bco = assembleBCO platform proto                                  p <- ioptr (liftM BCOPtrBCO ul_bco)                                  emit (push_alts pk) [Op p]-  PUSH_ALTS_TUPLE proto tuple_info tuple_proto+  PUSH_ALTS_TUPLE proto call_info tuple_proto                            -> do let ul_bco = assembleBCO platform proto                                      ul_tuple_bco = assembleBCO platform                                                                 tuple_proto                                  p <- ioptr (liftM BCOPtrBCO ul_bco)                                  p_tup <- ioptr (liftM BCOPtrBCO ul_tuple_bco)                                  info <- int (fromIntegral $-                                              mkTupleInfoSig platform tuple_info)+                                              mkNativeCallInfoSig platform call_info)                                  emit bci_PUSH_ALTS_T                                       [Op p, Op info, Op p_tup]   PUSH_PAD8                -> emit bci_PUSH_PAD8 []@@ -409,6 +421,10 @@   PUSH_UBX lit nws         -> do np <- literal lit                                  emit bci_PUSH_UBX [Op np, SmallOp nws] +  -- see Note [Generating code for top-level string literal bindings] in GHC.StgToByteCode+  PUSH_ADDR nm             -> do np <- lit [BCONPtrAddr nm]+                                 emit bci_PUSH_UBX [Op np, SmallOp 1]+   PUSH_APPLY_N             -> emit bci_PUSH_APPLY_N []   PUSH_APPLY_V             -> emit bci_PUSH_APPLY_V []   PUSH_APPLY_F             -> emit bci_PUSH_APPLY_F []@@ -439,6 +455,38 @@                                  emit bci_TESTLT_W [Op np, LabelOp l]   TESTEQ_W  w l            -> do np <- word w                                  emit bci_TESTEQ_W [Op np, LabelOp l]+  TESTLT_I64  i l          -> do np <- int64 i+                                 emit bci_TESTLT_I64 [Op np, LabelOp l]+  TESTEQ_I64  i l          -> do np <- int64 i+                                 emit bci_TESTEQ_I64 [Op np, LabelOp l]+  TESTLT_I32  i l          -> do np <- int (fromIntegral i)+                                 emit bci_TESTLT_I32 [Op np, LabelOp l]+  TESTEQ_I32 i l           -> do np <- int (fromIntegral i)+                                 emit bci_TESTEQ_I32 [Op np, LabelOp l]+  TESTLT_I16  i l          -> do np <- int (fromIntegral i)+                                 emit bci_TESTLT_I16 [Op np, LabelOp l]+  TESTEQ_I16 i l           -> do np <- int (fromIntegral i)+                                 emit bci_TESTEQ_I16 [Op np, LabelOp l]+  TESTLT_I8  i l           -> do np <- int (fromIntegral i)+                                 emit bci_TESTLT_I8 [Op np, LabelOp l]+  TESTEQ_I8 i l            -> do np <- int (fromIntegral i)+                                 emit bci_TESTEQ_I8 [Op np, LabelOp l]+  TESTLT_W64  w l          -> do np <- word64 w+                                 emit bci_TESTLT_W64 [Op np, LabelOp l]+  TESTEQ_W64  w l          -> do np <- word64 w+                                 emit bci_TESTEQ_W64 [Op np, LabelOp l]+  TESTLT_W32  w l          -> do np <- word (fromIntegral w)+                                 emit bci_TESTLT_W32 [Op np, LabelOp l]+  TESTEQ_W32  w l          -> do np <- word (fromIntegral w)+                                 emit bci_TESTEQ_W32 [Op np, LabelOp l]+  TESTLT_W16  w l          -> do np <- word (fromIntegral w)+                                 emit bci_TESTLT_W16 [Op np, LabelOp l]+  TESTEQ_W16  w l          -> do np <- word (fromIntegral w)+                                 emit bci_TESTEQ_W16 [Op np, LabelOp l]+  TESTLT_W8  w l           -> do np <- word (fromIntegral w)+                                 emit bci_TESTLT_W8 [Op np, LabelOp l]+  TESTEQ_W8  w l           -> do np <- word (fromIntegral w)+                                 emit bci_TESTEQ_W8 [Op np, LabelOp l]   TESTLT_F  f l            -> do np <- float f                                  emit bci_TESTLT_F [Op np, LabelOp l]   TESTEQ_F  f l            -> do np <- float f@@ -453,11 +501,11 @@   SWIZZLE   stkoff n       -> emit bci_SWIZZLE [SmallOp stkoff, SmallOp n]   JMP       l              -> emit bci_JMP [LabelOp l]   ENTER                    -> emit bci_ENTER []-  RETURN                   -> emit bci_RETURN []-  RETURN_UNLIFTED rep      -> emit (return_unlifted rep) []+  RETURN rep               -> emit (return_non_tuple rep) []   RETURN_TUPLE             -> emit bci_RETURN_T []   CCALL off m_addr i       -> do np <- addr m_addr                                  emit bci_CCALL [SmallOp off, Op np, SmallOp i]+  PRIMCALL                 -> emit bci_PRIMCALL []   BRK_FUN index uniq cc    -> do p1 <- ptr BCOPtrBreakArray                                  q <- int (getKey uniq)                                  np <- addr cc@@ -504,6 +552,7 @@     int16 = words . mkLitI64 platform     int32 = words . mkLitI64 platform     int64 = words . mkLitI64 platform+    word64 = words . mkLitW64 platform     words ws = lit (map BCONPtrWord ws)     word w = words [w] @@ -521,16 +570,16 @@ push_alts V32 = error "push_alts: vector" push_alts V64 = error "push_alts: vector" -return_unlifted :: ArgRep -> Word16-return_unlifted V   = bci_RETURN_V-return_unlifted P   = bci_RETURN_P-return_unlifted N   = bci_RETURN_N-return_unlifted L   = bci_RETURN_L-return_unlifted F   = bci_RETURN_F-return_unlifted D   = bci_RETURN_D-return_unlifted V16 = error "return_unlifted: vector"-return_unlifted V32 = error "return_unlifted: vector"-return_unlifted V64 = error "return_unlifted: vector"+return_non_tuple :: ArgRep -> Word16+return_non_tuple V   = bci_RETURN_V+return_non_tuple P   = bci_RETURN_P+return_non_tuple N   = bci_RETURN_N+return_non_tuple L   = bci_RETURN_L+return_non_tuple F   = bci_RETURN_F+return_non_tuple D   = bci_RETURN_D+return_non_tuple V16 = error "return_non_tuple: vector"+return_non_tuple V32 = error "return_non_tuple: vector"+return_non_tuple V64 = error "return_non_tuple: vector"  {-   we can only handle up to a fixed number of words on the stack,@@ -546,41 +595,44 @@   maximum number of tuple elements may be larger. Elements can also   take multiple words on the stack (for example Double# on a 32 bit   platform).-  -}-maxTupleNativeStackSize :: WordOff-maxTupleNativeStackSize = 62+maxTupleReturnNativeStackSize :: WordOff+maxTupleReturnNativeStackSize = 62  {--  Construct the tuple_info word that stg_ctoi_t and stg_ret_t use-  to convert a tuple between the native calling convention and the+  Construct the call_info word that stg_ctoi_t, stg_ret_t and stg_primcall+  use to convert arguments between the native calling convention and the   interpreter. -  See Note [GHCi tuple layout] for more information.+  See Note [GHCi and native call registers] for more information.  -}-mkTupleInfoSig :: Platform -> TupleInfo -> Word32-mkTupleInfoSig platform TupleInfo{..}-  | tupleNativeStackSize > maxTupleNativeStackSize-  = pprPanic "mkTupleInfoSig: tuple too big for the bytecode compiler"-             (ppr tupleNativeStackSize <+> text "stack words." <+>+mkNativeCallInfoSig :: Platform -> NativeCallInfo -> Word32+mkNativeCallInfoSig platform NativeCallInfo{..}+  | nativeCallType == NativeTupleReturn && nativeCallStackSpillSize > maxTupleReturnNativeStackSize+  = pprPanic "mkNativeCallInfoSig: tuple too big for the bytecode compiler"+             (ppr nativeCallStackSpillSize <+> text "stack words." <+>               text "Use -fobject-code to get around this limit"              )   | otherwise-  = assert (length regs <= 24) {- 24 bits for bitmap -}-    assert (tupleNativeStackSize < 255) {- 8 bits for stack size -}-    assert (all (`elem` regs) (regSetToList tupleRegs)) {- all regs accounted for -}-    foldl' reg_bit 0 (zip regs [0..]) .|.-      (fromIntegral tupleNativeStackSize `shiftL` 24)+  = assertPpr (length regs <= 24) (text "too many registers for bitmap:" <+> ppr (length regs)) {- 24 bits for register bitmap -}+    assertPpr (cont_offset < 255) (text "continuation offset too large:" <+> ppr cont_offset) {- 8 bits for continuation offset (only for NativeTupleReturn) -}+    assertPpr (all (`elem` regs) (regSetToList nativeCallRegs)) (text "not all registers accounted for") {- all regs accounted for -}+    foldl' reg_bit 0 (zip regs [0..]) .|. (cont_offset `shiftL` 24)   where+    cont_offset :: Word32+    cont_offset+      | nativeCallType == NativeTupleReturn = fromIntegral nativeCallStackSpillSize+      | otherwise                           = 0 -- there is no continuation for primcalls+     reg_bit :: Word32 -> (GlobalReg, Int) -> Word32     reg_bit x (r, n)-      | r `elemRegSet` tupleRegs = x .|. 1 `shiftL` n-      | otherwise                = x-    regs = tupleRegsCover platform+      | r `elemRegSet` nativeCallRegs = x .|. 1 `shiftL` n+      | otherwise                     = x+    regs = allArgRegsCover platform -mkTupleInfoLit :: Platform -> TupleInfo -> Literal-mkTupleInfoLit platform tuple_info =-  mkLitWord platform . fromIntegral $ mkTupleInfoSig platform tuple_info+mkNativeCallInfoLit :: Platform -> NativeCallInfo -> Literal+mkNativeCallInfoLit platform call_info =+  mkLitWord platform . fromIntegral $ mkNativeCallInfoSig platform call_info  -- Make lists of host-sized words for literals, so that when the -- words are placed in memory at increasing addresses, the@@ -589,6 +641,7 @@ mkLitF   :: Platform -> Float  -> [Word] mkLitD   :: Platform -> Double -> [Word] mkLitI64 :: Platform -> Int64  -> [Word]+mkLitW64 :: Platform -> Word64 -> [Word]  mkLitF platform f = case platformWordSize platform of   PW4 -> runST $ do@@ -635,13 +688,18 @@         w1 <- readArray d_arr 1         return [w0 :: Word,w1]      )-   PW8 -> runST (do-        arr <- newArray_ ((0::Int),0)-        writeArray arr 0 ii+   PW8 -> [fromIntegral ii :: Word]++mkLitW64 platform ww = case platformWordSize platform of+   PW4 -> runST (do+        arr <- newArray_ ((0::Word),1)+        writeArray arr 0 ww         d_arr <- castSTUArray arr         w0 <- readArray d_arr 0-        return [w0 :: Word]+        w1 <- readArray d_arr 1+        return [w0 :: Word,w1]      )+   PW8 -> [fromIntegral ww :: Word]  mkLitI i = [fromIntegral i :: Word] 

@@ -1,5 +1,6 @@  {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-} {-# OPTIONS_GHC -funbox-strict-fields #-} -- --  (c) The University of Glasgow 2002-2006@@ -24,7 +25,9 @@ import GHC.Builtin.PrimOps import GHC.Runtime.Heap.Layout +import Data.Int import Data.Word+ import GHC.Stack.CCS (CostCentre)  import GHC.Stg.Syntax@@ -85,10 +88,9 @@    | PUSH_BCO     (ProtoBCO Name)     -- Push an alt continuation-   | PUSH_ALTS          (ProtoBCO Name)-   | PUSH_ALTS_UNLIFTED (ProtoBCO Name) ArgRep+   | PUSH_ALTS          (ProtoBCO Name) ArgRep    | PUSH_ALTS_TUPLE    (ProtoBCO Name) -- continuation-                        !TupleInfo+                        !NativeCallInfo                         (ProtoBCO Name) -- tuple return BCO     -- Pushing 8, 16 and 32 bits of padding (for constructors).@@ -110,6 +112,10 @@         -- type, and it appears impossible to get hold of the bits of         -- an addr, even though we need to assemble BCOs. +   -- Push a top-level Addr#. This is a pseudo-instruction assembled to PUSH_UBX,+   -- see Note [Generating code for top-level string literal bindings] in GHC.StgToByteCode.+   | PUSH_ADDR Name+    -- various kinds of application    | PUSH_APPLY_N    | PUSH_APPLY_V@@ -141,6 +147,22 @@    | TESTEQ_I  Int    LocalLabel    | TESTLT_W  Word   LocalLabel    | TESTEQ_W  Word   LocalLabel+   | TESTLT_I64 Int64 LocalLabel+   | TESTEQ_I64 Int64 LocalLabel+   | TESTLT_I32 Int32 LocalLabel+   | TESTEQ_I32 Int32 LocalLabel+   | TESTLT_I16 Int16 LocalLabel+   | TESTEQ_I16 Int16 LocalLabel+   | TESTLT_I8 Int8   LocalLabel+   | TESTEQ_I8 Int16  LocalLabel+   | TESTLT_W64 Word64 LocalLabel+   | TESTEQ_W64 Word64 LocalLabel+   | TESTLT_W32 Word32 LocalLabel+   | TESTEQ_W32 Word32 LocalLabel+   | TESTLT_W16 Word16 LocalLabel+   | TESTEQ_W16 Word16 LocalLabel+   | TESTLT_W8 Word8 LocalLabel+   | TESTEQ_W8 Word8 LocalLabel    | TESTLT_F  Float  LocalLabel    | TESTEQ_F  Float  LocalLabel    | TESTLT_D  Double LocalLabel@@ -166,15 +188,18 @@                                 -- (XXX: inefficient, but I don't know                                 -- what the alignment constraints are.) +   | PRIMCALL+    -- For doing magic ByteArray passing to foreign calls    | SWIZZLE          Word16 -- to the ptr N words down the stack,                       Word16 -- add M (interpreted as a signed 16-bit entity)     -- To Infinity And Beyond    | ENTER-   | RETURN                 -- return a lifted value-   | RETURN_UNLIFTED ArgRep -- return an unlifted value, here's its rep-   | RETURN_TUPLE           -- return an unboxed tuple (info already on stack)+   | RETURN ArgRep -- return a non-tuple value, here's its rep; see+                   -- Note [Return convention for non-tuple values] in GHC.StgToByteCode+   | RETURN_TUPLE  -- return an unboxed tuple (info already on stack); see+                   -- Note [unboxed tuple bytecodes and tuple_BCO] in GHC.StgToByteCode     -- Breakpoints    | BRK_FUN          Word16 Unique (RemotePtr CostCentre)@@ -249,10 +274,9 @@                                                <> ppr op    ppr (PUSH_BCO bco)        = hang (text "PUSH_BCO") 2 (ppr bco) -   ppr (PUSH_ALTS bco)       = hang (text "PUSH_ALTS") 2 (ppr bco)-   ppr (PUSH_ALTS_UNLIFTED bco pk) = hang (text "PUSH_ALTS_UNLIFTED" <+> ppr pk) 2 (ppr bco)-   ppr (PUSH_ALTS_TUPLE bco tuple_info tuple_bco) =-                               hang (text "PUSH_ALTS_TUPLE" <+> ppr tuple_info)+   ppr (PUSH_ALTS bco pk)    = hang (text "PUSH_ALTS" <+> ppr pk) 2 (ppr bco)+   ppr (PUSH_ALTS_TUPLE bco call_info tuple_bco) =+                               hang (text "PUSH_ALTS_TUPLE" <+> ppr call_info)                                     2                                     (ppr tuple_bco $+$ ppr bco) @@ -264,6 +288,7 @@    ppr (PUSH_UBX16 lit)      = text "PUSH_UBX16" <+> ppr lit    ppr (PUSH_UBX32 lit)      = text "PUSH_UBX32" <+> ppr lit    ppr (PUSH_UBX lit nw)     = text "PUSH_UBX" <+> parens (ppr nw) <+> ppr lit+   ppr (PUSH_ADDR nm)        = text "PUSH_ADDR" <+> ppr nm    ppr PUSH_APPLY_N          = text "PUSH_APPLY_N"    ppr PUSH_APPLY_V          = text "PUSH_APPLY_V"    ppr PUSH_APPLY_F          = text "PUSH_APPLY_F"@@ -291,6 +316,22 @@    ppr (TESTEQ_I  i lab)     = text "TESTEQ_I" <+> int i <+> text "__" <> ppr lab    ppr (TESTLT_W  i lab)     = text "TESTLT_W" <+> int (fromIntegral i) <+> text "__" <> ppr lab    ppr (TESTEQ_W  i lab)     = text "TESTEQ_W" <+> int (fromIntegral i) <+> text "__" <> ppr lab+   ppr (TESTLT_I64  i lab)   = text "TESTLT_I64" <+> ppr i <+> text "__" <> ppr lab+   ppr (TESTEQ_I64  i lab)   = text "TESTEQ_I64" <+> ppr i <+> text "__" <> ppr lab+   ppr (TESTLT_I32  i lab)   = text "TESTLT_I32" <+> ppr i <+> text "__" <> ppr lab+   ppr (TESTEQ_I32  i lab)   = text "TESTEQ_I32" <+> ppr i <+> text "__" <> ppr lab+   ppr (TESTLT_I16  i lab)   = text "TESTLT_I16" <+> ppr i <+> text "__" <> ppr lab+   ppr (TESTEQ_I16  i lab)   = text "TESTEQ_I16" <+> ppr i <+> text "__" <> ppr lab+   ppr (TESTLT_I8  i lab)    = text "TESTLT_I8" <+> ppr i <+> text "__" <> ppr lab+   ppr (TESTEQ_I8  i lab)    = text "TESTEQ_I8" <+> ppr i <+> text "__" <> ppr lab+   ppr (TESTLT_W64  i lab)   = text "TESTLT_W64" <+> ppr i <+> text "__" <> ppr lab+   ppr (TESTEQ_W64  i lab)   = text "TESTEQ_W64" <+> ppr i <+> text "__" <> ppr lab+   ppr (TESTLT_W32  i lab)   = text "TESTLT_W32" <+> ppr i <+> text "__" <> ppr lab+   ppr (TESTEQ_W32  i lab)   = text "TESTEQ_W32" <+> ppr i <+> text "__" <> ppr lab+   ppr (TESTLT_W16  i lab)   = text "TESTLT_W16" <+> ppr i <+> text "__" <> ppr lab+   ppr (TESTEQ_W16  i lab)   = text "TESTEQ_W16" <+> ppr i <+> text "__" <> ppr lab+   ppr (TESTLT_W8  i lab)    = text "TESTLT_W8" <+> ppr i <+> text "__" <> ppr lab+   ppr (TESTEQ_W8  i lab)    = text "TESTEQ_W8" <+> ppr i <+> text "__" <> ppr lab    ppr (TESTLT_F  f lab)     = text "TESTLT_F" <+> float f <+> text "__" <> ppr lab    ppr (TESTEQ_F  f lab)     = text "TESTEQ_F" <+> float f <+> text "__" <> ppr lab    ppr (TESTLT_D  d lab)     = text "TESTLT_D" <+> double d <+> text "__" <> ppr lab@@ -306,13 +347,16 @@                                                       0x1 -> text "(interruptible)"                                                       0x2 -> text "(unsafe)"                                                       _   -> empty)+   ppr PRIMCALL              = text "PRIMCALL"    ppr (SWIZZLE stkoff n)    = text "SWIZZLE " <+> text "stkoff" <+> ppr stkoff                                                <+> text "by" <+> ppr n    ppr ENTER                 = text "ENTER"-   ppr RETURN                = text "RETURN"-   ppr (RETURN_UNLIFTED pk)  = text "RETURN_UNLIFTED  " <+> ppr pk+   ppr (RETURN pk)           = text "RETURN  " <+> ppr pk    ppr (RETURN_TUPLE)        = text "RETURN_TUPLE"-   ppr (BRK_FUN index uniq _cc) = text "BRK_FUN" <+> ppr index <+> ppr uniq <+> text "<cc>"+   ppr (BRK_FUN index uniq _cc) = text "BRK_FUN" <+> ppr index <+> mb_uniq <+> text "<cc>"+     where mb_uniq = sdocOption sdocSuppressUniques $ \case+             True  -> text "<uniq>"+             False -> ppr uniq   @@ -343,16 +387,14 @@ bciStackUse PUSH_G{}              = 1 bciStackUse PUSH_PRIMOP{}         = 1 bciStackUse PUSH_BCO{}            = 1-bciStackUse (PUSH_ALTS bco)       = 2 {- profiling only, restore CCCS -} ++bciStackUse (PUSH_ALTS bco _)     = 2 {- profiling only, restore CCCS -} +                                     3 + protoBCOStackUse bco-bciStackUse (PUSH_ALTS_UNLIFTED bco _) = 2 {- profiling only, restore CCCS -} +-                                         4 + protoBCOStackUse bco bciStackUse (PUSH_ALTS_TUPLE bco info _) =-   -- (tuple_bco, tuple_info word, cont_bco, stg_ctoi_t)+   -- (tuple_bco, call_info word, cont_bco, stg_ctoi_t)    -- tuple-   -- (tuple_info, tuple_bco, stg_ret_t)+   -- (call_info, tuple_bco, stg_ret_t)    1 {- profiling only -} +-   7 + fromIntegral (tupleSize info) + protoBCOStackUse bco+   7 + fromIntegral (nativeCallSize info) + protoBCOStackUse bco bciStackUse (PUSH_PAD8)           = 1  -- overapproximation bciStackUse (PUSH_PAD16)          = 1  -- overapproximation bciStackUse (PUSH_PAD32)          = 1  -- overapproximation on 64bit arch@@ -360,6 +402,7 @@ bciStackUse (PUSH_UBX16 _)        = 1  -- overapproximation bciStackUse (PUSH_UBX32 _)        = 1  -- overapproximation on 64bit arch bciStackUse (PUSH_UBX _ nw)       = fromIntegral nw+bciStackUse PUSH_ADDR{}           = 1 bciStackUse PUSH_APPLY_N{}        = 1 bciStackUse PUSH_APPLY_V{}        = 1 bciStackUse PUSH_APPLY_F{}        = 1@@ -380,6 +423,22 @@ bciStackUse TESTEQ_I{}            = 0 bciStackUse TESTLT_W{}            = 0 bciStackUse TESTEQ_W{}            = 0+bciStackUse TESTLT_I64{}          = 0+bciStackUse TESTEQ_I64{}          = 0+bciStackUse TESTLT_I32{}          = 0+bciStackUse TESTEQ_I32{}          = 0+bciStackUse TESTLT_I16{}          = 0+bciStackUse TESTEQ_I16{}          = 0+bciStackUse TESTLT_I8{}           = 0+bciStackUse TESTEQ_I8{}           = 0+bciStackUse TESTLT_W64{}          = 0+bciStackUse TESTEQ_W64{}          = 0+bciStackUse TESTLT_W32{}          = 0+bciStackUse TESTEQ_W32{}          = 0+bciStackUse TESTLT_W16{}          = 0+bciStackUse TESTEQ_W16{}          = 0+bciStackUse TESTLT_W8{}           = 0+bciStackUse TESTEQ_W8{}           = 0 bciStackUse TESTLT_F{}            = 0 bciStackUse TESTEQ_F{}            = 0 bciStackUse TESTLT_D{}            = 0@@ -389,10 +448,10 @@ bciStackUse CASEFAIL{}            = 0 bciStackUse JMP{}                 = 0 bciStackUse ENTER{}               = 0-bciStackUse RETURN{}              = 0-bciStackUse RETURN_UNLIFTED{}     = 1 -- pushes stg_ret_X for some X+bciStackUse RETURN{}              = 1 -- pushes stg_ret_X for some X bciStackUse RETURN_TUPLE{}        = 1 -- pushes stg_ret_t header bciStackUse CCALL{}               = 0+bciStackUse PRIMCALL{}            = 1 -- pushes stg_primcall bciStackUse SWIZZLE{}             = 0 bciStackUse BRK_FUN{}             = 0 

@@ -8,10 +8,7 @@  -- | Bytecode assembler and linker module GHC.ByteCode.Linker-  ( ClosureEnv-  , emptyClosureEnv-  , extendClosureEnv-  , linkBCO+  ( linkBCO   , lookupStaticPtr   , lookupIE   , nameToCLabel@@ -36,6 +33,8 @@ import GHC.Data.FastString import GHC.Data.SizedSeq +import GHC.Linker.Types+ import GHC.Utils.Panic import GHC.Utils.Panic.Plain import GHC.Utils.Outputable@@ -52,46 +51,35 @@   Linking interpretables into something we can run -} -type ClosureEnv = NameEnv (Name, ForeignHValue)--emptyClosureEnv :: ClosureEnv-emptyClosureEnv = emptyNameEnv--extendClosureEnv :: ClosureEnv -> [(Name,ForeignHValue)] -> ClosureEnv-extendClosureEnv cl_env pairs-  = extendNameEnvList cl_env [ (n, (n,v)) | (n,v) <- pairs]--{--  Linking interpretables into something we can run--}- linkBCO   :: Interp-  -> ItblEnv-  -> ClosureEnv+  -> LinkerEnv   -> NameEnv Int   -> RemoteRef BreakArray   -> UnlinkedBCO   -> IO ResolvedBCO-linkBCO interp ie ce bco_ix breakarray+linkBCO interp le bco_ix breakarray            (UnlinkedBCO _ arity insns bitmap lits0 ptrs0) = do   -- fromIntegral Word -> Word64 should be a no op if Word is Word64   -- otherwise it will result in a cast to longlong on 32bit systems.-  lits <- mapM (fmap fromIntegral . lookupLiteral interp ie) (ssElts lits0)-  ptrs <- mapM (resolvePtr interp ie ce bco_ix breakarray) (ssElts ptrs0)+  lits <- mapM (fmap fromIntegral . lookupLiteral interp le) (ssElts lits0)+  ptrs <- mapM (resolvePtr interp le bco_ix breakarray) (ssElts ptrs0)   return (ResolvedBCO isLittleEndian arity insns bitmap               (listArray (0, fromIntegral (sizeSS lits0)-1) lits)               (addListToSS emptySS ptrs)) -lookupLiteral :: Interp -> ItblEnv -> BCONPtr -> IO Word-lookupLiteral interp ie ptr = case ptr of+lookupLiteral :: Interp -> LinkerEnv -> BCONPtr -> IO Word+lookupLiteral interp le ptr = case ptr of   BCONPtrWord lit -> return lit   BCONPtrLbl  sym -> do     Ptr a# <- lookupStaticPtr interp sym     return (W# (int2Word# (addr2Int# a#)))   BCONPtrItbl nm -> do-    Ptr a# <- lookupIE interp ie nm+    Ptr a# <- lookupIE interp (itbl_env le) nm     return (W# (int2Word# (addr2Int# a#)))+  BCONPtrAddr nm -> do+    Ptr a# <- lookupAddr interp (addr_env le) nm+    return (W# (int2Word# (addr2Int# a#)))   BCONPtrStr _ ->     -- should be eliminated during assembleBCOs     panic "lookupLiteral: BCONPtrStr"@@ -123,6 +111,20 @@                                       (unpackFS sym_to_find1 ++ " or " ++                                        unpackFS sym_to_find2) +-- see Note [Generating code for top-level string literal bindings] in GHC.StgToByteCode+lookupAddr :: Interp -> AddrEnv -> Name -> IO (Ptr ())+lookupAddr interp ae addr_nm = do+  case lookupNameEnv ae addr_nm of+    Just (_, AddrPtr ptr) -> return (fromRemotePtr ptr)+    Nothing -> do -- try looking up in the object files.+      let sym_to_find = nameToCLabel addr_nm "bytes"+                          -- see Note [Bytes label] in GHC.Cmm.CLabel+      m <- lookupSymbol interp sym_to_find+      case m of+        Just ptr -> return ptr+        Nothing -> linkFail "GHC.ByteCode.Linker.lookupAddr"+                     (unpackFS sym_to_find)+ lookupPrimOp :: Interp -> PrimOp -> IO (RemotePtr ()) lookupPrimOp interp primop = do   let sym_to_find = primopToCLabel primop "closure"@@ -133,18 +135,17 @@  resolvePtr   :: Interp-  -> ItblEnv-  -> ClosureEnv+  -> LinkerEnv   -> NameEnv Int   -> RemoteRef BreakArray   -> BCOPtr   -> IO ResolvedBCOPtr-resolvePtr interp ie ce bco_ix breakarray ptr = case ptr of+resolvePtr interp le bco_ix breakarray ptr = case ptr of   BCOPtrName nm     | Just ix <- lookupNameEnv bco_ix nm     -> return (ResolvedBCORef ix) -- ref to another BCO in this group -    | Just (_, rhv) <- lookupNameEnv ce nm+    | Just (_, rhv) <- lookupNameEnv (closure_env le) nm     -> return (ResolvedBCOPtr (unsafeForeignRefToRemoteRef rhv))      | otherwise@@ -160,7 +161,7 @@     -> ResolvedBCOStaticPtr <$> lookupPrimOp interp op    BCOPtrBCO bco-    -> ResolvedBCOPtrBCO <$> linkBCO interp ie ce bco_ix breakarray bco+    -> ResolvedBCOPtrBCO <$> linkBCO interp le bco_ix breakarray bco    BCOPtrBreakArray     -> return (ResolvedBCOPtrBreakArray breakarray)

@@ -9,10 +9,11 @@   ( CompiledByteCode(..), seqCompiledByteCode   , FFIInfo(..)   , RegBitmap(..)-  , TupleInfo(..), voidTupleInfo+  , NativeCallType(..), NativeCallInfo(..), voidTupleReturnInfo, voidPrimCallInfo   , ByteOff(..), WordOff(..)   , UnlinkedBCO(..), BCOPtr(..), BCONPtr(..)   , ItblEnv, ItblPtr(..)+  , AddrEnv, AddrPtr(..)   , CgBreakInfo(..)   , ModBreaks (..), BreakIndex, emptyModBreaks   , CCostCentre@@ -50,7 +51,7 @@   { bc_bcos   :: [UnlinkedBCO]  -- Bunch of interpretable bindings   , bc_itbls  :: ItblEnv        -- A mapping from DataCons to their itbls   , bc_ffis   :: [FFIInfo]      -- ffi blocks we allocated-  , bc_strs   :: [RemotePtr ()] -- malloc'd strings+  , bc_strs   :: AddrEnv        -- malloc'd top-level strings   , bc_breaks :: Maybe ModBreaks -- breakpoint info (Nothing if we're not                                  -- creating breakpoints, for some reason)   }@@ -68,7 +69,7 @@   rnf bc_bcos `seq`   seqEltsNameEnv rnf bc_itbls `seq`   rnf bc_ffis `seq`-  rnf bc_strs `seq`+  seqEltsNameEnv rnf bc_strs `seq`   rnf (fmap seqModBreaks bc_breaks)  newtype ByteOff = ByteOff Int@@ -102,29 +103,42 @@     See GHC.StgToByteCode.layoutTuple for more details. -}-data TupleInfo = TupleInfo-  { tupleSize            :: !WordOff   -- total size of tuple in words-  , tupleRegs            :: !GlobalRegSet-  , tupleNativeStackSize :: !WordOff {- words spilled on the stack by-                                        GHCs native calling convention -}-  } deriving (Show) -instance Outputable TupleInfo where-  ppr TupleInfo{..} = text "<size" <+> ppr tupleSize <+>-                      text "stack" <+> ppr tupleNativeStackSize <+>-                      text "regs"  <+>-                      ppr (map (text.show) $ regSetToList tupleRegs) <>-                      char '>'+data NativeCallType = NativePrimCall+                    | NativeTupleReturn+  deriving (Eq) -voidTupleInfo :: TupleInfo-voidTupleInfo = TupleInfo 0 emptyRegSet 0+data NativeCallInfo = NativeCallInfo+  { nativeCallType           :: !NativeCallType+  , nativeCallSize           :: !WordOff   -- total size of arguments in words+  , nativeCallRegs           :: !GlobalRegSet+  , nativeCallStackSpillSize :: !WordOff {- words spilled on the stack by+                                            GHCs native calling convention -}+  } +instance Outputable NativeCallInfo where+  ppr NativeCallInfo{..} = text "<arg_size" <+> ppr nativeCallSize <+>+                           text "stack" <+> ppr nativeCallStackSpillSize <+>+                           text "regs"  <+>+                           ppr (map (text . show) $ regSetToList nativeCallRegs) <>+                           char '>'+++voidTupleReturnInfo :: NativeCallInfo+voidTupleReturnInfo = NativeCallInfo NativeTupleReturn 0 emptyRegSet 0++voidPrimCallInfo :: NativeCallInfo+voidPrimCallInfo = NativeCallInfo NativePrimCall 0 emptyRegSet 0+ type ItblEnv = NameEnv (Name, ItblPtr)+type AddrEnv = NameEnv (Name, AddrPtr)         -- We need the Name in the range so we know which         -- elements to filter out when unloading a module  newtype ItblPtr = ItblPtr (RemotePtr Heap.StgInfoTable)   deriving (Show, NFData)+newtype AddrPtr = AddrPtr (RemotePtr ())+  deriving (NFData)  data UnlinkedBCO    = UnlinkedBCO {@@ -155,6 +169,12 @@   = BCONPtrWord  {-# UNPACK #-} !Word   | BCONPtrLbl   !FastString   | BCONPtrItbl  !Name+  -- | A reference to a top-level string literal; see+  -- Note [Generating code for top-level string literal bindings] in GHC.StgToByteCode.+  | BCONPtrAddr  !Name+  -- | Only used internally in the assembler in an intermediate representation;+  -- should never appear in a fully-assembled UnlinkedBCO.+  -- Also see Note [Allocating string literals] in GHC.ByteCode.Asm.   | BCONPtrStr   !ByteString  instance NFData BCONPtr where

@@ -65,6 +65,7 @@         mkSMAP_DIRTY_infoLabel,         mkBadAlignmentLabel,         mkOutOfBoundsAccessLabel,+        mkMemcpyRangeOverlapLabel,         mkArrWords_infoLabel,         mkSRTInfoLabel, @@ -643,7 +644,8 @@     mkCAFBlackHoleInfoTableLabel,     mkSMAP_FROZEN_CLEAN_infoLabel, mkSMAP_FROZEN_DIRTY_infoLabel,     mkSMAP_DIRTY_infoLabel, mkBadAlignmentLabel,-    mkOutOfBoundsAccessLabel, mkMUT_VAR_CLEAN_infoLabel :: CLabel+    mkOutOfBoundsAccessLabel, mkMemcpyRangeOverlapLabel,+    mkMUT_VAR_CLEAN_infoLabel :: CLabel mkDirty_MUT_VAR_Label           = mkForeignLabel (fsLit "dirty_MUT_VAR") Nothing ForeignLabelInExternalPackage IsFunction mkNonmovingWriteBarrierEnabledLabel                                 = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "nonmoving_write_barrier_enabled") CmmData@@ -661,7 +663,8 @@ mkSMAP_FROZEN_DIRTY_infoLabel   = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_SMALL_MUT_ARR_PTRS_FROZEN_DIRTY") CmmInfo mkSMAP_DIRTY_infoLabel          = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_SMALL_MUT_ARR_PTRS_DIRTY") CmmInfo mkBadAlignmentLabel             = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_badAlignment")      CmmEntry-mkOutOfBoundsAccessLabel        = mkForeignLabel (fsLit "rtsOutOfBoundsAccess") Nothing ForeignLabelInExternalPackage IsFunction+mkOutOfBoundsAccessLabel        = mkForeignLabel (fsLit "rtsOutOfBoundsAccess")  Nothing ForeignLabelInExternalPackage IsFunction+mkMemcpyRangeOverlapLabel       = mkForeignLabel (fsLit "rtsMemcpyRangeOverlap") Nothing ForeignLabelInExternalPackage IsFunction mkMUT_VAR_CLEAN_infoLabel       = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_MUT_VAR_CLEAN")     CmmInfo  mkSRTInfoLabel :: Int -> CLabel@@ -1356,6 +1359,7 @@                    ordinary Haskell function of arity 1 that                    allocates a (Just x) box:                       Just = \x -> Just x+    Just_entry:    The entry code for the worker function     Just_closure:  The closure for this worker      Nothing_closure: a statically allocated closure for Nothing

@@ -3,7 +3,7 @@   assignArgumentsPos,   assignStack,   realArgRegsCover,-  tupleRegsCover+  allArgRegsCover ) where  import GHC.Prelude@@ -221,12 +221,109 @@       realLongRegs   platform       -- we don't save XMM registers if they are not used for parameter passing --- Like realArgRegsCover but always includes the node. This covers the real--- and virtual registers used for unboxed tuples.------ Note: if anything changes in how registers for unboxed tuples overlap,---       make sure to also update GHC.StgToByteCode.layoutTuple. -tupleRegsCover :: Platform -> [GlobalReg]-tupleRegsCover platform =+{-++  Note [GHCi and native call registers]+  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++  The GHCi bytecode interpreter does not have access to the STG registers+  that the native calling convention uses for passing arguments. It uses+  helper stack frames to move values between the stack and registers.++  If only a single register needs to be moved, GHCi uses a specific stack+  frame. For example stg_ctoi_R1p saves a heap pointer value from STG register+  R1 and stg_ctoi_D1 saves a double precision floating point value from D1.+  In the other direction, helpers stg_ret_p and stg_ret_d move a value from+  the stack to the R1 and D1 registers, respectively.++  When GHCi needs to move more than one register it cannot use a specific+  helper frame. It would simply be impossible to create a helper for all+  possible combinations of register values. Instead, there are generic helper+  stack frames that use a call_info word that describes the active registers+  and the number of stack words used by the arguments of a call.++  These helper stack frames are currently:++      - stg_ret_t:    return a tuple to the continuation at the top of+                          the stack+      - stg_ctoi_t:   convert a tuple return value to be used in+                          bytecode+      - stg_primcall: call a function+++  The call_info word contains a bitmap of the active registers+  for the call and and a stack offset. The layout is as follows:++      - bit 0-23:  Bitmap of active registers for the call, the+                   order corresponds to the list returned by+                   allArgRegsCover. For example if bit 0 (the least+                   significant bit) is set, the first register in the+                   allArgRegsCover list is active. Bit 1 for the+                   second register in the list and so on.++      - bit 24-31: Unsigned byte indicating the stack offset+                   of the continuation in words. For tuple returns+                   this is the number of words returned on the+                   stack. For primcalls this field is unused, since+                   we don't jump to a continuation.++    The upper 32 bits on 64 bit platforms are currently unused.++    If a register is smaller than a word on the stack (for example a+    single precision float on a 64 bit system), then the stack slot+    is padded to a whole word.++    Example:++        If a tuple is returned in three registers and an additional two+        words on the stack, then three bits in the register bitmap+        (bits 0-23) would be set. And bit 24-31 would be+        00000010 (two in binary).++        The values on the stack before a call to POP_ARG_REGS would+        be as follows:++            ...+            continuation+            stack_arg_1+            stack_arg_2+            register_arg_3+            register_arg_2+            register_arg_1 <- Sp++        A call to POP_ARG_REGS(call_info) would move register_arg_1+        to the register corresponding to the lowest set bit in the+        call_info word. register_arg_2 would be moved to the register+        corresponding to the second lowest set bit, and so on.++        After POP_ARG_REGS(call_info), the stack pointer Sp points+        to the topmost stack argument, so the stack looks as follows:++            ...+            continuation+            stack_arg_1+            stack_arg_2 <- Sp++        At this point all the arguments are in place and we are ready+        to jump to the continuation, the location (offset from Sp) of+        which is found by inspecting the value of bits 24-31. In this+        case the offset is two words.++    On x86_64, the double precision (Dn) and single precision+    floating (Fn) point registers overlap, e.g. D1 uses the same+    physical register as F1. On this platform, the list returned+    by allArgRegsCover contains only entries for the double+    precision registers. If an argument is passed in register+    Fn, the bit corresponding to Dn should be set.++  Note: if anything changes in how registers for native calls overlap,+           make sure to also update GHC.StgToByteCode.layoutNativeCall+ -}++-- Like realArgRegsCover but always includes the node. This covers all real+-- and virtual registers actually used for passing arguments.++allArgRegsCover :: Platform -> [GlobalReg]+allArgRegsCover platform =   nub (VanillaReg 1 VGcPtr : realArgRegsCover platform)

@@ -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.4.5-src/ghc-9.4.5/compiler/GHC/Cmm/Lexer.x" #-}+{-# LINE 13 "_build/source-dist/ghc-9.4.6-src/ghc-9.4.6/compiler/GHC/Cmm/Lexer.x" #-} module GHC.Cmm.Lexer (    CmmToken(..), cmmlex,   ) where@@ -385,7 +385,7 @@   , (0,alex_action_20)   ] -{-# LINE 133 "_build/source-dist/ghc-9.4.5-src/ghc-9.4.5/compiler/GHC/Cmm/Lexer.x" #-}+{-# LINE 133 "_build/source-dist/ghc-9.4.6-src/ghc-9.4.6/compiler/GHC/Cmm/Lexer.x" #-} data CmmToken   = CmmT_SpecChar  Char   | CmmT_DotDot

@@ -3126,8 +3126,8 @@   ( fsLit "SAVE_REGS",             \[] -> emitSaveRegs ),   ( fsLit "RESTORE_REGS",          \[] -> emitRestoreRegs ), -  ( fsLit "PUSH_TUPLE_REGS",      \[live_regs] -> emitPushTupleRegs live_regs ),-  ( fsLit "POP_TUPLE_REGS",       \[live_regs] -> emitPopTupleRegs live_regs ),+  ( fsLit "PUSH_ARG_REGS",         \[live_regs] -> emitPushArgRegs live_regs ),+  ( fsLit "POP_ARG_REGS",          \[live_regs] -> emitPopArgRegs live_regs ),    ( fsLit "LDV_ENTER",             \[e] -> ldvEnter e ),   ( fsLit "LDV_RECORD_CREATE",     \[e] -> ldvRecordCreate e ),

@@ -693,12 +693,16 @@     -- 1. Compute Reg +/- n directly.     --    For Add/Sub we can directly encode 12bits, or 12bits lsl #12.     CmmMachOp (MO_Add w) [(CmmReg reg), CmmLit (CmmInt n _)]-      | n > 0 && n < 4096 -> return $ Any (intFormat w) (\d -> unitOL $ annExpr expr (ADD (OpReg w d) (OpReg w' r') (OpImm (ImmInteger n))))+      | n > 0 && n < 4096+      , w == W32 || w == W64 -- Work around #23749+      -> return $ Any (intFormat w) (\d -> unitOL $ annExpr expr (ADD (OpReg w d) (OpReg w' r') (OpImm (ImmInteger n))))       -- TODO: 12bits lsl #12; e.g. lower 12 bits of n are 0; shift n >> 12, and set lsl to #12.       where w' = formatToWidth (cmmTypeFormat (cmmRegType plat reg))             r' = getRegisterReg plat reg     CmmMachOp (MO_Sub w) [(CmmReg reg), CmmLit (CmmInt n _)]-      | n > 0 && n < 4096 -> return $ Any (intFormat w) (\d -> unitOL $ annExpr expr (SUB (OpReg w d) (OpReg w' r') (OpImm (ImmInteger n))))+      | n > 0 && n < 4096+      , w == W32 || w == W64 -- Work around #23749+      -> return $ Any (intFormat w) (\d -> unitOL $ annExpr expr (SUB (OpReg w d) (OpReg w' r') (OpImm (ImmInteger n))))       -- TODO: 12bits lsl #12; e.g. lower 12 bits of n are 0; shift n >> 12, and set lsl to #12.       where w' = formatToWidth (cmmTypeFormat (cmmRegType plat reg))             r' = getRegisterReg plat reg

@@ -53,7 +53,7 @@         isRuntimeArg, isRuntimeVar,          -- * Unfolding data types-        Unfolding(..),  UnfoldingGuidance(..), UnfoldingSource(..),+        Unfolding(..),  UnfoldingCache(..), UnfoldingGuidance(..), UnfoldingSource(..),          -- ** Constructing 'Unfolding's         noUnfolding, bootUnfolding, evaldUnfolding, mkOtherCon,@@ -1368,15 +1368,8 @@         uf_tmpl       :: CoreExpr,        -- Template; occurrence info is correct         uf_src        :: UnfoldingSource, -- Where the unfolding came from         uf_is_top     :: Bool,          -- True <=> top level binding-        uf_is_value   :: Bool,          -- exprIsHNF template (cached); it is ok to discard-                                        --      a `seq` on this variable-        uf_is_conlike :: Bool,          -- True <=> applicn of constructor or CONLIKE function-                                        --      Cached version of exprIsConLike-        uf_is_work_free :: Bool,                -- True <=> doesn't waste (much) work to expand-                                        --          inside an inlining-                                        --      Cached version of exprIsCheap-        uf_expandable :: Bool,          -- True <=> can expand in RULE matching-                                        --      Cached version of exprIsExpandable+        uf_cache      :: UnfoldingCache,        -- Cache of flags computable from the expr+                                                -- See Note [Tying the 'CoreUnfolding' knot]         uf_guidance   :: UnfoldingGuidance      -- Tells about the *size* of the template.     }   -- ^ An unfolding with redundant cached information. Parameters:@@ -1426,6 +1419,21 @@                        -- Inline absolutely always, however boring the context.  +-- | Properties of a 'CoreUnfolding' that could be computed on-demand from its template.+-- See Note [UnfoldingCache]+data UnfoldingCache+  = UnfoldingCache {+        uf_is_value   :: !Bool,         -- exprIsHNF template (cached); it is ok to discard+                                        --      a `seq` on this variable+        uf_is_conlike :: !Bool,         -- True <=> applicn of constructor or CONLIKE function+                                        --      Cached version of exprIsConLike+        uf_is_work_free :: !Bool,       -- True <=> doesn't waste (much) work to expand+                                        --          inside an inlining+                                        --      Cached version of exprIsCheap+        uf_expandable :: !Bool          -- True <=> can expand in RULE matching+                                        --      Cached version of exprIsExpandable+    }+  deriving (Eq)  -- | 'UnfoldingGuidance' says when unfolding should take place data UnfoldingGuidance@@ -1456,7 +1464,23 @@   | UnfNever        -- The RHS is big, so don't inline it   deriving (Eq) -{-+{- Note [UnfoldingCache]+~~~~~~~~~~~~~~~~~~~~~~~~+The UnfoldingCache field of an Unfolding holds four (strict) booleans,+all derived from the uf_tmpl field of the unfolding.++* We serialise the UnfoldingCache to and from interface files, for+  reasons described in  Note [Tying the 'CoreUnfolding' knot] in+  GHC.IfaceToCore++* Because it is a strict data type, we must be careful not to+  pattern-match on it until we actually want its values.  E.g+  GHC.Core.Unfold.callSiteInline/tryUnfolding are careful not to force+  it unnecessarily.  Just saves a bit of work.++* When `seq`ing Core to eliminate space leaks, to suffices to `seq` on+  the cache, but not its fields, because it is strict in all fields.+ Note [Historical note: unfoldings for wrappers] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We used to have a nice clever scheme in interface files for@@ -1563,8 +1587,8 @@ -- yield a value (something in HNF): returns @False@ if unsure isValueUnfolding :: Unfolding -> Bool         -- Returns False for OtherCon-isValueUnfolding (CoreUnfolding { uf_is_value = is_evald }) = is_evald-isValueUnfolding _                                          = False+isValueUnfolding (CoreUnfolding { uf_cache = cache }) = uf_is_value cache+isValueUnfolding _                                    = False  -- | Determines if it possibly the case that the unfolding will -- yield a value. Unlike 'isValueUnfolding' it returns @True@@@ -1572,31 +1596,33 @@ isEvaldUnfolding :: Unfolding -> Bool         -- Returns True for OtherCon isEvaldUnfolding (OtherCon _)                               = True-isEvaldUnfolding (CoreUnfolding { uf_is_value = is_evald }) = is_evald+isEvaldUnfolding (CoreUnfolding { uf_cache = cache }) = uf_is_value cache isEvaldUnfolding _                                          = False  -- | @True@ if the unfolding is a constructor application, the application -- of a CONLIKE function or 'OtherCon' isConLikeUnfolding :: Unfolding -> Bool-isConLikeUnfolding (OtherCon _)                             = True-isConLikeUnfolding (CoreUnfolding { uf_is_conlike = con })  = con-isConLikeUnfolding _                                        = False+isConLikeUnfolding (OtherCon _)                         = True+isConLikeUnfolding (CoreUnfolding { uf_cache = cache }) = uf_is_conlike cache+isConLikeUnfolding _                                    = False  -- | Is the thing we will unfold into certainly cheap? isCheapUnfolding :: Unfolding -> Bool-isCheapUnfolding (CoreUnfolding { uf_is_work_free = is_wf }) = is_wf-isCheapUnfolding _                                           = False+isCheapUnfolding (CoreUnfolding { uf_cache = cache }) = uf_is_work_free cache+isCheapUnfolding _                                    = False  isExpandableUnfolding :: Unfolding -> Bool-isExpandableUnfolding (CoreUnfolding { uf_expandable = is_expable }) = is_expable-isExpandableUnfolding _                                              = False+isExpandableUnfolding (CoreUnfolding { uf_cache = cache }) = uf_expandable cache+isExpandableUnfolding _                                    = False  expandUnfolding_maybe :: Unfolding -> Maybe CoreExpr -- Expand an expandable unfolding; this is used in rule matching --   See Note [Expanding variables] in GHC.Core.Rules -- The key point here is that CONLIKE things can be expanded-expandUnfolding_maybe (CoreUnfolding { uf_expandable = True, uf_tmpl = rhs }) = Just rhs-expandUnfolding_maybe _                                                       = Nothing+expandUnfolding_maybe (CoreUnfolding { uf_cache = cache, uf_tmpl = rhs })+  | uf_expandable cache+    = Just rhs+expandUnfolding_maybe _ = Nothing  isCompulsoryUnfolding :: Unfolding -> Bool isCompulsoryUnfolding (CoreUnfolding { uf_src = InlineCompulsory }) = True

@@ -216,8 +216,8 @@ pprCoAxiom :: CoAxiom br -> SDoc -- Used in debug-printing only pprCoAxiom ax@(CoAxiom { co_ax_tc = tc, co_ax_branches = branches })-  = hang (text "axiom" <+> ppr ax <+> dcolon)-       2 (vcat (map (pprCoAxBranchUser tc) (fromBranches branches)))+  = hang (text "axiom" <+> ppr ax)+       2 (braces $ vcat (map (pprCoAxBranchUser tc) (fromBranches branches)))  pprCoAxBranchUser :: TyCon -> CoAxBranch -> SDoc -- Used when printing injectivity errors (FamInst.reportInjectivityErrors)@@ -251,8 +251,12 @@     [ pprUserForAll (mkTyCoVarBinders Inferred bndrs')          -- See Note [Printing foralls in type family instances] in GHC.Iface.Type     , pp_lhs <+> ppr_rhs tidy_env ee_rhs-    , text "-- Defined" <+> pp_loc ]+    , vcat [ text "-- Defined" <+> pp_loc+           , ppUnless (null incomps) $ whenPprDebug $+             text "-- Incomps:" <+> vcat (map (pprCoAxBranch fam_tc) incomps) ]+    ]   where+    incomps = coAxBranchIncomps branch     loc = coAxBranchSpan branch     pp_loc | isGoodSrcSpan loc = text "at" <+> ppr (srcSpanStart loc)            | otherwise         = text "in" <+> ppr loc

@@ -36,7 +36,7 @@ import GHC.Prelude  import {-# SOURCE #-} GHC.Core.TyCo.Rep ( Type )-import {-# SOURCE #-} GHC.Core.TyCo.Ppr ( pprType )+import {-# SOURCE #-} GHC.Core.TyCo.Ppr ( pprType, pprTyVar ) import {-# SOURCE #-} GHC.Core.TyCon    ( TyCon ) import GHC.Utils.Outputable import GHC.Data.FastString@@ -275,7 +275,6 @@   = length tvs + length cvs   where     CoAxBranch { cab_tvs = tvs, cab_cvs = cvs } = coAxiomNthBranch ax index- coAxiomName :: CoAxiom br -> Name coAxiomName = co_ax_name @@ -331,7 +330,7 @@ Note [CoAxBranch type variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In the case of a CoAxBranch of an associated type-family instance,-we use the *same* type variables (where possible) as the+we use the *same* type variables in cab_tvs (where possible) as the enclosing class or instance.  Consider    instance C Int [z] where@@ -341,8 +340,11 @@ same 'z', so that it's easy to check that that type is the same as that in the instance header. -So, unlike FamInsts, there is no expectation that the cab_tvs-are fresh wrt each other, or any other CoAxBranch.+However, I believe that the cab_tvs of any CoAxBranch are distinct+from the cab_tvs of other CoAxBranches in the same CoAxiom.  This is+important when checking for compatiblity and apartness; e.g. see+GHC.Core.FamInstEnv.compatibleBranches.  (The story seems a bit wobbly+here, but it seems to work.)  Note [CoAxBranch roles] ~~~~~~~~~~~~~~~~~~~~~~~@@ -458,6 +460,12 @@ * Note [RoughMap and rm_empty] for how this complicates the RoughMap implementation slightly. -} +{- *********************************************************************+*                                                                      *+              Instances, especially pretty-printing+*                                                                      *+********************************************************************* -}+ instance Eq (CoAxiom br) where     a == b = getUnique a == getUnique b     a /= b = getUnique a /= getUnique b@@ -465,9 +473,6 @@ instance Uniquable (CoAxiom br) where     getUnique = co_ax_unique -instance Outputable (CoAxiom br) where-    ppr = ppr . getName- instance NamedThing (CoAxiom br) where     getName = co_ax_name @@ -477,13 +482,22 @@     gunfold _ _  = error "gunfold"     dataTypeOf _ = mkNoRepType "CoAxiom" +instance Outputable (CoAxiom br) where+  -- You may want GHC.Core.Coercion.pprCoAxiom instead+  ppr = ppr . getName+ instance Outputable CoAxBranch where-  ppr (CoAxBranch { cab_loc = loc-                  , cab_lhs = lhs-                  , cab_rhs = rhs }) =-    text "CoAxBranch" <+> parens (ppr loc) <> colon-      <+> brackets (fsep (punctuate comma (map pprType lhs)))-      <+> text "=>" <+> pprType rhs+  -- This instance doesn't know the name of the type family+  -- If possible, use GHC.Core.Coercion.pprCoAxBranch instead+  ppr (CoAxBranch { cab_tvs = tvs, cab_cvs = cvs+                  , cab_lhs = lhs_tys, cab_rhs = rhs, cab_incomps = incomps })+    = text "CoAxBranch" <+> braces payload+    where+      payload = hang (text "forall" <+> pprWithCommas pprTyVar (tvs ++ cvs) <> dot)+                   2 (vcat [ text "<tycon>" <+> sep (map pprType lhs_tys)+                           , nest 2 (text "=" <+> ppr rhs)+                           , ppUnless (null incomps) $+                             text "incomps:" <+> vcat (map ppr incomps) ])  {- ************************************************************************

@@ -106,8 +106,8 @@ import Data.List( find )  {--Data constructor representation-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Note [Data constructor representation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider the following Haskell data type declaration          data T = T !Int ![Int]@@ -208,7 +208,7 @@  * The wrapper (if it exists) takes dcOrigArgTys as its arguments.   The worker takes dataConRepArgTys as its arguments-  If the worker is absent, dataConRepArgTys is the same as dcOrigArgTys+  If the wrapper is absent, dataConRepArgTys is the same as dcOrigArgTys  * The 'NoDataConRep' case of DataConRep is important. Not only is it   efficient, but it also ensures that the wrapper is replaced by the@@ -554,12 +554,22 @@  Note [DataCon arities] ~~~~~~~~~~~~~~~~~~~~~~-dcSourceArity does not take constraints into account,-but dcRepArity does.  For example:+A `DataCon`'s source arity and core representation arity may differ:+`dcSourceArity` does not take constraints into account, but `dcRepArity` does.++The additional arguments taken into account by `dcRepArity` include quantified+dictionaries and coercion arguments, lifted and unlifted (despite the unlifted+coercion arguments having a zero-width runtime representation).+For example:    MkT :: Ord a => a -> T a     dcSourceArity = 1     dcRepArity    = 2 +   MkU :: (b ~ '[]) => U b+    dcSourceArity = 0+    dcRepArity    = 1++ Note [DataCon user type variable binders] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In System FC, data constructor type signatures always quantify over all of@@ -885,8 +895,8 @@         Trep :: Int# -> a -> Void# -> T a Actually, the unboxed part isn't implemented yet! -Not that this representation is still *different* from runtime-representation. (Which is what STG uses afer unarise).+Note that this representation is still *different* from runtime+representation. (Which is what STG uses after unarise).  This is how T would end up being used in STG post-unarise: @@ -1322,9 +1332,10 @@ dataConSourceArity :: DataCon -> Arity dataConSourceArity (MkData { dcSourceArity = arity }) = arity --- | Gives the number of actual fields in the /representation/ of the--- data constructor. This may be more than appear in the source code;--- the extra ones are the existentially quantified dictionaries+-- | Gives the number of value arguments (including zero-width coercions)+-- stored by the given `DataCon`'s worker in its Core representation. This may+-- differ from the number of arguments that appear in the source code; see also+-- Note [DataCon arities] dataConRepArity :: DataCon -> Arity dataConRepArity (MkData { dcRepArity = arity }) = arity @@ -1333,8 +1344,14 @@ isNullarySrcDataCon :: DataCon -> Bool isNullarySrcDataCon dc = dataConSourceArity dc == 0 --- | Return whether there are any argument types for this 'DataCon's runtime representation type--- See Note [DataCon arities]+-- | Return whether this `DataCon`'s worker, in its Core representation, takes+-- any value arguments.+--+-- In particular, remember that we include coercion arguments in the arity of+-- the Core representation of the `DataCon` -- both lifted and unlifted+-- coercions, despite the latter having zero-width runtime representation.+--+-- See also Note [DataCon arities]. isNullaryRepDataCon :: DataCon -> Bool isNullaryRepDataCon dc = dataConRepArity dc == 0 

@@ -25,7 +25,7 @@         FamInstMatch(..),         lookupFamInstEnv, lookupFamInstEnvConflicts, lookupFamInstEnvByTyCon, -        isDominatedBy, apartnessCheck,+        isDominatedBy, apartnessCheck, compatibleBranches,          -- Injectivity         InjectivityCheckResult(..),@@ -531,15 +531,16 @@ compatibleBranches :: CoAxBranch -> CoAxBranch -> Bool compatibleBranches (CoAxBranch { cab_lhs = lhs1, cab_rhs = rhs1 })                    (CoAxBranch { cab_lhs = lhs2, cab_rhs = rhs2 })-  = let (commonlhs1, commonlhs2) = zipAndUnzip lhs1 lhs2-             -- See Note [Compatibility of eta-reduced axioms]-    in case tcUnifyTysFG alwaysBindFun commonlhs1 commonlhs2 of-      SurelyApart -> True-      Unifiable subst-        | Type.substTyAddInScope subst rhs1 `eqType`-          Type.substTyAddInScope subst rhs2-        -> True-      _ -> False+  = case tcUnifyTysFG alwaysBindFun commonlhs1 commonlhs2 of+      -- Here we need the cab_tvs of the two branches to be disinct.+      -- See Note [CoAxBranch type variables] in GHC.Core.Coercion.Axiom.+      SurelyApart     -> True+      MaybeApart {}   -> False+      Unifiable subst -> Type.substTyAddInScope subst rhs1 `eqType`+                         Type.substTyAddInScope subst rhs2+  where+     (commonlhs1, commonlhs2) = zipAndUnzip lhs1 lhs2+     -- See Note [Compatibility of eta-reduced axioms]  -- | Result of testing two type family equations for injectiviy. data InjectivityCheckResult@@ -590,7 +591,7 @@   where     go :: [CoAxBranch] -> CoAxBranch -> ([CoAxBranch], CoAxBranch)     go prev_brs cur_br-       = (cur_br : prev_brs, new_br)+       = (new_br : prev_brs, new_br)        where          new_br = cur_br { cab_incomps = mk_incomps prev_brs cur_br } 

@@ -51,7 +51,7 @@ import GHC.Core.TyCo.Ppr ( pprTyVar, pprTyVars ) import GHC.Core.TyCon as TyCon import GHC.Core.Coercion.Axiom-import GHC.Core.Unify+import GHC.Core.FamInstEnv( compatibleBranches ) import GHC.Core.InstEnv      ( instanceDFunId, instEnvElts ) import GHC.Core.Coercion.Opt ( checkAxInstCo ) import GHC.Core.Opt.Arity    ( typeArity )@@ -2548,8 +2548,10 @@        ; lintL (null cvs)                (text "Coercion variables bound in family axiom")        ; forM_ incomps $ \ br' ->-           lintL (not (compatible_branches br br')) $-           text "Incorrect incompatible branch:" <+> ppr br' }+           lintL (not (compatibleBranches br br')) $+           hang (text "Incorrect incompatible branches:")+              2 (vcat [text "Branch:"       <+> ppr br,+                       text "Bogus incomp:" <+> ppr br']) }  lint_axiom_group :: NonEmpty (CoAxiom Branched) -> LintM () lint_axiom_group (_  :| []) = return ()@@ -2571,7 +2573,7 @@   , Just br2@(CoAxBranch { cab_tvs = tvs2                          , cab_lhs = lhs2                          , cab_rhs = rhs2 }) <- coAxiomSingleBranch_maybe ax2-  = lintL (compatible_branches br1 br2) $+  = lintL (compatibleBranches br1 br2) $     vcat [ hsep [ text "Axioms", ppr ax1, text "and", ppr ax2                 , text "are incompatible" ]          , text "tvs1 =" <+> pprTyVars tvs1@@ -2585,27 +2587,6 @@   = addErrL (text "Open type family axiom has more than one branch: either" <+>              ppr ax1 <+> text "or" <+> ppr ax2) -compatible_branches :: CoAxBranch -> CoAxBranch -> Bool--- True <=> branches are compatible. See Note [Compatibility] in GHC.Core.FamInstEnv.-compatible_branches (CoAxBranch { cab_tvs = tvs1-                                , cab_lhs = lhs1-                                , cab_rhs = rhs1 })-                    (CoAxBranch { cab_tvs = tvs2-                                , cab_lhs = lhs2-                                , cab_rhs = rhs2 })-  = -- we need to freshen ax2 w.r.t. ax1-    -- do this by pretending tvs1 are in scope when processing tvs2-    let in_scope       = mkInScopeSet (mkVarSet tvs1)-        subst0         = mkEmptyTCvSubst in_scope-        (subst, _)     = substTyVarBndrs subst0 tvs2-        lhs2'          = substTys subst lhs2-        rhs2'          = substTy  subst rhs2-    in-    case tcUnifyTys alwaysBindFun lhs1 lhs2' of-      Just unifying_subst -> substTy unifying_subst rhs1  `eqType`-                             substTy unifying_subst rhs2'-      Nothing             -> True- {- ************************************************************************ *                                                                      *@@ -3128,33 +3109,8 @@ dumpLoc (InCo co)   = (noSrcLoc, text "In the coercion" <+> quotes (ppr co)) dumpLoc (InAxiom ax)-  = (getSrcLoc ax_name, text "In the coercion axiom" <+> ppr ax_name <+> dcolon <+> pp_ax)-  where-    CoAxiom { co_ax_name     = ax_name-            , co_ax_tc       = tc-            , co_ax_role     = ax_role-            , co_ax_branches = branches } = ax-    branch_list = fromBranches branches--    pp_ax-      | [branch] <- branch_list-      = pp_branch branch--      | otherwise-      = braces $ vcat (map pp_branch branch_list)--    pp_branch (CoAxBranch { cab_tvs = tvs-                          , cab_cvs = cvs-                          , cab_lhs = lhs_tys-                          , cab_rhs = rhs_ty })-      = sep [ brackets (pprWithCommas pprTyVar (tvs ++ cvs)) <> dot-            , ppr (mkTyConApp tc lhs_tys)-            , text "~_" <> pp_role ax_role-            , ppr rhs_ty ]--    pp_role Nominal          = text "N"-    pp_role Representational = text "R"-    pp_role Phantom          = text "P"+  = (getSrcLoc ax, hang (text "In the coercion axiom")+                      2 (pprCoAxiom ax))  pp_binders :: [Var] -> SDoc pp_binders bs = sep (punctuate comma (map pp_binder bs))

@@ -1333,7 +1333,7 @@ idArityType :: Id -> ArityType idArityType v   | strict_sig <- idDmdSig v-  , not $ isTopSig strict_sig+  , not $ isNopSig strict_sig   , (ds, div) <- splitDmdSig strict_sig   , let arity = length ds   -- Every strictness signature admits an arity signature!

@@ -89,28 +89,35 @@       where         anal_body env'           | WithDmdType body_ty bs' <- go env' bs-          = WithDmdType (add_exported_uses env' body_ty (bindersOf b)) bs'+          = WithDmdType (body_ty `plusDmdType` keep_alive_roots env' (bindersOf b)) bs'      cons_up :: WithDmdType (DmdResult b [b]) -> WithDmdType [b]     cons_up (WithDmdType dmd_ty (R b' bs')) = WithDmdType dmd_ty (b' : bs') -    add_exported_uses :: AnalEnv -> DmdType -> [Id] -> DmdType-    add_exported_uses env = foldl' (add_exported_use env)+    keep_alive_roots :: AnalEnv -> [Id] -> DmdEnv+    -- See Note [Absence analysis for stable unfoldings and RULES]+    -- Here we keep alive "roots", e.g., exported ids and stuff mentioned in+    -- orphan RULES+    keep_alive_roots env ids = plusDmdEnvs (map (demandRoot env) (filter is_root ids)) -    -- If @e@ is denoted by @dmd_ty@, then @add_exported_use _ dmd_ty id@-    -- corresponds to the demand type of @(id, e)@, but is a lot more direct.-    -- See Note [Analysing top-level bindings].-    add_exported_use :: AnalEnv -> DmdType -> Id -> DmdType-    add_exported_use env dmd_ty id-      | isExportedId id || elemVarSet id rule_fvs-      -- See Note [Absence analysis for stable unfoldings and RULES]-      = dmd_ty `plusDmdType` fst (dmdAnalStar env topDmd (Var id))-      | otherwise-      = dmd_ty+    is_root :: Id -> Bool+    is_root id = isExportedId id || elemVarSet id rule_fvs      rule_fvs :: IdSet     rule_fvs = rulesRhsFreeIds rules +demandRoot :: AnalEnv -> Id -> DmdEnv+-- See Note [Absence analysis for stable unfoldings and RULES]+demandRoot env id = fst (dmdAnalStar env topDmd (Var id))++demandRoots :: AnalEnv -> [Id] -> DmdEnv+-- See Note [Absence analysis for stable unfoldings and RULES]+demandRoots env roots = plusDmdEnvs (map (demandRoot env) roots)++demandRootSet :: AnalEnv -> IdSet -> DmdEnv+demandRootSet env ids = demandRoots env (nonDetEltsUniqSet ids)+  -- It's OK to use nonDetEltsUniqSet here because plusDmdType is commutative+ -- | We attach useful (e.g. not 'topDmd') 'idDemandInfo' to top-level bindings -- that satisfy this function. --@@ -292,7 +299,7 @@      -- See Note [Absence analysis for stable unfoldings and RULES]     rule_fvs           = bndrRuleAndUnfoldingIds id-    final_ty           = body_ty' `plusDmdType` rhs_ty `keepAliveDmdType` rule_fvs+    final_ty           = body_ty' `plusDmdType` rhs_ty `plusDmdType` demandRootSet env rule_fvs  -- | Let bindings can be processed in two ways: -- Down (RHS before body) or Up (body before RHS).@@ -309,18 +316,18 @@ dmdAnalBindLetDown :: TopLevelFlag -> AnalEnv -> SubDemand -> CoreBind -> (AnalEnv -> WithDmdType a) -> WithDmdType (DmdResult CoreBind a) dmdAnalBindLetDown top_lvl env dmd bind anal_body = case bind of   NonRec id rhs-    | (env', lazy_fv, id1, rhs1) <-+    | (env', weak_fv, id1, rhs1) <-         dmdAnalRhsSig top_lvl NonRecursive env dmd id rhs-    -> do_rest env' lazy_fv [(id1, rhs1)] (uncurry NonRec . only)+    -> do_rest env' weak_fv [(id1, rhs1)] (uncurry NonRec . only)   Rec pairs-    | (env', lazy_fv, pairs') <- dmdFix top_lvl env dmd pairs-    -> do_rest env' lazy_fv pairs' Rec+    | (env', weak_fv, pairs') <- dmdFix top_lvl env dmd pairs+    -> do_rest env' weak_fv pairs' Rec   where-    do_rest env' lazy_fv pairs1 build_bind = WithDmdType final_ty (R (build_bind pairs2) body')+    do_rest env' weak_fv pairs1 build_bind = WithDmdType final_ty (R (build_bind pairs2) body')       where         WithDmdType body_ty body'        = anal_body env'         -- see Note [Lazy and unleashable free variables]-        dmd_ty                          = addLazyFVs body_ty lazy_fv+        dmd_ty                          = addWeakFVs body_ty weak_fv         WithDmdType final_ty id_dmds    = findBndrsDmds env' dmd_ty (strictMap fst pairs1)         -- Important to force this as build_bind might not force it.         !pairs2                         = strictZipWith do_one pairs1 id_dmds@@ -350,15 +357,15 @@ -- See ↦* relation in the Cardinality Analysis paper dmdAnalStar :: AnalEnv             -> Demand   -- This one takes a *Demand*-            -> CoreExpr -- Should obey the let/app invariant-            -> (PlusDmdArg, CoreExpr)+            -> CoreExpr+            -> (DmdEnv, CoreExpr) dmdAnalStar env (n :* sd) e   -- NB: (:*) expands AbsDmd and BotDmd as needed   -- See Note [Analysing with absent demand]   | WithDmdType dmd_ty e' <- dmdAnal env sd e   = assertPpr (mightBeLiftedType (exprType e) || exprOkForSpeculation e) (ppr e)     -- The argument 'e' should satisfy the let/app invariant-    (toPlusDmdArg $ multDmdType n dmd_ty, e')+    (discardArgDmds $ multDmdType n dmd_ty, e')  -- Main Demand Analsysis machinery dmdAnal, dmdAnal' :: AnalEnv@@ -371,13 +378,13 @@ dmdAnal' _ _ (Lit lit)     = WithDmdType nopDmdType (Lit lit) dmdAnal' _ _ (Type ty)     = WithDmdType nopDmdType (Type ty) -- Doesn't happen, in fact dmdAnal' _ _ (Coercion co)-  = WithDmdType (unitDmdType (coercionDmdEnv co)) (Coercion co)+  = WithDmdType (noArgsDmdType (coercionDmdEnv co)) (Coercion co)  dmdAnal' env dmd (Var var)   = WithDmdType (dmdTransform env var dmd) (Var var)  dmdAnal' env dmd (Cast e co)-  = WithDmdType (dmd_ty `plusDmdType` mkPlusDmdArg (coercionDmdEnv co)) (Cast e' co)+  = WithDmdType (dmd_ty `plusDmdType` coercionDmdEnv co) (Cast e' co)   where     WithDmdType dmd_ty e' = dmdAnal env dmd e @@ -472,7 +479,7 @@           = alt_ty2          WithDmdType scrut_ty scrut' = dmdAnal env scrut_sd scrut-        res_ty             = alt_ty3 `plusDmdType` toPlusDmdArg scrut_ty+        res_ty             = alt_ty3 `plusDmdType` discardArgDmds scrut_ty     in --    pprTrace "dmdAnal:Case1" (vcat [ text "scrut" <+> ppr scrut --                                   , text "dmd" <+> ppr dmd@@ -517,7 +524,7 @@           = deferAfterPreciseException alt_ty1           | otherwise           = alt_ty1-        res_ty               = alt_ty2 `plusDmdType` toPlusDmdArg scrut_ty+        res_ty               = scrut_ty `plusDmdType` discardArgDmds alt_ty2      in --    pprTrace "dmdAnal:Case2" (vcat [ text "scrut" <+> ppr scrut@@ -915,7 +922,7 @@   --   * Case and constructor field binders   | otherwise   = -- pprTrace "dmdTransform:other" (vcat [ppr var, ppr boxity, ppr sd]) $-    unitDmdType (unitVarEnv var (C_11 :* sd))+    noArgsDmdType (addVarDmdEnv nopDmdEnv var (C_11 :* sd))  {- ********************************************************************* *                                                                      *@@ -923,6 +930,10 @@ *                                                                      * ********************************************************************* -} +-- | An environment in which all demands are weak according to 'isWeakDmd'.+-- See Note [Lazy and unleashable free variables].+type WeakDmds = VarEnv Demand+ -- | @dmdAnalRhsSig@ analyses the given RHS to compute a demand signature -- for the LetDown rule. It works as follows: --@@ -937,13 +948,13 @@   -> RecFlag   -> AnalEnv -> SubDemand   -> Id -> CoreExpr-  -> (AnalEnv, DmdEnv, Id, CoreExpr)+  -> (AnalEnv, WeakDmds, Id, CoreExpr) -- Process the RHS of the binding, add the strictness signature -- to the Id, and augment the environment with the signature as well. -- See Note [NOINLINE and strictness] dmdAnalRhsSig top_lvl rec_flag env let_dmd id rhs-  = -- pprTrace "dmdAnalRhsSig" (ppr id $$ ppr let_dmd $$ ppr rhs_dmds $$ ppr sig $$ ppr lazy_fv) $-    (final_env, lazy_fv, final_id, final_rhs)+  = -- pprTrace "dmdAnalRhsSig" (ppr id $$ ppr let_dmd $$ ppr rhs_dmds $$ ppr sig $$ ppr weak_fvs) $+    (final_env, weak_fvs, final_id, final_rhs)   where     rhs_arity = idArity id     -- See Note [Demand signatures are computed for a threshold demand based on idArity]@@ -962,13 +973,11 @@       = unboxedWhenSmall env rec_flag (resultType_maybe id) topSubDmd      WithDmdType rhs_dmd_ty rhs' = dmdAnal env rhs_dmd rhs-    DmdType rhs_fv rhs_dmds rhs_div = rhs_dmd_ty-    -- See Note [Do not unbox class dictionaries]-    -- See Note [Boxity for bottoming functions]-    (final_rhs_dmds, final_rhs) = finaliseArgBoxities env id rhs_arity rhs' rhs_div-                                  `orElse` (rhs_dmds, rhs')+    DmdType rhs_env rhs_dmds = rhs_dmd_ty+    (final_rhs_dmds, final_rhs) = finaliseArgBoxities env id rhs_arity rhs' (de_div rhs_env)+                                    `orElse` (rhs_dmds, rhs') -    sig = mkDmdSigForArity rhs_arity (DmdType sig_fv final_rhs_dmds rhs_div)+    sig = mkDmdSigForArity rhs_arity (DmdType sig_env final_rhs_dmds)      final_id   = id `setIdDmdSig` sig     !final_env = extendAnalEnv top_lvl env final_id sig@@ -985,16 +994,20 @@     --        we'd have to do an additional iteration. reuseEnv makes sure that     --        we never get used-once info for FVs of recursive functions.     --        See #14816 where we try to get rid of reuseEnv.-    rhs_fv1 = case rec_flag of-                Recursive    -> reuseEnv rhs_fv-                NonRecursive -> rhs_fv+    rhs_env1 = case rec_flag of+                Recursive    -> reuseEnv rhs_env+                NonRecursive -> rhs_env      -- See Note [Absence analysis for stable unfoldings and RULES]-    rhs_fv2 = rhs_fv1 `keepAliveDmdEnv` bndrRuleAndUnfoldingIds id+    rhs_env2 = rhs_env1 `plusDmdEnv` demandRootSet env (bndrRuleAndUnfoldingIds id)      -- See Note [Lazy and unleashable free variables]-    !(!lazy_fv, !sig_fv) = partitionVarEnv isWeakDmd rhs_fv2+    !(!sig_env, !weak_fvs) = splitWeakDmds rhs_env2 +splitWeakDmds :: DmdEnv -> (DmdEnv, WeakDmds)+splitWeakDmds (DE fvs div) = (DE sig_fvs div, weak_fvs)+  where (!weak_fvs, !sig_fvs) = partitionVarEnv isWeakDmd fvs+ -- | The result type after applying 'idArity' many arguments. Returns 'Nothing' -- when the type doesn't have exactly 'idArity' many arrows. resultType_maybe :: Id -> Maybe Type@@ -1216,8 +1229,8 @@  Note [Absence analysis for stable unfoldings and RULES] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Ticket #18638 shows that it's really important to do absence analysis-for stable unfoldings. Consider+Among others, tickets #18638 and #23208 show that it's really important to treat+stable unfoldings as demanded. Consider     g = blah @@ -1234,24 +1247,48 @@  Now if f is subsequently inlined, we'll use 'g' and ... disaster. -SOLUTION: if f has a stable unfolding, adjust its DmdEnv (the demands-on its free variables) so that no variable mentioned in its unfolding-is Absent.  This is done by the function Demand.keepAliveDmdEnv.+SOLUTION: if f has a stable unfolding, treat every free variable as a+/demand root/, that is: Analyse it as if it was a variable occuring in a+'topDmd' context. This is done in `demandRoot` (which we also use for exported+top-level ids). Do the same for Ids free in the RHS of any RULES for f. -ALSO: do the same for Ids free in the RHS of any RULES for f.+Wrinkles: -PS: You may wonder how it can be that f's optimised RHS has somehow-discarded 'g', but when f is inlined we /don't/ discard g in the same-way. I think a simple example is-   g = (a,b)-   f = \x.  fst g-   {-# INLINE f #-}+  (W1) You may wonder how it can be that f's optimised RHS has somehow+    discarded 'g', but when f is inlined we /don't/ discard g in the same+    way. I think a simple example is+       g = (a,b)+       f = \x.  fst g+       {-# INLINE f #-} -Now f's optimised RHS will be \x.a, but if we change g to (error "..")-(since it is apparently Absent) and then inline (\x. fst g) we get-disaster.  But regardless, #18638 was a more complicated version of-this, that actually happened in practice.+    Now f's optimised RHS will be \x.a, but if we change g to (error "..")+    (since it is apparently Absent) and then inline (\x. fst g) we get+    disaster.  But regardless, #18638 was a more complicated version of+    this, that actually happened in practice. +  (W2) You might wonder why we don't simply take the free vars of the+    unfolding/RULE and map them to topDmd. The reason is that any of the free vars+    might have demand signatures themselves that in turn demand transitive free+    variables and that we hence need to unleash! This came up in #23208.+    Consider++       err :: Int -> b+       err = error "really important message"++       sg :: Int -> Int+       sg _ = case err of {}  -- Str=<1B>b {err:->S}++       g :: a -> a  -- g is exported+       g x = x+       {-# RULES "g" g @Int = sg #-}++    Here, `err` is only demanded by `sg`'s demand signature: It doesn't occur+    in the weak_fvs of `sg`'s RHS at all. Hence when we `demandRoots` `sg`+    because it occurs in the RULEs of `g` (which is exported), we better unleash+    the demand signature of `sg`, too! Before #23208 we simply added a 'topDmd'+    for `sg`, failing to unleash the signature and hence observed an absent+    error instead of the `really important message`.+ Note [Boxity for bottoming functions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider@@ -1728,8 +1765,7 @@        -> AnalEnv                            -- Does not include bindings for this binding        -> SubDemand        -> [(Id,CoreExpr)]-       -> (AnalEnv, DmdEnv, [(Id,CoreExpr)]) -- Binders annotated with strictness info-+       -> (AnalEnv, WeakDmds, [(Id,CoreExpr)]) -- Binders annotated with strictness info dmdFix top_lvl env let_dmd orig_pairs   = loop 1 initial_pairs   where@@ -1739,33 +1775,33 @@      -- If fixed-point iteration does not yield a result we use this instead     -- See Note [Safe abortion in the fixed-point iteration]-    abort :: (AnalEnv, DmdEnv, [(Id,CoreExpr)])-    abort = (env, lazy_fv', zapped_pairs)-      where (lazy_fv, pairs') = step True (zapIdDmdSig orig_pairs)+    abort :: (AnalEnv, WeakDmds, [(Id,CoreExpr)])+    abort = (env, weak_fv', zapped_pairs)+      where (weak_fv, pairs') = step True (zapIdDmdSig orig_pairs)             -- Note [Lazy and unleashable free variables]-            non_lazy_fvs = plusVarEnvList $ map (dmdSigDmdEnv . idDmdSig . fst) pairs'-            lazy_fv'     = lazy_fv `plusVarEnv` mapVarEnv (const topDmd) non_lazy_fvs+            weak_fvs = plusVarEnvList $ map (de_fvs . dmdSigDmdEnv . idDmdSig . fst) pairs'+            weak_fv'     = plusVarEnv_C plusDmd weak_fv $ mapVarEnv (const topDmd) weak_fvs             zapped_pairs = zapIdDmdSig pairs'      -- The fixed-point varies the idDmdSig field of the binders, and terminates if that     -- annotation does not change any more.-    loop :: Int -> [(Id,CoreExpr)] -> (AnalEnv, DmdEnv, [(Id,CoreExpr)])+    loop :: Int -> [(Id,CoreExpr)] -> (AnalEnv, WeakDmds, [(Id,CoreExpr)])     loop n pairs = -- pprTrace "dmdFix" (ppr n <+> vcat [ ppr id <+> ppr (idDmdSig id)                    --                                     | (id,_)<- pairs]) $                    loop' n pairs      loop' n pairs-      | found_fixpoint = (final_anal_env, lazy_fv, pairs')+      | found_fixpoint = (final_anal_env, weak_fv, pairs')       | n == 10        = abort       | otherwise      = loop (n+1) pairs'       where         found_fixpoint    = map (idDmdSig . fst) pairs' == map (idDmdSig . fst) pairs         first_round       = n == 1-        (lazy_fv, pairs') = step first_round pairs+        (weak_fv, pairs') = step first_round pairs         final_anal_env    = extendAnalEnvs top_lvl env (map fst pairs') -    step :: Bool -> [(Id, CoreExpr)] -> (DmdEnv, [(Id, CoreExpr)])-    step first_round pairs = (lazy_fv, pairs')+    step :: Bool -> [(Id, CoreExpr)] -> (WeakDmds, [(Id, CoreExpr)])+    step first_round pairs = (weak_fv, pairs')       where         -- In all but the first iteration, delete the virgin flag         start_env | first_round = env@@ -1773,17 +1809,17 @@          start = (extendAnalEnvs top_lvl start_env (map fst pairs), emptyVarEnv) -        !((_,!lazy_fv), !pairs') = mapAccumL my_downRhs start pairs+        !((_,!weak_fv), !pairs') = mapAccumL my_downRhs start pairs                 -- mapAccumL: Use the new signature to do the next pair                 -- The occurrence analyser has arranged them in a good order                 -- so this can significantly reduce the number of iterations needed -        my_downRhs (env, lazy_fv) (id,rhs)+        my_downRhs (env, weak_fv) (id,rhs)           = -- pprTrace "my_downRhs" (ppr id $$ ppr (idDmdSig id) $$ ppr sig) $-            ((env', lazy_fv'), (id', rhs'))+            ((env', weak_fv'), (id', rhs'))           where-            !(!env', !lazy_fv1, !id', !rhs') = dmdAnalRhsSig top_lvl Recursive env let_dmd id rhs-            !lazy_fv'                    = plusVarEnv_C plusDmd lazy_fv lazy_fv1+            !(!env', !weak_fv1, !id', !rhs') = dmdAnalRhsSig top_lvl Recursive env let_dmd id rhs+            !weak_fv'                    = plusVarEnv_C plusDmd weak_fv weak_fv1      zapIdDmdSig :: [(Id, CoreExpr)] -> [(Id, CoreExpr)]     zapIdDmdSig pairs = [(setIdDmdSig id nopSig, rhs) | (id, rhs) <- pairs ]@@ -1857,23 +1893,24 @@ *                                                                      * ********************************************************************* -} -unitDmdType :: DmdEnv -> DmdType-unitDmdType dmd_env = DmdType dmd_env [] topDiv+noArgsDmdType :: DmdEnv -> DmdType+noArgsDmdType dmd_env = DmdType dmd_env []  coercionDmdEnv :: Coercion -> DmdEnv coercionDmdEnv co = coercionsDmdEnv [co]  coercionsDmdEnv :: [Coercion] -> DmdEnv-coercionsDmdEnv cos = mapVarEnv (const topDmd) (getUniqSet $ coVarsOfCos cos)-                      -- The VarSet from coVarsOfCos is really a VarEnv Var+coercionsDmdEnv cos+  = mkTermDmdEnv $ mapVarEnv (const topDmd) $ getUniqSet $ coVarsOfCos cos+  -- The VarSet from coVarsOfCos is really a VarEnv Var  addVarDmd :: DmdType -> Var -> Demand -> DmdType-addVarDmd (DmdType fv ds res) var dmd-  = DmdType (extendVarEnv_C plusDmd fv var dmd) ds res+addVarDmd (DmdType fv ds) var dmd+  = DmdType (addVarDmdEnv fv var dmd) ds -addLazyFVs :: DmdType -> DmdEnv -> DmdType-addLazyFVs dmd_ty lazy_fvs-  = dmd_ty `plusDmdType` mkPlusDmdArg lazy_fvs+addWeakFVs :: DmdType -> WeakDmds -> DmdType+addWeakFVs dmd_ty weak_fvs+  = dmd_ty `plusDmdType` mkTermDmdEnv weak_fvs         -- Using plusDmdType (rather than just plus'ing the envs)         -- is vital.  Consider         --      let f = \x -> (x,y)@@ -1882,7 +1919,7 @@         -- demand with the bottom coming up from 'error'         --         -- I got a loop in the fixpointer without this, due to an interaction-        -- with the lazy_fv filtering in dmdAnalRhsSig.  Roughly, it was+        -- with the weak_fv filtering in dmdAnalRhsSig.  Roughly, it was         --      letrec f n x         --          = letrec g y = x `fatbar`         --                         letrec h z = z + ...g...@@ -1983,14 +2020,14 @@  But now the signature lies! (Missing variables are assumed to be absent.) To make up for this, the code that analyses the binding keeps the demand on those-variable separate (usually called "lazy_fv") and adds it to the demand of the+variable separate (usually called "weak_fv") and adds it to the demand of the whole binding later.  What if we decide _not_ to store a strictness signature for a binding at all, as we do when aborting a fixed-point iteration? The we risk losing the information that the strict variables are being used. In that case, we take all free variables mentioned in the (unsound) strictness signature, conservatively approximate the-demand put on them (topDmd), and add that to the "lazy_fv" returned by "dmdFix".+demand put on them (topDmd), and add that to the "weak_fv" returned by "dmdFix".   ************************************************************************

@@ -3065,9 +3065,11 @@         ; (alt_env', scrut', case_bndr') <- improveSeq fam_envs env2 scrut                                                        case_bndr case_bndr2 alts -        ; (imposs_deflt_cons, in_alts) <- prepareAlts scrut' case_bndr' alts+        ; (imposs_deflt_cons, in_alts) <- prepareAlts scrut' case_bndr alts           -- NB: it's possible that the returned in_alts is empty: this is handled           -- by the caller (rebuildCase) in the missingAlt function+          -- NB: pass case_bndr::InId, not case_bndr' :: OutId, to prepareAlts+          --     See Note [Shadowing in prepareAlts] in GHC.Core.Opt.Simplify.Utils          ; alts' <- mapM (simplAlt alt_env' (Just scrut') imposs_deflt_cons case_bndr' cont') in_alts --      ; pprTrace "simplAlts" (ppr case_bndr $$ ppr alts $$ ppr cont') $ return ()@@ -4077,7 +4079,7 @@ mkLetUnfolding :: UnfoldingOpts -> TopLevelFlag -> UnfoldingSource                -> InId -> OutExpr -> SimplM Unfolding mkLetUnfolding !uf_opts top_lvl src id new_rhs-  = return (mkUnfolding uf_opts src is_top_lvl is_bottoming new_rhs)+  = return (mkUnfolding uf_opts src is_top_lvl is_bottoming new_rhs Nothing)             -- We make an  unfolding *even for loop-breakers*.             -- Reason: (a) It might be useful to know that they are WHNF             --         (b) In GHC.Iface.Tidy we currently assume that, if we want to@@ -4144,7 +4146,7 @@                         -- A test case is #4138                         -- But retain a previous boring_ok of True; e.g. see                         -- the way it is set in calcUnfoldingGuidanceWithArity-                        in return (mkCoreUnfolding src is_top_lvl expr' guide')+                        in return (mkCoreUnfolding src is_top_lvl expr' Nothing guide')                             -- See Note [Top-level flag on inline rules] in GHC.Core.Unfold                    _other              -- Happens for INLINABLE things@@ -4299,7 +4301,9 @@            ; return (rule { ru_bndrs = bndrs'                           , ru_fn    = fn_name'                           , ru_args  = args'-                          , ru_rhs   = rhs' }) }+                          , ru_rhs   = occurAnalyseExpr rhs' }) }+                            -- Remember to occ-analyse, to drop dead code.+                            -- See Note [OccInfo in unfoldings and rules] in GHC.Core  {- Note [Simplifying the RHS of a RULE] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

@@ -2077,7 +2077,7 @@       = (poly_id `setIdUnfolding` unf, poly_rhs)       where         poly_rhs = mkLams tvs_here rhs-        unf = mkUnfolding uf_opts InlineRhs is_top_lvl False poly_rhs+        unf = mkUnfolding uf_opts InlineRhs is_top_lvl False poly_rhs Nothing          -- We want the unfolding.  Consider         --      let@@ -2168,26 +2168,37 @@ If we inline h into f, the default case of the inlined h can't happen. If we don't notice this, we may end up filtering out *all* the cases of the inner case y, which give us nowhere to go!++Note [Shadowing in prepareAlts]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Note that we pass case_bndr::InId to prepareAlts; an /InId/, not an+/OutId/.  This is vital, because `refineDefaultAlt` uses `tys` to build+a new /InAlt/.  If you pass an OutId, we'll end up appling the+substitution twice: disaster (#23012).++However this does mean that filling in the default alt might be+delayed by a simplifier cycle, because an InId has less info than an+OutId.  Test simplCore/should_compile/simpl013 apparently shows this+up, although I'm not sure exactly how.. -} -prepareAlts :: OutExpr -> OutId -> [InAlt] -> SimplM ([AltCon], [InAlt])+prepareAlts :: OutExpr -> InId -> [InAlt] -> SimplM ([AltCon], [InAlt]) -- The returned alternatives can be empty, none are possible-prepareAlts scrut case_bndr' alts-  | Just (tc, tys) <- splitTyConApp_maybe (varType case_bndr')-           -- Case binder is needed just for its type. Note that as an-           --   OutId, it has maximum information; this is important.-           --   Test simpl013 is an example+--+-- Note that case_bndr is an InId; see Note [Shadowing in prepareAlts]+prepareAlts scrut case_bndr alts+  | Just (tc, tys) <- splitTyConApp_maybe (idType case_bndr)   = do { us <- getUniquesM-       ; let (idcs1, alts1)       = filterAlts tc tys imposs_cons alts-             (yes2,  alts2)       = refineDefaultAlt us (idMult case_bndr') tc tys idcs1 alts1-               -- the multiplicity on case_bndr's is the multiplicity of the+       ; let (idcs1, alts1) = filterAlts tc tys imposs_cons alts+             (yes2,  alts2) = refineDefaultAlt us (idMult case_bndr) tc tys idcs1 alts1+               -- The multiplicity on case_bndr's is the multiplicity of the                -- case expression The newly introduced patterns in                -- refineDefaultAlt must be scaled by this multiplicity              (yes3, idcs3, alts3) = combineIdenticalAlts idcs1 alts2              -- "idcs" stands for "impossible default data constructors"              -- i.e. the constructors that can't match the default case-       ; when yes2 $ tick (FillInCaseDefault case_bndr')-       ; when yes3 $ tick (AltMerge case_bndr')+       ; when yes2 $ tick (FillInCaseDefault case_bndr)+       ; when yes3 $ tick (AltMerge case_bndr)        ; return (idcs3, alts3) }    | otherwise  -- Not a data type, so nothing interesting happens

@@ -1891,15 +1891,16 @@ calcSpecInfo fn arg_bndrs (CP { cp_qvars = qvars, cp_args = pats }) extra_bndrs   = ( spec_lam_bndrs_w_dmds     , spec_call_args-    , mkClosedDmdSig [idDemandInfo b | b <- spec_lam_bndrs_w_dmds, isId b] div )+    , zapDmdEnvSig (DmdSig (dt{dt_args = spec_fn_dmds})) )   where-    DmdSig (DmdType _ fn_dmds div) = idDmdSig fn+    DmdSig dt@DmdType{dt_args=fn_dmds} = idDmdSig fn+    spec_fn_dmds = [idDemandInfo b | b <- spec_lam_bndrs_w_dmds, isId b]      val_pats   = filterOut isTypeArg pats                  -- Value args at call sites, used to determine how many demands to drop-                 -- from the original functions demand and for setting up dmd_env.-    dmd_env    = go emptyVarEnv fn_dmds val_pats-    qvar_dmds  = [ lookupVarEnv dmd_env qv `orElse` topDmd | qv <- qvars, isId qv ]+                 -- from the original functions demand and for setting up arg_dmd_env.+    arg_dmd_env = go emptyVarEnv fn_dmds val_pats+    qvar_dmds  = [ lookupVarEnv arg_dmd_env qv `orElse` topDmd | qv <- qvars, isId qv ]     extra_dmds = dropList val_pats fn_dmds      -- Annotate the variables with the strictness information from@@ -1923,12 +1924,12 @@     set_dmds (v:vs) ds@(d:ds') | isTyVar v = v                   : set_dmds vs ds                                | otherwise = setIdDemandInfo v d : set_dmds vs ds' -    go :: DmdEnv -> [Demand] -> [CoreExpr] -> DmdEnv+    go :: VarEnv Demand -> [Demand] -> [CoreExpr] -> VarEnv Demand     -- We've filtered out all the type patterns already     go env (d:ds) (pat : pats)     = go (go_one env d pat) ds pats     go env _      _                = env -    go_one :: DmdEnv -> Demand -> CoreExpr -> DmdEnv+    go_one :: VarEnv Demand -> Demand -> CoreExpr -> VarEnv Demand     go_one env d          (Var v) = extendVarEnv_C plusDmd env v d     go_one env (_n :* cd) e -- NB: _n does not have to be strict       | (Var _, args) <- collectArgs e

@@ -50,10 +50,11 @@ import GHC.Types.Name import GHC.Types.Tickish import GHC.Types.Id.Make  ( voidArgId, voidPrimId )-import GHC.Types.Var      ( isLocalVar )+import GHC.Types.Var      ( isLocalVar, mkLocalVar ) import GHC.Types.Var.Set import GHC.Types.Var.Env import GHC.Types.Id+import GHC.Types.Id.Info import GHC.Types.Error  import GHC.Utils.Error ( mkMCDiagnostic )@@ -62,6 +63,7 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Trace+import GHC.Utils.Panic.Plain( assert )  import GHC.Unit.Module( Module ) import GHC.Unit.Module.ModGuts@@ -1523,12 +1525,49 @@                    | otherwise   = (spec_bndrs1, spec_rhs1, spec_fn_ty1)                   join_arity_decr = length rule_lhs_args - length spec_bndrs-                 spec_join_arity | Just orig_join_arity <- isJoinId_maybe fn-                                 = Just (orig_join_arity - join_arity_decr)-                                 | otherwise-                                 = Nothing -           ; spec_fn <- newSpecIdSM fn spec_fn_ty spec_join_arity+                 simpl_opts = initSimpleOpts dflags++                 --------------------------------------+                 -- Add a suitable unfolding if the spec_inl_prag says so+                 -- See Note [Inline specialisations]+                 (spec_inl_prag, spec_unf)+                   | not is_local && isStrongLoopBreaker (idOccInfo fn)+                   = (neverInlinePragma, noUnfolding)+                         -- See Note [Specialising imported functions] in "GHC.Core.Opt.OccurAnal"++                   | isInlinablePragma inl_prag+                   = (inl_prag { inl_inline = NoUserInlinePrag }, noUnfolding)++                   | otherwise+                   = (inl_prag, specUnfolding simpl_opts spec_bndrs (`mkApps` spec_args)+                                              rule_lhs_args fn_unf)++                 --------------------------------------+                 -- Adding arity information just propagates it a bit faster+                 --      See Note [Arity decrease] in GHC.Core.Opt.Simplify+                 -- Copy InlinePragma information from the parent Id.+                 -- So if f has INLINE[1] so does spec_fn+                 arity_decr     = count isValArg rule_lhs_args - count isId spec_bndrs++                 --------------------------------------+                 -- Add a suitable unfolding; see Note [Inline specialisations]+                 -- The wrap_unf_body applies the original unfolding to the specialised+                 -- arguments, not forgetting to wrap the dx_binds around the outside (#22358)+                 spec_fn_info+                   = vanillaIdInfo `setArityInfo`      max 0 (fn_arity - arity_decr)+                                   `setInlinePragInfo` spec_inl_prag+                                   `setUnfoldingInfo`  spec_unf++                 -- Compute the IdDetails of the specialise Id+                 -- See Note [Transfer IdDetails during specialisation]+                 spec_fn_details+                   = case idDetails fn of+                       JoinId join_arity _ -> JoinId (join_arity - join_arity_decr) Nothing+                       DFunId is_nt        -> DFunId is_nt+                       _                   -> VanillaId++           ; spec_fn <- newSpecIdSM (idName fn) spec_fn_ty spec_fn_details spec_fn_info            ; let                 -- The rule to put in the function's specialisation is:                 --      forall x @b d1' d2'.@@ -1566,33 +1605,7 @@                 -- See Note [Specialising Calls]                 spec_uds = foldr consDictBind rhs_uds dx_binds -                simpl_opts = initSimpleOpts dflags--                ---------------------------------------                -- Add a suitable unfolding if the spec_inl_prag says so-                -- See Note [Inline specialisations]-                (spec_inl_prag, spec_unf)-                  | not is_local && isStrongLoopBreaker (idOccInfo fn)-                  = (neverInlinePragma, noUnfolding)-                        -- See Note [Specialising imported functions] in "GHC.Core.Opt.OccurAnal"--                  | isInlinablePragma inl_prag-                  = (inl_prag { inl_inline = NoUserInlinePrag }, noUnfolding)--                  | otherwise-                  = (inl_prag, specUnfolding simpl_opts spec_bndrs (`mkApps` spec_args)-                                             rule_lhs_args fn_unf)--                ---------------------------------------                -- Adding arity information just propagates it a bit faster-                --      See Note [Arity decrease] in GHC.Core.Opt.Simplify-                -- Copy InlinePragma information from the parent Id.-                -- So if f has INLINE[1] so does spec_fn-                arity_decr     = count isValArg rule_lhs_args - count isId spec_bndrs-                spec_f_w_arity = spec_fn `setIdArity`      max 0 (fn_arity - arity_decr)-                                         `setInlinePragma` spec_inl_prag-                                         `setIdUnfolding`  spec_unf-                                         `asJoinId_maybe`  spec_join_arity+                spec_f_w_arity = spec_fn                  _rule_trace_doc = vcat [ ppr fn <+> dcolon <+> ppr fn_type                                        , ppr spec_fn  <+> dcolon <+> ppr spec_fn_ty@@ -1608,7 +1621,7 @@  {- Note [Specialising DFuns] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~-DFuns have a special sort of unfolding (DFunUnfolding), and these are+DFuns have a special sort of unfolding (DFunUnfolding), and it is hard to specialise a DFunUnfolding to give another DFunUnfolding unless the DFun is fully applied (#18120).  So, in the case of DFunIds we simply extend the CallKey with trailing UnspecArgs, so we'll@@ -1617,6 +1630,36 @@ There is an ASSERT that checks this, in the DFunUnfolding case of GHC.Core.Unfold.specUnfolding. +Note [Transfer IdDetails during specialisation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When specialising a function, `newSpecIdSM` comes up with a fresh Id the+specialised RHS will be bound to. It is critical that we get the `IdDetails` of+the specialised Id correct:++* JoinId: We want the specialised Id to be a join point, too.  But+  we have to carefully adjust the arity++* DFunId: It is crucial that we also make the new Id a DFunId.+  - First, because it obviously /is/ a DFun, having a DFunUnfolding and+    all that; see Note [Specialising DFuns]++  - Second, DFuns get very delicate special treatment in the demand analyser;+    see GHC.Core.Opt.DmdAnal.enterDFun.  If the specialised function isn't+    also a DFunId, this special treatment doesn't happen, so the demand+    analyser makes a too-strict DFun, and we get an infinite loop.  See Note+    [Do not strictify a DFun's parameter dictionaries] in GHC.Core.Opt.DmdAnal.+    #22549 describes the loop, and (lower down) a case where a /specialised/+    DFun caused a loop.++* WorkerLikeId: Introduced by WW, so after Specialise. Nevertheless, they come+  up when specialising imports. We must keep them as VanillaIds because WW+  will detect them as WorkerLikeIds again. That is, unless specialisation+  allows unboxing of all previous CBV args, in which case sticking to+  VanillaIds was the only correct choice to begin with.++* RecSelId, DataCon*Id, ClassOpId, PrimOpId, FCallId, CoVarId, TickBoxId:+  Never specialised.+ Note [Specialisation Must Preserve Sharing] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider a function:@@ -2980,15 +3023,14 @@                               ty' = substTy env (idType b)                         ; return (mkUserLocal (nameOccName n) uniq Many ty' (getSrcSpan n)) } -newSpecIdSM :: Id -> Type -> Maybe JoinArity -> SpecM Id+newSpecIdSM :: Name -> Type -> IdDetails -> IdInfo -> SpecM Id     -- Give the new Id a similar occurrence name to the old one-newSpecIdSM old_id new_ty join_arity_maybe+newSpecIdSM old_name new_ty details info   = do  { uniq <- getUniqueM-        ; let name    = idName old_id-              new_occ = mkSpecOcc (nameOccName name)-              new_id  = mkUserLocal new_occ uniq Many new_ty (getSrcSpan name)-                          `asJoinId_maybe` join_arity_maybe-        ; return new_id }+        ; let new_occ  = mkSpecOcc (nameOccName old_name)+              new_name = mkInternalName uniq new_occ  (getSrcSpan old_name)+        ; return (assert (not (isCoVarType new_ty)) $+                  mkLocalVar details new_name Many new_ty info) }  {-                 Old (but interesting) stuff about unboxed bindings

@@ -529,7 +529,7 @@       has_caf_info = not (mayHaveCafRefs caf_info)        str_info = dmdSigInfo info-      has_str_info = not (isTopSig str_info)+      has_str_info = not (isNopSig str_info)        unf_info = realUnfoldingInfo info       has_unf = hasSomeUnfolding unf_info@@ -573,7 +573,7 @@     has_caf_info = not (mayHaveCafRefs caf_info)      str_info = dmdSigInfo info-    has_str_info = not (isTopSig str_info)+    has_str_info = not (isNopSig str_info)      cpr_info = cprSigInfo info     has_cpr_info = cpr_info /= topCprSig@@ -623,18 +623,14 @@                 <+> sep (map (pprBndr LambdaBind) bndrs) <+> arrow)             2 (ppr con <+> sep (map ppr args))   ppr (CoreUnfolding { uf_src = src-                     , uf_tmpl=rhs, uf_is_top=top, uf_is_value=hnf-                     , uf_is_conlike=conlike, uf_is_work_free=wf-                     , uf_expandable=exp, uf_guidance=g })+                     , uf_tmpl=rhs, uf_is_top=top+                     , uf_cache=cache, uf_guidance=g })         = text "Unf" <> braces (pp_info $$ pp_rhs)     where       pp_info = fsep $ punctuate comma                 [ text "Src="        <> ppr src                 , text "TopLvl="     <> ppr top-                , text "Value="      <> ppr hnf-                , text "ConLike="    <> ppr conlike-                , text "WorkFree="   <> ppr wf-                , text "Expandable=" <> ppr exp+                , ppr cache                 , text "Guidance="   <> ppr g ]       pp_tmpl = ppUnlessOption sdocSuppressUnfoldings                   (text "Tmpl=" <+> ppr rhs)@@ -642,6 +638,15 @@              | otherwise          = empty             -- Don't print the RHS or we get a quadratic             -- blowup in the size of the printout!++instance Outputable UnfoldingCache where+    ppr (UnfoldingCache { uf_is_value = hnf, uf_is_conlike = conlike+                        , uf_is_work_free = wf, uf_expandable = exp })+        = fsep $ punctuate comma+          [ text "Value="      <> ppr hnf+          , text "ConLike="    <> ppr conlike+          , text "WorkFree="   <> ppr wf+          , text "Expandable=" <> ppr exp ]  {- -----------------------------------------------------

@@ -50,6 +50,7 @@ import GHC.Core.Coercion as Coercion import GHC.Core.Tidy     ( tidyRules ) import GHC.Core.Map.Expr ( eqCoreExpr )+import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr )  import GHC.Tc.Utils.TcType  ( tcSplitTyConApp_maybe ) import GHC.Builtin.Types    ( anyTypeOfKind )@@ -190,13 +191,18 @@ -- ^ Used to make 'CoreRule' for an 'Id' defined in the module being -- compiled. See also 'GHC.Core.CoreRule' mkRule this_mod is_auto is_local name act fn bndrs args rhs-  = Rule { ru_name = name, ru_fn = fn, ru_act = act,-           ru_bndrs = bndrs, ru_args = args,-           ru_rhs = rhs,-           ru_rough = roughTopNames args,-           ru_origin = this_mod,-           ru_orphan = orph,-           ru_auto = is_auto, ru_local = is_local }+  = Rule { ru_name   = name+         , ru_act    = act+         , ru_fn     = fn+         , ru_bndrs  = bndrs+         , ru_args   = args+         , ru_rhs    = occurAnalyseExpr rhs+                       -- See Note [OccInfo in unfoldings and rules]+         , ru_rough  = roughTopNames args+         , ru_origin = this_mod+         , ru_orphan = orph+         , ru_auto   = is_auto+         , ru_local  = is_local }   where         -- Compute orphanhood.  See Note [Orphans] in GHC.Core.InstEnv         -- A rule is an orphan only if none of the variables

@@ -104,10 +104,11 @@  seqUnfolding :: Unfolding -> () seqUnfolding (CoreUnfolding { uf_tmpl = e, uf_is_top = top,-                uf_is_value = b1, uf_is_work_free = b2,-                uf_expandable = b3, uf_is_conlike = b4,-                uf_guidance = g})-  = seqExpr e `seq` top `seq` b1 `seq` b2 `seq` b3 `seq` b4 `seq` seqGuidance g+                uf_cache = cache, uf_guidance = g})+  = seqExpr e `seq` top `seq` cache `seq` seqGuidance g+    -- The unf_cache :: UnfoldingCache field is a strict data type,+    -- so it is sufficient to use plain `seq` for this field+    -- See Note [UnfoldingCache] in GHC.Core  seqUnfolding _ = () 

@@ -693,7 +693,7 @@    unfolding_from_rhs = mkUnfolding uf_opts InlineRhs                                     (isTopLevel top_level)                                     False -- may be bottom or not-                                    new_rhs+                                    new_rhs Nothing  simpleUnfoldingFun :: IdUnfoldingFun simpleUnfoldingFun id

@@ -84,7 +84,7 @@ -- This means the code generator can get the full calling convention by only looking at the function -- itself without having to inspect the RHS. ----- The actual logic is in tidyCbvInfo and takes:+-- The actual logic is in computeCbvInfo and takes: -- * The function id -- * The functions rhs -- And gives us back the function annotated with the marks.@@ -362,15 +362,16 @@     (tidy_env', bndrs') = tidyBndrs tidy_env bndrs  tidyNestedUnfolding tidy_env-    unf@(CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src, uf_is_value = is_value })+    unf@(CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src, uf_cache = cache })   | isStableSource src   = seqIt $ unf { uf_tmpl = tidyExpr tidy_env unf_rhs }    -- Preserves OccInfo-            -- This seqIt avoids a space leak: otherwise the uf_is_value,-            -- uf_is_conlike, ... fields may retain a reference to the-            -- pre-tidied expression forever (GHC.CoreToIface doesn't look at them)+            -- This seqIt avoids a space leak: otherwise the uf_cache+            -- field may retain a reference to the pre-tidied+            -- expression forever (GHC.CoreToIface doesn't look at+            -- them)    -- Discard unstable unfoldings, but see Note [Preserve evaluatedness]-  | is_value = evaldUnfolding+  | uf_is_value cache = evaldUnfolding   | otherwise = noUnfolding    where

@@ -1035,11 +1035,11 @@       -- Things with an INLINE pragma may have an unfolding *and*       -- be a loop breaker  (maybe the knot is not yet untied)         CoreUnfolding { uf_tmpl = unf_template-                      , uf_is_work_free = is_wf-                      , uf_guidance = guidance, uf_expandable = is_exp }+                      , uf_cache = unf_cache+                      , uf_guidance = guidance }           | active_unfolding -> tryUnfolding logger opts case_depth id lone_variable                                     arg_infos cont_info unf_template-                                    is_wf is_exp guidance+                                    unf_cache guidance           | otherwise -> traceInline logger opts id "Inactive unfolding:" (ppr id) Nothing         NoUnfolding      -> Nothing         BootUnfolding    -> Nothing@@ -1161,11 +1161,10 @@ -}  tryUnfolding :: Logger -> UnfoldingOpts -> Int -> Id -> Bool -> [ArgSummary] -> CallCtxt-             -> CoreExpr -> Bool -> Bool -> UnfoldingGuidance+             -> CoreExpr -> UnfoldingCache -> UnfoldingGuidance              -> Maybe CoreExpr-tryUnfolding logger opts !case_depth id lone_variable-             arg_infos cont_info unf_template-             is_wf is_exp guidance+tryUnfolding logger opts !case_depth id lone_variable arg_infos+             cont_info unf_template unf_cache guidance  = case guidance of      UnfNever -> traceInline logger opts id str (text "UnfNever") Nothing @@ -1177,7 +1176,7 @@         -> traceInline logger opts id str (mk_doc some_benefit empty False) Nothing         where           some_benefit = calc_some_benefit uf_arity-          enough_args = (n_val_args >= uf_arity) || (unsat_ok && n_val_args > 0)+          enough_args  = (n_val_args >= uf_arity) || (unsat_ok && n_val_args > 0)       UnfIfGoodArgs { ug_args = arg_discounts, ug_res = res_discount, ug_size = size }         | unfoldingVeryAggressive opts@@ -1188,9 +1187,6 @@         -> traceInline logger opts id str (mk_doc some_benefit extra_doc False) Nothing         where           some_benefit = calc_some_benefit (length arg_discounts)-          extra_doc = vcat [ text "case depth =" <+> int case_depth-                           , text "depth based penalty =" <+> int depth_penalty-                           , text "discounted size =" <+> int adjusted_size ]           -- See Note [Avoid inlining into deeply nested cases]           depth_treshold = unfoldingCaseThreshold opts           depth_scaling = unfoldingCaseScaling opts@@ -1200,7 +1196,18 @@           small_enough = adjusted_size <= unfoldingUseThreshold opts           discount = computeDiscount arg_discounts res_discount arg_infos cont_info +          extra_doc = vcat [ text "case depth =" <+> int case_depth+                           , text "depth based penalty =" <+> int depth_penalty+                           , text "discounted size =" <+> int adjusted_size ]+   where+    -- Unpack the UnfoldingCache lazily because it may not be needed, and all+    -- its fields are strict; so evaluating unf_cache at all forces all the+    -- isWorkFree etc computations to take place.  That risks wasting effort for+    -- Ids that are never going to inline anyway.+    -- See Note [UnfoldingCache] in GHC.Core+    UnfoldingCache{ uf_is_work_free = is_wf, uf_expandable = is_exp } = unf_cache+     mk_doc some_benefit extra_doc yes_or_no       = vcat [ text "arg infos" <+> ppr arg_infos              , text "interesting continuation" <+> ppr cont_info

@@ -6,6 +6,7 @@    , mkUnfolding    , mkCoreUnfolding    , mkFinalUnfolding+   , mkFinalUnfolding'    , mkSimpleUnfolding    , mkWorkerUnfolding    , mkInlineUnfolding@@ -36,15 +37,24 @@ import GHC.Utils.Misc import GHC.Utils.Panic +import Data.Maybe ( fromMaybe )+ -- the very simple optimiser is used to optimise unfoldings import {-# SOURCE #-} GHC.Core.SimpleOpt   -mkFinalUnfolding :: UnfoldingOpts -> UnfoldingSource -> DmdSig -> CoreExpr -> Unfolding+mkFinalUnfolding :: UnfoldingOpts -> UnfoldingSource -> DmdSig -> CoreExpr -> Maybe UnfoldingCache -> Unfolding -- "Final" in the sense that this is a GlobalId that will not be further -- simplified; so the unfolding should be occurrence-analysed-mkFinalUnfolding opts src strict_sig expr+mkFinalUnfolding opts src strict_sig expr = mkFinalUnfolding' opts src strict_sig expr++-- See Note [Tying the 'CoreUnfolding' knot] for why interfaces need+-- to pass a precomputed 'UnfoldingCache'+mkFinalUnfolding' :: UnfoldingOpts -> UnfoldingSource -> DmdSig -> CoreExpr -> Maybe UnfoldingCache -> Unfolding+-- "Final" in the sense that this is a GlobalId that will not be further+-- simplified; so the unfolding should be occurrence-analysed+mkFinalUnfolding' opts src strict_sig expr   = mkUnfolding opts src                 True {- Top level -}                 (isDeadEndSig strict_sig)@@ -59,7 +69,7 @@ mkCompulsoryUnfolding' :: CoreExpr -> Unfolding mkCompulsoryUnfolding' expr   = mkCoreUnfolding InlineCompulsory True-                    expr+                    expr Nothing                     (UnfWhen { ug_arity = 0    -- Arity of unfolding doesn't matter                              , ug_unsat_ok = unSaturatedOk, ug_boring_ok = boringCxtOk }) @@ -71,7 +81,7 @@  mkSimpleUnfolding :: UnfoldingOpts -> CoreExpr -> Unfolding mkSimpleUnfolding !opts rhs-  = mkUnfolding opts InlineRhs False False rhs+  = mkUnfolding opts InlineRhs False False rhs Nothing  mkDFunUnfolding :: [Var] -> DataCon -> [CoreExpr] -> Unfolding mkDFunUnfolding bndrs con ops@@ -85,7 +95,7 @@ -- after demand/CPR analysis mkWrapperUnfolding opts expr arity   = mkCoreUnfolding InlineStable True-                    (simpleOptExpr opts expr)+                    (simpleOptExpr opts expr) Nothing                     (UnfWhen { ug_arity     = arity                              , ug_unsat_ok  = unSaturatedOk                              , ug_boring_ok = boringCxtNotOk })@@ -96,7 +106,7 @@                   (CoreUnfolding { uf_src = src, uf_tmpl = tmpl                                  , uf_is_top = top_lvl })   | isStableSource src-  = mkCoreUnfolding src top_lvl new_tmpl guidance+  = mkCoreUnfolding src top_lvl new_tmpl Nothing guidance   where     new_tmpl = simpleOptExpr opts (work_fn tmpl)     guidance = calcUnfoldingGuidance (so_uf_opts opts) False new_tmpl@@ -111,7 +121,7 @@ mkInlineUnfolding opts expr   = mkCoreUnfolding InlineStable                     True         -- Note [Top-level flag on inline rules]-                    expr' guide+                    expr' Nothing guide   where     expr' = simpleOptExpr opts expr     guide = UnfWhen { ug_arity = manifestArity expr'@@ -125,7 +135,7 @@ mkInlineUnfoldingWithArity arity opts expr   = mkCoreUnfolding InlineStable                     True         -- Note [Top-level flag on inline rules]-                    expr' guide+                    expr' Nothing guide   where     expr' = simpleOptExpr opts expr     guide = UnfWhen { ug_arity = arity@@ -138,7 +148,7 @@  mkInlinableUnfolding :: SimpleOpts -> CoreExpr -> Unfolding mkInlinableUnfolding opts expr-  = mkUnfolding (so_uf_opts opts) InlineStable False False expr'+  = mkUnfolding (so_uf_opts opts) InlineStable False False expr' Nothing   where     expr' = simpleOptExpr opts expr @@ -172,7 +182,7 @@                              , uf_guidance = old_guidance })  | isStableSource src  -- See Note [Specialising unfoldings]  , UnfWhen { ug_arity = old_arity } <- old_guidance- = mkCoreUnfolding src top_lvl new_tmpl+ = mkCoreUnfolding src top_lvl new_tmpl Nothing                    (old_guidance { ug_arity = old_arity - arity_decrease })  where    new_tmpl = simpleOptExpr opts $@@ -286,11 +296,12 @@             -> Bool       -- Definitely a bottoming binding                           -- (only relevant for top-level bindings)             -> CoreExpr+            -> Maybe UnfoldingCache             -> Unfolding -- Calculates unfolding guidance -- Occurrence-analyses the expression before capturing it-mkUnfolding opts src top_lvl is_bottoming expr-  = mkCoreUnfolding src top_lvl expr guidance+mkUnfolding opts src top_lvl is_bottoming expr cache+  = mkCoreUnfolding src top_lvl expr cache guidance   where     is_top_bottoming = top_lvl && is_bottoming     guidance         = calcUnfoldingGuidance opts is_top_bottoming expr@@ -298,33 +309,33 @@         -- See Note [Calculate unfolding guidance on the non-occ-anal'd expression]  mkCoreUnfolding :: UnfoldingSource -> Bool -> CoreExpr-                -> UnfoldingGuidance -> Unfolding--- Occurrence-analyses the expression before capturing it-mkCoreUnfolding src top_lvl expr guidance-  =+                -> Maybe UnfoldingCache -> UnfoldingGuidance -> Unfolding+mkCoreUnfolding src top_lvl expr precomputed_cache guidance+  = CoreUnfolding { uf_tmpl = cache `seq`+                              occurAnalyseExpr expr+      -- occAnalyseExpr: see Note [Occurrence analysis of unfoldings]+      -- See #20905 for what a discussion of this 'seq'.+      -- We are careful to make sure we only+      -- have one copy of an unfolding around at once.+      -- Note [Thoughtful forcing in mkCoreUnfolding] -  let is_value = exprIsHNF expr-      is_conlike = exprIsConLike expr-      is_work_free = exprIsWorkFree expr-      is_expandable = exprIsExpandable expr-  in-  -- See #20905 for what is going on here. We are careful to make sure we only-  -- have one copy of an unfolding around at once.-  -- Note [Thoughtful forcing in mkCoreUnfolding]-  CoreUnfolding { uf_tmpl         = is_value `seq`-                                    is_conlike `seq`-                                    is_work_free `seq`-                                    is_expandable `seq`-                                      occurAnalyseExpr expr,-                      -- See Note [Occurrence analysis of unfoldings]-                    uf_src          = src,-                    uf_is_top       = top_lvl,-                    uf_is_value     = is_value,-                    uf_is_conlike   = is_conlike,-                    uf_is_work_free = is_work_free,-                    uf_expandable   = is_expandable,-                    uf_guidance     = guidance }+                  , uf_src          = src+                  , uf_is_top       = top_lvl+                  , uf_cache        = cache+                  , uf_guidance     = guidance }+  where+    is_value      = exprIsHNF expr+    is_conlike    = exprIsConLike expr+    is_work_free  = exprIsWorkFree expr+    is_expandable = exprIsExpandable expr +    recomputed_cache = UnfoldingCache { uf_is_value = is_value+                                      , uf_is_conlike = is_conlike+                                      , uf_is_work_free = is_work_free+                                      , uf_expandable = is_expandable }++    cache = fromMaybe recomputed_cache precomputed_cache+ ---------------- certainlyWillInline :: UnfoldingOpts -> IdInfo -> CoreExpr -> Maybe Unfolding -- ^ Sees if the unfolding is pretty certain to inline.@@ -454,4 +465,3 @@ The result of fixing this led to a 1G reduction in peak memory usage (12G -> 11G) when compiling a very large module (peak 3 million terms). For more discussion see #20905. -}-

@@ -2308,10 +2308,9 @@   | c1 == c2 && equalLength bs1 bs2   = concatMap (uncurry (diffExpr False env')) (zip a1 a2)   where env' = rnBndrs2 env bs1 bs2-diffUnfold env (CoreUnfolding t1 _ _ v1 cl1 wf1 x1 g1)-               (CoreUnfolding t2 _ _ v2 cl2 wf2 x2 g2)-  | v1 == v2 && cl1 == cl2-    && wf1 == wf2 && x1 == x2 && g1 == g2+diffUnfold env (CoreUnfolding t1 _ _ c1 g1)+               (CoreUnfolding t2 _ _ c2 g2)+  | c1 == c2 && g1 == g2   = diffExpr False env t1 t2 diffUnfold _   uf1 uf2   = [fsep [ppr uf1, text "/=", ppr uf2]]

@@ -81,7 +81,7 @@ import GHC.Types.Var.Env import GHC.Types.Var.Set import GHC.Types.Tickish-import GHC.Types.Demand ( isTopSig )+import GHC.Types.Demand ( isNopSig ) import GHC.Types.Cpr ( topCprSig )  import GHC.Utils.Outputable@@ -482,7 +482,7 @@     ------------  Strictness  --------------         -- No point in explicitly exporting TopSig     sig_info = dmdSigInfo id_info-    strict_hsinfo | not (isTopSig sig_info) = Just (HsDmdSig sig_info)+    strict_hsinfo | not (isNopSig sig_info) = Just (HsDmdSig sig_info)                   | otherwise               = Nothing      ------------  CPR --------------@@ -510,6 +510,7 @@ toIfUnfolding :: Bool -> Unfolding -> Maybe IfaceInfoItem toIfUnfolding lb (CoreUnfolding { uf_tmpl = rhs                                 , uf_src = src+                                , uf_cache = cache                                 , uf_guidance = guidance })   = Just $ HsUnfold lb $     case src of@@ -517,9 +518,9 @@           -> case guidance of                UnfWhen {ug_arity = arity, ug_unsat_ok = unsat_ok, ug_boring_ok =  boring_ok }                       -> IfInlineRule arity unsat_ok boring_ok if_rhs-               _other -> IfCoreUnfold True if_rhs+               _other -> IfCoreUnfold True cache if_rhs         InlineCompulsory -> IfCompulsory if_rhs-        InlineRhs        -> IfCoreUnfold False if_rhs+        InlineRhs        -> IfCoreUnfold False cache if_rhs         -- Yes, even if guidance is UnfNever, expose the unfolding         -- If we didn't want to expose the unfolding, GHC.Iface.Tidy would         -- have stuck in NoUnfolding.  For supercompilation we want

@@ -1084,7 +1084,7 @@         where           depth = val_args args           stricts = case idDmdSig v of-                            DmdSig (DmdType _ demands _)+                            DmdSig (DmdType _ demands)                               | listLengthCmp demands depth /= GT -> demands                                     -- length demands <= depth                               | otherwise                         -> []

@@ -281,7 +281,7 @@              -- wrapper code mentions the ffi_arg type, which comes from ffi.h             ffi_includes-              | platformMisc_libFFI $ platformMisc dflags = "#include <ffi.h>\n"+              | platformMisc_libFFI $ platformMisc dflags = "#include \"rts/ghc_ffi.h\"\n"               | otherwise = ""          stub_h_file_exists

@@ -22,6 +22,7 @@   , stgPipeline_pprOpts = initStgPprOpts dflags   , stgPipeline_phases = getStgToDo for_bytecode dflags   , stgPlatform = targetPlatform dflags+  , stgPipeline_forBytecode = for_bytecode   }  -- | Which Stg-to-Stg passes to run. Depends on flags, ways etc.

@@ -799,18 +799,18 @@       else use (T_LlvmMangle pipe_env hsc_env llc_fn)   asPipeline False pipe_env hsc_env location mangled_fn -cmmCppPipeline :: P m => PipeEnv -> HscEnv -> FilePath -> m FilePath+cmmCppPipeline :: P m => PipeEnv -> HscEnv -> FilePath -> m (Maybe FilePath) cmmCppPipeline pipe_env hsc_env input_fn = do   output_fn <- use (T_CmmCpp pipe_env hsc_env input_fn)   cmmPipeline pipe_env hsc_env output_fn -cmmPipeline :: P m => PipeEnv -> HscEnv -> FilePath -> m FilePath+cmmPipeline :: P m => PipeEnv -> HscEnv -> FilePath -> m (Maybe FilePath) cmmPipeline pipe_env hsc_env input_fn = do   (fos, output_fn) <- use (T_Cmm pipe_env hsc_env input_fn)   mo_fn <- hscPostBackendPipeline pipe_env hsc_env HsSrcFile (backend (hsc_dflags hsc_env)) Nothing output_fn   case mo_fn of-    Nothing -> panic "CMM pipeline - produced no .o file"-    Just mo_fn -> use (T_MergeForeign pipe_env hsc_env mo_fn fos)+    Nothing -> return Nothing+    Just mo_fn -> Just <$> use (T_MergeForeign pipe_env hsc_env mo_fn fos)  hscPostBackendPipeline :: P m => PipeEnv -> HscEnv -> HscSource -> Backend -> Maybe ModLocation -> FilePath -> m (Maybe FilePath) hscPostBackendPipeline _ _ HsBootFile _ _ _   = return Nothing@@ -873,8 +873,8 @@    fromPhase LlvmLlc    = llvmLlcPipeline pipe_env hsc_env Nothing input_fn    fromPhase LlvmMangle = llvmManglePipeline pipe_env hsc_env Nothing input_fn    fromPhase StopLn     = return (Just input_fn)-   fromPhase CmmCpp     = Just <$> cmmCppPipeline pipe_env hsc_env input_fn-   fromPhase Cmm        = Just <$> cmmPipeline pipe_env hsc_env input_fn+   fromPhase CmmCpp     = cmmCppPipeline pipe_env hsc_env input_fn+   fromPhase Cmm        = cmmPipeline pipe_env hsc_env input_fn    fromPhase MergeForeign = panic "fromPhase: MergeForeign"  {-

@@ -600,8 +600,8 @@     = pure i  rnIfaceUnfolding :: Rename IfaceUnfolding-rnIfaceUnfolding (IfCoreUnfold stable if_expr)-    = IfCoreUnfold stable <$> rnIfaceExpr if_expr+rnIfaceUnfolding (IfCoreUnfold stable cache if_expr)+    = IfCoreUnfold stable cache <$> rnIfaceExpr if_expr rnIfaceUnfolding (IfCompulsory if_expr)     = IfCompulsory <$> rnIfaceExpr if_expr rnIfaceUnfolding (IfInlineRule arity unsat_ok boring_ok if_expr)

@@ -47,7 +47,7 @@ import GHC.Types.Unique ( hasKey ) import GHC.Iface.Type import GHC.Iface.Recomp.Binary-import GHC.Core( IsOrphan, isOrphan )+import GHC.Core( IsOrphan, isOrphan, UnfoldingCache(..) ) import GHC.Types.Demand import GHC.Types.Cpr import GHC.Core.Class@@ -359,7 +359,7 @@ -- only later attached to the Id.  Partial reason: some are orphans.  data IfaceUnfolding-  = IfCoreUnfold Bool IfaceExpr -- True <=> INLINABLE, False <=> regular unfolding+  = IfCoreUnfold Bool IfUnfoldingCache IfaceExpr -- True <=> INLINABLE, False <=> regular unfolding                                 -- Possibly could eliminate the Bool here, the information                                 -- is also in the InlinePragma. @@ -374,7 +374,9 @@    | IfDFunUnfold [IfaceBndr] [IfaceExpr] +type IfUnfoldingCache = UnfoldingCache + -- We only serialise the IdDetails of top-level Ids, and even then -- we only need a very limited selection.  Notably, none of the -- implicit ones are needed here, because they are not put in@@ -1488,7 +1490,7 @@  instance Outputable IfaceUnfolding where   ppr (IfCompulsory e)     = text "<compulsory>" <+> parens (ppr e)-  ppr (IfCoreUnfold s e)   = (if s+  ppr (IfCoreUnfold s _ e)   = (if s                                 then text "<stable>"                                 else Outputable.empty)                               <+> parens (ppr e)@@ -1741,7 +1743,7 @@ freeNamesItem _                      = emptyNameSet  freeNamesIfUnfold :: IfaceUnfolding -> NameSet-freeNamesIfUnfold (IfCoreUnfold _ e)     = freeNamesIfExpr e+freeNamesIfUnfold (IfCoreUnfold _ _ e)     = freeNamesIfExpr e freeNamesIfUnfold (IfCompulsory e)       = freeNamesIfExpr e freeNamesIfUnfold (IfInlineRule _ _ _ e) = freeNamesIfExpr e freeNamesIfUnfold (IfDFunUnfold bs es)   = freeNamesIfBndrs bs &&& fnList freeNamesIfExpr es@@ -2265,9 +2267,10 @@             _ -> HsTagSig <$> get bh  instance Binary IfaceUnfolding where-    put_ bh (IfCoreUnfold s e) = do+    put_ bh (IfCoreUnfold s c e) = do         putByte bh 0         put_ bh s+        putUnfoldingCache bh c         put_ bh e     put_ bh (IfInlineRule a b c d) = do         putByte bh 1@@ -2286,8 +2289,9 @@         h <- getByte bh         case h of             0 -> do s <- get bh+                    c <- getUnfoldingCache bh                     e <- get bh-                    return (IfCoreUnfold s e)+                    return (IfCoreUnfold s c e)             1 -> do a <- get bh                     b <- get bh                     c <- get bh@@ -2299,6 +2303,26 @@             _ -> do e <- get bh                     return (IfCompulsory e) +putUnfoldingCache :: BinHandle -> IfUnfoldingCache -> IO ()+putUnfoldingCache bh (UnfoldingCache { uf_is_value = hnf, uf_is_conlike = conlike+                                     , uf_is_work_free = wf, uf_expandable = exp }) = do+    let b = zeroBits .<<|. hnf .<<|. conlike .<<|. wf .<<|. exp+    putByte bh b++getUnfoldingCache :: BinHandle -> IO IfUnfoldingCache+getUnfoldingCache bh = do+    b <- getByte bh+    let hnf     = testBit b 3+        conlike = testBit b 2+        wf      = testBit b 1+        exp     = testBit b 0+    return (UnfoldingCache { uf_is_value = hnf, uf_is_conlike = conlike+                           , uf_is_work_free = wf, uf_expandable = exp })++infixl 9 .<<|.+(.<<|.) :: (Bits a) => a -> Bool -> a+x .<<|. b = (if b then (`setBit` 0) else id) (x `shiftL` 1)+ instance Binary IfaceAlt where     put_ bh (IfaceAlt a b c) = do         put_ bh a@@ -2614,8 +2638,9 @@  instance NFData IfaceUnfolding where   rnf = \case-    IfCoreUnfold inlinable expr ->-      rnf inlinable `seq` rnf expr+    IfCoreUnfold inlinable cache expr ->+      rnf inlinable `seq` cache `seq` rnf expr+    -- See Note [UnfoldingCache] in GHC.Core for why it suffices to merely `seq` on cache     IfCompulsory expr ->       rnf expr     IfInlineRule arity b1 b2 e ->

@@ -51,7 +51,7 @@ import GHC.Types.Id import GHC.Types.Id.Make ( mkDictSelRhs ) import GHC.Types.Id.Info-import GHC.Types.Demand  ( isDeadEndAppSig, isTopSig, isDeadEndSig )+import GHC.Types.Demand  ( isDeadEndAppSig, isNopSig, isDeadEndSig ) import GHC.Types.Cpr     ( mkCprSig, botCpr ) import GHC.Types.Basic import GHC.Types.Name hiding (varName)@@ -1253,7 +1253,7 @@     mb_bot_str = exprBotStrictness_maybe orig_rhs      sig = dmdSigInfo idinfo-    final_sig | not $ isTopSig sig+    final_sig | not $ isNopSig sig               = warnPprTrace (_bottom_hidden sig) "tidyTopIdInfo" (ppr name) sig               -- try a cheap-and-cheerful bottom analyser               | Just (_, nsig) <- mb_bot_str = nsig

@@ -1722,12 +1722,12 @@  tcUnfolding :: TopLevelFlag -> Name -> Type -> IdInfo -> IfaceUnfolding -> IfL Unfolding -- See Note [Lazily checking Unfoldings]-tcUnfolding toplvl name _ info (IfCoreUnfold stable if_expr)+tcUnfolding toplvl name _ info (IfCoreUnfold stable cache if_expr)   = do  { uf_opts <- unfoldingOpts <$> getDynFlags         ; expr <- tcUnfoldingRhs False toplvl name if_expr         ; let unf_src | stable    = InlineStable                       | otherwise = InlineRhs-        ; return $ mkFinalUnfolding uf_opts unf_src strict_sig expr }+        ; return $ mkFinalUnfolding uf_opts unf_src strict_sig expr (Just cache) }   where     -- Strictness should occur before unfolding!     strict_sig = dmdSigInfo info@@ -1738,7 +1738,7 @@  tcUnfolding toplvl name _ _ (IfInlineRule arity unsat_ok boring_ok if_expr)   = do  { expr <- tcUnfoldingRhs False toplvl name if_expr-        ; return $ mkCoreUnfolding InlineStable True expr guidance }+        ; return $ mkCoreUnfolding InlineStable True expr Nothing guidance }   where     guidance = UnfWhen { ug_arity = arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok } @@ -1749,6 +1749,49 @@   where     doc = text "Class ops for dfun" <+> ppr name     (_, _, cls, _) = tcSplitDFunTy dfun_ty++{- Note [Tying the 'CoreUnfolding' knot]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The unfolding of recursive definitions can contain references to the+Id being defined. Consider the following example:++    foo :: ()+    foo = foo++The unfolding template of 'foo' is, of course, 'foo'; so the interface+file for this module contains:++    foo :: ();  Unfolding = foo++When rehydrating the interface file we are going to make an Id for+'foo' (in GHC.IfaceToCore), with an 'Unfolding'. We used to make this+'Unfolding' by calling 'mkFinalUnfolding', but that needs to populate,+among other fields, the 'uf_is_value' field, by computing+'exprIsValue' of the template (in this case, 'foo').++'exprIsValue e' looks at the unfoldings of variables in 'e' to see if+they are evaluated; so it consults the `uf_is_value` field of+variables in `e`. Now we can see the problem: to set the `uf_is_value`+field of `foo`'s unfolding, we look at its unfolding (in this case+just `foo` itself!). Loop. This is the root cause of ticket #22272.++The simple solution we chose is to serialise the various auxiliary+fields of `CoreUnfolding` so that we don't need to recreate them when+rehydrating. Specifically, the following fields are moved to the+'UnfoldingCache', which is persisted in the interface file:++* 'uf_is_conlike'+* 'uf_is_value'+* 'uf_is_work_free'+* 'uf_expandable'++These four bits make the interface files only one byte larger per+unfolding; on the other hand, this does save calls to 'exprIsValue',+'exprIsExpandable' etc for every imported Id.++We could choose to do this only for loop breakers. But that's a bit+more complicated and it seems good all round.+-}  {- Note [Lazily checking Unfoldings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

@@ -140,8 +140,11 @@  emptyLoaderState :: LoaderState emptyLoaderState = LoaderState-   { closure_env = emptyNameEnv-   , itbl_env    = emptyNameEnv+   { linker_env = LinkerEnv+     { closure_env = emptyNameEnv+     , itbl_env    = emptyNameEnv+     , addr_env    = emptyNameEnv+     }    , pkgs_loaded = init_pkgs    , bcos_loaded = emptyModuleEnv    , objs_loaded = emptyModuleEnv@@ -156,17 +159,16 @@  extendLoadedEnv :: Interp -> [(Name,ForeignHValue)] -> IO () extendLoadedEnv interp new_bindings =-  modifyLoaderState_ interp $ \pls@LoaderState{..} -> do-    let new_ce = extendClosureEnv closure_env new_bindings-    return $! pls{ closure_env = new_ce }+  modifyLoaderState_ interp $ \pls -> do+    return $! modifyClosureEnv pls $ \ce ->+      extendClosureEnv ce new_bindings     -- strictness is important for not retaining old copies of the pls  deleteFromLoadedEnv :: Interp -> [Name] -> IO () deleteFromLoadedEnv interp to_remove =   modifyLoaderState_ interp $ \pls -> do-    let ce = closure_env pls-    let new_ce = delListFromNameEnv ce to_remove-    return pls{ closure_env = new_ce }+    return $ modifyClosureEnv pls $ \ce ->+      delListFromNameEnv ce to_remove  -- | Load the module containing the given Name and get its associated 'HValue'. --@@ -184,7 +186,7 @@            then throwGhcExceptionIO (ProgramError "")            else return (pls', links, pkgs) -    case lookupNameEnv (closure_env pls) name of+    case lookupNameEnv (closure_env (linker_env pls)) name of       Just (_,aa) -> return (pls,(aa, links, pkgs))       Nothing     -> assertPpr (isExternalName name) (ppr name) $                      do let sym_to_find = nameToCLabel name "closure"@@ -246,10 +248,7 @@         -- package), so the reset action only removes the names we         -- added earlier.           reset_old_env = liftIO $-            modifyLoaderState_ interp $ \pls ->-                let cur = closure_env pls-                    new = delListFromNameEnv cur (map fst new_env)-                in return pls{ closure_env = new }+            deleteFromLoadedEnv interp (map fst new_env)   -- | Display the loader state.@@ -593,13 +592,11 @@       then throwGhcExceptionIO (ProgramError "")       else do         -- Load the expression itself-        let ie = itbl_env pls-            ce = closure_env pls-         -- Load the necessary packages and linkables-        let nobreakarray = error "no break array"+        let le = linker_env pls+            nobreakarray = error "no break array"             bco_ix = mkNameEnv [(unlinkedBCOName root_ul_bco, 0)]-        resolved <- linkBCO interp ie ce bco_ix nobreakarray root_ul_bco+        resolved <- linkBCO interp le bco_ix nobreakarray root_ul_bco         bco_opts <- initBCOOpts (hsc_dflags hsc_env)         [root_hvref] <- createBCOs interp bco_opts [resolved]         fhv <- mkFinalizedHValue interp root_hvref@@ -910,15 +907,16 @@         then throwGhcExceptionIO (ProgramError "")         else do           -- Link the expression itself-          let ie = plusNameEnv (itbl_env pls) bc_itbls-              ce = closure_env pls+          let le  = linker_env pls+              le2 = le { itbl_env = plusNameEnv (itbl_env le) bc_itbls+                       , addr_env = plusNameEnv (addr_env le) bc_strs }            -- Link the necessary packages and linkables           bco_opts <- initBCOOpts (hsc_dflags hsc_env)-          new_bindings <- linkSomeBCOs bco_opts interp ie ce [cbc]+          new_bindings <- linkSomeBCOs bco_opts interp le2 [cbc]           nms_fhvs <- makeForeignNamedHValueRefs interp new_bindings-          let pls2 = pls { closure_env = extendClosureEnv ce nms_fhvs-                         , itbl_env    = ie }+          let ce2  = extendClosureEnv (closure_env le2) nms_fhvs+              !pls2 = pls { linker_env = le2 { closure_env = ce2 } }           return (pls2, (nms_fhvs, links_needed, units_needed))   where     free_names = uniqDSetToList $@@ -1136,11 +1134,12 @@             cbcs      = map byteCodeOfObject unlinkeds  -            ies        = map bc_itbls cbcs-            gce       = closure_env pls-            final_ie  = foldr plusNameEnv (itbl_env pls) ies+            le1 = linker_env pls+            ie2 = foldr plusNameEnv (itbl_env le1) (map bc_itbls cbcs)+            ae2 = foldr plusNameEnv (addr_env le1) (map bc_strs cbcs)+            le2 = le1 { itbl_env = ie2, addr_env = ae2 } -        names_and_refs <- linkSomeBCOs bco_opts interp final_ie gce cbcs+        names_and_refs <- linkSomeBCOs bco_opts interp le2 cbcs          -- We only want to add the external ones to the ClosureEnv         let (to_add, to_drop) = partition (isExternalName.fst) names_and_refs@@ -1150,21 +1149,20 @@         -- Wrap finalizers on the ones we want to keep         new_binds <- makeForeignNamedHValueRefs interp to_add -        return pls1 { closure_env = extendClosureEnv gce new_binds,-                      itbl_env    = final_ie }+        let ce2 = extendClosureEnv (closure_env le2) new_binds+        return $! pls1 { linker_env = le2 { closure_env = ce2 } }  -- Link a bunch of BCOs and return references to their values linkSomeBCOs :: BCOOpts              -> Interp-             -> ItblEnv-             -> ClosureEnv+             -> LinkerEnv              -> [CompiledByteCode]              -> IO [(Name,HValueRef)]                         -- The returned HValueRefs are associated 1-1 with                         -- the incoming unlinked BCOs.  Each gives the                         -- value of the corresponding unlinked BCO -linkSomeBCOs bco_opts interp ie ce mods = foldr fun do_link mods []+linkSomeBCOs bco_opts interp le mods = foldr fun do_link mods []  where   fun CompiledByteCode{..} inner accum =     case bc_breaks of@@ -1177,7 +1175,7 @@     let flat = [ (breakarray, bco) | (breakarray, bcos) <- mods, bco <- bcos ]         names = map (unlinkedBCOName . snd) flat         bco_ix = mkNameEnv (zip names [0..])-    resolved <- sequence [ linkBCO interp ie ce bco_ix breakarray bco+    resolved <- sequence [ linkBCO interp le bco_ix breakarray bco                          | (breakarray, bco) <- flat ]     hvrefs <- createBCOs interp bco_opts resolved     return (zip names hvrefs)@@ -1267,15 +1265,11 @@   let -- Note that we want to remove all *local*       -- (i.e. non-isExternal) names too (these are the       -- temporary bindings from the command line).-      keep_name :: (Name, a) -> Bool-      keep_name (n,_) = isExternalName n &&-                        nameModule n `elemModuleEnv` remaining_bcos_loaded--      itbl_env'     = filterNameEnv keep_name itbl_env-      closure_env'  = filterNameEnv keep_name closure_env+      keep_name :: Name -> Bool+      keep_name n = isExternalName n &&+                    nameModule n `elemModuleEnv` remaining_bcos_loaded -      !new_pls = pls { itbl_env = itbl_env',-                       closure_env = closure_env',+      !new_pls = pls { linker_env = filterLinkerEnv keep_name linker_env,                        bcos_loaded = remaining_bcos_loaded,                        objs_loaded = remaining_objs_loaded } 

@@ -10,6 +10,12 @@    ( Loader (..)    , LoaderState (..)    , uninitializedLoader+   , modifyClosureEnv+   , LinkerEnv(..)+   , filterLinkerEnv+   , ClosureEnv+   , emptyClosureEnv+   , extendClosureEnv    , Linkable(..)    , LinkableSet    , mkLinkableSet@@ -32,12 +38,12 @@  import GHC.Prelude import GHC.Unit                ( UnitId, Module )-import GHC.ByteCode.Types      ( ItblEnv, CompiledByteCode )+import GHC.ByteCode.Types      ( ItblEnv, AddrEnv, CompiledByteCode ) import GHC.Fingerprint.Type    ( Fingerprint ) import GHCi.RemoteTypes        ( ForeignHValue )  import GHC.Types.Var           ( Id )-import GHC.Types.Name.Env      ( NameEnv )+import GHC.Types.Name.Env      ( NameEnv, emptyNameEnv, extendNameEnvList, filterNameEnv ) import GHC.Types.Name          ( Name )  import GHC.Utils.Outputable@@ -66,23 +72,16 @@ library. The Maybe may be Nothing to indicate that the linker has not yet been initialised. -The LoaderState maps Names to actual closures (for interpreted code only), for+The LinkerEnv maps Names to actual closures (for interpreted code only), for use during linking. -}  newtype Loader = Loader { loader_state :: MVar (Maybe LoaderState) }  data LoaderState = LoaderState-    { closure_env :: ClosureEnv+    { linker_env :: !LinkerEnv         -- ^ Current global mapping from Names to their true values -    , itbl_env    :: !ItblEnv-        -- ^ The current global mapping from RdrNames of DataCons to-        -- info table addresses.-        -- When a new Unlinked is linked into the running image, or an existing-        -- module in the image is replaced, the itbl_env must be updated-        -- appropriately.-     , bcos_loaded :: !LinkableSet         -- ^ The currently loaded interpreted modules (home package) @@ -101,7 +100,44 @@ uninitializedLoader :: IO Loader uninitializedLoader = Loader <$> newMVar Nothing +modifyClosureEnv :: LoaderState -> (ClosureEnv -> ClosureEnv) -> LoaderState+modifyClosureEnv pls f =+    let le = linker_env pls+        ce = closure_env le+    in pls { linker_env = le { closure_env = f ce } }++data LinkerEnv = LinkerEnv+  { closure_env :: !ClosureEnv+      -- ^ Current global mapping from closure Names to their true values++  , itbl_env    :: !ItblEnv+      -- ^ The current global mapping from RdrNames of DataCons to+      -- info table addresses.+      -- When a new Unlinked is linked into the running image, or an existing+      -- module in the image is replaced, the itbl_env must be updated+      -- appropriately.++  , addr_env    :: !AddrEnv+      -- ^ Like 'closure_env' and 'itbl_env', but for top-level 'Addr#' literals,+      -- see Note [Generating code for top-level string literal bindings] in GHC.StgToByteCode.+  }++filterLinkerEnv :: (Name -> Bool) -> LinkerEnv -> LinkerEnv+filterLinkerEnv f le = LinkerEnv+  { closure_env = filterNameEnv (f . fst) (closure_env le)+  , itbl_env    = filterNameEnv (f . fst) (itbl_env le)+  , addr_env    = filterNameEnv (f . fst) (addr_env le)+  }+ type ClosureEnv = NameEnv (Name, ForeignHValue)++emptyClosureEnv :: ClosureEnv+emptyClosureEnv = emptyNameEnv++extendClosureEnv :: ClosureEnv -> [(Name,ForeignHValue)] -> ClosureEnv+extendClosureEnv cl_env pairs+  = extendNameEnvList cl_env [ (n, (n,v)) | (n,v) <- pairs]+ type PkgsLoaded = UniqDFM UnitId LoadedPkgInfo  data LoadedPkgInfo

@@ -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.4.5-src/ghc-9.4.5/compiler/GHC/Parser/HaddockLex.x" #-}+{-# LINE 1 "_build/source-dist/ghc-9.4.6-src/ghc-9.4.6/compiler/GHC/Parser/HaddockLex.x" #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -funbox-strict-fields #-}@@ -110,7 +110,7 @@   , (0,alex_action_1)   ] -{-# LINE 87 "_build/source-dist/ghc-9.4.5-src/ghc-9.4.5/compiler/GHC/Parser/HaddockLex.x" #-}+{-# LINE 87 "_build/source-dist/ghc-9.4.6-src/ghc-9.4.6/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.4.5-src/ghc-9.4.5/compiler/GHC/Parser/Lexer.x" #-}+{-# LINE 43 "_build/source-dist/ghc-9.4.6-src/ghc-9.4.6/compiler/GHC/Parser/Lexer.x" #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-}@@ -609,7 +609,7 @@   , (0,alex_action_84)   ] -{-# LINE 700 "_build/source-dist/ghc-9.4.5-src/ghc-9.4.5/compiler/GHC/Parser/Lexer.x" #-}+{-# LINE 700 "_build/source-dist/ghc-9.4.6-src/ghc-9.4.6/compiler/GHC/Parser/Lexer.x" #-} -- ----------------------------------------------------------------------------- -- The token type 

@@ -204,6 +204,33 @@ over the exact StgPass we are using. Which allows us to run the analysis on the output of itself. +Note [Tag inference for interpreted code]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The bytecode interpreter has a different behaviour when it comes+to the tagging of binders in certain situations than the StgToCmm code generator.++a) Tags for let-bindings:++  When compiling a binding for a constructor like `let x = Just True`+  Whether `x` will be properly tagged depends on the backend.+  For the interpreter x points to a BCO which once+  evaluated returns a properly tagged pointer to the heap object.+  In the Cmm backend for the same binding we would allocate the constructor right+  away and x will immediately be represented by a tagged pointer.+  This means for interpreted code we can not assume let bound constructors are+  properly tagged. Hence we distinguish between targeting bytecode and native in+  the analysis.+  We make this differentiation in `mkLetSig` where we simply never assume+  lets are tagged when targeting bytecode.++b) When referencing ids from other modules the Cmm backend will try to put a+   proper tag on these references through various means. When doing analysis we+   usually predict these cases to improve precision of the analysis.+   But to my knowledge the bytecode generator makes no such attempts so we must+   not infer imported bindings as tagged.+   This is handled in GHC.Stg.InferTags.Types.lookupInfo++ -}  {- *********************************************************************@@ -212,20 +239,12 @@ *                                                                      * ********************************************************************* -} --- doCodeGen :: HscEnv -> Module -> InfoTableProvMap -> [TyCon]---           -> CollectedCCs---           -> [CgStgTopBinding] -- ^ Bindings come already annotated with fvs---           -> HpcInfo---           -> IO (Stream IO CmmGroupSRTs CmmCgInfos)---          -- Note we produce a 'Stream' of CmmGroups, so that the---          -- backend can be run incrementally.  Otherwise it generates all---          -- the C-- up front, which has a significant space cost.-inferTags :: StgPprOpts -> Logger -> (GHC.Unit.Types.Module) -> [CgStgTopBinding] -> IO ([TgStgTopBinding], NameEnv TagSig)-inferTags ppr_opts logger this_mod stg_binds = do-+inferTags :: StgPprOpts -> Bool -> Logger -> (GHC.Unit.Types.Module) -> [CgStgTopBinding] -> IO ([TgStgTopBinding], NameEnv TagSig)+inferTags ppr_opts !for_bytecode logger this_mod stg_binds = do+    -- pprTraceM "inferTags for " (ppr this_mod <> text " bytecode:" <> ppr for_bytecode)     -- Annotate binders with tag information.     let (!stg_binds_w_tags) = {-# SCC "StgTagFields" #-}-                                        inferTagsAnal stg_binds+                                        inferTagsAnal for_bytecode stg_binds     putDumpFileMaybe logger Opt_D_dump_stg_tags "CodeGenAnal STG:" FormatSTG (pprGenStgTopBindings ppr_opts stg_binds_w_tags)      let export_tag_info = collectExportInfo stg_binds_w_tags@@ -254,10 +273,10 @@                     , XLetNoEscape i ~ XLetNoEscape 'InferTaggedBinders                     , XRhsClosure i ~ XRhsClosure 'InferTaggedBinders) -inferTagsAnal :: [GenStgTopBinding 'CodeGen] -> [GenStgTopBinding 'InferTaggedBinders]-inferTagsAnal binds =+inferTagsAnal :: Bool -> [GenStgTopBinding 'CodeGen] -> [GenStgTopBinding 'InferTaggedBinders]+inferTagsAnal for_bytecode binds =   -- pprTrace "Binds" (pprGenStgTopBindings shortStgPprOpts $ binds) $-  snd (mapAccumL inferTagTopBind initEnv binds)+  snd (mapAccumL inferTagTopBind (initEnv for_bytecode) binds)  ----------------------- inferTagTopBind :: TagEnv 'CodeGen -> GenStgTopBinding 'CodeGen@@ -420,11 +439,12 @@     --   ppr bndr $$     --   ppr (isDeadEndId id) $$     --   ppr sig)-    (env', StgNonRec (id, sig) rhs')+    (env', StgNonRec (id, out_sig) rhs')   where     id   = getBinderId in_env bndr-    env' = extendSigEnv in_env [(id, sig)]-    (sig,rhs') = inferTagRhs id in_env rhs+    (in_sig,rhs') = inferTagRhs id in_env rhs+    out_sig = mkLetSig in_env in_sig+    env' = extendSigEnv in_env [(id, out_sig)]  inferTagBind in_env (StgRec pairs)   = -- pprTrace "rec" (ppr (map fst pairs) $$ ppr (in_env { te_env = out_env }, StgRec pairs')) $@@ -443,15 +463,18 @@        | in_sigs == out_sigs = (te_env rhs_env, out_bndrs `zip` rhss')        | otherwise     = go env' out_sigs rhss'        where-         out_bndrs = map updateBndr in_bndrs -- TODO: Keeps in_ids alive          in_bndrs = in_ids `zip` in_sigs+         out_bndrs = map updateBndr in_bndrs -- TODO: Keeps in_ids alive          rhs_env = extendSigEnv go_env in_bndrs          (out_sigs, rhss') = unzip (zipWithEqual "inferTagBind" anaRhs in_ids go_rhss)          env' = makeTagged go_env           anaRhs :: Id -> GenStgRhs q -> (TagSig, GenStgRhs 'InferTaggedBinders)-         anaRhs bnd rhs = inferTagRhs bnd rhs_env rhs+         anaRhs bnd rhs =+            let (sig_rhs,rhs') = inferTagRhs bnd rhs_env rhs+            in (mkLetSig go_env sig_rhs, rhs') +          updateBndr :: (Id,TagSig) -> (Id,TagSig)          updateBndr (v,sig) = (setIdTagSig v sig, sig) @@ -535,6 +558,15 @@ -- become thunks. We encode this by giving changing RhsCon nodes the info TagDunno   = --pprTrace "inferTagRhsCon" (ppr grp_ids) $     (TagSig (inferConTag env con args), StgRhsCon cc con cn ticks args)++-- Adjust let semantics to the targeted backend.+-- See Note [Tag inference for interpreted code]+mkLetSig :: TagEnv p -> TagSig -> TagSig+mkLetSig env in_sig+  | for_bytecode = TagSig TagDunno+  | otherwise = in_sig+  where+    for_bytecode = te_bytecode env  {- Note [Constructor TagSigs] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

@@ -32,6 +32,7 @@ import GHC.Core.Type  import GHC.StgToCmm.Types+import GHC.StgToCmm.Closure (mkLFImported)  import GHC.Stg.Utils import GHC.Stg.Syntax as StgSyn@@ -269,13 +270,10 @@                             TagTagged -> True                             TagTuple _ -> True -- Consider unboxed tuples tagged.         False -- Imported-            | Just con <- (isDataConWorkId_maybe v)-            , isNullaryRepDataCon con-            -> return True-            | Just lf_info <- idLFInfo_maybe v-            -> return $-                -- Can we treat the thing as tagged based on it's LFInfo?-                case lf_info of+            -> return $!+                -- Determine whether it is tagged from the LFInfo of the imported id.+                -- See Note [The LFInfo of Imported Ids]+                case mkLFImported v of                     -- Function, applied not entered.                     LFReEntrant {}                         -> True@@ -292,9 +290,6 @@                     LFLetNoEscape {}                     -- Shouldn't be possible. I don't think we can export letNoEscapes                         -> True--            | otherwise-            -> return False   isArgTagged :: StgArg -> RM Bool

@@ -54,24 +54,30 @@ type TagSigEnv = IdEnv TagSig data TagEnv p = TE { te_env :: TagSigEnv                    , te_get :: BinderP p -> Id+                   , te_bytecode :: !Bool                    }  instance Outputable (TagEnv p) where-    ppr te = ppr (te_env te)-+    ppr te = for_txt <+> ppr (te_env te)+        where+            for_txt = if te_bytecode te+                then text "for_bytecode"+                else text "for_native"  getBinderId :: TagEnv p -> BinderP p -> Id getBinderId = te_get -initEnv :: TagEnv 'CodeGen-initEnv = TE { te_env = emptyVarEnv-             , te_get = \x -> x}+initEnv :: Bool -> TagEnv 'CodeGen+initEnv for_bytecode = TE { te_env = emptyVarEnv+             , te_get = \x -> x+             , te_bytecode = for_bytecode }  -- | Simple convert env to a env of the 'InferTaggedBinders pass -- with no other changes. makeTagged :: TagEnv p -> TagEnv 'InferTaggedBinders makeTagged env = TE { te_env = te_env env-                    , te_get = fst }+                    , te_get = fst+                    , te_bytecode = te_bytecode env }  noSig :: TagEnv p -> BinderP p -> (Id, TagSig) noSig env bndr@@ -80,14 +86,18 @@   where     var = getBinderId env bndr +-- | Look up a sig in the given env lookupSig :: TagEnv p -> Id -> Maybe TagSig lookupSig env fun = lookupVarEnv (te_env env) fun +-- | Look up a sig in the env or derive it from information+-- in the arg itself. lookupInfo :: TagEnv p -> StgArg -> TagInfo lookupInfo env (StgVarArg var)   -- Nullary data constructors like True, False   | Just dc <- isDataConWorkId_maybe var   , isNullaryRepDataCon dc+  , not for_bytecode   = TagProper    | isUnliftedType (idType var)@@ -98,6 +108,7 @@   = info    | Just lf_info <- idLFInfo_maybe var+  , not for_bytecode   =   case lf_info of           -- Function, tagged (with arity)           LFReEntrant {}@@ -117,6 +128,8 @@    | otherwise   = TagDunno+  where+    for_bytecode = te_bytecode env  lookupInfo _ (StgLitArg {})   = TagProper

@@ -50,6 +50,7 @@   -- ^ Should we lint the STG at various stages of the pipeline?   , stgPipeline_pprOpts     :: !StgPprOpts   , stgPlatform             :: !Platform+  , stgPipeline_forBytecode :: !Bool   }  newtype StgM a = StgM { _unStgM :: ReaderT Char IO a }@@ -93,7 +94,7 @@           -- annotations (which is used by code generator to compute offsets into closures)         ; let binds_sorted_with_fvs = depSortWithAnnotStgPgm this_mod binds'         -- See Note [Tag inference for interactive contexts]-        ; inferTags (stgPipeline_pprOpts opts) logger this_mod binds_sorted_with_fvs+        ; inferTags (stgPipeline_pprOpts opts) (stgPipeline_forBytecode opts) logger this_mod binds_sorted_with_fvs    }    where

@@ -236,7 +236,7 @@         -- which can't be let-bound   | StgConApp   DataCon                 ConstructorNumber-                [StgArg] -- Saturated+                [StgArg] -- Saturated. (After Unarisation, [NonVoid StgArg])                 [Type]   -- See Note [Types in StgConApp] in GHC.Stg.Unarise    | StgOpApp    StgOp    -- Primitive op or foreign call

@@ -958,6 +958,8 @@ --------------------------------------------------------------------------------  {-+Note [Unarisation of Void binders and arguments]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ For arguments (StgArg) and binders (Id) we have two kind of unarisation:    - When unarising function arg binders and arguments, we don't want to remove

@@ -59,13 +59,13 @@ import GHC.Utils.Panic import GHC.Utils.Panic.Plain import GHC.Utils.Exception (evaluate)-import GHC.StgToCmm.Closure ( NonVoid(..), fromNonVoid, nonVoidIds )+import GHC.StgToCmm.Closure ( NonVoid(..), fromNonVoid, nonVoidIds, argPrimRep ) import GHC.StgToCmm.Layout import GHC.Runtime.Heap.Layout hiding (WordOff, ByteOff, wordsToBytes) import GHC.Data.Bitmap import GHC.Data.OrdList import GHC.Data.Maybe-import GHC.Types.Var.Env+import GHC.Types.Name.Env (mkNameEnv) import GHC.Types.Tickish  import Data.List ( genericReplicate, genericLength, intersperse@@ -106,7 +106,7 @@                 (text "GHC.StgToByteCode"<+>brackets (ppr this_mod))                 (const ()) $ do         -- Split top-level binds into strings and others.-        -- See Note [generating code for top-level string literal bindings].+        -- See Note [Generating code for top-level string literal bindings].         let (strings, lifted_binds) = partitionEithers $ do  -- list monad                 bnd <- binds                 case bnd of@@ -117,7 +117,7 @@         stringPtrs <- allocateTopStrings interp strings          (BcM_State{..}, proto_bcos) <--           runBc hsc_env this_mod mb_modBreaks (mkVarEnv stringPtrs) $ do+           runBc hsc_env this_mod mb_modBreaks $ do              let flattened_binds = concatMap flattenBind (reverse lifted_binds)              mapM schemeTopBind flattened_binds @@ -128,7 +128,7 @@            "Proto-BCOs" FormatByteCode            (vcat (intersperse (char ' ') (map ppr proto_bcos))) -        cbc <- assembleBCOs interp profile proto_bcos tycs (map snd stringPtrs)+        cbc <- assembleBCOs interp profile proto_bcos tycs stringPtrs           (case modBreaks of              Nothing -> Nothing              Just mb -> Just mb{ modBreaks_breakInfo = breakInfo })@@ -148,29 +148,50 @@         interp  = hscInterp hsc_env         profile = targetProfile dflags +-- | see Note [Generating code for top-level string literal bindings] allocateTopStrings   :: Interp   -> [(Id, ByteString)]-  -> IO [(Var, RemotePtr ())]+  -> IO AddrEnv allocateTopStrings interp topStrings = do   let !(bndrs, strings) = unzip topStrings   ptrs <- interpCmd interp $ MallocStrings strings-  return $ zip bndrs ptrs+  return $ mkNameEnv (zipWith mk_entry bndrs ptrs)+  where+    mk_entry bndr ptr = let nm = getName bndr+                        in (nm, (nm, AddrPtr ptr)) -{--Note [generating code for top-level string literal bindings]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Here is a summary on how the byte code generator deals with top-level string-literals:+{- Note [Generating code for top-level string literal bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+As described in Note [Compilation plan for top-level string literals]+in GHC.Core, the core-to-core optimizer can introduce top-level Addr#+bindings to represent string literals. The creates two challenges for+the bytecode compiler: (1) compiling the bindings themselves, and+(2) compiling references to such bindings. Here is a summary on how+we deal with them: -1. Top-level string literal bindings are separated from the rest of the module.+  1. Top-level string literal bindings are separated from the rest of+     the module. Memory for them is allocated immediately, via+     interpCmd, in allocateTopStrings, and the resulting AddrEnv is+     recorded in the bc_strs field of the CompiledByteCode result. -2. The strings are allocated via interpCmd, in allocateTopStrings+  2. When we encounter a reference to a top-level string literal, we+     generate a PUSH_ADDR pseudo-instruction, which is assembled to+     a PUSH_UBX instruction with a BCONPtrAddr argument. -3. The mapping from binders to allocated strings (topStrings) are maintained in-   BcM and used when generating code for variable references.--}+  3. The loader accumulates string literal bindings from loaded+     bytecode in the addr_env field of the LinkerEnv. +  4. The BCO linker resolves BCONPtrAddr references by searching both+     the addr_env (to find literals defined in bytecode) and the native+     symbol table (to find literals defined in native code).++This strategy works alright, but it does have one significant problem:+we never free the memory that we allocate for the top-level strings.+In theory, we could explicitly free it when BCOs are unloaded, but+this comes with its own complications; see #22400 for why. For now,+we just accept the leak, but it would nice to find something better. -}+ -- ----------------------------------------------------------------------------- -- Compilation schema for the bytecode generator @@ -298,7 +319,7 @@         -- 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])+    emitBc (mkProtoBCO platform (getName id) (toOL [PACK data_con 0, RETURN P])                        (Right rhs) 0 0 [{-no bitmap-}] False{-not alts-})    | otherwise@@ -459,15 +480,14 @@         non_void VoidRep = False         non_void _ = True     ret <- case filter non_void reps of-             -- use RETURN_UBX for unary representations-             []    -> return (unitOL $ RETURN_UNLIFTED V)-             [rep] -> return (unitOL $ RETURN_UNLIFTED (toArgRep platform rep))+             -- use RETURN for nullary/unary representations+             []    -> return (unitOL $ RETURN V)+             [rep] -> return (unitOL $ RETURN (toArgRep platform rep))              -- otherwise use RETURN_TUPLE with a tuple descriptor              nv_reps -> do-               let (tuple_info, args_offsets) = layoutTuple profile 0 (primRepCmmType platform) nv_reps-                   args_ptrs = map (\(rep, off) -> (isFollowableArg (toArgRep platform rep), off)) args_offsets-               tuple_bco <- emitBc (tupleBCO platform tuple_info args_ptrs)-               return $ PUSH_UBX (mkTupleInfoLit platform tuple_info) 1 `consOL`+               let (call_info, args_offsets) = layoutNativeCall profile NativeTupleReturn 0 (primRepCmmType platform) nv_reps+               tuple_bco <- emitBc (tupleBCO platform call_info args_offsets)+               return $ PUSH_UBX (mkNativeCallInfoLit platform call_info) 1 `consOL`                         PUSH_BCO tuple_bco `consOL`                         unitOL RETURN_TUPLE     return ( mkSlideB platform szb (d - s) -- clear to sequel@@ -484,7 +504,11 @@     profile <- getProfile     let platform = profilePlatform profile         arg_ty e = primRepCmmType platform (atomPrimRep e)-        (tuple_info, tuple_components) = layoutTuple profile d arg_ty es+        (call_info, tuple_components) = layoutNativeCall profile+                                                         NativeTupleReturn+                                                         d+                                                         arg_ty+                                                         es         go _   pushes [] = return (reverse pushes)         go !dd pushes ((a, off):cs) = do (push, szb) <- pushAtom dd p a                                          massert (off == dd + szb)@@ -492,7 +516,7 @@     pushes <- go d [] tuple_components     ret <- returnUnliftedReps d                               s-                              (wordsToBytes platform $ tupleSize tuple_info)+                              (wordsToBytes platform $ nativeCallSize call_info)                               (map atomPrimRep es)     return (mconcat pushes `appOL` ret) @@ -502,7 +526,7 @@     :: StackDepth -> Sequel -> BCEnv -> CgStgExpr -> BcM BCInstrList schemeE d s p (StgLit lit) = returnUnliftedAtom d s p (StgLitArg lit) schemeE d s p (StgApp x [])-   | not (usePlainReturn (idType x)) = returnUnliftedAtom d s p (StgVarArg x)+   | isUnliftedType (idType x) = returnUnliftedAtom d s p (StgVarArg x) -- Delegate tail-calls to schemeT. schemeE d s p e@(StgApp {}) = schemeT d s p e schemeE d s p e@(StgConApp {}) = schemeT d s p e@@ -648,17 +672,17 @@    -- Case 1 schemeT d s p (StgOpApp (StgFCallOp (CCall ccall_spec) _ty) args result_ty)    = if isSupportedCConv ccall_spec-      then generateCCall d s p ccall_spec result_ty (reverse args)+      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 StgPrimCallOp{} _args _ty)-   = unsupportedCConvException+schemeT d s p (StgOpApp (StgPrimCallOp (PrimCall label unit)) args result_ty)+   = generatePrimCall d s p label (Just unit) result_ty args -   -- Case 2: Unboxed tuple schemeT d s p (StgConApp con _cn args _tys)+   -- Case 2: Unboxed tuple    | isUnboxedTupleDataCon con || isUnboxedSumDataCon con    = returnUnboxedTuple d s p args @@ -667,7 +691,7 @@    = do alloc_con <- mkConAppCode d s p con args         platform <- profilePlatform <$> getProfile         return (alloc_con         `appOL`-                mkSlideW 1 (bytesToWords platform $ d - s) `snocOL` RETURN)+                mkSlideW 1 (bytesToWords platform $ d - s) `snocOL` RETURN P)     -- Case 4: Tail call of function schemeT d s p (StgApp fn args)@@ -807,14 +831,11 @@         -- have the same runtime rep. We have more efficient specialized         -- return frames for the situations with one non-void element. +        non_void_arg_reps = non_void (typeArgReps platform bndr_ty)         ubx_tuple_frame =           (isUnboxedTupleType bndr_ty || isUnboxedSumType bndr_ty) &&           length non_void_arg_reps > 1 -        ubx_frame = not ubx_tuple_frame && not (usePlainReturn bndr_ty)--        non_void_arg_reps = non_void (typeArgReps platform bndr_ty)-         profiling           | Just interp <- hsc_interp hsc_env           = interpreterProfiled interp@@ -823,7 +844,8 @@         -- Top of stack is the return itbl, as usual.         -- underneath it is the pointer to the alt_code BCO.         -- When an alt is entered, it assumes the returned value is-        -- on top of the itbl.+        -- on top of the itbl; see Note [Return convention for non-tuple values]+        -- for details.         ret_frame_size_b :: StackDepth         ret_frame_size_b | ubx_tuple_frame =                              (if profiling then 5 else 4) * wordSize platform@@ -837,21 +859,20 @@         -- The size of the return frame info table pointer if one exists         unlifted_itbl_size_b :: StackDepth         unlifted_itbl_size_b | ubx_tuple_frame = wordSize platform-                             | ubx_frame       = wordSize platform                              | otherwise       = 0 -        (bndr_size, tuple_info, args_offsets)+        (bndr_size, call_info, args_offsets)            | ubx_tuple_frame =                let bndr_ty = primRepCmmType platform                    bndr_reps = filter (not.isVoidRep) (bcIdPrimReps bndr)-                   (tuple_info, args_offsets) =-                       layoutTuple profile 0 bndr_ty bndr_reps-               in ( wordsToBytes platform (tupleSize tuple_info)-                  , tuple_info+                   (call_info, args_offsets) =+                       layoutNativeCall profile NativeTupleReturn 0 bndr_ty bndr_reps+               in ( wordsToBytes platform (nativeCallSize call_info)+                  , call_info                   , args_offsets                   )            | otherwise = ( wordsToBytes platform (idSizeW platform bndr)-                         , voidTupleInfo+                         , voidTupleReturnInfo                          , []                          ) @@ -885,17 +906,18 @@            | isUnboxedTupleType bndr_ty || isUnboxedSumType bndr_ty =              let bndr_ty = primRepCmmType platform . bcIdPrimRep                  tuple_start = d_bndr-                 (tuple_info, args_offsets) =-                   layoutTuple profile-                               0-                               bndr_ty-                               bndrs+                 (call_info, args_offsets) =+                   layoutNativeCall profile+                                    NativeTupleReturn+                                    0+                                    bndr_ty+                                    bndrs                   stack_bot = d_alts                   p' = Map.insertList                         [ (arg, tuple_start --                                wordsToBytes platform (tupleSize tuple_info) ++                                wordsToBytes platform (nativeCallSize call_info) +                                 offset)                         | (arg, offset) <- args_offsets                         , not (isVoidRep $ bcIdPrimRep arg)]@@ -936,12 +958,26 @@               | otherwise               -> DiscrP (fromIntegral (dataConTag dc - fIRST_TAG))             LitAlt l -> case l of-              LitNumber LitNumInt i  -> DiscrI (fromInteger i)-              LitNumber LitNumWord w -> DiscrW (fromInteger w)-              LitFloat r             -> DiscrF (fromRational r)-              LitDouble r            -> DiscrD (fromRational r)-              LitChar i              -> DiscrI (ord i)-              _ -> pprPanic "schemeE(StgCase).my_discr" (ppr l)+              LitNumber LitNumInt i    -> DiscrI (fromInteger i)+              LitNumber LitNumInt8 i   -> DiscrI8 (fromInteger i)+              LitNumber LitNumInt16 i  -> DiscrI16 (fromInteger i)+              LitNumber LitNumInt32 i  -> DiscrI32 (fromInteger i)+              LitNumber LitNumInt64 i  -> DiscrI64 (fromInteger i)+              LitNumber LitNumWord w   -> DiscrW (fromInteger w)+              LitNumber LitNumWord8 w  -> DiscrW8 (fromInteger w)+              LitNumber LitNumWord16 w -> DiscrW16 (fromInteger w)+              LitNumber LitNumWord32 w -> DiscrW32 (fromInteger w)+              LitNumber LitNumWord64 w -> DiscrW64 (fromInteger w)+              LitNumber LitNumBigNat _ -> unsupported+              LitFloat r               -> DiscrF (fromRational r)+              LitDouble r              -> DiscrD (fromRational r)+              LitChar i                -> DiscrI (ord i)+              LitString {}             -> unsupported+              LitRubbish {}            -> unsupported+              LitNullAddr {}           -> unsupported+              LitLabel {}              -> unsupported+              where+                  unsupported = pprPanic "schemeE(StgCase).my_discr:" (ppr l)          maybe_ncons            | not isAlgCase = Nothing@@ -967,8 +1003,8 @@          -- unboxed tuples get two more words, the second is a pointer (tuple_bco)         (extra_pointers, extra_slots)-           | ubx_tuple_frame && profiling = ([1], 3) -- tuple_info, tuple_BCO, CCCS-           | ubx_tuple_frame              = ([1], 2) -- tuple_info, tuple_BCO+           | ubx_tuple_frame && profiling = ([1], 3) -- call_info, tuple_BCO, CCCS+           | ubx_tuple_frame              = ([1], 2) -- call_info, tuple_BCO            | otherwise                    = ([], 0)          bitmap_size = trunc16W $ fromIntegral extra_slots +@@ -1010,24 +1046,14 @@                            p scrut      alt_bco' <- emitBc alt_bco      if ubx_tuple_frame-       then do-              let args_ptrs =-                    map (\(rep, off) -> (isFollowableArg (toArgRep platform rep), off))-                        args_offsets-              tuple_bco <- emitBc (tupleBCO platform tuple_info args_ptrs)-              return (PUSH_ALTS_TUPLE alt_bco' tuple_info tuple_bco-                      `consOL` scrut_code)-       else let push_alts-                  | not ubx_frame-                  = PUSH_ALTS alt_bco'-                  | otherwise-                  = let unlifted_rep =-                          case non_void_arg_reps of-                            []    -> V-                            [rep] -> rep-                            _     -> panic "schemeE(StgCase).push_alts"-                    in PUSH_ALTS_UNLIFTED alt_bco' unlifted_rep-            in return (push_alts `consOL` scrut_code)+       then do tuple_bco <- emitBc (tupleBCO platform call_info args_offsets)+               return (PUSH_ALTS_TUPLE alt_bco' call_info tuple_bco+                       `consOL` scrut_code)+       else let scrut_rep = case non_void_arg_reps of+                  []    -> V+                  [rep] -> rep+                  _     -> panic "schemeE(StgCase).push_alts"+            in return (PUSH_ALTS alt_bco' scrut_rep `consOL` scrut_code)   -- -----------------------------------------------------------------------------@@ -1036,14 +1062,15 @@ -- The native calling convention uses registers for tuples, but in the -- bytecode interpreter, all values live on the stack. -layoutTuple :: Profile-            -> ByteOff-            -> (a -> CmmType)-            -> [a]-            -> ( TupleInfo      -- See Note [GHCi TupleInfo]-               , [(a, ByteOff)] -- argument, offset on stack-               )-layoutTuple profile start_off arg_ty reps =+layoutNativeCall :: Profile+                 -> NativeCallType+                 -> ByteOff+                 -> (a -> CmmType)+                 -> [a]+                 -> ( NativeCallInfo      -- See Note [GHCi TupleInfo]+                    , [(a, ByteOff)] -- argument, offset on stack+                    )+layoutNativeCall profile call_type start_off arg_ty reps =   let platform = profilePlatform profile       (orig_stk_bytes, pos) = assignArgumentsPos profile                                                  0@@ -1056,7 +1083,7 @@        -- sort the register parameters by register and add them to the stack       regs_order :: Map.Map GlobalReg Int-      regs_order = Map.fromList $ zip (tupleRegsCover platform) [0..]+      regs_order = Map.fromList $ zip (allArgRegsCover platform) [0..]        reg_order :: GlobalReg -> (Int, GlobalReg)       reg_order reg | Just n <- Map.lookup reg regs_order = (n, reg)@@ -1085,10 +1112,11 @@       get_byte_off _                 =           panic "GHC.StgToByteCode.layoutTuple get_byte_off" -  in ( TupleInfo-         { tupleSize        = bytesToWords platform (ByteOff new_stk_bytes)-         , tupleRegs        = regs_set-         , tupleNativeStackSize = bytesToWords platform+  in ( NativeCallInfo+         { nativeCallType           = call_type+         , nativeCallSize           = bytesToWords platform (ByteOff new_stk_bytes)+         , nativeCallRegs           = regs_set+         , nativeCallStackSpillSize = bytesToWords platform                                                (ByteOff orig_stk_bytes)          }      , sortBy (comparing snd) $@@ -1096,24 +1124,41 @@                   (orig_stk_params ++ map get_byte_off new_stk_params)      ) -{--  We use the plain return convention (ENTER/PUSH_ALTS) for-  lifted types and unlifted algebraic types.+{- Note [Return convention for non-tuple values]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The RETURN and ENTER instructions are used to return values. RETURN directly+returns the value at the top of the stack while ENTER evaluates it first (so+RETURN is only used when the result is already known to be evaluated), but the+end result is the same: control returns to the enclosing stack frame with the+result at the top of the stack. -  Other types use PUSH_ALTS_UNLIFTED/PUSH_ALTS_TUPLE which expect-  additional data on the stack.- -}-usePlainReturn :: Type -> Bool-usePlainReturn t-  | isUnboxedTupleType t || isUnboxedSumType t = False-  | otherwise = typePrimRep t == [LiftedRep] ||-                (typePrimRep t == [UnliftedRep] && isAlgType t)+The PUSH_ALTS instruction pushes a two-word stack frame that receives a single+lifted value. Its payload is a BCO that is executed when control returns, with+the stack set up as if a RETURN instruction had just been executed: the returned+value is at the top of the stack, and beneath it is the two-word frame being+returned to. It is the continuation BCO’s job to pop its own frame off the+stack, so the simplest possible continuation consists of two instructions: -{- Note [unboxed tuple bytecodes and tuple_BCO]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+    SLIDE 1 2   -- pop the return frame off the stack, keeping the returned value+    RETURN P    -- return the returned value to our caller++RETURN and PUSH_ALTS are not really instructions but are in fact representation-+polymorphic *families* of instructions indexed by ArgRep. ENTER, however, is a+single real instruction, since it is only used to return lifted values, which+are always pointers.++The RETURN, ENTER, and PUSH_ALTS instructions are only used when the returned+value has nullary or unary representation. Returning/receiving an unboxed+tuple (or, indirectly, an unboxed sum, since unboxed sums have been desugared to+unboxed tuples by Unarise) containing two or more results uses the special+RETURN_TUPLE/PUSH_ALTS_TUPLE instructions, which use a different return+convention. See Note [unboxed tuple bytecodes and tuple_BCO] for details.++Note [unboxed tuple bytecodes and tuple_BCO]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~   We have the bytecode instructions RETURN_TUPLE and PUSH_ALTS_TUPLE to   return and receive arbitrary unboxed tuples, respectively. These-  instructions use the helper data tuple_BCO and tuple_info.+  instructions use the helper data tuple_BCO and call_info.    The helper data is used to convert tuples between GHCs native calling   convention (object code), which uses stack and registers, and the bytecode@@ -1125,7 +1170,7 @@   =================    Bytecode that returns a tuple first pushes all the tuple fields followed-  by the appropriate tuple_info and tuple_BCO onto the stack. It then+  by the appropriate call_info and tuple_BCO onto the stack. It then   executes the RETURN_TUPLE instruction, which causes the interpreter   to push stg_ret_t_info to the top of the stack. The stack (growing down)   then looks as follows:@@ -1136,14 +1181,14 @@       tuple_field_2       ...       tuple_field_n-      tuple_info+      call_info       tuple_BCO       stg_ret_t_info <- Sp    If next_frame is bytecode, the interpreter will start executing it. If   it's object code, the interpreter jumps back to the scheduler, which in   turn jumps to stg_ret_t. stg_ret_t converts the tuple to the native-  calling convention using the description in tuple_info, and then jumps+  calling convention using the description in call_info, and then jumps   to next_frame.  @@ -1155,13 +1200,13 @@   tuple. The PUSH_ALTS_TUPLE instuction contains three pieces of data:       * cont_BCO: the continuation that receives the tuple-     * tuple_info: see below+     * call_info: see below      * tuple_BCO: see below    The interpreter pushes these onto the stack when the PUSH_ALTS_TUPLE   instruction is executed, followed by stg_ctoi_tN_info, with N depending   on the number of stack words used by the tuple in the GHC native calling-  convention. N is derived from tuple_info.+  convention. N is derived from call_info.    For example if we expect a tuple with three words on the stack, the stack   looks as follows after PUSH_ALTS_TUPLE:@@ -1172,7 +1217,7 @@       cont_free_var_2       ...       cont_free_var_n-      tuple_info+      call_info       tuple_BCO       cont_BCO       stg_ctoi_t3_info <- Sp@@ -1192,24 +1237,23 @@   that is already on the stack.  -  The tuple_info word+  The call_info word   =================== -  The tuple_info word describes the stack and STG register (e.g. R1..R6,-  D1..D6) usage for the tuple. tuple_info contains enough information to+  The call_info word describes the stack and STG register (e.g. R1..R6,+  D1..D6) usage for the tuple. call_info contains enough information to   convert the tuple between the stack-only bytecode and stack+registers   GHC native calling conventions. -  See Note [GHCi tuple layout] for more details of how the data is packed-  in a single word.+  See Note [GHCi and native call registers] for more details of how the+  data is packed in a single word.   -} -tupleBCO :: Platform -> TupleInfo -> [(Bool, ByteOff)] -> [FFIInfo] -> ProtoBCO Name-tupleBCO platform info pointers =+tupleBCO :: Platform -> NativeCallInfo -> [(PrimRep, ByteOff)] -> [FFIInfo] -> ProtoBCO Name+tupleBCO platform args_info args =   mkProtoBCO platform invented_name body_code (Left [])              0{-no arity-} bitmap_size bitmap False{-is alts-}-   where     {-       The tuple BCO is never referred to by name, so we can get away@@ -1219,16 +1263,131 @@     -}     invented_name  = mkSystemVarName (mkPseudoUniqueE 0) (fsLit "tuple") -    -- the first word in the frame is the tuple_info word,+    -- the first word in the frame is the call_info word,     -- which is not a pointer-    bitmap_size = trunc16W $ 1 + tupleSize info-    bitmap      = intsToReverseBitmap platform (fromIntegral bitmap_size) $-                  map ((+1) . fromIntegral . bytesToWords platform . snd)-                      (filter fst pointers)+    nptrs_prefix = 1+    (bitmap_size, bitmap) = mkStackBitmap platform nptrs_prefix args_info args+     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 args_info args =+  mkProtoBCO platform invented_name body_code (Left [])+             0{-no arity-} bitmap_size bitmap False{-is alts-}+  where+    {-+      The primcall BCO is never referred to by name, so we can get away+      with using a fake name here. We will need to change this if we want+      to save some memory by sharing the BCO between places that have+      the same tuple shape+    -}+    invented_name  = mkSystemVarName (mkPseudoUniqueE 0) (fsLit "primcall")++    -- The first two words in the frame (after the BCO) are the call_info word+    -- and the pointer to the Cmm function being called. Neither of these is a+    -- pointer that should be followed by the garbage collector.+    nptrs_prefix = 2+    (bitmap_size, bitmap) = mkStackBitmap platform nptrs_prefix args_info args++    -- if the primcall BCO is ever run it's a bug, since the BCO should only+    -- be pushed immediately before running the PRIMCALL bytecode instruction,+    -- which immediately leaves the interpreter to jump to the stg_primcall_info+    -- Cmm function+    body_code =  unitOL CASEFAIL++-- | Builds a bitmap for a stack layout with a nonpointer prefix followed by+-- some number of arguments.+mkStackBitmap+  :: Platform+  -> WordOff+  -- ^ The number of nonpointer words that prefix the arguments.+  -> NativeCallInfo+  -> [(PrimRep, ByteOff)]+  -- ^ The stack layout of the arguments, where each offset is relative to the+  -- /bottom/ of the stack space they occupy. Their offsets must be word-aligned,+  -- and the list must be sorted in order of ascending offset (i.e. bottom to top).+  -> (Word16, [StgWord])+mkStackBitmap platform nptrs_prefix args_info args+  = (bitmap_size, bitmap)+  where+    bitmap_size = trunc16W $ nptrs_prefix + arg_bottom+    bitmap = intsToReverseBitmap platform (fromIntegral bitmap_size) ptr_offsets++    arg_bottom = nativeCallSize args_info+    ptr_offsets = reverse $ map (fromIntegral . convert_arg_offset)+                $ mapMaybe get_ptr_offset args++    get_ptr_offset :: (PrimRep, ByteOff) -> Maybe ByteOff+    get_ptr_offset (rep, byte_offset)+      | isFollowableArg (toArgRep platform rep) = Just byte_offset+      | otherwise                               = Nothing++    convert_arg_offset :: ByteOff -> WordOff+    convert_arg_offset arg_offset =+      -- The argument offsets are relative to `arg_bottom`, but+      -- `intsToReverseBitmap` expects offsets from the top, so we need to flip+      -- them around.+      nptrs_prefix + (arg_bottom - bytesToWords platform arg_offset)+ -- -----------------------------------------------------------------------------+-- Deal with a primitive call to native code.++generatePrimCall+    :: StackDepth+    -> Sequel+    -> BCEnv+    -> CLabelString          -- where to call+    -> Maybe Unit+    -> Type+    -> [StgArg]              -- args (atoms)+    -> BcM BCInstrList+generatePrimCall d s p target _mb_unit _result_ty args+ = do+     profile <- getProfile+     let+         platform = profilePlatform profile++         non_void VoidRep = False+         non_void _       = True++         nv_args :: [StgArg]+         nv_args = filter (non_void . argPrimRep) args++         (args_info, args_offsets) =+              layoutNativeCall profile+                               NativePrimCall+                               0+                               (primRepCmmType platform . argPrimRep)+                               nv_args++         prim_args_offsets = mapFst argPrimRep args_offsets+         shifted_args_offsets = mapSnd (+ d) args_offsets++         push_target = PUSH_UBX (LitLabel target Nothing IsFunction) 1+         push_info = PUSH_UBX (mkNativeCallInfoLit platform args_info) 1+         {-+            compute size to move payload (without stg_primcall_info header)++            size of arguments plus three words for:+                - function pointer to the target+                - call_info word+                - BCO to describe the stack frame+          -}+         szb = wordsToBytes platform (nativeCallSize args_info + 3)+         go _   pushes [] = return (reverse pushes)+         go !dd pushes ((a, off):cs) = do (push, szb) <- pushAtom dd p a+                                          massert (off == dd + szb)+                                          go (dd + szb) (push:pushes) cs+     push_args <- go d [] shifted_args_offsets+     args_bco <- emitBc (primCallBCO platform args_info prim_args_offsets)+     return $ mconcat push_args `appOL`+              (push_target `consOL`+               push_info `consOL`+               PUSH_BCO args_bco `consOL`+               (mkSlideB platform szb (d - s) `appOL` unitOL PRIMCALL))++-- ----------------------------------------------------------------------------- -- Deal with a CCall.  -- Taggedly push the args onto the stack R->L,@@ -1245,11 +1404,17 @@     -> Type     -> [StgArg]              -- args (atoms)     -> BcM BCInstrList-generateCCall d0 s p (CCallSpec target cconv safety) result_ty args_r_to_l+generateCCall d0 s p (CCallSpec target PrimCallConv _) result_ty args+ | (StaticTarget _ label mb_unit _) <- target+ = generatePrimCall d0 s p label mb_unit result_ty args+ | otherwise+ = panic "GHC.StgToByteCode.generateCCall: primcall convention only supports static targets"+generateCCall d0 s p (CCallSpec target cconv safety) result_ty args  = do      profile <- getProfile       let+         args_r_to_l = reverse args          platform = profilePlatform profile          -- useful constants          addr_size_b :: ByteOff@@ -1426,7 +1591,7 @@          -- slide and return          d_after_r_min_s = bytesToWords platform (d_after_r - s)          wrapup       = mkSlideW (trunc16W r_sizeW) (d_after_r_min_s - r_sizeW)-                        `snocOL` RETURN_UNLIFTED (toArgRep platform r_rep)+                        `snocOL` RETURN (toArgRep platform r_rep)          --trace (show (arg1_offW, args_offW  ,  (map argRepSizeW a_reps) )) $      return (          push_args `appOL`@@ -1540,7 +1705,6 @@  The code we generate is this:                 push arg-                push bogus-word                  TESTEQ_I 0 L1                   PUSH_G <lbl for first data con>@@ -1558,13 +1722,6 @@          L_exit: SLIDE 1 n                 ENTER--The 'bogus-word' push is because TESTEQ_I expects the top of the stack-to have an info-table, and the next word to have the value to be-tested.  This is very weird, but it's the way it is right now.  See-Interpreter.c.  We don't actually need an info-table here; we just-need to have the argument to be one-from-top on the stack, hence pushing-a 1-word null. See #8383. -}  @@ -1590,14 +1747,10 @@            slide_ws = bytesToWords platform (d - s + arg_bytes)         return (push_arg-               `appOL` unitOL (PUSH_UBX LitNullAddr 1)-                   -- Push bogus word (see Note [Implementing tagToEnum#])                `appOL` concatOL steps                `appOL` toOL [ LABEL label_fail, CASEFAIL,                               LABEL label_exit ]-               `appOL` mkSlideW 1 (slide_ws + 1)-                   -- "+1" to account for bogus word-                   --      (see Note [Implementing tagToEnum#])+               `appOL` mkSlideW 1 slide_ws                `appOL` unitOL ENTER)   where         mkStep l_exit (my_label, next_label, n, name_for_n)@@ -1663,28 +1816,27 @@         -- slots on to the top of the stack.     | otherwise  -- var must be a global variable-   = do topStrings <- getTopStrings-        platform <- targetPlatform <$> getDynFlags-        case lookupVarEnv topStrings var of-            Just ptr -> pushAtom d p $ StgLitArg $ mkLitWord platform $-              fromIntegral $ ptrToWordPtr $ fromRemotePtr ptr-            Nothing-              -- PUSH_G doesn't tag constructors. So we use PACK here-              -- if we are dealing with nullary constructor.-              | Just con <- isDataConWorkId_maybe var-              -> do-                  massert (sz == wordSize platform)-                  massert (isNullaryRepDataCon con)-                  return (unitOL (PACK con 0), sz)-              | otherwise-              -> do-                  let-                  massert (sz == wordSize platform)-                  return (unitOL (PUSH_G (getName var)), sz)-              where-                !sz = idSizeCon platform var+   = do platform <- targetPlatform <$> getDynFlags+        let !szb = idSizeCon platform var+        massert (szb == wordSize platform) +        -- PUSH_G doesn't tag constructors. So we use PACK here+        -- if we are dealing with nullary constructor.+        case isDataConWorkId_maybe var of+          Just con -> do+            massert (isNullaryRepDataCon con)+            return (unitOL (PACK con 0), szb) +          Nothing+            -- see Note [Generating code for top-level string literal bindings]+            | isUnliftedType (idType var) -> do+              massert (idType var `eqType` addrPrimTy)+              return (unitOL (PUSH_ADDR (getName var)), szb)++            | otherwise -> do+              return (unitOL (PUSH_G (getName var)), szb)++ pushAtom _ _ (StgLitArg lit) = pushLiteral True lit  pushLiteral :: Bool -> Literal -> BcM (BCInstrList, ByteOff)@@ -1840,14 +1992,30 @@          notd_ways = sortBy (comparing fst) not_defaults           testLT (DiscrI i) fail_label = TESTLT_I i fail_label+         testLT (DiscrI8 i) fail_label = TESTLT_I8 (fromIntegral i) fail_label+         testLT (DiscrI16 i) fail_label = TESTLT_I16 (fromIntegral i) fail_label+         testLT (DiscrI32 i) fail_label = TESTLT_I32 (fromIntegral i) fail_label+         testLT (DiscrI64 i) fail_label = TESTLT_I64 (fromIntegral i) fail_label          testLT (DiscrW i) fail_label = TESTLT_W i fail_label+         testLT (DiscrW8 i) fail_label = TESTLT_W8 (fromIntegral i) fail_label+         testLT (DiscrW16 i) fail_label = TESTLT_W16 (fromIntegral i) fail_label+         testLT (DiscrW32 i) fail_label = TESTLT_W32 (fromIntegral i) fail_label+         testLT (DiscrW64 i) fail_label = TESTLT_W64 (fromIntegral i) fail_label          testLT (DiscrF i) fail_label = TESTLT_F i fail_label          testLT (DiscrD i) fail_label = TESTLT_D i fail_label          testLT (DiscrP i) fail_label = TESTLT_P i fail_label          testLT NoDiscr    _          = panic "mkMultiBranch NoDiscr"           testEQ (DiscrI i) fail_label = TESTEQ_I i fail_label+         testEQ (DiscrI8 i) fail_label = TESTEQ_I8 (fromIntegral i) fail_label+         testEQ (DiscrI16 i) fail_label = TESTEQ_I16 (fromIntegral i) fail_label+         testEQ (DiscrI32 i) fail_label = TESTEQ_I32 (fromIntegral i) fail_label+         testEQ (DiscrI64 i) fail_label = TESTEQ_I64 (fromIntegral i) fail_label          testEQ (DiscrW i) fail_label = TESTEQ_W i fail_label+         testEQ (DiscrW8 i) fail_label = TESTEQ_W8 (fromIntegral i) fail_label+         testEQ (DiscrW16 i) fail_label = TESTEQ_W16 (fromIntegral i) fail_label+         testEQ (DiscrW32 i) fail_label = TESTEQ_W32 (fromIntegral i) fail_label+         testEQ (DiscrW64 i) fail_label = TESTEQ_W64 (fromIntegral i) fail_label          testEQ (DiscrF i) fail_label = TESTEQ_F i fail_label          testEQ (DiscrD i) fail_label = TESTEQ_D i fail_label          testEQ (DiscrP i) fail_label = TESTEQ_P i fail_label@@ -1860,7 +2028,15 @@             | otherwise             = case fst (head notd_ways) of                 DiscrI _ -> ( DiscrI minBound,  DiscrI maxBound )+                DiscrI8 _ -> ( DiscrI8 minBound, DiscrI8 maxBound )+                DiscrI16 _ -> ( DiscrI16 minBound, DiscrI16 maxBound )+                DiscrI32 _ -> ( DiscrI32 minBound, DiscrI32 maxBound )+                DiscrI64 _ -> ( DiscrI64 minBound, DiscrI64 maxBound )                 DiscrW _ -> ( DiscrW minBound,  DiscrW maxBound )+                DiscrW8 _ -> ( DiscrW8 minBound, DiscrW8 maxBound )+                DiscrW16 _ -> ( DiscrW16 minBound, DiscrW16 maxBound )+                DiscrW32 _ -> ( DiscrW32 minBound, DiscrW32 maxBound )+                DiscrW64 _ -> ( DiscrW64 minBound, DiscrW64 maxBound )                 DiscrF _ -> ( DiscrF minF,      DiscrF maxF )                 DiscrD _ -> ( DiscrD minD,      DiscrD maxD )                 DiscrP _ -> ( DiscrP algMinBound, DiscrP algMaxBound )@@ -1896,7 +2072,15 @@ -- Describes case alts data Discr    = DiscrI Int+   | DiscrI8 Int8+   | DiscrI16 Int16+   | DiscrI32 Int32+   | DiscrI64 Int64    | DiscrW Word+   | DiscrW8 Word8+   | DiscrW16 Word16+   | DiscrW32 Word32+   | DiscrW64 Word64    | DiscrF Float    | DiscrD Double    | DiscrP Word16@@ -1905,7 +2089,15 @@  instance Outputable Discr where    ppr (DiscrI i) = int i+   ppr (DiscrI8 i) = text (show i)+   ppr (DiscrI16 i) = text (show i)+   ppr (DiscrI32 i) = text (show i)+   ppr (DiscrI64 i) = text (show i)    ppr (DiscrW w) = text (show w)+   ppr (DiscrW8 w) = text (show w)+   ppr (DiscrW16 w) = text (show w)+   ppr (DiscrW32 w) = text (show w)+   ppr (DiscrW64 w) = text (show w)    ppr (DiscrF f) = text (show f)    ppr (DiscrD d) = text (show d)    ppr (DiscrP i) = ppr i@@ -1954,7 +2146,7 @@ isSupportedCConv (CCallSpec _ cconv _) = case cconv of    CCallConv            -> True     -- we explicitly pattern match on every    StdCallConv          -> True     -- convention to ensure that a warning-   PrimCallConv         -> False    -- is triggered when a new one is added+   PrimCallConv         -> True     -- is triggered when a new one is added    JavaScriptCallConv   -> False    CApiConv             -> True @@ -2012,8 +2204,6 @@                                          -- Should be free()d when it is GCd         , modBreaks   :: Maybe ModBreaks -- info about breakpoints         , breakInfo   :: IntMap CgBreakInfo-        , topStrings  :: IdEnv (RemotePtr ()) -- top-level string literals-          -- See Note [generating code for top-level string literal bindings].         }  newtype BcM r = BcM (BcM_State -> IO (BcM_State, r)) deriving (Functor)@@ -2024,11 +2214,10 @@   return (st, x)  runBc :: HscEnv -> Module -> Maybe ModBreaks-      -> IdEnv (RemotePtr ())       -> BcM r       -> IO (BcM_State, r)-runBc hsc_env this_mod modBreaks topStrings (BcM m)-   = m (BcM_State hsc_env this_mod 0 [] modBreaks IntMap.empty topStrings)+runBc hsc_env this_mod modBreaks (BcM m)+   = m (BcM_State hsc_env this_mod 0 [] modBreaks IntMap.empty)  thenBc :: BcM a -> (a -> BcM b) -> BcM b thenBc (BcM expr) cont = BcM $ \st0 -> do@@ -2096,9 +2285,6 @@  getCurrentModule :: BcM Module getCurrentModule = BcM $ \st -> return (st, thisModule st)--getTopStrings :: BcM (IdEnv (RemotePtr ()))-getTopStrings = BcM $ \st -> return (st, topStrings st)  tickFS :: FastString tickFS = fsLit "ticked"

@@ -265,22 +265,124 @@         -- Use the LambdaFormInfo from the interface         lf_info       Nothing-        -- Interface doesn't have a LambdaFormInfo, make a conservative one from-        -- the type.-        | Just con <- isDataConWorkId_maybe id-        , isNullaryRepDataCon con-        -> LFCon con   -- An imported nullary constructor-                       -- We assume that the constructor is evaluated so that-                       -- the id really does point directly to the constructor-+        -- Interface doesn't have a LambdaFormInfo, so make a conservative one from the type.+        -- See Note [The LFInfo of Imported Ids]; The order of the guards musn't be changed!         | arity > 0         -> LFReEntrant TopLevel arity True ArgUnknown +        | Just con <- isDataConId_maybe id+          -- See Note [Imported unlifted nullary datacon wrappers must have correct LFInfo] in GHC.StgToCmm.Types+          -- and Note [The LFInfo of Imported Ids] below+        -> assert (hasNoNonZeroWidthArgs con) $+           LFCon con   -- An imported nullary constructor+                       -- We assume that the constructor is evaluated so that+                       -- the id really does point directly to the constructor+         | otherwise         -> mkLFArgument id -- Not sure of exact arity   where     arity = idFunRepArity id+    hasNoNonZeroWidthArgs = all (isZeroBitTy . scaledThing) . dataConRepArgTys +{-+Note [The LFInfo of Imported Ids]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+As explained in Note [Conveying CAF-info and LFInfo between modules] and+Note [Imported unlifted nullary datacon wrappers must have correct LFInfo], the+LambdaFormInfo records the details of a closure representation and is often,+when optimisations are enabled, serialized to the interface of a module.++In particular, the `lfInfo` field of the `IdInfo` field of an `Id`+* For Ids defined in this module: is `Nothing`+* For imported Ids:+  * is (Just lf_info) if the LFInfo was serialised into the interface file+    (typically, when the exporting module was compiled with -O)+  * is Nothing if it wasn't serialised++However, when an interface doesn't have a LambdaFormInfo for some imported Id+(so that its `lfInfo` field is `Nothing`), we can conservatively create one+using `mkLFImported`.++The LambdaFormInfo we give an Id is used in determining how to tag its pointer+(see `litIdInfo`). Therefore, it's crucial we re-construct a LambdaFormInfo as+faithfully as possible or otherwise risk having pointers incorrectly tagged,+which can lead to performance issues and even segmentation faults (see #23231+and #23146). In particular, saturated data constructor applications *must* be+unambiguously given `LFCon`, and the invariant++  If the LFInfo (serialised or built with mkLFImported) says LFCon, then it+  really is a static data constructor, and similar for LFReEntrant++must be upheld.++In `mkLFImported`, we make a conservative approximation to the real+LambdaFormInfo as follows:++(1) Ids with an `idFunRepArity > 0` are `LFReEntrant` and pointers to them are+tagged (by `litIdInfo`) with the corresponding arity.+    - This is also true of data con wrappers and workers with arity > 0,+    regardless of the runtime relevance of the arguments+    - For example, `Just :: a -> Maybe a` is given `LFReEntrant`+               and `HNil :: (a ~# '[]) -> HList a` is given `LFReEntrant` too++(2) Data constructors with `idFunRepArity == 0` should be given `LFCon` because+they are fully saturated data constructor applications and pointers to them+should be tagged with the constructor index.++(2.1) A datacon *wrapper* with zero arity must be a fully saturated application+of the worker to zero-width arguments only (which are dropped after unarisation)++(2.2) A datacon *worker* with zero arity is trivially fully saturated, it takes+no arguments whatsoever (not even zero-width args)++To ensure we properly give `LFReEntrant` to data constructors with some arity,+and `LFCon` only to data constructors with zero arity, we must first check for+`arity > 0` and only afterwards `isDataConId` -- the order of the guards in+`mkLFImported` is quite important.++As an example, consider the following data constructors:++  data T1 a where+    TCon1 :: {-# UNPACK #-} !(a :~: True) -> T1 a++  data T2 a where+    TCon2 :: {-# UNPACK #-} !() -> T2 a++  data T3 a where+    TCon3 :: T3 '[]++`TCon1`'s wrapper has a lifted equality argument, which is non-zero-width, while+the worker has an unlifted equality argument, which is zero-width.++`TCon2`'s wrapper has a lifted equality argument, which is non-zero-width,+while the worker has no arguments.++`TCon3`'s wrapper has no arguments, and the worker has 1 zero-width argument;+their Core representation:++  $WTCon3 :: T3 '[]+  $WTCon3 = TCon3 @[] <Refl>++  TCon3 :: forall (a :: * -> *). (a ~# []) => T a+  TCon3 = /\a. \(co :: a~#[]). TCon3 co++For `TCon1`, both the wrapper and worker will be given `LFReEntrant` since they+both have arity == 1.++For `TCon2`, the wrapper will be given `LFReEntrant` since it has arity == 1+while the worker is `LFCon` since its arity == 0++For `TCon3`, the wrapper will be given `LFCon` since its arity == 0 and the+worker `LFReEntrant` since its arity == 1++One might think we could give *workers* with only zero-width-args the `LFCon`+LambdaFormInfo, e.g. give `LFCon` to the worker of `TCon1` and `TCon3`.+However, these workers, albeit rarely used, are unambiguously functions+-- which makes `LFReEntrant`, the LambdaFormInfo we give them, correct.+See also the discussion in #23158.++-}+ ------------- mkLFStringLit :: LambdaFormInfo mkLFStringLit = LFUnlifted@@ -309,8 +411,7 @@ -- Also see Note [Tagging big families] in GHC.StgToCmm.Expr -- -- The interpreter also needs to be updated if we change the--- tagging strategy. See Note [Data constructor dynamic tags] in--- rts/Interpreter.c+-- tagging strategy; see tagConstr in rts/Interpreter.c.  isSmallFamily :: Platform -> Int -> Bool isSmallFamily platform fam_size = fam_size <= mAX_PTR_TAG platform

@@ -82,8 +82,8 @@ mkRhsInit platform reg lf_info expr   = mkAssign (CmmLocal reg) (addDynTag platform expr (lfDynTag platform lf_info)) +-- | Returns a 'CmmExpr' for the *tagged* pointer idInfoToAmode :: CgIdInfo -> CmmExpr--- Returns a CmmExpr for the *tagged* pointer idInfoToAmode CgIdInfo { cg_loc = CmmLoc e } = e idInfoToAmode cg_info   = pprPanic "idInfoToAmode" (ppr (cg_id cg_info))        -- LneLoc@@ -150,7 +150,7 @@               in return $                   litIdInfo platform id (mkLFImported id) (CmmLabel ext_lbl)           else-              cgLookupPanic id -- Bug+              cgLookupPanic id -- Bug, id is neither in local binds nor is external         }}}  -- | Retrieve cg info for a name if it already exists.

@@ -8,15 +8,17 @@  module GHC.StgToCmm.Foreign (   cgForeignCall,-  emitPrimCall, emitCCall,+  emitPrimCall,+  emitCCall,+  emitCCallNeverReturns,   emitForeignCall,   emitSaveThreadState,   saveThreadState,   emitLoadThreadState,   emitSaveRegs,   emitRestoreRegs,-  emitPushTupleRegs,-  emitPopTupleRegs,+  emitPushArgRegs,+  emitPopArgRegs,   loadThreadState,   emitOpenNursery,   emitCloseNursery,@@ -194,19 +196,33 @@ -}  -emitCCall :: [(CmmFormal,ForeignHint)]-          -> CmmExpr-          -> [(CmmActual,ForeignHint)]-          -> FCode ()-emitCCall hinted_results fn hinted_args+emitCCall' :: CmmReturnInfo+           -> [(CmmFormal,ForeignHint)]+           -> CmmExpr+           -> [(CmmActual,ForeignHint)]+           -> FCode ()+emitCCall' ret_info hinted_results fn hinted_args   = void $ emitForeignCall PlayRisky results target args   where     (args, arg_hints) = unzip hinted_args     (results, result_hints) = unzip hinted_results     target = ForeignTarget fn fc-    fc = ForeignConvention CCallConv arg_hints result_hints CmmMayReturn+    fc = ForeignConvention CCallConv arg_hints result_hints ret_info +emitCCall :: [(CmmFormal,ForeignHint)]+          -> CmmExpr+          -> [(CmmActual,ForeignHint)]+          -> FCode ()+emitCCall = emitCCall' CmmMayReturn +emitCCallNeverReturns+  :: [(CmmFormal,ForeignHint)]+  -> CmmExpr+  -> [(CmmActual,ForeignHint)]+  -> FCode ()+emitCCallNeverReturns = emitCCall' CmmNeverReturns++ emitPrimCall :: [CmmFormal] -> CallishMachOp -> [CmmActual] -> FCode () emitPrimCall res op args   = void $ emitForeignCall PlayRisky res (PrimTarget op) args@@ -349,7 +365,7 @@ -- bytecode interpreter. -- -- The "live registers" bitmap corresponds to the list of registers given by--- 'tupleRegsCover', with the least significant bit indicating liveness of+-- 'allArgRegsCover', with the least significant bit indicating liveness of -- the first register in the list. -- -- Each register is saved to a stack slot of one or more machine words, even@@ -362,12 +378,12 @@ --    if((mask & 2) != 0) { Sp_adj(-1); Sp(0) = R2; } --    if((mask & 1) != 0) { Sp_adj(-1); Sp(0) = R1; } ----- See Note [GHCi tuple layout]+-- See Note [GHCi and native call registers] -emitPushTupleRegs :: CmmExpr -> FCode ()-emitPushTupleRegs regs_live = do+emitPushArgRegs :: CmmExpr -> FCode ()+emitPushArgRegs regs_live = do   platform <- getPlatform-  let regs = zip (tupleRegsCover platform) [0..]+  let regs = zip (allArgRegsCover platform) [0..]       save_arg (reg, n) =         let mask     = CmmLit (CmmInt (1 `shiftL` n) (wordWidth platform))             live     = cmmAndWord platform regs_live mask@@ -381,11 +397,11 @@         in mkCmmIfThen cond $ catAGraphs [adj_sp, save_reg]   emit . catAGraphs =<< mapM save_arg (reverse regs) --- | Pop a subset of STG registers from the stack (see 'emitPushTupleRegs')-emitPopTupleRegs :: CmmExpr -> FCode ()-emitPopTupleRegs regs_live = do+-- | Pop a subset of STG registers from the stack (see 'emitPushArgRegs')+emitPopArgRegs :: CmmExpr -> FCode ()+emitPopArgRegs regs_live = do   platform <- getPlatform-  let regs = zip (tupleRegsCover platform) [0..]+  let regs = zip (allArgRegsCover platform) [0..]       save_arg (reg, n) =         let mask     = CmmLit (CmmInt (1 `shiftL` n) (wordWidth platform))             live     = cmmAndWord platform regs_live mask

@@ -188,9 +188,11 @@  data CgIdInfo   = CgIdInfo-        { cg_id :: Id   -- Id that this is the info for+        { cg_id  :: Id+          -- ^ Id that this is the info for         , cg_lf  :: LambdaFormInfo-        , cg_loc :: CgLoc                     -- CmmExpr for the *tagged* value+        , cg_loc :: CgLoc+          -- ^ 'CmmExpr' for the *tagged* value         }  instance OutputableP Platform CgIdInfo where

@@ -311,7 +311,7 @@ --  #define sizzeofByteArrayzh(r,a) \ --     r = ((StgArrBytes *)(a))->bytes   SizeofByteArrayOp -> \[arg] -> opIntoRegs $ \[res] ->-    emit $ mkAssign (CmmLocal res) (cmmLoadIndexW platform arg (fixedHdrSizeW profile) (bWord platform))+    emitAssign (CmmLocal res) (byteArraySize platform profile arg)  --  #define sizzeofMutableByteArrayzh(r,a) \ --      r = ((StgArrBytes *)(a))->bytes@@ -320,7 +320,7 @@ --  #define getSizzeofMutableByteArrayzh(r,a) \ --      r = ((StgArrBytes *)(a))->bytes   GetSizeofMutableByteArrayOp -> \[arg] -> opIntoRegs $ \[res] ->-    emitAssign (CmmLocal res) (cmmLoadIndexW platform arg (fixedHdrSizeW profile) (bWord platform))+    emitAssign (CmmLocal res) (byteArraySize platform profile arg)   --  #define touchzh(o)                  /* nothing */@@ -394,15 +394,10 @@ -- Getting the size of pointer arrays    SizeofArrayOp -> \[arg] -> opIntoRegs $ \[res] ->-    emit $ mkAssign (CmmLocal res) (cmmLoadIndexW platform arg-      (fixedHdrSizeW profile + bytesToWordsRoundUp platform (pc_OFFSET_StgMutArrPtrs_ptrs (platformConstants platform)))-        (bWord platform))+    emitAssign (CmmLocal res) (ptrArraySize platform profile arg)   SizeofMutableArrayOp      -> emitPrimOp cfg SizeofArrayOp   SizeofSmallArrayOp -> \[arg] -> opIntoRegs $ \[res] ->-    emit $ mkAssign (CmmLocal res)-     (cmmLoadIndexW platform arg-     (fixedHdrSizeW profile + bytesToWordsRoundUp platform (pc_OFFSET_StgSmallMutArrPtrs_ptrs (platformConstants platform)))-        (bWord platform))+    emitAssign (CmmLocal res) (smallPtrArraySize platform profile arg)    SizeofSmallMutableArrayOp    -> emitPrimOp cfg SizeofSmallArrayOp   GetSizeofSmallMutableArrayOp -> emitPrimOp cfg SizeofSmallArrayOp@@ -2069,7 +2064,7 @@                  -> [CmmExpr]                  -> FCode () doIndexOffAddrOp maybe_post_read_cast rep [res] [addr,idx]-   = mkBasicIndexedRead NaturallyAligned 0 maybe_post_read_cast rep res addr rep idx+   = mkBasicIndexedRead False NaturallyAligned 0 maybe_post_read_cast rep res addr rep idx doIndexOffAddrOp _ _ _ _    = panic "GHC.StgToCmm.Prim: doIndexOffAddrOp" @@ -2081,7 +2076,7 @@                    -> FCode () doIndexOffAddrOpAs maybe_post_read_cast rep idx_rep [res] [addr,idx]    = let alignment = alignmentFromTypes rep idx_rep-     in mkBasicIndexedRead alignment 0 maybe_post_read_cast rep res addr idx_rep idx+     in mkBasicIndexedRead False alignment 0 maybe_post_read_cast rep res addr idx_rep idx doIndexOffAddrOpAs _ _ _ _ _    = panic "GHC.StgToCmm.Prim: doIndexOffAddrOpAs" @@ -2093,7 +2088,7 @@ doIndexByteArrayOp maybe_post_read_cast rep [res] [addr,idx]    = do profile <- getProfile         doByteArrayBoundsCheck idx addr rep rep-        mkBasicIndexedRead NaturallyAligned (arrWordsHdrSize profile) maybe_post_read_cast rep res addr rep idx+        mkBasicIndexedRead False NaturallyAligned (arrWordsHdrSize profile) maybe_post_read_cast rep res addr rep idx doIndexByteArrayOp _ _ _ _    = panic "GHC.StgToCmm.Prim: doIndexByteArrayOp" @@ -2107,7 +2102,7 @@    = do profile <- getProfile         doByteArrayBoundsCheck idx addr idx_rep rep         let alignment = alignmentFromTypes rep idx_rep-        mkBasicIndexedRead alignment (arrWordsHdrSize profile) maybe_post_read_cast rep res addr idx_rep idx+        mkBasicIndexedRead False alignment (arrWordsHdrSize profile) maybe_post_read_cast rep res addr idx_rep idx doIndexByteArrayOpAs _ _ _ _ _    = panic "GHC.StgToCmm.Prim: doIndexByteArrayOpAs" @@ -2119,15 +2114,15 @@    = do profile <- getProfile         platform <- getPlatform         doPtrArrayBoundsCheck idx addr-        mkBasicIndexedRead NaturallyAligned (arrPtrsHdrSize profile) Nothing (gcWord platform) res addr (gcWord platform) idx+        mkBasicIndexedRead True NaturallyAligned (arrPtrsHdrSize profile) Nothing (gcWord platform) res addr (gcWord platform) idx  doWriteOffAddrOp :: Maybe MachOp                  -> CmmType                  -> [LocalReg]                  -> [CmmExpr]                  -> FCode ()-doWriteOffAddrOp maybe_pre_write_cast idx_ty [] [addr,idx,val]-   = mkBasicIndexedWrite 0 maybe_pre_write_cast addr idx_ty idx val+doWriteOffAddrOp castOp idx_ty [] [addr,idx, val]+   = mkBasicIndexedWrite False 0 addr idx_ty idx (maybeCast castOp val) doWriteOffAddrOp _ _ _ _    = panic "GHC.StgToCmm.Prim: doWriteOffAddrOp" @@ -2136,11 +2131,12 @@                    -> [LocalReg]                    -> [CmmExpr]                    -> FCode ()-doWriteByteArrayOp maybe_pre_write_cast idx_ty [] [addr,idx,val]+doWriteByteArrayOp castOp idx_ty [] [addr,idx, rawVal]    = do profile <- getProfile         platform <- getPlatform+        let val = maybeCast castOp rawVal         doByteArrayBoundsCheck idx addr idx_ty (cmmExprType platform val)-        mkBasicIndexedWrite (arrWordsHdrSize profile) maybe_pre_write_cast addr idx_ty idx val+        mkBasicIndexedWrite False (arrWordsHdrSize profile) addr idx_ty idx val doWriteByteArrayOp _ _ _ _    = panic "GHC.StgToCmm.Prim: doWriteByteArrayOp" @@ -2162,8 +2158,7 @@        -- This write barrier is to ensure that the heap writes to the object        -- referred to by val have happened before we write val into the array.        -- See #12469 for details.-       emitPrimCall [] MO_WriteBarrier []-       mkBasicIndexedWrite hdr_size Nothing addr ty idx val+       mkBasicIndexedWrite True hdr_size addr ty idx val         emit (setInfo addr (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel)))        -- the write barrier.  We must write a byte into the mark table:@@ -2171,16 +2166,12 @@        emit $ mkStore (          cmmOffsetExpr platform           (cmmOffsetExprW platform (cmmOffsetB platform addr hdr_size)-                         (loadArrPtrsSize profile addr))+                         (ptrArraySize platform profile addr))           (CmmMachOp (mo_wordUShr platform) [idx, mkIntExpr platform (pc_MUT_ARR_PTRS_CARD_BITS (platformConstants platform))])          ) (CmmLit (CmmInt 1 W8)) -loadArrPtrsSize :: Profile -> CmmExpr -> CmmExpr-loadArrPtrsSize profile addr = cmmLoadBWord platform (cmmOffsetB platform addr off)- where off = fixedHdrSize profile + pc_OFFSET_StgMutArrPtrs_ptrs (profileConstants profile)-       platform = profilePlatform profile--mkBasicIndexedRead :: AlignmentSpec+mkBasicIndexedRead :: Bool         -- Should this imply an acquire barrier+                   -> AlignmentSpec                    -> ByteOff      -- Initial offset in bytes                    -> Maybe MachOp -- Optional result cast                    -> CmmType      -- Type of element we are accessing@@ -2189,27 +2180,40 @@                    -> CmmType      -- Type of element by which we are indexing                    -> CmmExpr      -- Index                    -> FCode ()-mkBasicIndexedRead alignment off Nothing ty res base idx_ty idx-   = do platform <- getPlatform-        emitAssign (CmmLocal res) (cmmLoadIndexOffExpr platform alignment off ty base idx_ty idx)-mkBasicIndexedRead alignment off (Just cast) ty res base idx_ty idx+mkBasicIndexedRead barrier alignment off mb_cast ty res base idx_ty idx    = do platform <- getPlatform-        emitAssign (CmmLocal res) (CmmMachOp cast [-                                   cmmLoadIndexOffExpr platform alignment off ty base idx_ty idx])+        let addr = cmmIndexOffExpr platform off (typeWidth idx_ty) base idx+        result <-+          if barrier+          then do+            res <- newTemp ty+            emitPrimCall [res] (MO_AtomicRead (typeWidth ty) MemOrderAcquire) [addr]+            return $ CmmReg (CmmLocal res)+          else+            return $ CmmLoad addr ty alignment -mkBasicIndexedWrite :: ByteOff      -- Initial offset in bytes-                    -> Maybe MachOp -- Optional value cast+        let casted =+              case mb_cast of+                Just cast -> CmmMachOp cast [result]+                Nothing   -> result+        emitAssign (CmmLocal res) casted++mkBasicIndexedWrite :: Bool         -- Should this imply a release barrier+                    -> ByteOff      -- Initial offset in bytes                     -> CmmExpr      -- Base address                     -> CmmType      -- Type of element by which we are indexing                     -> CmmExpr      -- Index                     -> CmmExpr      -- Value to write                     -> FCode ()-mkBasicIndexedWrite off Nothing base idx_ty idx val+mkBasicIndexedWrite barrier off base idx_ty idx val    = do platform <- getPlatform         let alignment = alignmentFromTypes (cmmExprType platform val) idx_ty-        emitStore' alignment (cmmIndexOffExpr platform off (typeWidth idx_ty) base idx) val-mkBasicIndexedWrite off (Just cast) base idx_ty idx val-   = mkBasicIndexedWrite off Nothing base idx_ty idx (CmmMachOp cast [val])+            addr = cmmIndexOffExpr platform off (typeWidth idx_ty) base idx+        if barrier+          then let w = typeWidth idx_ty+                   op = MO_AtomicWrite w MemOrderRelease+               in emitPrimCall [] op [addr, val]+          else emitStore' alignment addr val  -- ---------------------------------------------------------------------------- -- Misc utils@@ -2237,6 +2241,30 @@ setInfo :: CmmExpr -> CmmExpr -> CmmAGraph setInfo closure_ptr info_ptr = mkStore closure_ptr info_ptr +maybeCast :: Maybe MachOp -> CmmExpr -> CmmExpr+maybeCast Nothing val = val+maybeCast (Just cast) val = CmmMachOp cast [val]++ptrArraySize :: Platform -> Profile -> CmmExpr -> CmmExpr+ptrArraySize platform profile arr =+  cmmLoadBWord platform (cmmOffsetB platform arr sz_off)+  where sz_off = fixedHdrSize profile+               + pc_OFFSET_StgMutArrPtrs_ptrs (platformConstants platform)++smallPtrArraySize :: Platform -> Profile -> CmmExpr -> CmmExpr+smallPtrArraySize platform profile arr =+  cmmLoadBWord platform (cmmOffsetB platform arr sz_off)+  where sz_off = fixedHdrSize profile+               + pc_OFFSET_StgSmallMutArrPtrs_ptrs (platformConstants platform)++byteArraySize :: Platform -> Profile -> CmmExpr -> CmmExpr+byteArraySize platform profile arr =+  cmmLoadBWord platform (cmmOffsetB platform arr sz_off)+  where sz_off = fixedHdrSize profile+               + pc_OFFSET_StgArrBytes_bytes (platformConstants platform)+++ ------------------------------------------------------------------------------ -- Helpers for translating vector primops. @@ -2482,10 +2510,9 @@     profile <- getProfile     platform <- getPlatform -    ifNonZero n $ do-        let last_touched_idx off = cmmOffsetB platform (cmmAddWord platform off n) (-1)-        doByteArrayBoundsCheck (last_touched_idx ba1_off) ba1 b8 b8-        doByteArrayBoundsCheck (last_touched_idx ba2_off) ba2 b8 b8+    whenCheckBounds $ ifNonZero n $ do+        emitRangeBoundsCheck ba1_off n (byteArraySize platform profile ba1)+        emitRangeBoundsCheck ba2_off n (byteArraySize platform profile ba2)      ba1_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform ba1 (arrWordsHdrSize profile)) ba1_off     ba2_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform ba2 (arrWordsHdrSize profile)) ba2_off@@ -2548,7 +2575,7 @@     -- Copy data (we assume the arrays aren't overlapping since     -- they're of different types)     copy _src _dst dst_p src_p bytes align =-        emitMemcpyCall dst_p src_p bytes align+        emitCheckedMemcpyCall dst_p src_p bytes align  -- | Takes a source 'MutableByteArray#', an offset in the source -- array, a destination 'MutableByteArray#', an offset into the@@ -2577,10 +2604,9 @@     profile <- getProfile     platform <- getPlatform -    ifNonZero n $ do-        let last_touched_idx off = cmmOffsetB platform (cmmAddWord platform off n) (-1)-        doByteArrayBoundsCheck (last_touched_idx src_off) src b8 b8-        doByteArrayBoundsCheck (last_touched_idx dst_off) dst b8 b8+    whenCheckBounds $ ifNonZero n $ do+        emitRangeBoundsCheck src_off n (byteArraySize platform profile src)+        emitRangeBoundsCheck dst_off n (byteArraySize platform profile dst)      let byteArrayAlignment = wordAlignment platform         srcOffAlignment = cmmExprAlignment src_off@@ -2598,11 +2624,10 @@     -- Use memcpy (we are allowed to assume the arrays aren't overlapping)     profile <- getProfile     platform <- getPlatform-    ifNonZero bytes $ do-        let last_touched_idx off = cmmOffsetB platform (cmmAddWord platform off bytes) (-1)-        doByteArrayBoundsCheck (last_touched_idx src_off) src b8 b8+    whenCheckBounds $ ifNonZero bytes $ do+        emitRangeBoundsCheck src_off bytes (byteArraySize platform profile src)     src_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform src (arrWordsHdrSize profile)) src_off-    emitMemcpyCall dst_p src_p bytes (mkAlignment 1)+    emitCheckedMemcpyCall dst_p src_p bytes (mkAlignment 1)  -- | Takes a source 'MutableByteArray#', an offset in the source array, a -- destination 'Addr#', and the number of bytes to copy.  Copies the given@@ -2619,19 +2644,21 @@     -- Use memcpy (we are allowed to assume the arrays aren't overlapping)     profile <- getProfile     platform <- getPlatform-    ifNonZero bytes $ do-        let last_touched_idx off = cmmOffsetB platform (cmmAddWord platform off bytes) (-1)-        doByteArrayBoundsCheck (last_touched_idx dst_off) dst b8 b8+    whenCheckBounds $ ifNonZero bytes $ do+        emitRangeBoundsCheck dst_off bytes (byteArraySize platform profile dst)     dst_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform dst (arrWordsHdrSize profile)) dst_off-    emitMemcpyCall dst_p src_p bytes (mkAlignment 1)+    emitCheckedMemcpyCall dst_p src_p bytes (mkAlignment 1)  ifNonZero :: CmmExpr -> FCode () -> FCode () ifNonZero e it = do     platform <- getPlatform     let pred = cmmNeWord platform e (zeroExpr platform)     code <- getCode it-    emit =<< mkCmmIfThen' pred code (Just False)+    emit =<< mkCmmIfThen' pred code (Just True)+      -- This function is used for range operation bounds-checks;+      -- Most calls to those ops will not have range length zero. + -- ---------------------------------------------------------------------------- -- Setting byte arrays @@ -2644,8 +2671,8 @@     profile <- getProfile     platform <- getPlatform -    doByteArrayBoundsCheck off ba b8 b8-    doByteArrayBoundsCheck (cmmOffset platform (cmmAddWord platform off len) (-1)) ba b8 b8+    whenCheckBounds $ ifNonZero len $+      emitRangeBoundsCheck off len (byteArraySize platform profile ba)      let byteArrayAlignment = wordAlignment platform -- known since BA is allocated on heap         offsetAlignment = cmmExprAlignment off@@ -2716,7 +2743,7 @@     -- they're of different types)     copy _src _dst dst_p src_p bytes =         do platform <- getPlatform-           emitMemcpyCall dst_p src_p (mkIntExpr platform bytes)+           emitCheckedMemcpyCall dst_p src_p (mkIntExpr platform bytes)                (wordAlignment platform)  @@ -2758,8 +2785,11 @@         dst     <- assignTempE dst0         dst_off <- assignTempE dst_off0 -        doPtrArrayBoundsCheck (cmmAddWord platform src_off (mkIntExpr platform n)) src-        doPtrArrayBoundsCheck (cmmAddWord platform dst_off (mkIntExpr platform n)) dst+        whenCheckBounds $ do+          emitRangeBoundsCheck src_off (mkIntExpr platform n)+                                       (ptrArraySize platform profile src)+          emitRangeBoundsCheck dst_off (mkIntExpr platform n)+                                       (ptrArraySize platform profile dst)          -- Nonmoving collector write barrier         emitCopyUpdRemSetPush platform (arrPtrsHdrSize profile) dst dst_off n@@ -2778,7 +2808,7 @@          -- The base address of the destination card table         dst_cards_p <- assignTempE $ cmmOffsetExprW platform dst_elems_p-                       (loadArrPtrsSize profile dst)+                       (ptrArraySize platform profile dst)          emitSetCards dst_off dst_cards_p n @@ -2790,7 +2820,7 @@     -- they're of different types)     copy _src _dst dst_p src_p bytes =         do platform <- getPlatform-           emitMemcpyCall dst_p src_p (mkIntExpr platform bytes)+           emitCheckedMemcpyCall dst_p src_p (mkIntExpr platform bytes)                (wordAlignment platform)  @@ -2827,9 +2857,11 @@         src     <- assignTempE src0         dst     <- assignTempE dst0 -        when (n /= 0) $ do-            doSmallPtrArrayBoundsCheck (cmmAddWord platform src_off (mkIntExpr platform n)) src-            doSmallPtrArrayBoundsCheck (cmmAddWord platform dst_off (mkIntExpr platform n)) dst+        whenCheckBounds $ do+          emitRangeBoundsCheck src_off (mkIntExpr platform n)+                                       (smallPtrArraySize platform profile src)+          emitRangeBoundsCheck dst_off (mkIntExpr platform n)+                                       (smallPtrArraySize platform profile dst)          -- Nonmoving collector write barrier         emitCopyUpdRemSetPush platform (smallArrPtrsHdrSize profile) dst dst_off n@@ -2924,7 +2956,7 @@      emit $ mkAssign (CmmLocal res_r) (CmmReg arr) --- | Takes and offset in the destination array, the base address of+-- | Takes an offset in the destination array, the base address of -- the card table, and the number of elements affected (*not* the -- number of cards). The number of elements may not be zero. -- Marks the relevant cards as dirty.@@ -2957,7 +2989,7 @@     profile <- getProfile     platform <- getPlatform     doSmallPtrArrayBoundsCheck idx addr-    mkBasicIndexedRead NaturallyAligned (smallArrPtrsHdrSize profile) Nothing (gcWord platform) res addr+    mkBasicIndexedRead True NaturallyAligned (smallArrPtrsHdrSize profile) Nothing (gcWord platform) res addr         (gcWord platform) idx  doWriteSmallPtrArrayOp :: CmmExpr@@ -2973,11 +3005,11 @@      -- Update remembered set for non-moving collector     tmp <- newTemp ty-    mkBasicIndexedRead NaturallyAligned (smallArrPtrsHdrSize profile) Nothing ty tmp addr ty idx+    mkBasicIndexedRead False NaturallyAligned (smallArrPtrsHdrSize profile) Nothing ty tmp addr ty idx     whenUpdRemSetEnabled $ emitUpdRemSetPush (CmmReg (CmmLocal tmp)) -    emitPrimCall [] MO_WriteBarrier [] -- #12469-    mkBasicIndexedWrite (smallArrPtrsHdrSize profile) Nothing addr ty idx val+    -- Write barrier needed due to #12469+    mkBasicIndexedWrite True (smallArrPtrsHdrSize profile) addr ty idx val     emit (setInfo addr (CmmLit (CmmLabel mkSMAP_DIRTY_infoLabel)))  ------------------------------------------------------------------------------@@ -3103,6 +3135,26 @@         (MO_Memcpy (alignmentBytes align))         [ dst, src, n ] +-- | Emit a call to @memcpy@, but check for range+-- overlap when -fcheck-prim-bounds is on.+emitCheckedMemcpyCall :: CmmExpr -> CmmExpr -> CmmExpr -> Alignment -> FCode ()+emitCheckedMemcpyCall dst src n align = do+    whenCheckBounds (getPlatform >>= doCheck)+    emitMemcpyCall dst src n align+  where+    doCheck platform = do+        overlapCheckFailed <- getCode $+          emitCCallNeverReturns [] (mkLblExpr mkMemcpyRangeOverlapLabel) []+        emit =<< mkCmmIfThen' rangesOverlap overlapCheckFailed (Just False)+      where+        rangesOverlap = (checkDiff dst src `or` checkDiff src dst) `ne` zero+        checkDiff p q = (p `minus` q) `uLT` n+        or = cmmOrWord platform+        minus = cmmSubWord platform+        uLT  = cmmULtWord platform+        ne   = cmmNeWord platform+        zero = zeroExpr platform+ -- | Emit a call to @memmove@. emitMemmoveCall :: CmmExpr -> CmmExpr -> CmmExpr -> Alignment -> FCode () emitMemmoveCall dst src n align =@@ -3197,50 +3249,68 @@ -- Array bounds checking --------------------------------------------------------------------------- -doBoundsCheck :: CmmExpr  -- ^ accessed index-              -> CmmExpr  -- ^ array size (in elements)-              -> FCode ()-doBoundsCheck idx sz = do-    do_bounds_check <- stgToCmmDoBoundsCheck <$> getStgToCmmConfig-    platform        <- getPlatform-    when do_bounds_check (doCheck platform)-  where-    doCheck platform = do-        boundsCheckFailed <- getCode $ emitCCall [] (mkLblExpr mkOutOfBoundsAccessLabel) []-        emit =<< mkCmmIfThen' isOutOfBounds boundsCheckFailed (Just False)-      where-        uGE = cmmUGeWord platform-        and = cmmAndWord platform-        zero = zeroExpr platform-        ne  = cmmNeWord platform-        isOutOfBounds = ((idx `uGE` sz) `and` (idx `ne` zero)) `ne` zero+whenCheckBounds :: FCode () -> FCode ()+whenCheckBounds a = do+  config <- getStgToCmmConfig+  case stgToCmmDoBoundsCheck config of+    False -> pure ()+    True  -> a --- We want to make sure that the array size computation is pushed into the--- Opt_DoBoundsChecking check to avoid regregressing compiler performance when--- it's disabled.-{-# INLINE doBoundsCheck #-}+emitBoundsCheck :: CmmExpr  -- ^ accessed index+                -> CmmExpr  -- ^ array size (in elements)+                -> FCode ()+emitBoundsCheck idx sz = do+    assertM (stgToCmmDoBoundsCheck <$> getStgToCmmConfig)+    platform <- getPlatform+    boundsCheckFailed <- getCode $+      emitCCallNeverReturns [] (mkLblExpr mkOutOfBoundsAccessLabel) []+    let isOutOfBounds = cmmUGeWord platform idx sz+    emit =<< mkCmmIfThen' isOutOfBounds boundsCheckFailed (Just False) +emitRangeBoundsCheck :: CmmExpr  -- ^ first accessed index+                     -> CmmExpr  -- ^ number of accessed indices (non-zero)+                     -> CmmExpr  -- ^ array size (in elements)+                     -> FCode ()+emitRangeBoundsCheck idx len arrSizeExpr = do+    assertM (stgToCmmDoBoundsCheck <$> getStgToCmmConfig)+    config <- getStgToCmmConfig+    platform <- getPlatform+    arrSize <- assignTempE arrSizeExpr+    -- arrSizeExpr is probably a load we don't want to duplicate+    rangeTooLargeReg <- newTemp (bWord platform)+    lastSafeIndexReg <- newTemp (bWord platform)+    _ <- withSequel (AssignTo [lastSafeIndexReg, rangeTooLargeReg] False) $+      cmmPrimOpApp config WordSubCOp [arrSize, len] Nothing+    boundsCheckFailed <- getCode $+      emitCCallNeverReturns [] (mkLblExpr mkOutOfBoundsAccessLabel) []+    let+      rangeTooLarge = CmmReg (CmmLocal rangeTooLargeReg)+      lastSafeIndex = CmmReg (CmmLocal lastSafeIndexReg)+      badStartIndex = (idx `uGT` lastSafeIndex)+      isOutOfBounds = (rangeTooLarge `or` badStartIndex) `neq` zero+      uGT = cmmUGtWord platform+      or = cmmOrWord platform+      neq = cmmNeWord platform+      zero = zeroExpr platform+    emit =<< mkCmmIfThen' isOutOfBounds boundsCheckFailed (Just False)+ doPtrArrayBoundsCheck     :: CmmExpr  -- ^ accessed index (in bytes)     -> CmmExpr  -- ^ pointer to @StgMutArrPtrs@     -> FCode ()-doPtrArrayBoundsCheck idx arr = do+doPtrArrayBoundsCheck idx arr = whenCheckBounds $ do     profile <- getProfile     platform <- getPlatform-    let sz = cmmLoadBWord platform (cmmOffset platform arr sz_off)-        sz_off = fixedHdrSize profile + pc_OFFSET_StgMutArrPtrs_ptrs (platformConstants platform)-    doBoundsCheck idx sz+    emitBoundsCheck idx (ptrArraySize platform profile arr)  doSmallPtrArrayBoundsCheck     :: CmmExpr  -- ^ accessed index (in bytes)     -> CmmExpr  -- ^ pointer to @StgMutArrPtrs@     -> FCode ()-doSmallPtrArrayBoundsCheck idx arr = do+doSmallPtrArrayBoundsCheck idx arr = whenCheckBounds $ do     profile <- getProfile     platform <- getPlatform-    let sz = cmmLoadBWord platform (cmmOffset platform arr sz_off)-        sz_off = fixedHdrSize profile + pc_OFFSET_StgSmallMutArrPtrs_ptrs (platformConstants platform)-    doBoundsCheck idx sz+    emitBoundsCheck idx (smallPtrArraySize platform profile arr)  doByteArrayBoundsCheck     :: CmmExpr  -- ^ accessed index (in elements)@@ -3248,18 +3318,18 @@     -> CmmType  -- ^ indexing type     -> CmmType  -- ^ element type     -> FCode ()-doByteArrayBoundsCheck idx arr idx_ty elem_ty = do+doByteArrayBoundsCheck idx arr idx_ty elem_ty = whenCheckBounds $ do     profile <- getProfile     platform <- getPlatform-    let sz = cmmLoadBWord platform (cmmOffset platform arr sz_off)-        sz_off = fixedHdrSize profile + pc_OFFSET_StgArrBytes_bytes (platformConstants platform)-        elem_sz = widthInBytes $ typeWidth elem_ty-        idx_sz = widthInBytes $ typeWidth idx_ty-        -- Ensure that the last byte of the access is within the array-        idx_bytes = cmmOffsetB platform-          (cmmMulWord platform idx (mkIntExpr platform idx_sz))-          (elem_sz - 1)-    doBoundsCheck idx_bytes sz+    let elem_w = typeWidth elem_ty+        idx_w = typeWidth idx_ty+        elem_sz = mkIntExpr platform $ widthInBytes elem_w+        arr_sz = byteArraySize platform profile arr+        effective_arr_sz =+          cmmUShrWord platform arr_sz (mkIntExpr platform (widthInLog idx_w))+    if elem_w == idx_w+      then emitBoundsCheck idx effective_arr_sz  -- aligned => simpler check+      else assert (idx_w == W8) (emitRangeBoundsCheck idx elem_sz arr_sz)  --------------------------------------------------------------------------- -- Pushing to the update remembered set

@@ -70,6 +70,52 @@ * We don't absolutely guarantee to serialise the CgInfo: we won't if you have   -fomit-interface-pragmas or -fno-code; and we won't read it in if you have   -fignore-interface-pragmas.  (We could revisit this decision.)++Note [Imported unlifted nullary datacon wrappers must have correct LFInfo]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+As described in `Note [Conveying CAF-info and LFInfo between modules]`,+imported unlifted nullary datacons must have their LambdaFormInfo set to+reflect the fact that they are evaluated . This is necessary as otherwise+references to them may be passed untagged to code that expects tagged+references.++What may be less obvious is that this must be done for not only datacon+workers but also *wrappers*. The reason is found in this program+from #23146:++    module B where++    type NP :: [UnliftedType] -> UnliftedType+    data NP xs where+      UNil :: NP '[]+++    module A where+    import B++    fieldsSam :: NP xs -> NP xs -> Bool+    fieldsSam UNil UNil = True++    x = fieldsSam UNil UNil++Due to its GADT nature, `B.UNil` produces a trivial wrapper++    $WUNil :: NP '[]+    $WUNil = UNil @'[] @~(<co:1>)++which is referenced in the RHS of `A.x`. If we fail to give `$WUNil` the+correct `LFCon 0` `LambdaFormInfo` then we will end up passing an untagged+pointer to `fieldsSam`. This is problematic as `fieldsSam` may take advantage+of the unlifted nature of its arguments by omitting handling of the zero+tag when scrutinising them.++The fix is straightforward: extend the logic in `mkLFImported` to cover+(nullary) datacon wrappers as well as workers. This is safe because we+know that the wrapper of a nullary datacon will be in WHNF, even if it+includes equalities evidence (since such equalities are not runtime+relevant). This fixed #23146.++See also Note [The LFInfo of Imported Ids] -}  -- | Codegen-generated Id infos, to be passed to downstream via interfaces.@@ -118,7 +164,7 @@         !StandardFormInfo         !Bool           -- True <=> *might* be a function type -  | LFCon               -- A saturated constructor application+  | LFCon               -- A saturated data constructor application         !DataCon        -- The constructor    | LFUnknown           -- Used for function arguments and imported things.

@@ -45,6 +45,7 @@ import GHC.Prelude  import GHC.Tc.Utils.Monad+import GHC.Tc.TyCl.Class ( substATBndrs ) import GHC.Hs import GHC.Types.Name.Reader import GHC.Types.Basic@@ -2096,8 +2097,8 @@         newFamInst SynFamilyInst axiom       where         fam_tvs     = tyConTyVars fam_tc-        rep_lhs_tys = substTyVars lhs_subst fam_tvs-        rep_rhs_tys = substTyVars rhs_subst fam_tvs+        (_, rep_lhs_tys) = substATBndrs lhs_subst fam_tvs+        (_, rep_rhs_tys) = substATBndrs rhs_subst fam_tvs         rep_rhs_ty  = mkTyConApp fam_tc rep_rhs_tys         rep_tcvs    = tyCoVarsOfTypesList rep_lhs_tys         (rep_tvs, rep_cvs) = partition isTyVar rep_tcvs

@@ -799,6 +799,11 @@     TcRnInvalidCIdentifier target       -> mkSimpleDecorated $            sep [quotes (ppr target) <+> text "is not a valid C identifier"]+    TcRnCannotDefaultConcrete frr+      -> mkSimpleDecorated $+         ppr (frr_context frr) $$+         text "cannot be assigned a fixed runtime representation," <+>+         text "not even by defaulting."    diagnosticReason = \case     TcRnUnknownMessage m@@ -1059,6 +1064,8 @@       -> ErrorWithoutFlag     TcRnInvalidCIdentifier{}       -> ErrorWithoutFlag+    TcRnCannotDefaultConcrete{}+      -> ErrorWithoutFlag    diagnosticHints = \case     TcRnUnknownMessage m@@ -1318,6 +1325,9 @@            _ -> noHints     TcRnInvalidCIdentifier{}       -> noHints+    TcRnCannotDefaultConcrete{}+      -> [SuggestAddTypeSignatures UnnamedBinding]+  deriveInstanceErrReasonHints :: Class                              -> UsingGeneralizedNewtypeDeriving

@@ -1790,6 +1790,16 @@   -}   TcRnInvalidCIdentifier :: !CLabelString -> TcRnMessage +  {- TcRnCannotDefaultConcrete is an error occurring when a concrete+    type variable cannot be defaulted.++    Test cases:+      T23153+  -}+  TcRnCannotDefaultConcrete+    :: !FixedRuntimeRepOrigin+    -> TcRnMessage+ -- | Specifies which backend code generators where expected for an FFI declaration data ExpectedBackends   = COrAsmOrLlvm         -- ^ C, Asm, or LLVM

@@ -1095,6 +1095,22 @@                                 or multi-parameter type classes  - an inferred type that includes unboxed tuples +Note [Inferred type with escaping kind]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Check for an inferred type with an escaping kind; e.g. #23051+   forall {k} {f :: k -> RuntimeRep} {g :: k} {a :: TYPE (f g)}. a+where the kind of the body of the forall mentions `f` and `g` which+are bound by the forall.  No no no.++This check, mkInferredPolyId, is really in the wrong place:+`inferred_poly_ty` doesn't obey the PKTI and it would be better not to+generalise it in the first place; see #20686.  But for now it works.++I considered adjusting the generalisation in GHC.Tc.Solver to directly check for+escaping kind variables; instead, promoting or defaulting them. But that+gets into the defaulting swamp and is a non-trivial and unforced+change, so I have left it alone for now.+ Note [Impedance matching] ~~~~~~~~~~~~~~~~~~~~~~~~~ Consider@@ -1184,7 +1200,9 @@   , Nothing <- sig_fn name   -- ...with no type signature   = setSrcSpanA b_loc    $     do  { ((co_fn, matches'), rhs_ty')-            <- tcInfer $ \ exp_ty ->+            <- tcInferFRR (FRRBinder name) $ \ exp_ty ->+                          -- tcInferFRR: the type of a let-binder must have+                          -- a fixed runtime rep. See #23176                        tcExtendBinderStack [TcIdBndr_ExpType name exp_ty NotTopLevel] $                           -- We extend the error context even for a non-recursive                           -- function so that in type error messages we show the@@ -1206,7 +1224,9 @@   | NonRecursive <- is_rec   -- ...binder isn't mentioned in RHS   , all (isNothing . sig_fn) bndrs   = addErrCtxt (patMonoBindsCtxt pat grhss) $-    do { (grhss', pat_ty) <- tcInfer $ \ exp_ty ->+    do { (grhss', pat_ty) <- tcInferFRR FRRPatBind $ \ exp_ty ->+                          -- tcInferFRR: the type of each let-binder must have+                          -- a fixed runtime rep. See #23176                              tcGRHSsPat grhss exp_ty         ; let exp_pat_ty :: Scaled ExpSigmaTypeFRR

@@ -583,7 +583,7 @@     loc = getLocA (dropWildCards hs_ty)     ctxt = ExprSigCtxt (lhsSigWcTypeContextSpan hs_ty) -tcExprSig :: UserTypeCtxt -> LHsExpr GhcRn -> TcIdSigInfo -> TcM (LHsExpr GhcTc, TcType)+tcExprSig :: UserTypeCtxt -> LHsExpr GhcRn -> TcIdSigInfo -> TcM (LHsExpr GhcTc, TcSigmaType) tcExprSig ctxt expr (CompleteSig { sig_bndr = poly_id, sig_loc = loc })   = setSrcSpan loc $   -- Sets the location for the implication constraint     do { let poly_ty = idType poly_id

@@ -7,6 +7,7 @@      unifyWanted,      makeSuperClasses,      StopOrContinue(..), stopWith, continueWith, andWhenContinue,+     rewriteEqEvidence,      solveCallStack    -- For GHC.Tc.Solver   ) where @@ -2302,7 +2303,7 @@                 -> MCoercion                -- :: kind(rhs) ~N kind(lhs)                 -> TcS (StopOrContinue Ct) canEqTyVarFunEq ev eq_rel swapped tv1 ps_xi1 fun_tc2 fun_args2 ps_xi2 mco-  = do { is_touchable <- touchabilityTest (ctEvFlavour ev) tv1 rhs+  = do { (is_touchable, rhs) <- touchabilityTest (ctEvFlavour ev) tv1 rhs        ; if | case is_touchable of { Untouchable -> False; _ -> True }             , cterHasNoProblem $                 checkTyVarEq tv1 rhs `cterRemoveProblem` cteTypeFamily

@@ -22,6 +22,7 @@ import GHC.Core.Coercion.Axiom ( CoAxBranch (..), CoAxiom (..), TypeEqn, fromBranches, sfInteractInert, sfInteractTop ) import GHC.Core.Class import GHC.Core.TyCon+import GHC.Core.Reduction import GHC.Tc.Instance.FunDeps import GHC.Tc.Instance.Family import GHC.Tc.Instance.Class ( InstanceWhat(..), safeOverlap )@@ -1562,7 +1563,7 @@                         -> TcType    -- RHS                         -> TcS (StopOrContinue Ct) tryToSolveByUnification work_item ev tv rhs-  = do { is_touchable <- touchabilityTest (ctEvFlavour ev) tv rhs+  = do { (is_touchable, rhs) <- touchabilityTest (ctEvFlavour ev) tv rhs        ; traceTcS "tryToSolveByUnification" (vcat [ ppr tv <+> char '~' <+> ppr rhs                                                   , ppr is_touchable ]) @@ -1922,7 +1923,7 @@   | otherwise   = do { res <- matchLocalInst pred loc        ; case res of-           OneInst {} -> chooseInstance work_item res+           OneInst {} -> chooseInstance ev res            _          -> continueWith work_item }    where@@ -1939,20 +1940,44 @@ doTopReactEqPred :: Ct -> EqRel -> TcType -> TcType -> TcS (StopOrContinue Ct) doTopReactEqPred work_item eq_rel t1 t2   -- See Note [Looking up primitive equalities in quantified constraints]-  | Just (cls, tys) <- boxEqPred eq_rel t1 t2-  = do { res <- matchLocalInst (mkClassPred cls tys) loc-       ; case res of-           OneInst { cir_mk_ev = mk_ev }-             -> chooseInstance work_item-                    (res { cir_mk_ev = mk_eq_ev cls tys mk_ev })-           _ -> continueWith work_item }--  | otherwise-  = continueWith work_item+  = do { ev_binds_var <- getTcEvBindsVar+       ; ics <- getInertCans+       ; if isWanted ev                       -- Never look up Givens in quantified constraints+         && not (null (inert_insts ics))      -- Shortcut common case+         && not (isCoEvBindsVar ev_binds_var) -- See Note [Instances in no-evidence implications]+         then try_for_qci+         else continueWith work_item}   where     ev   = ctEvidence work_item     loc = ctEvLoc ev +    role = eqRelRole eq_rel++    try_for_qci  -- First try looking for (lhs ~ rhs)+       | Just (cls, tys) <- boxEqPred eq_rel t1 t2+       = do { res <- matchLocalInst (mkClassPred cls tys) loc+            ; traceTcS "final_qci_check:1" (ppr (mkClassPred cls tys))+            ; case res of+                OneInst { cir_mk_ev = mk_ev }+                  -> chooseInstance ev (res { cir_mk_ev = mk_eq_ev cls tys mk_ev })+                _ -> try_swapping }+       | otherwise+       = continueWith work_item++    try_swapping  -- Now try looking for (rhs ~ lhs)  (see #23333)+       | Just (cls, tys) <- boxEqPred eq_rel t2 t1+       = do { res <- matchLocalInst (mkClassPred cls tys) loc+            ; traceTcS "final_qci_check:2" (ppr (mkClassPred cls tys))+            ; case res of+                OneInst { cir_mk_ev = mk_ev }+                  -> do { ev' <- rewriteEqEvidence emptyRewriterSet ev IsSwapped+                                      (mkReflRedn role t2) (mkReflRedn role t1)+                        ; chooseInstance ev' (res { cir_mk_ev = mk_eq_ev cls tys mk_ev }) }+                _ -> do { traceTcS "final_qci_check:3" (ppr work_item)+                        ; continueWith work_item }}+       | otherwise+       = continueWith work_item+     mk_eq_ev cls tys mk_ev evs       = case (mk_ev evs) of           EvExpr e -> EvExpr (Var sc_id `mkTyApps` tys `App` e)@@ -2185,7 +2210,7 @@                OneInst { cir_what = what }                   -> do { insertSafeOverlapFailureTcS what work_item                         ; addSolvedDict what ev cls xis-                        ; chooseInstance work_item lkup_res }+                        ; chooseInstance ev lkup_res }                _  -> -- NoInstance or NotSure                      -- We didn't solve it; so try functional dependencies with                      -- the instance environment, and return@@ -2197,27 +2222,23 @@ doTopReactDict _ w = pprPanic "doTopReactDict" (ppr w)  -chooseInstance :: Ct -> ClsInstResult -> TcS (StopOrContinue Ct)+chooseInstance :: CtEvidence -> ClsInstResult -> TcS (StopOrContinue Ct) chooseInstance work_item                (OneInst { cir_new_theta = theta                         , cir_what      = what                         , cir_mk_ev     = mk_ev })-  = do { traceTcS "doTopReact/found instance for" $ ppr ev+  = do { traceTcS "doTopReact/found instance for" $ ppr work_item        ; deeper_loc <- checkInstanceOK loc what pred        ; checkReductionDepth deeper_loc pred-       ; evb <- getTcEvBindsVar-       ; if isCoEvBindsVar evb-         then continueWith work_item-                  -- See Note [Instances in no-evidence implications]-         else-           do { evc_vars <- mapM (newWanted deeper_loc (ctRewriters work_item)) theta-              ; setEvBindIfWanted ev (mk_ev (map getEvExpr evc_vars))-              ; emitWorkNC (freshGoals evc_vars)-              ; stopWith ev "Dict/Top (solved wanted)" }}+       ; assertPprM (getTcEvBindsVar >>= return . not . isCoEvBindsVar)+                    (ppr work_item)+       ; evc_vars <- mapM (newWanted deeper_loc (ctEvRewriters work_item)) theta+       ; setEvBindIfWanted work_item (mk_ev (map getEvExpr evc_vars))+       ; emitWorkNC (freshGoals evc_vars)+       ; stopWith work_item "Dict/Top (solved wanted)" }   where-     ev         = ctEvidence work_item-     pred       = ctEvPred ev-     loc        = ctEvLoc ev+     pred = ctEvPred work_item+     loc  = ctEvLoc work_item  chooseInstance work_item lookup_res   = pprPanic "chooseInstance" (ppr work_item $$ ppr lookup_res)@@ -2240,26 +2261,6 @@        = setCtLocOrigin loc (ScOrigin infinity)        | otherwise        = loc--{- Note [Instances in no-evidence implications]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In #15290 we had-  [G] forall p q. Coercible p q => Coercible (m p) (m q))-  [W] forall <no-ev> a. m (Int, IntStateT m a)-                          ~R#-                        m (Int, StateT Int m a)--The Given is an ordinary quantified constraint; the Wanted is an implication-equality that arises from-  [W] (forall a. t1) ~R# (forall a. t2)--But because the (t1 ~R# t2) is solved "inside a type" (under that forall a)-we can't generate any term evidence.  So we can't actually use that-lovely quantified constraint.  Alas!--This test arranges to ignore the instance-based solution under these-(rare) circumstances.   It's sad, but I  really don't see what else we can do.--}   matchClassInst :: DynFlags -> InertSet

@@ -1250,35 +1250,37 @@   ppr (TouchableOuterLevel tvs lvl) = text "TouchableOuterLevel" <> parens (ppr lvl <+> ppr tvs)   ppr Untouchable                   = text "Untouchable" -touchabilityTest :: CtFlavour -> TcTyVar -> TcType -> TcS TouchabilityTestResult--- This is the key test for untouchability:+touchabilityTest :: CtFlavour -> TcTyVar -> TcType -> TcS (TouchabilityTestResult, TcType)+-- ^ This is the key test for untouchability: -- See Note [Unification preconditions] in GHC.Tc.Utils.Unify -- and Note [Solve by unification] in GHC.Tc.Solver.Interact+--+-- Returns a new rhs type, as this function can turn make some metavariables concrete. touchabilityTest flav tv1 rhs   | flav /= Given  -- See Note [Do not unify Givens]   , MetaTv { mtv_tclvl = tv_lvl, mtv_info = info } <- tcTyVarDetails tv1-  = do { can_continue_solving <- wrapTcS $ startSolvingByUnification info rhs-       ; if not can_continue_solving-         then return Untouchable-         else-    do { ambient_lvl  <- getTcLevel+  = do { continue_solving <- wrapTcS $ startSolvingByUnification info rhs+       ; case continue_solving of+       { Nothing -> return (Untouchable, rhs)+       ; Just rhs ->+    do { let (free_metas, free_skols) = partition isPromotableMetaTyVar $+                                        nonDetEltsUniqSet               $+                                        tyCoVarsOfType rhs+       ; ambient_lvl  <- getTcLevel        ; given_eq_lvl <- getInnermostGivenEqLevel         ; if | tv_lvl `sameDepthAs` ambient_lvl-            -> return TouchableSameLevel+            -> return (TouchableSameLevel, rhs)              | tv_lvl `deeperThanOrSame` given_eq_lvl   -- No intervening given equalities             , all (does_not_escape tv_lvl) free_skols  -- No skolem escapes-            -> return (TouchableOuterLevel free_metas tv_lvl)+            -> return (TouchableOuterLevel free_metas tv_lvl, rhs)              | otherwise-            -> return Untouchable } }+            -> return (Untouchable, rhs) } } }   | otherwise-  = return Untouchable+  = return (Untouchable, rhs)   where-     (free_metas, free_skols) = partition isPromotableMetaTyVar $-                                nonDetEltsUniqSet               $-                                tyCoVarsOfType rhs       does_not_escape tv_lvl fv        | isTyVar fv = tv_lvl `deeperThanOrSame` tcTyVarLevel fv@@ -1702,8 +1704,8 @@ Consider [G] forall a. blah => a ~ T          [W] S ~# T -Then doTopReactEqPred carefully looks up the (boxed) constraint (S ~-T) in the quantified constraints, and wraps the (boxed) evidence it+Then doTopReactEqPred carefully looks up the (boxed) constraint (S ~ T)+in the quantified constraints, and wraps the (boxed) evidence it gets back in an eq_sel to extract the unboxed (S ~# T).  We can't put that term into a coercion, so we add a value binding     h = eq_sel (...)@@ -1919,23 +1921,21 @@      -- See Detail (8) of the Note.    = do { should_break <- final_check-       ; if should_break then do { redn <- go rhs-                                 ; return (Just redn) }-                         else return Nothing }+       ; mapM go should_break }   where     flavour = ctEvFlavour ev     eq_rel  = ctEvEqRel ev      final_check = case flavour of-      Given  -> return True+      Given  -> return $ Just rhs       Wanted    -- Wanteds work only with a touchable tyvar on the left                 -- See "Wanted" section of the Note.         | TyVarLHS lhs_tv <- lhs ->-          do { result <- touchabilityTest Wanted lhs_tv rhs+          do { (result, rhs) <- touchabilityTest Wanted lhs_tv rhs              ; return $ case result of-                          Untouchable -> False-                          _           -> True }-        | otherwise -> return False+                          Untouchable -> Nothing+                          _           -> Just rhs }+        | otherwise -> return Nothing      -- This could be considerably more efficient. See Detail (5) of Note.     go :: TcType -> TcS ReductionN

@@ -23,6 +23,7 @@    , instDeclCtxt2    , instDeclCtxt3    , tcATDefault+   , substATBndrs    ) where @@ -38,7 +39,7 @@ import GHC.Tc.Utils.Instantiate( tcSuperSkolTyVars ) import GHC.Tc.Gen.HsType import GHC.Tc.Utils.TcMType-import GHC.Core.Type     ( piResultTys )+import GHC.Core.Type     ( extendTvSubstWithClone, piResultTys ) import GHC.Core.Predicate import GHC.Core.Multiplicity import GHC.Tc.Types.Origin@@ -56,7 +57,7 @@ import GHC.Types.Name.Env import GHC.Types.Name.Set import GHC.Types.Var-import GHC.Types.Var.Env+import GHC.Types.Var.Env ( lookupVarEnv ) import GHC.Types.SourceFile (HscSource(..)) import GHC.Utils.Outputable import GHC.Utils.Panic@@ -522,8 +523,7 @@    --            instance C [x]    -- Then we want to generate the decl:   type F [x] b = ()   | Just (rhs_ty, _loc) <- defs-  = do { let (subst', pat_tys') = mapAccumL subst_tv inst_subst-                                            (tyConTyVars fam_tc)+  = do { let (subst', pat_tys') = substATBndrs inst_subst (tyConTyVars fam_tc)              rhs'     = substTyUnchecked subst' rhs_ty              tcv' = tyCoVarsOfTypesList pat_tys'              (tv', cv') = partition isTyVar tcv'@@ -546,14 +546,73 @@   | otherwise  -- defs = Nothing   = do { warnMissingAT (tyConName fam_tc)        ; return [] }++-- | Apply a substitution to the type variable binders of an associated type+-- family. This is used to compute default instances for associated type+-- families (see 'tcATDefault') as well as @newtype@-derived associated type+-- family instances (see @gen_Newtype_fam_insts@ in "GHC.Tc.Deriv.Generate").+--+-- As a concrete example, consider the following class and associated type+-- family:+--+-- @+--   class C k (a :: k) where+--     type F k a (b :: k) :: Type+--     type F j p q = (Proxy @j p, Proxy @j (q :: j))+-- @+--+-- If a user defines this instance:+--+-- @+-- instance C (Type -> Type) Maybe where {}+-- @+--+-- Then in order to typecheck the default @F@ instance, we must apply the+-- substitution @[k :-> (Type -> Type), a :-> Maybe]@ to @F@'s binders, which+-- are @[k, a, (b :: k)]@. The result should look like this:+--+-- @+--   type F (Type -> Type) Maybe (b :: Type -> Type) =+--     (Proxy @(Type -> Type) Maybe, Proxy @(Type -> Type) (b :: Type -> Type))+-- @+--+-- Making this work requires some care. There are two cases:+--+-- 1. If we encounter a type variable in the domain of the substitution (e.g.,+--    @k@ or @a@), then we apply the substitution directly.+--+-- 2. Otherwise, we substitute into the type variable's kind (e.g., turn+--    @b :: k@ to @b :: Type -> Type@). We then return an extended substitution+--    where the old @b@ (of kind @k@) maps to the new @b@ (of kind @Type -> Type@).+--+--    This step is important to do in case there are later occurrences of @b@,+--    which we must ensure have the correct kind. Otherwise, we might end up+--    with @Proxy \@(Type -> Type) (b :: k)@ on the right-hand side of the+--    default instance, which would be completely wrong.+--+-- Contrast 'substATBndrs' function with similar substitution functions:+--+-- * 'substTyVars' does not substitute into the kinds of each type variable,+--   nor does it extend the substitution. 'substTyVars' is meant for occurrences+--   of type variables, whereas 'substATBndr's is meant for binders.+--+-- * 'substTyVarBndrs' does substitute into kinds and extends the substitution,+--   but it does not apply the substitution to the variables themselves. As+--   such, 'substTyVarBndrs' returns a list of 'TyVar's rather than a list of+--   'Type's.+substATBndrs :: TCvSubst -> [TyVar] -> (TCvSubst, [Type])+substATBndrs = mapAccumL substATBndr   where-    subst_tv subst tc_tv+    substATBndr :: TCvSubst -> TyVar -> (TCvSubst, Type)+    substATBndr subst tc_tv+        -- Case (1) in the Haddocks       | Just ty <- lookupVarEnv (getTvSubstEnv subst) tc_tv       = (subst, ty)+        -- Case (2) in the Haddocks       | otherwise-      = (extendTvSubst subst tc_tv ty', ty')+      = (extendTvSubstWithClone subst tc_tv tc_tv', mkTyVarTy tc_tv')       where-        ty' = mkTyVarTy (updateTyVarKind (substTyUnchecked subst) tc_tv)+        tc_tv' = updateTyVarKind (substTy subst) tc_tv  warnMissingAT :: Name -> TcM () warnMissingAT name

@@ -64,6 +64,8 @@  import GHC.Unit.Module +import GHC.Rename.Utils (wrapGenSpan)+ import GHC.Types.Basic import GHC.Types.Error import GHC.Types.FieldLabel@@ -947,10 +949,11 @@     -- mentions this particular record selector     deflt | all dealt_with all_cons = []           | otherwise = [mkSimpleMatch CaseAlt-                            [L loc' (WildPat noExtField)]-                            (mkHsApp (L loc' (HsVar noExtField-                                         (L locn (getName rEC_SEL_ERROR_ID))))-                                     (L loc' (HsLit noComments msg_lit)))]+                            [wrapGenSpan (WildPat noExtField)]+                            (wrapGenSpan+                                (HsApp noComments+                                    (wrapGenSpan (HsVar noExtField (wrapGenSpan (getName rEC_SEL_ERROR_ID))))+                                    (wrapGenSpan (HsLit noComments msg_lit))))]          -- Do not add a default case unless there are unmatched         -- constructors.  We must take account of GADTs, else we

@@ -1,5 +1,6 @@  {-# LANGUAGE MultiWayIf      #-}+{-# LANGUAGE RecursiveDo     #-} {-# LANGUAGE TupleSections   #-}  {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}@@ -501,8 +502,17 @@ newInferExpType = new_inferExpType Nothing  newInferExpTypeFRR :: FixedRuntimeRepContext -> TcM ExpTypeFRR-newInferExpTypeFRR frr_orig = new_inferExpType (Just frr_orig)+newInferExpTypeFRR frr_orig+  = do { th_stage <- getStage+       ; if+          -- See [Wrinkle: Typed Template Haskell]+          -- in Note [hasFixedRuntimeRep] in GHC.Tc.Utils.Concrete.+          | Brack _ (TcPending {}) <- th_stage+          -> new_inferExpType Nothing +          | otherwise+          -> new_inferExpType (Just frr_orig) }+ new_inferExpType :: Maybe FixedRuntimeRepContext -> TcM ExpType new_inferExpType mb_frr_orig   = do { u <- newUnique@@ -557,20 +567,28 @@  inferResultToType :: InferResult -> TcM Type inferResultToType (IR { ir_uniq = u, ir_lvl = tc_lvl-                      , ir_ref = ref })+                      , ir_ref = ref+                      , ir_frr = mb_frr })   = do { mb_inferred_ty <- readTcRef ref        ; tau <- case mb_inferred_ty of             Just ty -> do { ensureMonoType ty                             -- See Note [inferResultToType]                           ; return ty }-            Nothing -> do { rr  <- newMetaTyVarTyAtLevel tc_lvl runtimeRepTy-                          ; tau <- newMetaTyVarTyAtLevel tc_lvl (mkTYPEapp rr)-                            -- See Note [TcLevel of ExpType]+            Nothing -> do { tau <- new_meta                           ; writeMutVar ref (Just tau)                           ; return tau }        ; traceTc "Forcing ExpType to be monomorphic:"                  (ppr u <+> text ":=" <+> ppr tau)        ; return tau }+  where+    -- See Note [TcLevel of ExpType]+    new_meta = case mb_frr of+      Nothing  ->  do { rr  <- newMetaTyVarTyAtLevel tc_lvl runtimeRepTy+                      ; newMetaTyVarTyAtLevel tc_lvl (mkTYPEapp rr) }+      Just frr -> mdo { rr  <- newConcreteTyVarAtLevel conc_orig tc_lvl runtimeRepTy+                      ; tau <- newMetaTyVarTyAtLevel tc_lvl (mkTYPEapp rr)+                      ; let conc_orig = ConcreteFRR $ FixedRuntimeRepOrigin tau frr+                      ; return tau }  {- Note [inferResultToType] ~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -893,6 +911,13 @@                         , mtv_ref   = ref                         , mtv_tclvl = tclvl }) } +newConcreteTvDetailsAtLevel :: ConcreteTvOrigin -> TcLevel -> TcM TcTyVarDetails+newConcreteTvDetailsAtLevel conc_orig tclvl+  = do { ref <- newMutVar Flexi+       ; return (MetaTv { mtv_info  = ConcreteTv conc_orig+                        , mtv_ref   = ref+                        , mtv_tclvl = tclvl }) }+ cloneMetaTyVar :: TcTyVar -> TcM TcTyVar cloneMetaTyVar tv   = assert (isTcTyVar tv) $@@ -938,7 +963,7 @@  -------------------- -- Works with both type and kind variables-writeMetaTyVar :: TcTyVar -> TcType -> TcM ()+writeMetaTyVar :: HasDebugCallStack => TcTyVar -> TcType -> TcM () -- Write into a currently-empty MetaTyVar  writeMetaTyVar tyvar ty@@ -956,7 +981,7 @@   = massertPpr False (text "Writing to non-meta tyvar" <+> ppr tyvar)  ---------------------writeMetaTyVarRef :: TcTyVar -> TcRef MetaDetails -> TcType -> TcM ()+writeMetaTyVarRef :: HasDebugCallStack => TcTyVar -> TcRef MetaDetails -> TcType -> TcM () -- Here the tyvar is for error checking only; -- the ref cell must be for the same tyvar writeMetaTyVarRef tyvar ref ty@@ -1123,6 +1148,13 @@         ; name    <- newMetaTyVarName (fsLit "p")         ; return (mkTyVarTy (mkTcTyVar name kind details)) } +newConcreteTyVarAtLevel :: ConcreteTvOrigin -> TcLevel -> TcKind -> TcM TcType+newConcreteTyVarAtLevel conc_orig tc_lvl kind+  = do  { details <- newConcreteTvDetailsAtLevel conc_orig tc_lvl+        ; name    <- newMetaTyVarName (fsLit "c")+        ; return (mkTyVarTy (mkTcTyVar name kind details)) }++ {- ********************************************************************* *                                                                      *           Finding variables to quantify over@@ -1826,6 +1858,17 @@        ; writeMetaTyVar tv manyDataConTy        ; return True } +  | isConcreteTyVar tv+    -- We don't want to quantify; but neither can we default to+    -- anything sensible.  (If it has kind RuntimeRep or Levity, as is+    -- often the case, it'll have been caught earlier by earlier+    -- cases. So in this exotic situation we just promote.  Not very+    -- satisfing, but it's very much a corner case: #23051)+    -- We should really implement the plan in #20686.+  = do { lvl <- getTcLevel+       ; _ <- promoteMetaTyVarTo lvl tv+       ; return True }+   | DefaultKindVars <- def_strat -- -XNoPolyKinds and this is a kind var: we must default it   = default_kind_var tv @@ -2240,7 +2283,7 @@ *                                                                      * ********************************************************************* -} -promoteMetaTyVarTo :: TcLevel -> TcTyVar -> TcM Bool+promoteMetaTyVarTo :: HasDebugCallStack => TcLevel -> TcTyVar -> TcM Bool -- When we float a constraint out of an implication we must restore -- invariant (WantedInv) in Note [TcLevel invariants] in GHC.Tc.Utils.TcType -- Return True <=> we did some promotion@@ -2258,7 +2301,7 @@    = return False  -- Returns whether or not *any* tyvar is defaulted-promoteTyVarSet :: TcTyVarSet -> TcM Bool+promoteTyVarSet :: HasDebugCallStack => TcTyVarSet -> TcM Bool promoteTyVarSet tvs   = do { tclvl <- getTcLevel        ; bools <- mapM (promoteMetaTyVarTo tclvl)  $

@@ -2055,10 +2055,10 @@            -- See Note [Unification preconditions], (UNTOUCHABLE) wrinkles       , cterHasNoProblem (checkTyVarEq tv1 ty2)            -- See Note [Prevent unification with type families]-      = do { can_continue_solving <- startSolvingByUnification (metaTyVarInfo tv1) ty2-           ; if not can_continue_solving-             then not_ok_so_defer-             else+      = do { mb_continue_solving <- startSolvingByUnification (metaTyVarInfo tv1) ty2+           ; case mb_continue_solving of+           { Nothing -> not_ok_so_defer+           ; Just ty2 ->         do { co_k <- uType KindLevel kind_origin (tcTypeKind ty2) (tyVarKind tv1)            ; traceTc "uUnfilledVar2 ok" $              vcat [ ppr tv1 <+> dcolon <+> ppr (tyVarKind tv1)@@ -2072,9 +2072,9 @@              then do { writeMetaTyVar tv1 ty2                      ; return (mkTcNomReflCo ty2) } -             else defer }} -- This cannot be solved now.  See GHC.Tc.Solver.Canonical-                           -- Note [Equalities with incompatible kinds] for how-                           -- this will be dealt with in the solver+             else defer }}} -- This cannot be solved now.  See GHC.Tc.Solver.Canonical+                            -- Note [Equalities with incompatible kinds] for how+                            -- this will be dealt with in the solver        | otherwise       = not_ok_so_defer@@ -2094,39 +2094,38 @@ -- | Checks (TYVAR-TV), (COERCION-HOLE) and (CONCRETE) of -- Note [Unification preconditions]; returns True if these conditions -- are satisfied. But see the Note for other preconditions, too.-startSolvingByUnification :: MetaInfo -> TcType  -- zonked-                          -> TcM Bool+startSolvingByUnification :: MetaInfo -> TcType -- zonked+                          -> TcM (Maybe TcType) startSolvingByUnification _ xi   | hasCoercionHoleTy xi  -- (COERCION-HOLE) check-  = return False+  = return Nothing startSolvingByUnification info xi   = case info of-      CycleBreakerTv -> return False+      CycleBreakerTv -> return Nothing       ConcreteTv conc_orig ->-        do { (_, not_conc_reasons) <- makeTypeConcrete conc_orig xi+        do { (xi, not_conc_reasons) <- makeTypeConcrete conc_orig xi                  -- NB: makeTypeConcrete has the side-effect of turning                  -- some TauTvs into ConcreteTvs, e.g.                  -- alpha[conc] ~# TYPE (TupleRep '[ beta[tau], IntRep ])                  -- will write `beta[tau] := beta[conc]`.                  ---                 -- We don't need to track these unifications for the purposes-                 -- of constraint solving (e.g. updating tcs_unified or tcs_unif_lvl),-                 -- as they don't unlock any further progress.+                 -- We return the new type, so that callers of this function+                 -- aren't required to zonk.            ; case not_conc_reasons of-               [] -> return True-               _  -> return False }+               [] -> return $ Just xi+               _  -> return Nothing }       TyVarTv ->         case tcGetTyVar_maybe xi of-           Nothing -> return False+           Nothing -> return Nothing            Just tv ->              case tcTyVarDetails tv of -- (TYVAR-TV) wrinkle-                SkolemTv {} -> return True-                RuntimeUnk  -> return True+                SkolemTv {} -> return $ Just xi+                RuntimeUnk  -> return $ Just xi                 MetaTv { mtv_info = info } ->                   case info of-                    TyVarTv -> return True-                    _       -> return False-      _ -> return True+                    TyVarTv -> return $ Just xi+                    _       -> return Nothing+      _ -> return $ Just xi  swapOverTyVars :: Bool -> TcTyVar -> TcTyVar -> Bool swapOverTyVars is_given tv1 tv2

@@ -56,6 +56,7 @@ import GHC.Tc.Utils.TcMType import GHC.Tc.Utils.Env   ( tcLookupGlobalOnly ) import GHC.Tc.Types.Evidence+import GHC.Tc.Errors.Types  import GHC.Core.TyCo.Ppr ( pprTyVar ) import GHC.Core.TyCon@@ -1771,7 +1772,7 @@ T9198 and #19668.  So yes, it seems worth it. -} -zonkTyVarOcc :: ZonkEnv -> TcTyVar -> TcM Type+zonkTyVarOcc :: HasDebugCallStack => ZonkEnv -> TcTyVar -> TcM Type zonkTyVarOcc env@(ZonkEnv { ze_flexi = flexi                           , ze_tv_env = tv_env                           , ze_meta_tv_env = mtv_env_ref }) tv@@ -1844,6 +1845,9 @@         | isMultiplicityTy zonked_kind         -> do { traceTc "Defaulting flexi tyvar to Many:" (pprTyVar tv)               ; return manyDataConTy }+        | Just (ConcreteFRR origin) <- isConcreteTyVar_maybe tv+        -> do { addErr $ TcRnCannotDefaultConcrete origin+              ; return (anyTypeOfKind zonked_kind) }         | otherwise         -> do { traceTc "Defaulting flexi tyvar to Any:" (pprTyVar tv)               ; return (anyTypeOfKind zonked_kind) }

@@ -45,28 +45,25 @@     -- ** Manipulating Boxity of a Demand     unboxDeeplyDmd, -    -- * Demand environments-    DmdEnv, emptyDmdEnv,-    keepAliveDmdEnv, reuseEnv,-     -- * Divergence     Divergence(..), topDiv, botDiv, exnDiv, lubDivergence, isDeadEndDiv, +    -- * Demand environments+    DmdEnv(..), addVarDmdEnv, mkTermDmdEnv, nopDmdEnv, plusDmdEnv, plusDmdEnvs,+    reuseEnv,+     -- * Demand types     DmdType(..), dmdTypeDepth,     -- ** Algebra     nopDmdType, botDmdType,-    lubDmdType, plusDmdType, multDmdType,-    -- *** PlusDmdArg-    PlusDmdArg, mkPlusDmdArg, toPlusDmdArg,+    lubDmdType, plusDmdType, multDmdType, discardArgDmds,     -- ** Other operations     peelFV, findIdDemand, addDemand, splitDmdTy, deferAfterPreciseException,-    keepAliveDmdType,      -- * Demand signatures     DmdSig(..), mkDmdSigForArity, mkClosedDmdSig,     splitDmdSig, dmdSigDmdEnv, hasDemandEnvSig,-    nopSig, botSig, isTopSig, isDeadEndSig, isDeadEndAppSig, trimBoxityDmdSig,+    nopSig, botSig, isNopSig, isDeadEndSig, isDeadEndAppSig, trimBoxityDmdSig,     -- ** Handling arity adjustments     prependArgsDmdSig, etaConvertDmdSig, @@ -85,9 +82,8 @@  import GHC.Prelude -import GHC.Types.Var ( Var, Id )+import GHC.Types.Var import GHC.Types.Var.Env-import GHC.Types.Var.Set import GHC.Types.Unique.FM import GHC.Types.Basic import GHC.Data.Maybe   ( orElse )@@ -1036,7 +1032,7 @@  argsOneShots :: DmdSig -> Arity -> [[OneShotInfo]] -- ^ See Note [Computing one-shot info]-argsOneShots (DmdSig (DmdType _ arg_ds _)) n_val_args+argsOneShots (DmdSig (DmdType _ arg_ds)) n_val_args   | unsaturated_call = []   | otherwise = go arg_ds   where@@ -1279,7 +1275,7 @@ -- defaultFvDmd (r1 `lubDivergence` r2) = defaultFvDmd r1 `lubDmd` defaultFvDmd r2 -- (See Note [Default demand on free variables and arguments] for why) --- | See Note [Asymmetry of 'plus*'], which concludes that 'plusDivergence'+-- | See Note [Asymmetry of plusDmdType], which concludes that 'plusDivergence' -- needs to be symmetric. -- Strictly speaking, we should have @plusDivergence Dunno Diverges = ExnOrDiv@. -- But that regresses in too many places (every infinite loop, basically) to be@@ -1550,112 +1546,131 @@ -}  -- Subject to Note [Default demand on free variables and arguments]-type DmdEnv = VarEnv Demand+-- | Captures the result of an evaluation of an expression, by+--+--   * Listing how the free variables of that expression have been evaluted+--     ('de_fvs')+--   * Saying whether or not evaluation would surely diverge ('de_div')+--+-- See Note [Demand env Equality].+data DmdEnv = DE { de_fvs :: !(VarEnv Demand), de_div :: !Divergence } -emptyDmdEnv :: DmdEnv-emptyDmdEnv = emptyVarEnv+instance Eq DmdEnv where+  DE fv1 div1 == DE fv2 div2+    = div1 == div2 && canonicalise div1 fv1 == canonicalise div2 fv2+    where+      canonicalise div fv = filterUFM (/= defaultFvDmd div) fv +mkEmptyDmdEnv :: Divergence -> DmdEnv+mkEmptyDmdEnv div = DE emptyVarEnv div++-- | Build a potentially terminating 'DmdEnv' from a finite map that says what+-- has been evaluated so far+mkTermDmdEnv :: VarEnv Demand -> DmdEnv+mkTermDmdEnv fvs = DE fvs topDiv++nopDmdEnv :: DmdEnv+nopDmdEnv = mkEmptyDmdEnv topDiv++botDmdEnv :: DmdEnv+botDmdEnv = mkEmptyDmdEnv botDiv++exnDmdEnv :: DmdEnv+exnDmdEnv = mkEmptyDmdEnv exnDiv++lubDmdEnv :: DmdEnv -> DmdEnv -> DmdEnv+lubDmdEnv (DE fv1 d1) (DE fv2 d2) = DE lub_fv lub_div+  where+    -- See Note [Demand env Equality]+    lub_fv  = plusVarEnv_CD lubDmd fv1 (defaultFvDmd d1) fv2 (defaultFvDmd d2)+    lub_div = lubDivergence d1 d2++addVarDmdEnv :: DmdEnv -> Id -> Demand -> DmdEnv+addVarDmdEnv env@(DE fvs div) id dmd+  = DE (extendVarEnv fvs id (dmd `plusDmd` lookupDmdEnv env id)) div++plusDmdEnv :: DmdEnv -> DmdEnv -> DmdEnv+plusDmdEnv (DE fv1 d1) (DE fv2 d2)+  -- In contrast to Note [Asymmetry of plusDmdType], this function is symmetric.+  | isEmptyVarEnv fv2, defaultFvDmd d2 == absDmd+  = DE fv1 (d1 `plusDivergence` d2) -- a very common case that is much more efficient+  | isEmptyVarEnv fv1, defaultFvDmd d1 == absDmd+  = DE fv2 (d1 `plusDivergence` d2) -- another very common case that is much more efficient+  | otherwise+  = DE (plusVarEnv_CD plusDmd fv1 (defaultFvDmd d1) fv2 (defaultFvDmd d2))+       (d1 `plusDivergence` d2)++-- | 'DmdEnv' is a monoid via 'plusDmdEnv' and 'nopDmdEnv'; this is its 'msum'+plusDmdEnvs :: [DmdEnv] -> DmdEnv+plusDmdEnvs []   = nopDmdEnv+plusDmdEnvs pdas = foldl1' plusDmdEnv pdas+ multDmdEnv :: Card -> DmdEnv -> DmdEnv-multDmdEnv C_11 env = env-multDmdEnv C_00 _   = emptyDmdEnv-multDmdEnv n    env = mapVarEnv (multDmd n) env+multDmdEnv C_11 env          = env+multDmdEnv C_00 _            = nopDmdEnv+multDmdEnv n    (DE fvs div) = DE (mapVarEnv (multDmd n) fvs) (multDivergence n div)  reuseEnv :: DmdEnv -> DmdEnv reuseEnv = multDmdEnv C_1N --- | @keepAliveDmdType dt vs@ makes sure that the Ids in @vs@ have--- /some/ usage in the returned demand types -- they are not Absent.--- See Note [Absence analysis for stable unfoldings and RULES]---     in "GHC.Core.Opt.DmdAnal".-keepAliveDmdEnv :: DmdEnv -> IdSet -> DmdEnv-keepAliveDmdEnv env vs-  = nonDetStrictFoldVarSet add env vs-  where-    add :: Id -> DmdEnv -> DmdEnv-    add v env = extendVarEnv_C add_dmd env v topDmd+lookupDmdEnv :: DmdEnv -> Id -> Demand+-- See Note [Default demand on free variables and arguments]+lookupDmdEnv (DE fv div) id = lookupVarEnv fv id `orElse` defaultFvDmd div -    add_dmd :: Demand -> Demand -> Demand-    -- If the existing usage is Absent, make it used-    -- Otherwise leave it alone-    add_dmd dmd _ | isAbsDmd dmd = topDmd-                  | otherwise    = dmd+delDmdEnv :: DmdEnv -> Id -> DmdEnv+delDmdEnv (DE fv div) id = DE (fv `delVarEnv` id) div  -- | Characterises how an expression -----    * Evaluates its free variables ('dt_env')+--    * Evaluates its free variables ('dt_env') including divergence info --    * Evaluates its arguments ('dt_args')---    * Diverges on every code path or not ('dt_div') ----- Equality is defined modulo 'defaultFvDmd's in 'dt_env'.--- See Note [Demand type Equality]. data DmdType   = DmdType-  { dt_env  :: !DmdEnv     -- ^ Demand on explicitly-mentioned free variables+  { dt_env  :: !DmdEnv     -- ^ Demands on free variables.+                           -- See Note [Demand type Divergence]   , dt_args :: ![Demand]   -- ^ Demand on arguments-  , dt_div  :: !Divergence -- ^ Whether evaluation diverges.-                          -- See Note [Demand type Divergence]   } --- | See Note [Demand type Equality].+-- | See Note [Demand env Equality]. instance Eq DmdType where-  (==) (DmdType fv1 ds1 div1)-       (DmdType fv2 ds2 div2) =  div1 == div2 && ds1 == ds2 -- cheap checks first-                              && canonicalise div1 fv1 == canonicalise div2 fv2-       where-         canonicalise div fv = filterUFM (/= defaultFvDmd div) fv+  DmdType env1 ds1 == DmdType env2 ds2+    = ds1 == ds2 -- cheap checks first+      && env1 == env2  -- | Compute the least upper bound of two 'DmdType's elicited /by the same -- incoming demand/! lubDmdType :: DmdType -> DmdType -> DmdType-lubDmdType d1 d2-  = DmdType lub_fv lub_ds lub_div+lubDmdType d1 d2 = DmdType lub_fv lub_ds   where     n = max (dmdTypeDepth d1) (dmdTypeDepth d2)-    (DmdType fv1 ds1 r1) = etaExpandDmdType n d1-    (DmdType fv2 ds2 r2) = etaExpandDmdType n d2--    -- See Note [Demand type Equality]-    lub_fv  = plusVarEnv_CD lubDmd fv1 (defaultFvDmd r1) fv2 (defaultFvDmd r2)+    (DmdType fv1 ds1) = etaExpandDmdType n d1+    (DmdType fv2 ds2) = etaExpandDmdType n d2     lub_ds  = zipWithEqual "lubDmdType" lubDmd ds1 ds2-    lub_div = lubDivergence r1 r2--type PlusDmdArg = (DmdEnv, Divergence)--mkPlusDmdArg :: DmdEnv -> PlusDmdArg-mkPlusDmdArg env = (env, topDiv)+    lub_fv = lubDmdEnv fv1 fv2 -toPlusDmdArg :: DmdType -> PlusDmdArg-toPlusDmdArg (DmdType fv _ r) = (fv, r)+discardArgDmds :: DmdType -> DmdEnv+discardArgDmds (DmdType fv _) = fv -plusDmdType :: DmdType -> PlusDmdArg -> DmdType-plusDmdType (DmdType fv1 ds1 r1) (fv2, t2)-    -- See Note [Asymmetry of 'plus*']-    -- 'plus' takes the argument/result info from its *first* arg,-    -- using its second arg just for its free-var info.-  | isEmptyVarEnv fv2, defaultFvDmd t2 == absDmd-  = DmdType fv1 ds1 (r1 `plusDivergence` t2) -- a very common case that is much more efficient-  | otherwise-  = DmdType (plusVarEnv_CD plusDmd fv1 (defaultFvDmd r1) fv2 (defaultFvDmd t2))-            ds1-            (r1 `plusDivergence` t2)+plusDmdType :: DmdType -> DmdEnv -> DmdType+plusDmdType (DmdType fv ds) fv'+  -- See Note [Asymmetry of plusDmdType]+  -- 'DmdEnv' forms a (monoidal) action on 'DmdType' via this operation.+  = DmdType (plusDmdEnv fv fv') ds  botDmdType :: DmdType-botDmdType = DmdType emptyDmdEnv [] botDiv+botDmdType = DmdType botDmdEnv []  -- | The demand type of doing nothing (lazy, absent, no Divergence -- information). Note that it is ''not'' the top of the lattice (which would be -- "may use everything"), so it is (no longer) called topDmdType. nopDmdType :: DmdType-nopDmdType = DmdType emptyDmdEnv [] topDiv--isTopDmdType :: DmdType -> Bool-isTopDmdType (DmdType env args div)-  = div == topDiv && null args && isEmptyVarEnv env+nopDmdType = DmdType nopDmdEnv []  -- | The demand type of an unspecified expression that is guaranteed to -- throw a (precise or imprecise) exception or diverge. exnDmdType :: DmdType-exnDmdType = DmdType emptyDmdEnv [] exnDiv+exnDmdType = DmdType exnDmdEnv []  dmdTypeDepth :: DmdType -> Arity dmdTypeDepth = length . dt_args@@ -1664,7 +1679,7 @@ -- expansion, where n must not be lower than the demand types depth. -- It appends the argument list with the correct 'defaultArgDmd'. etaExpandDmdType :: Arity -> DmdType -> DmdType-etaExpandDmdType n d@DmdType{dt_args = ds, dt_div = div}+etaExpandDmdType n d@DmdType{dt_args = ds, dt_env = env}   | n == depth = d   | n >  depth = d{dt_args = inc_ds}   | otherwise  = pprPanic "etaExpandDmdType: arity decrease" (ppr n $$ ppr d)@@ -1676,7 +1691,7 @@         --  * Divergence is still valid:         --    - A dead end after 2 arguments stays a dead end after 3 arguments         --    - The remaining case is Dunno, which is already topDiv-        inc_ds = take n (ds ++ repeat (defaultArgDmd div))+        inc_ds = take n (ds ++ repeat (defaultArgDmd (de_div env)))  -- | A conservative approximation for a given 'DmdType' in case of an arity -- decrease. Currently, it's just nopDmdType.@@ -1688,30 +1703,27 @@ -- We already have a suitable demand on all -- free vars, so no need to add more! splitDmdTy ty@DmdType{dt_args=dmd:args} = (dmd, ty{dt_args=args})-splitDmdTy ty@DmdType{dt_div=div}       = (defaultArgDmd div, ty)+splitDmdTy ty@DmdType{dt_env=env}       = (defaultArgDmd (de_div env), ty)  multDmdType :: Card -> DmdType -> DmdType-multDmdType n (DmdType fv args res_ty)+multDmdType n (DmdType fv args)   = -- pprTrace "multDmdType" (ppr n $$ ppr fv $$ ppr (multDmdEnv n fv)) $     DmdType (multDmdEnv n fv)             (map (multDmd n) args)-            (multDivergence n res_ty)  peelFV :: DmdType -> Var -> (DmdType, Demand)-peelFV (DmdType fv ds res) id = -- pprTrace "rfv" (ppr id <+> ppr dmd $$ ppr fv)-                               (DmdType fv' ds res, dmd)+peelFV (DmdType fv ds) id = -- pprTrace "rfv" (ppr id <+> ppr dmd $$ ppr fv)+                            (DmdType fv' ds, dmd)   where   -- Force these arguments so that old `Env` is not retained.-  !fv' = fv `delVarEnv` id-  -- See Note [Default demand on free variables and arguments]-  !dmd  = lookupVarEnv fv id `orElse` defaultFvDmd res+  !fv' = fv `delDmdEnv` id+  !dmd = lookupDmdEnv fv id  addDemand :: Demand -> DmdType -> DmdType-addDemand dmd (DmdType fv ds res) = DmdType fv (dmd:ds) res+addDemand dmd (DmdType fv ds) = DmdType fv (dmd:ds)  findIdDemand :: DmdType -> Var -> Demand-findIdDemand (DmdType fv _ res) id-  = lookupVarEnv fv id `orElse` defaultFvDmd res+findIdDemand (DmdType fv _) id = lookupDmdEnv fv id  -- | When e is evaluated after executing an IO action that may throw a precise -- exception, we act as if there is an additional control flow path that is@@ -1727,11 +1739,6 @@ deferAfterPreciseException :: DmdType -> DmdType deferAfterPreciseException = lubDmdType exnDmdType --- | See 'keepAliveDmdEnv'.-keepAliveDmdType :: DmdType -> VarSet -> DmdType-keepAliveDmdType (DmdType fvs ds res) vars =-  DmdType (fvs `keepAliveDmdEnv` vars) ds res- {- Note [deferAfterPreciseException] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The big picture is in Note [Precise exceptions and strictness analysis]@@ -1787,32 +1794,25 @@ strong enough to unleash err's signature and hence we see that the whole expression diverges! -Note [Demand type Equality]+Note [Demand env Equality] ~~~~~~~~~~~~~~~~~~~~~~~~~~~-What is the difference between the DmdType <L>{x->A} and <L>?+What is the difference between the Demand env {x->A} and {}? Answer: There is none! They have the exact same semantics, because any var that-is not mentioned in 'dt_env' implicitly has demand 'defaultFvDmd', based on-the divergence of the demand type 'dt_div'.-Similarly, <B>b{x->B, y->A} is the same as <B>b{y->A}, because the default FV-demand of BotDiv is B. But neither is equal to <B>b, because y has demand B in+is not mentioned in 'de_fvs' implicitly has demand 'defaultFvDmd', based on+the divergence of the demand env 'de_div'.+Similarly, b{x->B, y->A} is the same as b{y->A}, because the default FV+demand of BotDiv is B. But neither is equal to b{}, because y has demand B in the latter, not A as before. -NB: 'dt_env' technically can't stand for its own, because it doesn't tell us the-demand on FVs that don't appear in the DmdEnv. Hence 'PlusDmdArg' carries along-a 'Divergence', for example.--The Eq instance of DmdType must reflect that, otherwise we can get into monotonicity-issues during fixed-point iteration (<L>{x->A} /= <L> /= <L>{x->A} /= ...).-It does so by filtering out any default FV demands prior to comparing 'dt_env'.-An alternative would be to maintain an invariant that there are no default FV demands-in 'dt_env' to begin with, but that seems more involved to maintain in the current-implementation.+The Eq instance of DmdEnv must reflect that, otherwise we can get into monotonicity+issues during fixed-point iteration ({x->A} /= {} /= {x->A} /= ...).+It does so by filtering out any default FV demands prior to comparing 'de_fvs'. -Note that 'lubDmdType' maintains this kind of equality by using 'plusVarEnv_CD',-involving 'defaultFvDmd' for any entries present in one 'dt_env' but not the+Note that 'lubDmdEnv' maintains this kind of equality by using 'plusVarEnv_CD',+involving 'defaultFvDmd' for any entries present in one 'de_fvs' but not the other. -Note [Asymmetry of 'plus*']+Note [Asymmetry of plusDmdType] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ 'plus' for DmdTypes is *asymmetrical*, because there can only one be one type contributing argument demands!  For example, given (e1 e2), we get@@ -1968,21 +1968,21 @@ -- | Turns a 'DmdType' computed for the particular 'Arity' into a 'DmdSig' -- unleashable at that arity. See Note [Understanding DmdType and DmdSig]. mkDmdSigForArity :: Arity -> DmdType -> DmdSig-mkDmdSigForArity arity dmd_ty@(DmdType fvs args div)-  | arity < dmdTypeDepth dmd_ty = DmdSig $ DmdType fvs (take arity args) div+mkDmdSigForArity arity dmd_ty@(DmdType fvs args)+  | arity < dmdTypeDepth dmd_ty = DmdSig $ DmdType fvs (take arity args)   | otherwise                   = DmdSig (etaExpandDmdType arity dmd_ty)  mkClosedDmdSig :: [Demand] -> Divergence -> DmdSig-mkClosedDmdSig ds res = mkDmdSigForArity (length ds) (DmdType emptyDmdEnv ds res)+mkClosedDmdSig ds div = mkDmdSigForArity (length ds) (DmdType (mkEmptyDmdEnv div) ds)  splitDmdSig :: DmdSig -> ([Demand], Divergence)-splitDmdSig (DmdSig (DmdType _ dmds res)) = (dmds, res)+splitDmdSig (DmdSig (DmdType env dmds)) = (dmds, de_div env)  dmdSigDmdEnv :: DmdSig -> DmdEnv-dmdSigDmdEnv (DmdSig (DmdType env _ _)) = env+dmdSigDmdEnv (DmdSig (DmdType env _)) = env  hasDemandEnvSig :: DmdSig -> Bool-hasDemandEnvSig = not . isEmptyVarEnv . dmdSigDmdEnv+hasDemandEnvSig = not . isEmptyVarEnv . de_fvs . dmdSigDmdEnv  botSig :: DmdSig botSig = DmdSig botDmdType@@ -1990,17 +1990,17 @@ nopSig :: DmdSig nopSig = DmdSig nopDmdType -isTopSig :: DmdSig -> Bool-isTopSig (DmdSig ty) = isTopDmdType ty+isNopSig :: DmdSig -> Bool+isNopSig (DmdSig ty) = ty == nopDmdType  -- | True if the signature diverges or throws an exception in a saturated call. -- See Note [Dead ends]. isDeadEndSig :: DmdSig -> Bool-isDeadEndSig (DmdSig (DmdType _ _ res)) = isDeadEndDiv res+isDeadEndSig (DmdSig (DmdType env _)) = isDeadEndDiv (de_div env)  -- | True when the signature indicates all arguments are boxed onlyBoxedArguments :: DmdSig -> Bool-onlyBoxedArguments (DmdSig (DmdType _ dmds _)) = all demandIsBoxed dmds+onlyBoxedArguments (DmdSig (DmdType _ dmds)) = all demandIsBoxed dmds  where    demandIsBoxed BotDmd    = True    demandIsBoxed AbsDmd    = True@@ -2020,12 +2020,15 @@ -- Hence this function conservatively returns False in that case. -- See Note [Dead ends]. isDeadEndAppSig :: DmdSig -> Int -> Bool-isDeadEndAppSig (DmdSig (DmdType _ ds res)) n-  = isDeadEndDiv res && not (lengthExceeds ds n)+isDeadEndAppSig (DmdSig (DmdType env ds)) n+  = isDeadEndDiv (de_div env) && not (lengthExceeds ds n) +trimBoxityDmdEnv :: DmdEnv -> DmdEnv+trimBoxityDmdEnv (DE fvs div) = DE (mapVarEnv trimBoxity fvs) div+ trimBoxityDmdType :: DmdType -> DmdType-trimBoxityDmdType (DmdType fvs ds res) =-  DmdType (mapVarEnv trimBoxity fvs) (map trimBoxity ds) res+trimBoxityDmdType (DmdType env ds) =+  DmdType (trimBoxityDmdEnv env) (map trimBoxity ds)  trimBoxityDmdSig :: DmdSig -> DmdSig trimBoxityDmdSig = coerce trimBoxityDmdType@@ -2034,12 +2037,10 @@ -- ^ Add extra ('topDmd') arguments to a strictness signature. -- In contrast to 'etaConvertDmdSig', this /prepends/ additional argument -- demands. This is used by FloatOut.-prependArgsDmdSig new_args sig@(DmdSig dmd_ty@(DmdType env dmds res))-  | new_args == 0       = sig-  | isTopDmdType dmd_ty = sig-  | new_args < 0        = pprPanic "prependArgsDmdSig: negative new_args"-                                   (ppr new_args $$ ppr sig)-  | otherwise           = DmdSig (DmdType env dmds' res)+prependArgsDmdSig new_args sig@(DmdSig dmd_ty@(DmdType env dmds))+  | new_args == 0        = sig+  | dmd_ty == nopDmdType = sig+  | otherwise            = DmdSig (DmdType env dmds')   where     dmds' = replicate new_args topDmd ++ dmds @@ -2080,7 +2081,7 @@ -- Given a function's 'DmdSig' and a 'SubDemand' for the evaluation context, -- return how the function evaluates its free variables and arguments. dmdTransformSig :: DmdSig -> DmdTransformer-dmdTransformSig (DmdSig dmd_ty@(DmdType _ arg_ds _)) sd+dmdTransformSig (DmdSig dmd_ty@(DmdType _ arg_ds)) sd   = multDmdType (fst $ peelManyCalls (length arg_ds) sd) dmd_ty     -- see Note [Demands from unsaturated function calls]     -- and Note [What are demand signatures?]@@ -2095,7 +2096,7 @@   where     arity = length str_marks     (n, body_sd) = peelManyCalls arity sd-    mk_body_ty n dmds = DmdType emptyDmdEnv (zipWith (bump n) str_marks dmds) topDiv+    mk_body_ty n dmds = DmdType nopDmdEnv (zipWith (bump n) str_marks dmds)     bump n str dmd | isMarkedStrict str = multDmd n (plusDmd str_field_dmd dmd)                    | otherwise          = multDmd n dmd     str_field_dmd = C_01 :* seqSubDmd -- Why not C_11? See Note [Data-con worker strictness]@@ -2106,11 +2107,11 @@ dmdTransformDictSelSig :: DmdSig -> DmdTransformer -- NB: This currently doesn't handle newtype dictionaries. -- It should simply apply call_sd directly to the dictionary, I suppose.-dmdTransformDictSelSig (DmdSig (DmdType _ [_ :* prod] _)) call_sd+dmdTransformDictSelSig (DmdSig (DmdType _ [_ :* prod])) call_sd    | (n, sd') <- peelCallDmd call_sd    , Prod _ sig_ds <- prod    = multDmdType n $-     DmdType emptyDmdEnv [C_11 :* mkProd Unboxed (map (enhance sd') sig_ds)] topDiv+     DmdType nopDmdEnv [C_11 :* mkProd Unboxed (map (enhance sd') sig_ds)]    | otherwise    = nopDmdType -- See Note [Demand transformer for a dictionary selector]   where@@ -2232,9 +2233,12 @@ it should not fall over. -} +zapDmdEnv :: DmdEnv -> DmdEnv+zapDmdEnv (DE _ div) = mkEmptyDmdEnv div+ -- | Remove the demand environment from the signature. zapDmdEnvSig :: DmdSig -> DmdSig-zapDmdEnvSig (DmdSig (DmdType _ ds r)) = mkClosedDmdSig ds r+zapDmdEnvSig (DmdSig (DmdType env ds)) = DmdSig (DmdType (zapDmdEnv env) ds)  zapUsageDemand :: Demand -> Demand -- Remove the usage info, but not the strictness info, from the demand@@ -2255,8 +2259,8 @@ -- | Remove all `C_01 :*` info (but not `CM` sub-demands) from the strictness --   signature zapUsedOnceSig :: DmdSig -> DmdSig-zapUsedOnceSig (DmdSig (DmdType env ds r))-    = DmdSig (DmdType env (map zapUsedOnceDemand ds) r)+zapUsedOnceSig (DmdSig (DmdType env ds))+    = DmdSig (DmdType env (map zapUsedOnceDemand ds))  data KillFlags = KillFlags     { kf_abs         :: Bool@@ -2341,11 +2345,11 @@ seqDemandList = foldr (seq . seqDemand) ()  seqDmdType :: DmdType -> ()-seqDmdType (DmdType env ds res) =-  seqDmdEnv env `seq` seqDemandList ds `seq` res `seq` ()+seqDmdType (DmdType env ds) =+  seqDmdEnv env `seq` seqDemandList ds `seq` ()  seqDmdEnv :: DmdEnv -> ()-seqDmdEnv env = seqEltsUFM seqDemand env+seqDmdEnv (DE fvs _) = seqEltsUFM seqDemand fvs  seqDmdSig :: DmdSig -> () seqDmdSig (DmdSig ty) = seqDmdType ty@@ -2454,17 +2458,20 @@   ppr ExnOrDiv = char 'x' -- for e(x)ception   ppr Dunno    = empty -instance Outputable DmdType where-  ppr (DmdType fv ds res)-    = hsep [hcat (map (angleBrackets . ppr) ds) <> ppr res,-            if null fv_elts then empty-            else braces (fsep (map pp_elt fv_elts))]+instance Outputable DmdEnv where+  ppr (DE fvs div)+    = ppr div <> if null fv_elts then empty+                 else braces (fsep (map pp_elt fv_elts))     where       pp_elt (uniq, dmd) = ppr uniq <> text "->" <> ppr dmd-      fv_elts = nonDetUFMToList fv+      fv_elts = nonDetUFMToList fvs         -- It's OK to use nonDetUFMToList here because we only do it for         -- pretty printing +instance Outputable DmdType where+  ppr (DmdType fv ds)+    = hcat (map (angleBrackets . ppr) ds) <> ppr fv+ instance Outputable DmdSig where    ppr (DmdSig ty) = ppr ty @@ -2513,15 +2520,6 @@       2 -> Prod <$> get bh <*> get bh       _ -> pprPanic "Binary:SubDemand" (ppr (fromIntegral h :: Int)) -instance Binary DmdSig where-  put_ bh (DmdSig aa) = put_ bh aa-  get bh = DmdSig <$> get bh--instance Binary DmdType where-  -- Ignore DmdEnv when spitting out the DmdType-  put_ bh (DmdType _ ds dr) = put_ bh ds *> put_ bh dr-  get bh = DmdType emptyDmdEnv <$> get bh <*> get bh- instance Binary Divergence where   put_ bh Dunno    = putByte bh 0   put_ bh ExnOrDiv = putByte bh 1@@ -2533,3 +2531,16 @@       1 -> return ExnOrDiv       2 -> return Diverges       _ -> pprPanic "Binary:Divergence" (ppr (fromIntegral h :: Int))++instance Binary DmdEnv where+  -- Ignore VarEnv when spitting out the DmdType+  put_ bh (DE _ d) = put_ bh d+  get bh = DE emptyVarEnv <$> get bh++instance Binary DmdType where+  put_ bh (DmdType fv ds) = put_ bh fv *> put_ bh ds+  get bh = DmdType <$> get bh <*> get bh++instance Binary DmdSig where+  put_ bh (DmdSig aa) = put_ bh aa+  get bh = DmdSig <$> get bh

@@ -695,6 +695,8 @@ setIdCallArity :: Id -> Arity -> Id setIdCallArity id arity = modifyIdInfo (`setCallArityInfo` arity) id +-- | This function counts all arguments post-unarisation, which includes+-- arguments with no runtime representation -- see Note [Unarisation and arity] idFunRepArity :: Id -> RepArity idFunRepArity x = countFunRepArgs (idArity x) (idType x) 

@@ -372,6 +372,7 @@         --         -- See documentation of the getters for what these packed fields mean.         lfInfo          :: !(Maybe LambdaFormInfo),+        -- ^ See Note [The LFInfo of Imported Ids] in GHC.StgToCmm.Closure          -- See documentation of the getters for what these packed fields mean.         tagSig          :: !(Maybe TagSig)@@ -451,7 +452,7 @@ oneShotInfo = bitfieldGetOneShotInfo . bitfield  -- | 'Id' arity, as computed by "GHC.Core.Opt.Arity". Specifies how many arguments--- this 'Id' has to be applied to before it doesn any meaningful work.+-- this 'Id' has to be applied to before it does any meaningful work. arityInfo :: IdInfo -> ArityInfo arityInfo = bitfieldGetArityInfo . bitfield 

@@ -1075,13 +1075,13 @@ putBS bh bs =   BS.unsafeUseAsCStringLen bs $ \(ptr, l) -> do     put_ bh l-    putPrim bh l (\op -> BS.memcpy op (castPtr ptr) l)+    putPrim bh l (\op -> copyBytes op (castPtr ptr) l)  getBS :: BinHandle -> IO ByteString getBS bh = do   l <- get bh :: IO Int   BS.create l $ \dest -> do-    getPrim bh l (\src -> BS.memcpy dest src l)+    getPrim bh l (\src -> copyBytes dest src l)  instance Binary ByteString where   put_ bh f = putBS bh f

@@ -900,6 +900,12 @@     ppr EQ = text "EQ"     ppr GT = text "GT" +instance Outputable Int8 where+   ppr n = integer $ fromIntegral n++instance Outputable Int16 where+   ppr n = integer $ fromIntegral n+ instance Outputable Int32 where    ppr n = integer $ fromIntegral n @@ -911,6 +917,9 @@  instance Outputable Integer where     ppr n = integer n++instance Outputable Word8 where+    ppr n = integer $ fromIntegral n  instance Outputable Word16 where     ppr n = integer $ fromIntegral n

@@ -3,7 +3,7 @@ -- ./configure.  Make sure you are editing ghc.cabal.in, not ghc.cabal.  Name: ghc-Version: 9.4.5+Version: 9.4.6 License: BSD-3-Clause License-File: LICENSE Author: The GHC Team@@ -91,9 +91,9 @@                    transformers == 0.5.*,                    exceptions == 0.10.*,                    stm,-                   ghc-boot   == 9.4.5,-                   ghc-heap   == 9.4.5,-                   ghci == 9.4.5+                   ghc-boot   == 9.4.6,+                   ghc-heap   == 9.4.6,+                   ghci == 9.4.6      if os(windows)         Build-Depends: Win32  >= 2.3 && < 2.13