ghc 9.4.4 → 9.4.5

raw patch · 59 files changed

+1217/−604 lines, 59 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

• GHC.hs +10/−2
• GHC/ByteCode/Types.hs +10/−8
• GHC/Cmm/Lexer.hs +2/−2
• GHC/CmmToAsm.hs +15/−0
• GHC/CmmToAsm/AArch64/CodeGen.hs +35/−16
• GHC/CmmToAsm/AArch64/Instr.hs +80/−11
• GHC/CmmToAsm/Reg/Graph/TrivColorable.hs +2/−4
• GHC/CmmToAsm/X86/CodeGen.hs +1/−1
• GHC/Core.hs +85/−16
• GHC/Core/Opt/ConstantFold.hs +2/−7
• GHC/Core/Opt/DmdAnal.hs +31/−7
• GHC/Core/Opt/FloatIn.hs +159/−104
• GHC/Core/Opt/OccurAnal.hs +27/−20
• GHC/Core/Opt/Simplify.hs +2/−2
• GHC/Core/Opt/SpecConstr.hs +102/−61
• GHC/Core/Opt/Specialise.hs +28/−2
• GHC/Core/Opt/WorkWrap/Utils.hs +60/−18
• GHC/Core/Type.hs +1/−1
• GHC/Core/Unify.hs +115/−30
• GHC/Core/Utils.hs +1/−1
• GHC/CoreToIface.hs +16/−0
• GHC/Driver/Errors/Ppr.hs +8/−7
• GHC/Driver/Errors/Types.hs +3/−3
• GHC/Driver/Main.hs +19/−12
• GHC/Driver/Make.hs +26/−19
• GHC/Driver/Pipeline/Execute.hs +25/−13
• GHC/Hs/Utils.hs +1/−1
• GHC/HsToCore/Usage.hs +5/−2
• GHC/Iface/Ext/Ast.hs +1/−1
• GHC/Iface/Load.hs +4/−2
• GHC/Iface/Recomp.hs +15/−12
• GHC/Iface/Tidy.hs +2/−1
• GHC/IfaceToCore.hs +17/−1
• GHC/Parser/HaddockLex.hs +2/−2
• GHC/Parser/Lexer.hs +2/−2
• GHC/Rename/Bind.hs +47/−10
• GHC/Runtime/Eval.hs +10/−2
• GHC/StgToByteCode.hs +3/−4
• GHC/Tc/Gen/Arrow.hs +1/−1
• GHC/Tc/Gen/Bind.hs +9/−25
• GHC/Tc/Gen/Match.hs +17/−36
• GHC/Tc/Gen/Match.hs-boot +2/−2
• GHC/Tc/Solver/Interact.hs +48/−41
• GHC/Tc/Solver/Monad.hs +2/−2
• GHC/Tc/Solver/Types.hs +17/−9
• GHC/Tc/TyCl.hs +1/−44
• GHC/Tc/TyCl/PatSyn.hs +1/−1
• GHC/Tc/Types/Constraint.hs +18/−11
• GHC/Tc/Validity.hs +51/−1
• GHC/ThToHs.hs +1/−1
• GHC/Types/Name.hs +1/−1
• GHC/Unit/Env.hs +4/−1
• GHC/Unit/Finder.hs +4/−1
• GHC/Unit/Module/Deps.hs +10/−2
• GHC/Unit/Module/Graph.hs +3/−3
• Language/Haskell/Syntax/Expr.hs +25/−7
• cbits/keepCAFsForGHCi.c +23/−3
• ghc-llvm-version.h +1/−1
• ghc.cabal +4/−4

@@ -360,6 +360,7 @@ import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Utils.Logger import GHC.Utils.Fingerprint @@ -561,7 +562,12 @@  initGhcMonad :: GhcMonad m => Maybe FilePath -> m () initGhcMonad mb_top_dir-  = do { env <- liftIO $+  = do { -- The call to c_keepCAFsForGHCi must not be optimized away. Even in non-debug builds.+         -- So we can't use assertM here.+         -- See Note [keepCAFsForGHCi] in keepCAFsForGHCi.c for details about why.+         !keep_cafs <- liftIO $ c_keepCAFsForGHCi+       ; massert keep_cafs+       ; env <- liftIO $                 do { top_dir <- findTopDir mb_top_dir                    ; mySettings <- initSysTools top_dir                    ; myLlvmConfig <- lazyInitLlvmConfig top_dir@@ -607,7 +613,6 @@         arch = platformArch platform         tablesNextToCode = platformTablesNextToCode platform - -- %************************************************************************ -- %*                                                                      * --             Flags & settings@@ -1994,3 +1999,6 @@  mkApiErr :: DynFlags -> SDoc -> GhcApiError mkApiErr dflags msg = GhcApiError (showSDoc dflags msg)++foreign import ccall unsafe "keepCAFsForGHCi"+    c_keepCAFsForGHCi   :: IO Bool

@@ -22,12 +22,10 @@  import GHC.Data.FastString import GHC.Data.SizedSeq-import GHC.Types.Id import GHC.Types.Name import GHC.Types.Name.Env import GHC.Utils.Outputable import GHC.Builtin.PrimOps-import GHC.Core.Type import GHC.Types.SrcLoc import GHCi.BreakArray import GHCi.RemoteTypes@@ -40,10 +38,10 @@ import Data.ByteString (ByteString) import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap-import Data.Maybe (catMaybes) import qualified GHC.Exts.Heap as Heap import GHC.Stack.CCS import GHC.Cmm.Expr ( GlobalRegSet, emptyRegSet, regSetToList )+import GHC.Iface.Syntax  -- ----------------------------------------------------------------------------- -- Compiled Byte Code@@ -163,18 +161,22 @@   rnf x = x `seq` ()  -- | Information about a breakpoint that we know at code-generation time+-- In order to be used, this needs to be hydrated relative to the current HscEnv by+-- 'hydrateCgBreakInfo'. Everything here can be fully forced and that's critical for+-- preventing space leaks (see #22530) data CgBreakInfo    = CgBreakInfo-   { cgb_vars   :: [Maybe (Id,Word16)]-   , cgb_resty  :: Type+   { cgb_tyvars :: ![IfaceTvBndr] -- ^ Type variables in scope at the breakpoint+   , cgb_vars   :: ![Maybe (IfaceIdBndr, Word16)]+   , cgb_resty  :: !IfaceType    } -- See Note [Syncing breakpoint info] in GHC.Runtime.Eval --- Not a real NFData instance because we can't rnf Id or Type seqCgBreakInfo :: CgBreakInfo -> () seqCgBreakInfo CgBreakInfo{..} =-  rnf (map snd (catMaybes (cgb_vars))) `seq`-  seqType cgb_resty+    rnf cgb_tyvars `seq`+    rnf cgb_vars `seq`+    rnf cgb_resty  instance Outputable UnlinkedBCO where    ppr (UnlinkedBCO nm _arity _insns _bitmap lits ptrs)

@@ -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.4-src/ghc-9.4.4/compiler/GHC/Cmm/Lexer.x" #-}+{-# LINE 13 "_build/source-dist/ghc-9.4.5-src/ghc-9.4.5/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.4-src/ghc-9.4.4/compiler/GHC/Cmm/Lexer.x" #-}+{-# LINE 133 "_build/source-dist/ghc-9.4.5-src/ghc-9.4.5/compiler/GHC/Cmm/Lexer.x" #-} data CmmToken   = CmmT_SpecChar  Char   | CmmT_DotDot

@@ -808,6 +808,19 @@ -- ----------------------------------------------------------------------------- -- Shortcut branches +-- Note [No asm-shortcutting on Darwin]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- Asm-shortcutting may produce relative references to symbols defined in+-- other compilation units. This is not something that MachO relocations+-- support (see #21972). For this reason we disable the optimisation on Darwin.+-- We do so in the backend without a warning since this flag is enabled by+-- `-O2`.+--+-- Another way to address this issue would be to rather implement a+-- PLT-relocatable jump-table strategy. However, this would only benefit Darwin+-- and does not seem worth the effort as this optimisation generally doesn't+-- offer terribly great benefits.+ shortcutBranches         :: forall statics instr jumpDest. (Outputable jumpDest)         => NCGConfig@@ -818,6 +831,8 @@  shortcutBranches config ncgImpl tops weights   | ncgEnableShortcutting config+    -- See Note [No asm-shortcutting on Darwin]+  , not $ osMachOTarget $ platformOS $ ncgPlatform config   = ( map (apply_mapping ncgImpl mapping) tops'     , shortcutWeightMap mappingBid <$!> weights )   | otherwise

@@ -3,7 +3,6 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE BinaryLiterals #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE NumericUnderscores #-} module GHC.CmmToAsm.AArch64.CodeGen (       cmmTopCodeGen     , generateJumpTableForInstr@@ -771,12 +770,12 @@       return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (LSR (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n))))      -- 3. Logic &&, ||-    CmmMachOp (MO_And w) [(CmmReg reg), CmmLit (CmmInt n _)] | isBitMaskImmediate (fromIntegral n) ->+    CmmMachOp (MO_And w) [(CmmReg reg), CmmLit (CmmInt n _)] | isAArch64Bitmask (fromIntegral n) ->       return $ Any (intFormat w) (\d -> unitOL $ annExpr expr (AND (OpReg w d) (OpReg w' r') (OpImm (ImmInteger n))))       where w' = formatToWidth (cmmTypeFormat (cmmRegType plat reg))             r' = getRegisterReg plat reg -    CmmMachOp (MO_Or w) [(CmmReg reg), CmmLit (CmmInt n _)] | isBitMaskImmediate (fromIntegral n) ->+    CmmMachOp (MO_Or w) [(CmmReg reg), CmmLit (CmmInt n _)] | isAArch64Bitmask (fromIntegral n) ->       return $ Any (intFormat w) (\d -> unitOL $ annExpr expr (ORR (OpReg w d) (OpReg w' r') (OpImm (ImmInteger n))))       where w' = formatToWidth (cmmTypeFormat (cmmRegType plat reg))             r' = getRegisterReg plat reg@@ -965,19 +964,6 @@      isNbitEncodeable :: Int -> Integer -> Bool     isNbitEncodeable n i = let shift = n - 1 in (-1 `shiftL` shift) <= i && i < (1 `shiftL` shift)-    -- This needs to check if n can be encoded as a bitmask immediate:-    ---    -- See https://stackoverflow.com/questions/30904718/range-of-immediate-values-in-armv8-a64-assembly-    ---    isBitMaskImmediate :: Integer -> Bool-    isBitMaskImmediate i = i `elem` [0b0000_0001, 0b0000_0010, 0b0000_0100, 0b0000_1000, 0b0001_0000, 0b0010_0000, 0b0100_0000, 0b1000_0000-                                    ,0b0000_0011, 0b0000_0110, 0b0000_1100, 0b0001_1000, 0b0011_0000, 0b0110_0000, 0b1100_0000-                                    ,0b0000_0111, 0b0000_1110, 0b0001_1100, 0b0011_1000, 0b0111_0000, 0b1110_0000-                                    ,0b0000_1111, 0b0001_1110, 0b0011_1100, 0b0111_1000, 0b1111_0000-                                    ,0b0001_1111, 0b0011_1110, 0b0111_1100, 0b1111_1000-                                    ,0b0011_1111, 0b0111_1110, 0b1111_1100-                                    ,0b0111_1111, 0b1111_1110-                                    ,0b1111_1111]      -- N.B. MUL does not set the overflow flag.     do_mul_may_oflo :: Width -> CmmExpr -> CmmExpr -> NatM Register@@ -1019,6 +1005,39 @@             mul (OpReg tmp_w tmp) (OpReg w reg_x) (OpReg w reg_y) `snocOL`             CMP (OpReg tmp_w tmp) (OpRegExt tmp_w tmp ext_mode 0) `snocOL`             CSET (OpReg w dst) NE)++-- | Is a given number encodable as a bitmask immediate?+--+-- https://stackoverflow.com/questions/30904718/range-of-immediate-values-in-armv8-a64-assembly+isAArch64Bitmask :: Integer -> Bool+-- N.B. zero and ~0 are not encodable as bitmask immediates+isAArch64Bitmask 0  = False+isAArch64Bitmask n+  | n == bit 64 - 1 = False+isAArch64Bitmask n  =+    check 64 || check 32 || check 16 || check 8+  where+    -- Check whether @n@ can be represented as a subpattern of the given+    -- width.+    check width+      | hasOneRun subpat =+          let n' = fromIntegral (mkPat width subpat)+          in n == n'+      | otherwise = False+      where+        subpat :: Word64+        subpat = fromIntegral (n .&. (bit width - 1))++    -- Construct a bit-pattern from a repeated subpatterns the given width.+    mkPat :: Int -> Word64 -> Word64+    mkPat width subpat =+        foldl' (.|.) 0 [ subpat `shiftL` p | p <- [0, width..63] ]++    -- Does the given number's bit representation match the regular expression+    -- @0*1*0*@?+    hasOneRun :: Word64 -> Bool+    hasOneRun m =+        64 == popCount m + countLeadingZeros m + countTrailingZeros m  -- | Instructions to sign-extend the value in the given register from width @w@ -- up to width @w'@.

@@ -72,6 +72,12 @@ regUsageOfInstr :: Platform -> Instr -> RegUsage regUsageOfInstr platform instr = case instr of   ANN _ i                  -> regUsageOfInstr platform i+  COMMENT{}                -> usage ([], [])+  MULTILINE_COMMENT{}      -> usage ([], [])+  PUSH_STACK_FRAME         -> usage ([], [])+  POP_STACK_FRAME          -> usage ([], [])+  DELTA{}                  -> usage ([], [])+   -- 1. Arithmetic Instructions ------------------------------------------------   ADD dst src1 src2        -> usage (regOp src1 ++ regOp src2, regOp dst)   CMN l r                  -> usage (regOp l ++ regOp r, [])@@ -136,7 +142,7 @@   FCVTZS dst src           -> usage (regOp src, regOp dst)   FABS dst src             -> usage (regOp src, regOp dst) -  _ -> panic "regUsageOfInstr"+  _ -> panic $ "regUsageOfInstr: " ++ instrCon instr    where         -- filtering the usage is necessary, otherwise the register@@ -200,7 +206,12 @@ patchRegsOfInstr :: Instr -> (Reg -> Reg) -> Instr patchRegsOfInstr instr env = case instr of     -- 0. Meta Instructions-    ANN d i        -> ANN d (patchRegsOfInstr i env)+    ANN d i             -> ANN d (patchRegsOfInstr i env)+    COMMENT{}           -> instr+    MULTILINE_COMMENT{} -> instr+    PUSH_STACK_FRAME    -> instr+    POP_STACK_FRAME     -> instr+    DELTA{}             -> instr     -- 1. Arithmetic Instructions ----------------------------------------------     ADD o1 o2 o3   -> ADD (patchOp o1) (patchOp o2) (patchOp o3)     CMN o1 o2      -> CMN (patchOp o1) (patchOp o2)@@ -266,8 +277,7 @@     SCVTF o1 o2    -> SCVTF (patchOp o1) (patchOp o2)     FCVTZS o1 o2   -> FCVTZS (patchOp o1) (patchOp o2)     FABS o1 o2     -> FABS (patchOp o1) (patchOp o2)--    _ -> pprPanic "patchRegsOfInstr" (text $ show instr)+    _              -> panic $ "patchRegsOfInstr: " ++ instrCon instr     where         patchOp :: Operand -> Operand         patchOp (OpReg w r) = OpReg w (env r)@@ -323,7 +333,7 @@         B (TBlock bid) -> B (TBlock (patchF bid))         BL (TBlock bid) ps rs -> BL (TBlock (patchF bid)) ps rs         BCOND c (TBlock bid) -> BCOND c (TBlock (patchF bid))-        _ -> pprPanic "patchJumpInstr" (text $ show instr)+        _ -> panic $ "patchJumpInstr: " ++ instrCon instr  -- ----------------------------------------------------------------------------- -- Note [Spills and Reloads]@@ -635,10 +645,69 @@     -- Float ABSolute value     | FABS Operand Operand -instance Show Instr where-    show (LDR _f o1 o2) = "LDR " ++ show o1 ++ ", " ++ show o2-    show (MOV o1 o2) = "MOV " ++ show o1 ++ ", " ++ show o2-    show _ = "missing"+instrCon :: Instr -> String+instrCon i =+    case i of+      COMMENT{} -> "COMMENT"+      MULTILINE_COMMENT{} -> "COMMENT"+      ANN{} -> "ANN"+      LOCATION{} -> "LOCATION"+      LDATA{} -> "LDATA"+      NEWBLOCK{} -> "NEWBLOCK"+      DELTA{} -> "DELTA"+      SXTB{} -> "SXTB"+      UXTB{} -> "UXTB"+      SXTH{} -> "SXTH"+      UXTH{} -> "UXTH"+      PUSH_STACK_FRAME{} -> "PUSH_STACK_FRAME"+      POP_STACK_FRAME{} -> "POP_STACK_FRAME"+      ADD{} -> "ADD"+      CMN{} -> "CMN"+      CMP{} -> "CMP"+      MSUB{} -> "MSUB"+      MUL{} -> "MUL"+      NEG{} -> "NEG"+      SDIV{} -> "SDIV"+      SMULH{} -> "SMULH"+      SMULL{} -> "SMULL"+      SUB{} -> "SUB"+      UDIV{} -> "UDIV"+      SBFM{} -> "SBFM"+      UBFM{} -> "UBFM"+      SBFX{} -> "SBFX"+      UBFX{} -> "UBFX"+      AND{} -> "AND"+      ANDS{} -> "ANDS"+      ASR{} -> "ASR"+      BIC{} -> "BIC"+      BICS{} -> "BICS"+      EON{} -> "EON"+      EOR{} -> "EOR"+      LSL{} -> "LSL"+      LSR{} -> "LSR"+      MOV{} -> "MOV"+      MOVK{} -> "MOVK"+      MVN{} -> "MVN"+      ORN{} -> "ORN"+      ORR{} -> "ORR"+      ROR{} -> "ROR"+      TST{} -> "TST"+      STR{} -> "STR"+      LDR{} -> "LDR"+      STP{} -> "STP"+      LDP{} -> "LDP"+      CSET{} -> "CSET"+      CBZ{} -> "CBZ"+      CBNZ{} -> "CBNZ"+      J{} -> "J"+      B{} -> "B"+      BL{} -> "BL"+      BCOND{} -> "BCOND"+      DMBSY{} -> "DMBSY"+      FCVT{} -> "FCVT"+      SCVTF{} -> "SCVTF"+      FCVTZS{} -> "FCVTZS"+      FABS{} -> "FABS"  data Target     = TBlock BlockId@@ -766,11 +835,11 @@ opRegUExt W32 r = OpRegExt W32 r EUXTW 0 opRegUExt W16 r = OpRegExt W16 r EUXTH 0 opRegUExt W8  r = OpRegExt W8  r EUXTB 0-opRegUExt w  _r = pprPanic "opRegUExt" (text $ show w)+opRegUExt w  _r = pprPanic "opRegUExt" (ppr w)  opRegSExt :: Width -> Reg -> Operand opRegSExt W64 r = OpRegExt W64 r ESXTX 0 opRegSExt W32 r = OpRegExt W32 r ESXTW 0 opRegSExt W16 r = OpRegExt W16 r ESXTH 0 opRegSExt W8  r = OpRegExt W8  r ESXTB 0-opRegSExt w  _r = pprPanic "opRegSExt" (text $ show w)+opRegSExt w  _r = pprPanic "opRegSExt" (ppr w)

@@ -109,10 +109,8 @@                             ArchPPC       -> 16                             ArchPPC_64 _  -> 15                             ArchARM _ _ _ -> panic "trivColorable ArchARM"-                            -- We should be able to allocate *a lot* more in princple.-                            -- essentially all 32 - SP, so 31, we'd trash the link reg-                            -- as well as the platform and all others though.-                            ArchAArch64   -> 18+                            -- N.B. x18 is reserved by the platform on AArch64/Darwin+                            ArchAArch64   -> 17                             ArchAlpha     -> panic "trivColorable ArchAlpha"                             ArchMipseb    -> panic "trivColorable ArchMipseb"                             ArchMipsel    -> panic "trivColorable ArchMipsel"

@@ -3951,7 +3951,7 @@   code <- assignMem_IntCode (intFormat width) addr val   let needs_fence = case mord of         MemOrderSeqCst  -> True-        MemOrderRelease -> True+        MemOrderRelease -> False         MemOrderAcquire -> pprPanic "genAtomicWrite: acquire ordering on write" empty         MemOrderRelaxed -> False   return $ if needs_fence then code `snocOL` MFENCE else code

@@ -368,14 +368,70 @@  Note [Core letrec invariant] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The right hand sides of all top-level and recursive @let@s-/must/ be of lifted type (see "Type#type_classification" for-the meaning of /lifted/ vs. /unlifted/).+The Core letrec invariant: -There is one exception to this rule, top-level @let@s are-allowed to bind primitive string literals: see-Note [Core top-level string literals].+    The right hand sides of all+      /top-level/ or /recursive/+    bindings must be of lifted type +    There is one exception to this rule, top-level @let@s are+    allowed to bind primitive string literals: see+    Note [Core top-level string literals].++See "Type#type_classification" in GHC.Core.Type+for the meaning of "lifted" vs. "unlifted").++For the non-top-level, non-recursive case see Note [Core let-can-float invariant].++Note [Core let-can-float invariant]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The let-can-float invariant:++    The right hand side of a /non-top-level/, /non-recursive/ binding+    may be of unlifted type, but only if+    the expression is ok-for-speculation+    or the 'Let' is for a join point.++    (For top-level or recursive lets see Note [Core letrec invariant].)++This means that the let can be floated around+without difficulty. For example, this is OK:++   y::Int# = x +# 1#++But this is not, as it may affect termination if the+expression is floated out:++   y::Int# = fac 4#++In this situation you should use @case@ rather than a @let@. The function+'GHC.Core.Utils.needsCaseBinding' can help you determine which to generate, or+alternatively use 'GHC.Core.Make.mkCoreLet' rather than this constructor directly,+which will generate a @case@ if necessary++The let-can-float invariant is initially enforced by mkCoreLet in GHC.Core.Make.++For discussion of some implications of the let-can-float invariant primops see+Note [Checking versus non-checking primops] in GHC.Builtin.PrimOps.++Historical Note [The let/app invariant]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Before 2022 GHC used the "let/app invariant", which applied the let-can-float rules+to the argument of an application, as well as to the RHS of a let.  This made some+kind of sense, because 'let' can always be encoded as application:+   let x=rhs in b   =    (\x.b) rhs++But the let/app invariant got in the way of RULES; see #19313.  For example+  up :: Int# -> Int#+  {-# RULES "up/down" forall x. up (down x) = x #-}+The LHS of this rule doesn't satisfy the let/app invariant.++Indeed RULES is a big reason that GHC doesn't use ANF, where the argument of an+application is always a variable or a constant.  To allow RULES to work nicely+we need to allow lots of things in the arguments of a call.++TL;DR: we relaxed the let/app invariant to become the let-can-float invariant.+ Note [Core top-level string literals] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ As an exception to the usual rule that top-level binders must be lifted,@@ -414,6 +470,8 @@   Note [Core top-level string literals]. Core-to-core passes may introduce   new top-level string literals. +  See GHC.Core.Utils.exprIsTopLevelBindable, and exprIsTickedString+ * In STG, top-level string literals are explicitly represented in the syntax   tree. @@ -421,14 +479,9 @@   in the object file, the content of the exported literal is given a label with   the _bytes suffix. -Note [Core let/app invariant]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The let/app invariant-     the right hand side of a non-recursive 'Let', and-     the argument of an 'App',-    /may/ be of unlifted type, but only if-    the expression is ok-for-speculation-    or the 'Let' is for a join point.+Note [NON-BOTTOM-DICTS invariant]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It is a global invariant (not checkable by Lint) that  This means that the let can be floated around without difficulty. For example, this is OK:@@ -448,8 +501,24 @@ The let/app invariant is initially enforced by mkCoreLet and mkCoreApp in GHC.Core.Make. -For discussion of some implications of the let/app invariant primops see-Note [Checking versus non-checking primops] in GHC.Builtin.PrimOps.+* A superclass selection from some other dictionary. This is harder to guarantee:+  see Note [Recursive superclasses] and Note [Solving superclass constraints]+  in GHC.Tc.TyCl.Instance.++A bad Core-to-Core pass could invalidate this reasoning, but that's too bad.+It's still an invariant of Core programs generated by GHC from Haskell, and+Core-to-Core passes maintain it.++Why is it useful to know that dictionaries are non-bottom?++1. It justifies the use of `-XDictsStrict`;+   see `GHC.Core.Types.Demand.strictifyDictDmd`++2. It means that (eq_sel d) is ok-for-speculation and thus+     case (eq_sel d) of _ -> blah+   can be discarded by the Simplifier.  See these Notes:+   Note [exprOkForSpeculation and type classes] in GHC.Core.Utils+   Note[Speculative evaluation] in GHC.CoreToStg.Prep  Note [Case expression invariants] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

@@ -1112,16 +1112,11 @@ -------------------------- doubleDecodeOp :: RuleOpts -> Literal -> Maybe CoreExpr doubleDecodeOp env (LitDouble ((decodeFloat . fromRational @Double) -> (m, e)))-  = Just $ mkCoreUbxTup [iNT64Ty, intPrimTy]-                        [ Lit (mkLitINT64 (toInteger m))+  = Just $ mkCoreUbxTup [int64PrimTy, intPrimTy]+                        [ Lit (mkLitInt64Wrap (toInteger m))                         , mkIntVal platform (toInteger e) ]   where     platform = roPlatform env-    (iNT64Ty, mkLitINT64)-      | platformWordSizeInBits platform < 64-      = (int64PrimTy, mkLitInt64Wrap)-      | otherwise-      = (intPrimTy  , mkLitIntWrap platform) doubleDecodeOp _   _   = Nothing 

@@ -281,7 +281,8 @@                  -> WithDmdType (DmdResult CoreBind a) dmdAnalBindLetUp top_lvl env id rhs anal_body = WithDmdType final_ty (R (NonRec id' rhs') (body'))   where-    WithDmdType body_ty body'   = anal_body env+    WithDmdType body_ty body'   = anal_body (addInScopeAnalEnv env id)+    -- See Note [Bringing a new variable into scope]     WithDmdType body_ty' id_dmd = findBndrDmd env body_ty id     -- See Note [Finalising boxity for demand signatures] @@ -415,7 +416,8 @@ dmdAnal' env dmd (Lam var body)   | isTyVar var   = let-        WithDmdType body_ty body' = dmdAnal env dmd body+        WithDmdType body_ty body' = dmdAnal (addInScopeAnalEnv env var) dmd body+        -- See Note [Bringing a new variable into scope]     in     WithDmdType body_ty (Lam var body') @@ -423,7 +425,8 @@   = let (n, body_dmd)    = peelCallDmd dmd           -- body_dmd: a demand to analyze the body -        WithDmdType body_ty body' = dmdAnal env body_dmd body+        WithDmdType body_ty body' = dmdAnal (addInScopeAnalEnv env var) body_dmd body+        -- See Note [Bringing a new variable into scope]         WithDmdType lam_ty var'   = annotateLamIdBndr env body_ty var         new_dmd_type = multDmdType n lam_ty     in@@ -435,7 +438,9 @@   -- can consider its field demands when analysing the scrutinee.   | want_precise_field_dmds alt   = let-        WithDmdType rhs_ty rhs'           = dmdAnal env dmd rhs+        rhs_env = addInScopeAnalEnvs env (case_bndr:bndrs)+        -- See Note [Bringing a new variable into scope]+        WithDmdType rhs_ty rhs'           = dmdAnal rhs_env dmd rhs         WithDmdType alt_ty1 fld_dmds      = findBndrsDmds env rhs_ty bndrs         WithDmdType alt_ty2 case_bndr_dmd = findBndrDmd env alt_ty1 case_bndr         !case_bndr'                       = setIdDemandInfo case_bndr case_bndr_dmd@@ -564,7 +569,9 @@  dmdAnalSumAlt :: AnalEnv -> SubDemand -> Id -> Alt Var -> WithDmdType CoreAlt dmdAnalSumAlt env dmd case_bndr (Alt con bndrs rhs)-  | WithDmdType rhs_ty rhs' <- dmdAnal env dmd rhs+  | let rhs_env = addInScopeAnalEnvs env (case_bndr:bndrs)+    -- See Note [Bringing a new variable into scope]+  , WithDmdType rhs_ty rhs' <- dmdAnal rhs_env dmd rhs   , WithDmdType alt_ty dmds <- findBndrsDmds env rhs_ty bndrs   , let (_ :* case_bndr_sd) = findIdDemand alt_ty case_bndr         -- See Note [Demand on case-alternative binders]@@ -2042,7 +2049,7 @@ emptySigEnv :: SigEnv emptySigEnv = emptyVarEnv --- | Extend an environment with the strictness IDs attached to the id+-- | Extend an environment with the strictness sigs attached to the Ids extendAnalEnvs :: TopLevelFlag -> AnalEnv -> [Id] -> AnalEnv extendAnalEnvs top_lvl env vars   = env { ae_sigs = extendSigEnvs top_lvl (ae_sigs env) vars }@@ -2061,6 +2068,12 @@ lookupSigEnv :: AnalEnv -> Id -> Maybe (DmdSig, TopLevelFlag) lookupSigEnv env id = lookupVarEnv (ae_sigs env) id +addInScopeAnalEnv :: AnalEnv -> Var -> AnalEnv+addInScopeAnalEnv env id = env { ae_sigs = delVarEnv (ae_sigs env) id }++addInScopeAnalEnvs :: AnalEnv -> [Var] -> AnalEnv+addInScopeAnalEnvs env ids = env { ae_sigs = delVarEnvList (ae_sigs env) ids }+ nonVirgin :: AnalEnv -> AnalEnv nonVirgin env = env { ae_virgin = False } @@ -2099,7 +2112,18 @@      fam_envs = ae_fam_envs env -{- Note [Making dictionary parameters strict]+{- Note [Bringing a new variable into scope]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+   f x = blah+   g = ...(\f. ...f...)...++In the body of the '\f', any occurrence of `f` refers to the lambda-bound `f`,+not the top-level `f` (which will be in `ae_sigs`).  So it's very important+to delete `f` from `ae_sigs` when we pass a lambda/case/let-up binding of `f`.+Otherwise chaos results (#22718).++Note [Making dictionary parameters strict] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The Opt_DictsStrict flag makes GHC use call-by-value for dictionaries.  Why? 

@@ -34,9 +34,12 @@ import GHC.Types.Var.Set  import GHC.Utils.Misc-import GHC.Utils.Panic import GHC.Utils.Panic.Plain +import GHC.Utils.Outputable++import Data.List        ( mapAccumL )+ {- Top-level interface function, @floatInwards@.  Note that we do not actually float any bindings downwards from the top-level.@@ -123,7 +126,7 @@ ************************************************************************ -} -type FreeVarSet  = DIdSet+type FreeVarSet  = DVarSet type BoundVarSet = DIdSet  data FloatInBind = FB BoundVarSet FreeVarSet FloatBind@@ -131,11 +134,17 @@         -- of recursive bindings, the set doesn't include the bound         -- variables. -type FloatInBinds = [FloatInBind]-        -- In reverse dependency order (innermost binder first)+type FloatInBinds    = [FloatInBind] -- In normal dependency order+                                     --    (outermost binder first)+type RevFloatInBinds = [FloatInBind] -- In reverse dependency order+                                     --    (innermost binder first) +instance Outputable FloatInBind where+  ppr (FB bvs fvs _) = text "FB" <> braces (sep [ text "bndrs =" <+> ppr bvs+                                                , text "fvs =" <+> ppr fvs ])+ fiExpr :: Platform-       -> FloatInBinds      -- Binds we're trying to drop+       -> RevFloatInBinds   -- Binds we're trying to drop                             -- as far "inwards" as possible        -> CoreExprWithFVs   -- Input expr        -> CoreExpr          -- Result@@ -146,13 +155,12 @@ fiExpr _ to_drop (_, AnnVar v)       = wrapFloats to_drop (Var v) fiExpr _ to_drop (_, AnnCoercion co) = wrapFloats to_drop (Coercion co) fiExpr platform to_drop (_, AnnCast expr (co_ann, co))-  = wrapFloats (drop_here ++ co_drop) $+  = wrapFloats drop_here $     Cast (fiExpr platform e_drop expr) co   where-    [drop_here, e_drop, co_drop]-      = sepBindsByDropPoint platform False-          [freeVarsOf expr, freeVarsOfAnn co_ann]-          to_drop+    (drop_here, [e_drop])+      = sepBindsByDropPoint platform False to_drop+          (freeVarsOfAnn co_ann) [freeVarsOf expr]  {- Applications: we do float inside applications, mainly because we@@ -161,7 +169,7 @@ -}  fiExpr platform to_drop ann_expr@(_,AnnApp {})-  = wrapFloats drop_here $ wrapFloats extra_drop $+  = wrapFloats drop_here $     mkTicks ticks $     mkApps (fiExpr platform fun_drop ann_fun)            (zipWithEqual "fiExpr" (fiExpr platform) arg_drops ann_args)@@ -169,21 +177,19 @@            -- length ann_args = length arg_fvs = length arg_drops   where     (ann_fun, ann_args, ticks) = collectAnnArgsTicks tickishFloatable ann_expr-    fun_ty  = exprType (deAnnotate ann_fun)     fun_fvs = freeVarsOf ann_fun-    arg_fvs = map freeVarsOf ann_args -    (drop_here : extra_drop : fun_drop : arg_drops)-       = sepBindsByDropPoint platform False-                             (extra_fvs : fun_fvs : arg_fvs)-                             to_drop+    (drop_here, fun_drop : arg_drops)+       = sepBindsByDropPoint platform False to_drop+                             here_fvs (fun_fvs : arg_fvs)+          -- Shortcut behaviour: if to_drop is empty,          -- sepBindsByDropPoint returns a suitable bunch of empty          -- lists without evaluating extra_fvs, and hence without          -- peering into each argument -    (_, extra_fvs) = foldl' add_arg (fun_ty, extra_fvs0) ann_args-    extra_fvs0 = case ann_fun of+    (here_fvs, arg_fvs) = mapAccumL add_arg here_fvs0 ann_args+    here_fvs0 = case ann_fun of                    (_, AnnVar _) -> fun_fvs                    _             -> emptyDVarSet           -- Don't float the binding for f into f x y z; see Note [Join points]@@ -191,17 +197,14 @@           -- join point, floating it in isn't especially harmful but it's           -- useless since the simplifier will immediately float it back out.) -    add_arg :: (Type,FreeVarSet) -> CoreExprWithFVs -> (Type,FreeVarSet)-    add_arg (fun_ty, extra_fvs) (_, AnnType ty)-      = (piResultTy fun_ty ty, extra_fvs)--    add_arg (fun_ty, extra_fvs) (arg_fvs, arg)-      | noFloatIntoArg arg arg_ty-      = (res_ty, extra_fvs `unionDVarSet` arg_fvs)-      | otherwise-      = (res_ty, extra_fvs)+    add_arg :: FreeVarSet -> CoreExprWithFVs -> (FreeVarSet,FreeVarSet)+    add_arg here_fvs (arg_fvs, AnnType _)+      = (here_fvs, arg_fvs)+    add_arg here_fvs (arg_fvs, arg)+      | noFloatIntoArg arg arg_ty = (here_fvs `unionDVarSet` arg_fvs, emptyDVarSet)+      | otherwise          = (here_fvs, arg_fvs)       where-       (_, arg_ty, res_ty) = splitFunTy fun_ty+       arg_ty = exprType $ deAnnotate' arg  {- Note [Dead bindings] ~~~~~~~~~~~~~~~~~~~~~~~@@ -283,7 +286,6 @@ Urk! if all are tyvars, and we don't float in, we may miss an       opportunity to float inside a nested case branch - Note [Floating coercions] ~~~~~~~~~~~~~~~~~~~~~~~~~ We could, in principle, have a coercion binding like@@ -303,6 +305,36 @@ bind a coercion variable mentioned in any of the types, that binder must be dropped right away. +Note [Shadowing and name capture]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have+    let x = y+1 in+    case p of+       (y:ys) -> ...x...+       [] -> blah+It is obviously bogus for FloatIn to transform to+    case p of+       (y:ys) -> ...(let x = y+1 in x)...+       [] -> blah+because the y is captured.  This doesn't happen much, because shadowing is+rare, but it did happen in #22662.++One solution would be to clone as we go.  But a simpler one is this:++  at a binding site (like that for (y:ys) above), abandon float-in for+  any floating bindings that mention the binders (y, ys in this case)++We achieve that by calling sepBindsByDropPoint with the binders in+the "used-here" set:++* In fiExpr (AnnLam ...).  For the body there is no need to delete+  the lambda-binders from the body_fvs, because any bindings that+  mention these binders will be dropped here anyway.++* In fiExpr (AnnCase ...). Remember to include the case_bndr in the+  binders.  Again, no need to delete the alt binders from the rhs+  free vars, beause any bindings mentioning them will be dropped+  here unconditionally. -}  fiExpr platform to_drop lam@(_, AnnLam _ _)@@ -311,11 +343,18 @@   = wrapFloats to_drop (mkLams bndrs (fiExpr platform [] body))    | otherwise           -- Float inside-  = mkLams bndrs (fiExpr platform to_drop body)+  = wrapFloats drop_here $+    mkLams bndrs (fiExpr platform body_drop body)    where     (bndrs, body) = collectAnnBndrs lam+    body_fvs      = freeVarsOf body +    -- Why sepBindsByDropPoint? Because of potential capture+    -- See Note [Shadowing and name capture]+    (drop_here, [body_drop]) = sepBindsByDropPoint platform False to_drop+                                  (mkDVarSet bndrs) [body_fvs]+ {- We don't float lets inwards past an SCC.         ToDo: keep info on current cc, and when passing@@ -454,16 +493,16 @@   = wrapFloats shared_binds $     fiExpr platform (case_float : rhs_binds) rhs   where-    case_float = FB (mkDVarSet (case_bndr : alt_bndrs)) scrut_fvs+    case_float = FB all_bndrs scrut_fvs                     (FloatCase scrut' case_bndr con alt_bndrs)     scrut'     = fiExpr platform scrut_binds scrut-    rhs_fvs    = freeVarsOf rhs `delDVarSetList` (case_bndr : alt_bndrs)-    scrut_fvs  = freeVarsOf scrut+    rhs_fvs    = freeVarsOf rhs    -- No need to delete alt_bndrs+    scrut_fvs  = freeVarsOf scrut  -- See Note [Shadowing and name capture]+    all_bndrs  = mkDVarSet alt_bndrs `extendDVarSet` case_bndr -    [shared_binds, scrut_binds, rhs_binds]-       = sepBindsByDropPoint platform False-           [scrut_fvs, rhs_fvs]-           to_drop+    (shared_binds, [scrut_binds, rhs_binds])+       = sepBindsByDropPoint platform False to_drop+                     all_bndrs [scrut_fvs, rhs_fvs]  fiExpr platform to_drop (_, AnnCase scrut case_bndr ty alts)   = wrapFloats drop_here1 $@@ -473,39 +512,43 @@          -- use zipWithEqual, we should have length alts_drops_s = length alts   where         -- Float into the scrut and alts-considered-together just like App-    [drop_here1, scrut_drops, alts_drops]-       = sepBindsByDropPoint platform False-           [scrut_fvs, all_alts_fvs]-           to_drop+    (drop_here1, [scrut_drops, alts_drops])+       = sepBindsByDropPoint platform False to_drop+             all_alt_bndrs [scrut_fvs, all_alt_fvs]+             -- all_alt_bndrs: see Note [Shadowing and name capture]          -- Float into the alts with the is_case flag set-    (drop_here2 : alts_drops_s)-      | [ _ ] <- alts = [] : [alts_drops]-      | otherwise     = sepBindsByDropPoint platform True alts_fvs alts_drops+    (drop_here2, alts_drops_s)+       = sepBindsByDropPoint platform True alts_drops emptyDVarSet alts_fvs -    scrut_fvs    = freeVarsOf scrut-    alts_fvs     = map alt_fvs alts-    all_alts_fvs = unionDVarSets alts_fvs-    alt_fvs (AnnAlt _con args rhs)-      = foldl' delDVarSet (freeVarsOf rhs) (case_bndr:args)-           -- Delete case_bndr and args from free vars of rhs-           -- to get free vars of alt+    scrut_fvs = freeVarsOf scrut +    all_alt_bndrs = foldr (unionDVarSet . ann_alt_bndrs) (unitDVarSet case_bndr) alts+    ann_alt_bndrs (AnnAlt _ bndrs _) = mkDVarSet bndrs++    alts_fvs :: [DVarSet]+    alts_fvs = [freeVarsOf rhs | AnnAlt _ _ rhs <- alts]+               -- No need to delete binders+               -- See Note [Shadowing and name capture]++    all_alt_fvs :: DVarSet+    all_alt_fvs = foldr unionDVarSet (unitDVarSet case_bndr) alts_fvs+     fi_alt to_drop (AnnAlt con args rhs) = Alt con args (fiExpr platform to_drop rhs)  ------------------ fiBind :: Platform-       -> FloatInBinds      -- Binds we're trying to drop-                            -- as far "inwards" as possible-       -> CoreBindWithFVs   -- Input binding-       -> DVarSet           -- Free in scope of binding-       -> ( FloatInBinds    -- Land these before-          , FloatInBind     -- The binding itself-          , FloatInBinds)   -- Land these after+       -> RevFloatInBinds    -- Binds we're trying to drop+                             -- as far "inwards" as possible+       -> CoreBindWithFVs    -- Input binding+       -> DVarSet            -- Free in scope of binding+       -> ( RevFloatInBinds  -- Land these before+          , FloatInBind      -- The binding itself+          , RevFloatInBinds) -- Land these after  fiBind platform to_drop (AnnNonRec id ann_rhs@(rhs_fvs, rhs)) body_fvs-  = ( extra_binds ++ shared_binds          -- Land these before-                                           -- See Note [extra_fvs (1)] and Note [extra_fvs (2)]+  = ( shared_binds          -- Land these before+                            -- See Note [extra_fvs (1)] and Note [extra_fvs (2)]     , FB (unitDVarSet id) rhs_fvs'         -- The new binding itself           (FloatLet (NonRec id rhs'))     , body_binds )                         -- Land these after@@ -523,10 +566,9 @@         -- We *can't* float into ok-for-speculation unlifted RHSs         -- But do float into join points -    [shared_binds, extra_binds, rhs_binds, body_binds]-        = sepBindsByDropPoint platform False-            [extra_fvs, rhs_fvs, body_fvs2]-            to_drop+    (shared_binds, [rhs_binds, body_binds])+        = sepBindsByDropPoint platform False to_drop+                      extra_fvs [rhs_fvs, body_fvs2]          -- Push rhs_binds into the right hand side of the binding     rhs'     = fiRhs platform rhs_binds id ann_rhs@@ -534,7 +576,7 @@                         -- Don't forget the rule_fvs; the binding mentions them!  fiBind platform to_drop (AnnRec bindings) body_fvs-  = ( extra_binds ++ shared_binds+  = ( shared_binds     , FB (mkDVarSet ids) rhs_fvs'          (FloatLet (Rec (fi_bind rhss_binds bindings)))     , body_binds )@@ -548,17 +590,16 @@                 unionDVarSets [ rhs_fvs | (bndr, (rhs_fvs, rhs)) <- bindings                               , noFloatIntoRhs Recursive bndr rhs ] -    (shared_binds:extra_binds:body_binds:rhss_binds)-        = sepBindsByDropPoint platform False-            (extra_fvs:body_fvs:rhss_fvs)-            to_drop+    (shared_binds, body_binds:rhss_binds)+        = sepBindsByDropPoint platform False to_drop+                       extra_fvs (body_fvs:rhss_fvs)      rhs_fvs' = unionDVarSets rhss_fvs `unionDVarSet`                unionDVarSets (map floatedBindsFVs rhss_binds) `unionDVarSet`                rule_fvs         -- Don't forget the rule variables!      -- Push rhs_binds into the right hand side of the binding-    fi_bind :: [FloatInBinds]       -- one per "drop pt" conjured w/ fvs_of_rhss+    fi_bind :: [RevFloatInBinds]   -- One per "drop pt" conjured w/ fvs_of_rhss             -> [(Id, CoreExprWithFVs)]             -> [(Id, CoreExpr)] @@ -567,7 +608,7 @@         | ((binder, rhs), to_drop) <- zipEqual "fi_bind" pairs to_drops ]  -------------------fiRhs :: Platform -> FloatInBinds -> CoreBndr -> CoreExprWithFVs -> CoreExpr+fiRhs :: Platform -> RevFloatInBinds -> CoreBndr -> CoreExprWithFVs -> CoreExpr fiRhs platform to_drop bndr rhs   | Just join_arity <- isJoinId_maybe bndr   , let (bndrs, body) = collectNAnnBndrs join_arity rhs@@ -667,68 +708,84 @@ We have to maintain the order on these drop-point-related lists. -} --- pprFIB :: FloatInBinds -> SDoc+-- pprFIB :: RevFloatInBinds -> SDoc -- pprFIB fibs = text "FIB:" <+> ppr [b | FB _ _ b <- fibs]  sepBindsByDropPoint     :: Platform-    -> Bool                -- True <=> is case expression-    -> [FreeVarSet]        -- One set of FVs per drop point-                           -- Always at least two long!-    -> FloatInBinds        -- Candidate floaters-    -> [FloatInBinds]      -- FIRST one is bindings which must not be floated-                           -- inside any drop point; the rest correspond-                           -- one-to-one with the input list of FV sets+    -> Bool                  -- True <=> is case expression+    -> RevFloatInBinds       -- Candidate floaters+    -> FreeVarSet            -- here_fvs: if these vars are free in a binding,+                             --   don't float that binding inside any drop point+    -> [FreeVarSet]          -- fork_fvs: one set of FVs per drop point+    -> ( RevFloatInBinds     -- Bindings which must not be floated inside+       , [RevFloatInBinds] ) -- Corresponds 1-1 with the input list of FV sets  -- Every input floater is returned somewhere in the result; -- none are dropped, not even ones which don't seem to be -- free in *any* of the drop-point fvs.  Why?  Because, for example, -- a binding (let x = E in B) might have a specialised version of -- x (say x') stored inside x, but x' isn't free in E or B.+--+-- The here_fvs argument is used for two things:+-- * Avoid shadowing bugs: see Note [Shadowing and name capture]+-- * Drop some of the bindings at the top, e.g. of an application  type DropBox = (FreeVarSet, FloatInBinds) -sepBindsByDropPoint platform is_case drop_pts floaters+dropBoxFloats :: DropBox -> RevFloatInBinds+dropBoxFloats (_, floats) = reverse floats++usedInDropBox :: DIdSet -> DropBox -> Bool+usedInDropBox bndrs (db_fvs, _) = db_fvs `intersectsDVarSet` bndrs++initDropBox :: DVarSet -> DropBox+initDropBox fvs = (fvs, [])++sepBindsByDropPoint platform is_case floaters here_fvs fork_fvs   | null floaters  -- Shortcut common case-  = [] : [[] | _ <- drop_pts]+  = ([], [[] | _ <- fork_fvs])    | otherwise-  = assert (drop_pts `lengthAtLeast` 2) $-    go floaters (map (\fvs -> (fvs, [])) (emptyDVarSet : drop_pts))+  = go floaters (initDropBox here_fvs) (map initDropBox fork_fvs)   where-    n_alts = length drop_pts+    n_alts = length fork_fvs -    go :: FloatInBinds -> [DropBox] -> [FloatInBinds]-        -- The *first* one in the argument list is the drop_here set-        -- The FloatInBinds in the lists are in the reverse of-        -- the normal FloatInBinds order; that is, they are the right way round!+    go :: RevFloatInBinds -> DropBox -> [DropBox]+       -> (RevFloatInBinds, [RevFloatInBinds])+        -- The *first* one in the pair is the drop_here set -    go [] drop_boxes = map (reverse . snd) drop_boxes+    go [] here_box fork_boxes+        = (dropBoxFloats here_box, map dropBoxFloats fork_boxes) -    go (bind_w_fvs@(FB bndrs bind_fvs bind) : binds) drop_boxes@(here_box : fork_boxes)-        = go binds new_boxes+    go (bind_w_fvs@(FB bndrs bind_fvs bind) : binds) here_box fork_boxes+        | drop_here = go binds (insert here_box) fork_boxes+        | otherwise = go binds here_box          new_fork_boxes         where           -- "here" means the group of bindings dropped at the top of the fork -          (used_here : used_in_flags) = [ fvs `intersectsDVarSet` bndrs-                                        | (fvs, _) <- drop_boxes]+          used_here     = bndrs `usedInDropBox` here_box+          used_in_flags = case fork_boxes of+                            []  -> []+                            [_] -> [True]  -- Push all bindings into a single branch+                                           -- No need to look at its free vars+                            _   -> map (bndrs `usedInDropBox`) fork_boxes+               -- Short-cut for the singleton case;+               -- used for lambdas and singleton cases            drop_here = used_here || cant_push            n_used_alts = count id used_in_flags -- returns number of Trues in list.            cant_push-            | is_case   = n_used_alts == n_alts   -- Used in all, don't push-                                                  -- Remember n_alts > 1+            | is_case   = (n_alts > 1 && n_used_alts == n_alts)+                             -- Used in all, muliple branches, don't push                           || (n_used_alts > 1 && not (floatIsDupable platform bind))                              -- floatIsDupable: see Note [Duplicating floats]              | otherwise = floatIsCase bind || n_used_alts > 1                              -- floatIsCase: see Note [Floating primops] -          new_boxes | drop_here = (insert here_box : fork_boxes)-                    | otherwise = (here_box : new_fork_boxes)-           new_fork_boxes = zipWithEqual "FloatIn.sepBinds" insert_maybe                                         fork_boxes used_in_flags @@ -738,9 +795,7 @@           insert_maybe box True  = insert box           insert_maybe box False = box -    go _ _ = panic "sepBindsByDropPoint/go" - {- Note [Duplicating floats] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ For case expressions we duplicate the binding if it is reasonably@@ -756,14 +811,14 @@ so we don't duplicate then. -} -floatedBindsFVs :: FloatInBinds -> FreeVarSet+floatedBindsFVs :: RevFloatInBinds -> FreeVarSet floatedBindsFVs binds = mapUnionDVarSet fbFVs binds  fbFVs :: FloatInBind -> DVarSet fbFVs (FB _ fvs _) = fvs -wrapFloats :: FloatInBinds -> CoreExpr -> CoreExpr--- Remember FloatInBinds is in *reverse* dependency order+wrapFloats :: RevFloatInBinds -> CoreExpr -> CoreExpr+-- Remember RevFloatInBinds is in *reverse* dependency order wrapFloats []               e = e wrapFloats (FB _ _ fl : bs) e = wrapFloats bs (wrapFloat fl e) 

@@ -1812,7 +1812,8 @@  occAnalLam env (Lam bndr expr)   | isTyVar bndr-  = let (WithUsageDetails usage expr') = occAnalLam env expr+  = let env1 = addOneInScope env bndr+        WithUsageDetails usage expr' = occAnalLam env1 expr     in WithUsageDetails usage (Lam bndr expr')        -- Important: Keep the 'env' unchanged so that with a RHS like        --   \(@ x) -> K @x (f @x)@@ -2458,9 +2459,10 @@            -- then please replace x by (y |> sym mco)            -- Invariant of course: idType x = exprType (y |> sym mco)            , occ_bs_env  :: !(VarEnv (OutId, MCoercion))-           , occ_bs_rng  :: !VarSet   -- Vars free in the range of occ_bs_env                    -- Domain is Global and Local Ids                    -- Range is just Local Ids+           , occ_bs_rng  :: !VarSet+                   -- Vars (TyVars and Ids) free in the range of occ_bs_env     }  @@ -2537,14 +2539,15 @@                                           _      -> False  addOneInScope :: OccEnv -> CoreBndr -> OccEnv+-- Needed for all Vars not just Ids+-- See Note [The binder-swap substitution] (BS3) addOneInScope env@(OccEnv { occ_bs_env = swap_env, occ_bs_rng = rng_vars }) bndr   | bndr `elemVarSet` rng_vars = env { occ_bs_env = emptyVarEnv, occ_bs_rng = emptyVarSet }   | otherwise                  = env { occ_bs_env = swap_env `delVarEnv` bndr }  addInScope :: OccEnv -> [Var] -> OccEnv--- See Note [The binder-swap substitution]--- It's only neccessary to call this on in-scope Ids,--- but harmless to include TyVars too+-- Needed for all Vars not just Ids+-- See Note [The binder-swap substitution] (BS3) addInScope env@(OccEnv { occ_bs_env = swap_env, occ_bs_rng = rng_vars }) bndrs   | any (`elemVarSet` rng_vars) bndrs = env { occ_bs_env = emptyVarEnv, occ_bs_rng = emptyVarSet }   | otherwise                         = env { occ_bs_env = swap_env `delVarEnvList` bndrs }@@ -2703,25 +2706,29 @@  (BS3) We need care when shadowing.  Suppose [x :-> b] is in occ_bs_env,       and we encounter:-         - \x. blah-           Here we want to delete the x-binding from occ_bs_env+         (i) \x. blah+             Here we want to delete the x-binding from occ_bs_env -         - \b. blah-           This is harder: we really want to delete all bindings that-           have 'b' free in the range.  That is a bit tiresome to implement,-           so we compromise.  We keep occ_bs_rng, which is the set of-           free vars of rng(occc_bs_env).  If a binder shadows any of these-           variables, we discard all of occ_bs_env.  Safe, if a bit-           brutal.  NB, however: the simplifer de-shadows the code, so the-           next time around this won't happen.+         (ii) \b. blah+              This is harder: we really want to delete all bindings that+              have 'b' free in the range.  That is a bit tiresome to implement,+              so we compromise.  We keep occ_bs_rng, which is the set of+              free vars of rng(occc_bs_env).  If a binder shadows any of these+              variables, we discard all of occ_bs_env.  Safe, if a bit+              brutal.  NB, however: the simplifer de-shadows the code, so the+              next time around this won't happen.        These checks are implemented in addInScope.+      (i) is needed only for Ids, but (ii) is needed for tyvars too (#22623)+      because if occ_bs_env has [x :-> ...a...] where `a` is a tyvar, we+      must not replace `x` by `...a...` under /\a. ...x..., or similarly+      under a case pattern match that binds `a`. -      The occurrence analyser itself does /not/ do cloning. It could, in-      principle, but it'd make it a bit more complicated and there is no-      great benefit. The simplifer uses cloning to get a no-shadowing-      situation, the care-when-shadowing behaviour above isn't needed for-      long.+      An alternative would be for the occurrence analyser to do cloning as+      it goes.  In principle it could do so, but it'd make it a bit more+      complicated and there is no great benefit. The simplifer uses+      cloning to get a no-shadowing situation, the care-when-shadowing+      behaviour above isn't needed for long.  (BS4) The domain of occ_bs_env can include GlobaIds.  Eg          case M.foo of b { alts }

@@ -3557,8 +3557,8 @@         --              let a = ...arg...         --              in [...hole...] a         -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable-    do  { let (dmd:_) = dmds   -- Never fails-        ; (floats1, cont') <- mkDupableContWithDmds env dmds cont+    do  { let (dmd:cont_dmds) = dmds   -- Never fails+        ; (floats1, cont') <- mkDupableContWithDmds env cont_dmds cont         ; let env' = env `setInScopeFromF` floats1         ; (_, se', arg') <- simplArg env' dup se arg         ; (let_floats2, arg'') <- makeTrivial env NotTopLevel dmd (fsLit "karg") arg'

@@ -45,6 +45,7 @@  import GHC.Types.Literal ( litIsLifted ) import GHC.Types.Id+import GHC.Types.Id.Make ( voidArgId, voidPrimId ) import GHC.Types.Var.Env import GHC.Types.Var.Set import GHC.Types.Name@@ -1741,24 +1742,13 @@ --        return ()                  -- And build the results-        ; let spec_body_ty   = exprType spec_body-              (spec_lam_args1, spec_sig, spec_arity1, spec_join_arity1)-                  = calcSpecInfo fn call_pat extra_bndrs-                  -- Annotate the variables with the strictness information from-                  -- the function (see Note [Strictness information in worker binders])-              add_void_arg = needsVoidWorkerArg fn arg_bndrs spec_lam_args1-              (spec_lam_args, spec_call_args, spec_arity, spec_join_arity)-                  | add_void_arg-                  -- See Note [SpecConst needs to add void args first]-                  , (spec_lam_args, spec_call_args, _) <- addVoidWorkerArg spec_lam_args1 []-                      -- needsVoidWorkerArg: usual w/w hack to avoid generating-                      -- a spec_rhs of unlifted type and no args.-                  , !spec_arity      <- spec_arity1 + 1-                  , !spec_join_arity <- fmap (+ 1) spec_join_arity1-                  = (spec_lam_args,  spec_call_args, spec_arity,  spec_join_arity)-                  | otherwise-                  = (spec_lam_args1, spec_lam_args1, spec_arity1, spec_join_arity1)+        ; let spec_body_ty = exprType spec_body+              (spec_lam_args, spec_call_args, spec_sig)+                  = calcSpecInfo fn arg_bndrs call_pat extra_bndrs +              spec_arity = count isId spec_lam_args+              spec_join_arity | isJoinId fn = Just (length spec_call_args)+                              | otherwise   = Nothing               spec_id    = asWorkerLikeId $                            mkLocalId spec_name Many                                      (mkLamTypes spec_lam_args spec_body_ty)@@ -1768,13 +1758,9 @@                              `setIdArity`     spec_arity                              `asJoinId_maybe` spec_join_arity -                -- Conditionally use result of new worker-wrapper transform-              spec_rhs   = mkLams spec_lam_args (mkSeqs cbv_args spec_body_ty spec_body)-              rule_rhs = mkVarApps (Var spec_id) $-                              -- This will give us all the arguments we quantify over-                              -- in the rule plus the void argument if present-                              -- since `length(qvars) + void + length(extra_bndrs) = length spec_call_args`-                              dropTail (length extra_bndrs) spec_call_args+        -- Conditionally use result of new worker-wrapper transform+              spec_rhs = mkLams spec_lam_args (mkSeqs cbv_args spec_body_ty spec_body)+              rule_rhs = mkVarApps (Var spec_id) spec_call_args               inline_act = idInlineActivation fn               this_mod   = sc_module env               rule       = mkRule this_mod True {- Auto -} True {- Local -}@@ -1814,73 +1800,129 @@         = rhs  -{- Note [SpecConst needs to add void args first]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+{- Note [SpecConstr void argument insertion]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider a function+    f :: Bool -> forall t. blah     f start @t = e We want to specialize for a partially applied call `f True`. See also Note [SpecConstr call patterns], second Wrinkle. Naively we would expect to get+    $sf :: forall t. blah     $sf @t = $se     RULE: f True = $sf-The specialized function only takes a single type argument-so we add a void argument to prevent it from turning into-a thunk. See Note [Protecting the last value argument] for details-why. Normally we would add the void argument after the-type argument giving us:+The specialized function only takes a single type argument so we add a+void argument to prevent it from turning into a thunk. See Note+[Protecting the last value argument] for details why. Normally we+would add the void argument after the type argument giving us:+     $sf :: forall t. Void# -> bla     $sf @t void = $se     RULE: f True = $sf void# (wrong)-But if you look closely this wouldn't typecheck!-If we substitute `f True` with `$sf void#` we expect the type argument to be applied first-but we apply void# first.-The easist fix seems to be just to add the void argument to the front of the arguments.-Now we get:++But if you look closely this wouldn't typecheck!  If we substitute `f+True` with `$sf void#` we expect the type argument to be applied first+but we apply void# first.  The easiest fix seems to be just to add the+void argument to the front of the arguments.  Now we get:+     $sf :: Void# -> forall t. bla     $sf void @t = $se     RULE: f True = $sf void#+ And now we can substitute `f True` with `$sf void#` with everything working out nicely!++More precisely, in `calcSpecInfo`+(i)  we need the void arg to /precede/ the `extra_bndrs`, but+(ii) it must still /follow/ `qvar_bndrs`.++Example to illustrate (ii):+  f :: forall r (a :: TYPE r). Bool -> a+  f = /\r. /\(a::TYPE r). \b. body++  {- Specialise for f _ _ True -}++  $sf :: forall r (a :: TYPE r). Void# -> a+  $sf = /\r. /\(a::TYPE r). \v. body[True/b]+  RULE: forall r (a :: TYPE r). f @r @a True = $sf @r @a void#++The void argument must follow the foralls, lest the forall be+ill-kinded.  See Note [Worker/wrapper needs to add void arg last] in+GHC.Core.Opt.WorkWrap.Utils.++Note [generaliseDictPats]+~~~~~~~~~~~~~~~~~~~~~~~~~+Consider these two rules (#21831, item 2):+  RULE "SPEC:foo"  forall d1 d2. foo @Int @Integer d1 d2 = $sfoo1+  RULE "SC:foo"    forall a. foo @Int @a $fNumInteger = $sfoo2 @a+The former comes from the type class specialiser, the latter from SpecConstr.+Note that $fNumInteger is a top-level binding for Num Integer.++The trouble is that neither is more general than the other.  In a call+   (foo @Int @Integer $fNumInteger d)+it isn't clear which rule to fire.++The trouble is that the SpecConstr rule fires on a /specific/ dict, $fNumInteger,+but actually /could/ fire regardless.  That is, it could be+  RULE "SC:foo"    forall a d. foo @Int @a d = $sfoo2 @a++Now, it is clear that SPEC:foo is more specific.  But GHC can't tell+that, because SpecConstr doesn't know that dictionary arguments are+singleton types!  So generaliseDictPats teaches it this fact.  It+spots such patterns (using typeDeterminesValue), and quantifies over+the dictionary.  Now we get++  RULE "SC:foo"    forall a d. foo @Int @a d = $sfoo2 @a++And /now/ "SPEC:foo" is clearly more specific: we can instantiate the new+"SC:foo" to match the (prefix of) "SPEC:foo". -} -calcSpecInfo :: Id                     -- The original function-             -> CallPat                -- Call pattern-             -> [Var]                  -- Extra bndrs-             -> ( [Var]                     -- Demand-decorated binders-                , DmdSig                    -- Strictness of specialised thing-                , Arity, Maybe JoinArity )  -- Arities of specialised thing--- Calcuate bits of IdInfo for the specialised function+calcSpecInfo :: Id           -- The original function+             -> [InVar]      -- Lambda binders of original RHS+             -> CallPat      -- Call pattern+             -> [Var]        -- Extra bndrs+             -> ( [Var]           -- Demand-decorated lambda binders+                                  --   for RHS of specialised function+                , [Var]           -- Args for call site+                , DmdSig )        -- Strictness of specialised thing+-- Calculate bits of IdInfo for the specialised function -- See Note [Transfer strictness] -- See Note [Strictness information in worker binders]-calcSpecInfo fn (CP { cp_qvars = qvars, cp_args = pats }) extra_bndrs-  | isJoinId fn    -- Join points have strictness and arity for LHS only-  = ( bndrs_w_dmds-    , mkClosedDmdSig qvar_dmds div-    , count isId qvars-    , Just (length qvars) )-  | otherwise-  = ( bndrs_w_dmds-    , mkClosedDmdSig (qvar_dmds ++ extra_dmds) div-    , count isId qvars + count isId extra_bndrs-    , Nothing )+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 )   where     DmdSig (DmdType _ fn_dmds div) = idDmdSig fn -    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.+    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 ]     extra_dmds = dropList val_pats fn_dmds -    bndrs_w_dmds =  set_dmds qvars       qvar_dmds-                 ++ set_dmds extra_bndrs extra_dmds+    -- Annotate the variables with the strictness information from+    -- the function (see Note [Strictness information in worker binders])+    qvars_w_dmds          = set_dmds qvars       qvar_dmds+    extras_w_dmds         = set_dmds extra_bndrs extra_dmds+    spec_lam_bndrs_w_dmds = final_qvars_w_dmds ++ extras_w_dmds +    (final_qvars_w_dmds, spec_call_args)+       | needsVoidWorkerArg fn arg_bndrs (qvars ++ extra_bndrs)+         -- Usual w/w hack to avoid generating+         -- a spec_rhs of unlifted or ill-kinded type and no args.+         -- See Note [SpecConstr void argument insertion]+       = ( qvars_w_dmds ++ [voidArgId], qvars ++ [voidPrimId] )+       | otherwise+       = ( qvars_w_dmds,                qvars )+     set_dmds :: [Var] -> [Demand] -> [Var]     set_dmds [] _   = []     set_dmds vs  [] = vs  -- Run out of demands     set_dmds (v:vs) ds@(d:ds') | isTyVar v = v                   : set_dmds vs ds                                | otherwise = setIdDemandInfo v d : set_dmds vs ds' -    dmd_env = go emptyVarEnv fn_dmds val_pats-     go :: DmdEnv -> [Demand] -> [CoreExpr] -> DmdEnv     -- We've filtered out all the type patterns already     go env (d:ds) (pat : pats)     = go (go_one env d pat) ds pats@@ -1893,7 +1935,6 @@       , Just (_b, ds) <- viewProd (length args) cd -- TODO: We may want to look at boxity _b, though...       = go env ds args     go_one env _  _ = env-  {- Note [spec_usg includes rhs_usg]

@@ -29,7 +29,8 @@ import GHC.Core.Unfold.Make import GHC.Core import GHC.Core.Rules-import GHC.Core.Utils     ( exprIsTrivial, getIdFromTrivialExpr_maybe+import GHC.Core.Utils     ( exprIsTrivial, exprIsTopLevelBindable+                          , getIdFromTrivialExpr_maybe                           , mkCast, exprType ) import GHC.Core.FVs import GHC.Core.TyCo.Rep (TyCoBinder (..))@@ -1321,7 +1322,10 @@                = [mkDB $ NonRec b r | (b,r) <- pairs]                  ++ bagToList dump_dbs -       ; if float_all then+             can_float_this_one = exprIsTopLevelBindable rhs (idType fn)+             -- exprIsTopLevelBindable: see Note [Care with unlifted bindings]++       ; if float_all && can_float_this_one then              -- Rather than discard the calls mentioning the bound variables              -- we float this (dictionary) binding along with the others               return ([], free_uds `snocDictBinds` final_binds)@@ -1658,6 +1662,28 @@ even in the case that @x = False@! Instead, we add a dummy 'Void#' argument to the specialisation '$sfInt' ($sfInt :: Void# -> Array# Int) in order to preserve laziness.++Note [Care with unlifted bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider (#22998)+    f x = let x::ByteArray# = <some literal>+              n::Natural    = NB x+          in wombat @192827 (n |> co)+where+  co :: Natural ~ KnownNat 192827+  wombat :: forall (n:Nat). KnownNat n => blah++Left to itself, the specialiser would float the bindings for `x` and `n` to top+level, so we can specialise `wombat`.  But we can't have a top-level ByteArray#+(see Note [Core letrec invariant] in GHC.Core).  Boo.++This is pretty exotic, so we take a simple way out: in specBind (the NonRec+case) do not float the binding itself unless it satisfies exprIsTopLevelBindable.+This is conservative: maybe the RHS of `x` has a free var that would stop it+floating to top level anyway; but that is hard to spot (since we don't know what+the non-top-level in-scope binders are) and rare (since the binding must satisfy+Note [Core let-can-float invariant] in GHC.Core).+  Note [Specialising Calls] ~~~~~~~~~~~~~~~~~~~~~~~~~

@@ -9,7 +9,7 @@  module GHC.Core.Opt.WorkWrap.Utils    ( WwOpts(..), initWwOpts, mkWwBodies, mkWWstr, mkWWstr_one-   , needsVoidWorkerArg, addVoidWorkerArg+   , needsVoidWorkerArg    , DataConPatContext(..)    , UnboxingDecision(..), wantToUnboxArg    , findTypeShape, IsRecDataConResult(..), isRecDataCon@@ -387,25 +387,34 @@ -- Note [Preserving float barriers]. needsVoidWorkerArg :: Id -> [Var] -> [Var] -> Bool needsVoidWorkerArg fn_id wrap_args work_args-  =  not (isJoinId fn_id) && no_value_arg -- See Note [Protecting the last value argument]-  || needs_float_barrier                  -- See Note [Preserving float barriers]+  =  thunk_problem         -- See Note [Protecting the last value argument]+  || needs_float_barrier   -- See Note [Preserving float barriers]   where-    no_value_arg        = all (not . isId) work_args+    -- thunk_problem: see Note [Protecting the last value argument]+    -- For join points we are only worried about (4), not (1-4).+    -- And (4) can't happen if (null work_args)+    --     (We could be more clever, by looking at the result type, but+    --      this approach is simple and conservative.)+    thunk_problem | isJoinId fn_id = no_value_arg && not (null work_args)+                  | otherwise      = no_value_arg+    no_value_arg = not (any isId work_args)++    -- needs_float_barrier: see Note [Preserving float barriers]+    needs_float_barrier = wrap_had_barrier && not work_has_barrier     is_float_barrier v  = isId v && hasNoOneShotInfo (idOneShotInfo v)     wrap_had_barrier    = any is_float_barrier wrap_args     work_has_barrier    = any is_float_barrier work_args-    needs_float_barrier = wrap_had_barrier && not work_has_barrier --- | Inserts a `Void#` arg before the first argument.------ Why as the first argument? See Note [SpecConst needs to add void args first]--- in SpecConstr.+-- | Inserts a `Void#` arg as the last argument.+-- Why last? See Note [Worker/wrapper needs to add void arg last] addVoidWorkerArg :: [Var] -> [StrictnessMark]-                 -> ([Var],     -- Lambda bound args-                     [Var],     -- Args at call site-                     [StrictnessMark]) -- cbv semantics for the worker args.-addVoidWorkerArg work_args cbv_marks-  = (voidArgId : work_args, voidPrimId:work_args, NotMarkedStrict:cbv_marks)+                 -> ( [Var]     -- Lambda bound args+                    , [Var]     -- Args at call site+                    , [StrictnessMark]) -- str semantics for the worker args+addVoidWorkerArg work_args str_marks+  = ( work_args ++ [voidArgId]+    , work_args ++ [voidPrimId]+    , str_marks ++ [NotMarkedStrict] )  {- Note [Protecting the last value argument]@@ -413,8 +422,8 @@ If the user writes (\_ -> E), they might be intentionally disallowing the sharing of E. Since absence analysis and worker-wrapper are keen to remove such unused arguments, we add in a void argument to prevent-the function from becoming a thunk.  Three reasons why turning a function-into a thunk might be bad:+the function from becoming a thunk.  Here are several reasons why turning+a function into a thunk might be bad:  1) It can create a space leak. e.g.       f x = let y () = [1..x]@@ -433,8 +442,20 @@        g = \x. 30#    Removing the \x would leave an unlifted binding. -NB: none of these apply to a join point.+4) It can create a worker of ill-kinded type (#22275).  Consider+     f :: forall r (a :: TYPE r). () -> a+     f x = f x+   Here `x` is absent, but if we simply drop it we'd end up with+     $wf :: forall r (a :: TYPE r). a+   But alas $wf's type is ill-kinded: the kind of (/\r (a::TYPE r).a)+   is (TYPE r), which mentions the bound variable `r`.  See also+   Note [Worker/wrapper needs to add void arg last] +See also Note [Preserving float barriers]++NB: Of these, only (1-3) don't apply to a join point, which can be+unlifted even if the RHS is not ok-for-speculation.+ Note [Preserving float barriers] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider@@ -467,7 +488,7 @@    * \a{Abs}.\b{os}.\c{os}... ==> \b{os}.\c{os}.\(_::Void#)...     Wrapper arg `a` was the only float barrier and had been dropped. Hence Void#-  * \a{Abs,os}.\b{os}.\c... ==> \b{os}.\c...+p  * \a{Abs,os}.\b{os}.\c... ==> \b{os}.\c...     Worker arg `c` is a float barrier.   * \a.\b{Abs}.\c{os}... ==> \a.\c{os}...     Worker arg `a` is a float barrier.@@ -478,6 +499,27 @@     enough to subsume Note [Protecting the last value argument].  Executable examples in T21150.++Note [Worker/wrapper needs to add void arg last]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider point (4) of Note [Protecting the last value argument]++  f :: forall r (a :: TYPE r). () -> a+  f x = f x++As pointed out in (4) we need to add a void argument.  But if we add+it /first/ we'd get++  $wf :: Void# -> forall r (a :: TYPE r). a+  $wf = ...++But alas $wf's type is /still/ still-kinded, just as before in (4).+Solution is simple: put the void argument /last/:++  $wf :: forall r (a :: TYPE r). Void# -> a+  $wf = ...++c.f Note [SpecConstr void argument insertion] in GHC.Core.Opt.SpecConstr  Note [Join points and beta-redexes] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

@@ -49,7 +49,7 @@         mkSpecForAllTy, mkSpecForAllTys,         mkVisForAllTys, mkTyCoInvForAllTy,         mkInfForAllTy, mkInfForAllTys,-        splitForAllTyCoVars,+        splitForAllTyCoVars, splitForAllTyVars,         splitForAllReqTVBinders, splitForAllInvisTVBinders,         splitForAllTyCoVarBinders,         splitForAllTyCoVar_maybe, splitForAllTyCoVar,

@@ -1,6 +1,6 @@ -- (c) The University of Glasgow 2006 -{-# LANGUAGE ScopedTypeVariables, PatternSynonyms #-}+{-# LANGUAGE ScopedTypeVariables, PatternSynonyms, MultiWayIf #-}  {-# LANGUAGE DeriveFunctor #-} @@ -50,6 +50,7 @@ import GHC.Types.Unique.Set import {-# SOURCE #-} GHC.Tc.Utils.TcType ( tcEqType ) import GHC.Exts( oneShot )+import GHC.Utils.Panic import GHC.Utils.Panic.Plain import GHC.Data.FastString @@ -1045,6 +1046,59 @@ (legitimately) have different numbers of arguments.  They are surelyApart, so we can report that without looking any further (see #15704).++Note [Unifying type applications]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Unifying type applications is quite subtle, as we found+in #23134 and #22647, when type families are involved.++Suppose+   type family F a :: Type -> Type+   type family G k :: k = r | r -> k++and consider these examples:++* F Int ~ F Char, where F is injective+  Since F is injective, we can reduce this to Int ~ Char,+  therefore SurelyApart.++* F Int ~ F Char, where F is not injective+  Without injectivity, return MaybeApart.++* G Type ~ G (Type -> Type) Int+  Even though G is injective and the arguments to G are different,+  we cannot deduce apartness because the RHS is oversaturated.+  For example, G might be defined as+    G Type = Maybe Int+    G (Type -> Type) = Maybe+  So we return MaybeApart.++* F Int Bool ~ F Int Char       -- SurelyApart (since Bool is apart from Char)+  F Int Bool ~ Maybe a          -- MaybeApart+  F Int Bool ~ a b              -- MaybeApart+  F Int Bool ~ Char -> Bool     -- MaybeApart+  An oversaturated type family can match an application,+  whether it's a TyConApp, AppTy or FunTy. Decompose.++* F Int ~ a b+  We cannot decompose a saturated, or under-saturated+  type family application. We return MaybeApart.++To handle all those conditions, unify_ty goes through+the following checks in sequence, where Fn is a type family+of arity n:++* (C1) Fn x_1 ... x_n ~ Fn y_1 .. y_n+  A saturated application.+  Here we can unify arguments in which Fn is injective.+* (C2) Fn x_1 ... x_n ~ anything, anything ~ Fn x_1 ... x_n+  A saturated type family can match anything - we return MaybeApart.+* (C3) Fn x_1 ... x_m ~ a b, a b ~ Fn x_1 ... x_m where m > n+  An oversaturated type family can be decomposed.+* (C4) Fn x_1 ... x_m ~ anything, anything ~ Fn x_1 ... x_m, where m > n+  If we couldn't decompose in the previous step, we return SurelyApart.++Afterwards, the rest of the code doesn't have to worry about type families. -}  -------------- unify_ty: the main workhorse -----------@@ -1093,43 +1147,63 @@   = uVar (umSwapRn env) tv2 ty1 (mkSymCo kco)  unify_ty env ty1 ty2 _kco- -- NB: This keeps Constraint and Type distinct, as it should for use in the- -- type-checker.-  | Just (tc1, tys1) <- mb_tc_app1-  , Just (tc2, tys2) <- mb_tc_app2+  -- Handle non-oversaturated type families first+  -- See Note [Unifying type applications]+  --+  -- (C1) If we have T x1 ... xn ~ T y1 ... yn, use injectivity information of T+  -- Note that both sides must not be oversaturated+  | Just (tc1, tys1) <- isSatTyFamApp mb_tc_app1+  , Just (tc2, tys2) <- isSatTyFamApp mb_tc_app2   , tc1 == tc2-  = if isInjectiveTyCon tc1 Nominal-    then unify_tys env tys1 tys2-    else do { let inj | isTypeFamilyTyCon tc1-                      = case tyConInjectivityInfo tc1 of-                               NotInjective -> repeat False-                               Injective bs -> bs-                      | otherwise-                      = repeat False+  = do { let inj = case tyConInjectivityInfo tc1 of+                          NotInjective -> repeat False+                          Injective bs -> bs -                  (inj_tys1, noninj_tys1) = partitionByList inj tys1-                  (inj_tys2, noninj_tys2) = partitionByList inj tys2+             (inj_tys1, noninj_tys1) = partitionByList inj tys1+             (inj_tys2, noninj_tys2) = partitionByList inj tys2 -            ; unify_tys env inj_tys1 inj_tys2-            ; unless (um_inj_tf env) $ -- See (end of) Note [Specification of unification]-              don'tBeSoSure MARTypeFamily $ unify_tys env noninj_tys1 noninj_tys2 }+       ; unify_tys env inj_tys1 inj_tys2+       ; unless (um_inj_tf env) $ -- See (end of) Note [Specification of unification]+         don'tBeSoSure MARTypeFamily $ unify_tys env noninj_tys1 noninj_tys2 } +  | Just _ <- isSatTyFamApp mb_tc_app1  -- (C2) A (not-over-saturated) type-family application+  = maybeApart MARTypeFamily            -- behaves like a type variable; might match++  | Just _ <- isSatTyFamApp mb_tc_app2  -- (C2) A (not-over-saturated) type-family application+                                        -- behaves like a type variable; might unify+                                        -- but doesn't match (as in the TyVarTy case)+  = if um_unif env then maybeApart MARTypeFamily else surelyApart++  -- Handle oversaturated type families.+  --+  -- They can match an application (TyConApp/FunTy/AppTy), this is handled+  -- the same way as in the AppTy case below.+  --+  -- If there is no application, an oversaturated type family can only+  -- match a type variable or a saturated type family,+  -- both of which we handled earlier. So we can say surelyApart.   | Just (tc1, _) <- mb_tc_app1-  , not (isGenerativeTyCon tc1 Nominal)-    -- E.g.   unify_ty (F ty1) b  =  MaybeApart-    --        because the (F ty1) behaves like a variable-    --        NB: if unifying, we have already dealt-    --            with the 'ty2 = variable' case-  = maybeApart MARTypeFamily+  , isTypeFamilyTyCon tc1+  = if | Just (ty1a, ty1b) <- tcRepSplitAppTy_maybe ty1+       , Just (ty2a, ty2b) <- tcRepSplitAppTy_maybe ty2+       -> unify_ty_app env ty1a [ty1b] ty2a [ty2b]            -- (C3)+       | otherwise -> surelyApart                             -- (C4)    | Just (tc2, _) <- mb_tc_app2-  , not (isGenerativeTyCon tc2 Nominal)-  , um_unif env-    -- E.g.   unify_ty [a] (F ty2) =  MaybeApart, when unifying (only)-    --        because the (F ty2) behaves like a variable-    --        NB: we have already dealt with the 'ty1 = variable' case-  = maybeApart MARTypeFamily+  , isTypeFamilyTyCon tc2+  = if | Just (ty1a, ty1b) <- tcRepSplitAppTy_maybe ty1+       , Just (ty2a, ty2b) <- tcRepSplitAppTy_maybe ty2+       -> unify_ty_app env ty1a [ty1b] ty2a [ty2b]            -- (C3)+       | otherwise -> surelyApart                             -- (C4) +  -- At this point, neither tc1 nor tc2 can be a type family.+  | Just (tc1, tys1) <- mb_tc_app1+  , Just (tc2, tys2) <- mb_tc_app2+  , tc1 == tc2+  = do { massertPpr (isInjectiveTyCon tc1 Nominal) (ppr tc1)+       ; unify_tys env tys1 tys2+       }+   where     mb_tc_app1 = tcSplitTyConApp_maybe ty1     mb_tc_app2 = tcSplitTyConApp_maybe ty2@@ -1215,6 +1289,17 @@     go _ _ = surelyApart       -- Possibly different saturations of a polykinded tycon       -- See Note [Polykinded tycon applications]++isSatTyFamApp :: Maybe (TyCon, [Type]) -> Maybe (TyCon, [Type])+-- Return the argument if we have a saturated type family application+-- If it is /over/ saturated then we return False.  E.g.+--     unify_ty (F a b) (c d)    where F has arity 1+-- we definitely want to decompose that type application! (#22647)+isSatTyFamApp tapp@(Just (tc, tys))+  |  isTypeFamilyTyCon tc+  && not (tys `lengthExceeds` tyConArity tc)  -- Not over-saturated+  = tapp+isSatTyFamApp _ = Nothing  --------------------------------- uVar :: UMEnv

@@ -166,7 +166,7 @@ coreAltsType (alt:_) = coreAltType alt coreAltsType []      = panic "coreAltsType" -mkLamType  :: Var -> Type -> Type+mkLamType  :: HasDebugCallStack => Var -> Type -> Type -- ^ Makes a @(->)@ type or an implicit forall type, depending -- on whether it is given a type variable or a term variable. -- This is used, for example, when producing the type of a lambda.

@@ -42,12 +42,18 @@     , toIfaceVar       -- * Other stuff     , toIfaceLFInfo+      -- * CgBreakInfo+    , dehydrateCgBreakInfo     ) where  import GHC.Prelude +import Data.Word+ import GHC.StgToCmm.Types +import GHC.ByteCode.Types+ import GHC.Core import GHC.Core.TyCon hiding ( pprPromotionQuote ) import GHC.Core.Coercion.Axiom@@ -657,6 +663,16 @@       IfLFUnlifted     LFLetNoEscape ->       panic "toIfaceLFInfo: LFLetNoEscape"++-- Dehydrating CgBreakInfo++dehydrateCgBreakInfo :: [TyVar] -> [Maybe (Id, Word16)] -> Type -> CgBreakInfo+dehydrateCgBreakInfo ty_vars idOffSets tick_ty =+          CgBreakInfo+            { cgb_tyvars = map toIfaceTvBndr ty_vars+            , cgb_vars = map (fmap (\(i, offset) -> (toIfaceIdBndr i, offset))) idOffSets+            , cgb_resty = toIfaceType tick_ty+            }  {- Note [Inlining and hs-boot files] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

@@ -76,28 +76,29 @@       -> diagnosticMessage m     DriverPsHeaderMessage m       -> diagnosticMessage m-    DriverMissingHomeModules missing buildingCabalPackage+    DriverMissingHomeModules uid missing buildingCabalPackage       -> let msg | buildingCabalPackage == YesBuildingCabalPackage                  = hang-                     (text "These modules are needed for compilation but not listed in your .cabal file's other-modules: ")+                     (text "These modules are needed for compilation but not listed in your .cabal file's other-modules for" <+> quotes (ppr uid) <+> text ":")                      4                      (sep (map ppr missing))                  | otherwise                  =                    hang-                     (text "Modules are not listed in command line but needed for compilation: ")+                     (text "Modules are not listed in options for"+                        <+> quotes (ppr uid) <+> text "but needed for compilation:")                      4                      (sep (map ppr missing))          in mkSimpleDecorated msg-    DriverUnknownHiddenModules missing+    DriverUnknownHiddenModules uid missing       -> let msg = hang-                     (text "Modules are listened as hidden but not part of the unit: ")+                     (text "Modules are listed as hidden in options for" <+> quotes (ppr uid) <+> text "but not part of the unit:")                      4                      (sep (map ppr missing))          in mkSimpleDecorated msg-    DriverUnknownReexportedModules missing+    DriverUnknownReexportedModules uid missing       -> let msg = hang-                     (text "Modules are listened as reexported but can't be found in any dependency: ")+                     (text "Modules are listed as reexported in options for" <+> quotes (ppr uid) <+> text "but can't be found in any dependency:")                      4                      (sep (map ppr missing))          in mkSimpleDecorated msg

@@ -126,17 +126,17 @@       Test case: warnings/should_compile/MissingMod    -}-  DriverMissingHomeModules :: [ModuleName] -> !BuildingCabalPackage -> DriverMessage+  DriverMissingHomeModules :: UnitId -> [ModuleName] -> !BuildingCabalPackage -> DriverMessage    {-| DriverUnknown is a warning that arises when a user tries to       reexport a module which isn't part of that unit.   -}-  DriverUnknownReexportedModules :: [ModuleName] -> DriverMessage+  DriverUnknownReexportedModules :: UnitId -> [ModuleName] -> DriverMessage    {-| DriverUnknownHiddenModules is a warning that arises when a user tries to       hide a module which isn't part of that unit.   -}-  DriverUnknownHiddenModules :: [ModuleName] -> DriverMessage+  DriverUnknownHiddenModules :: UnitId -> [ModuleName] -> DriverMessage    {-| DriverUnusedPackages occurs when when package is requested on command line,       but was never needed during compilation. Activated by -Wunused-packages.

@@ -778,6 +778,12 @@             msg $ UpToDate             return $ HscUpToDate checked_iface Nothing           -- Do need linkable+          backend+            | not (backendProducesObject backend)+            , IsBoot <- isBootSummary mod_summary+            -> do+            msg $ UpToDate+            return $ HscUpToDate checked_iface Nothing           _ -> do             -- Check to see whether the expected build products already exist.             -- If they don't exists then we trigger recompilation.@@ -1303,19 +1309,20 @@         -- restore old errors         logDiagnostics oldErrs -        case (isEmptyMessages safeErrs) of-          -- Failed safe check-          False -> liftIO . throwErrors $ safeErrs+        diag_opts <- initDiagOpts <$> getDynFlags+        logger <- getLogger -          -- Passed safe check-          True -> do-            let infPassed = isEmptyMessages infErrs-            tcg_env' <- case (not infPassed) of-              True  -> markUnsafeInfer tcg_env infErrs-              False -> return tcg_env-            when (packageTrustOn dflags) $ checkPkgTrust pkgReqs-            let newTrust = pkgTrustReqs dflags safePkgs infPkgs infPassed-            return tcg_env' { tcg_imports = impInfo `plusImportAvails` newTrust }+        -- Will throw if failed safe check+        liftIO $ printOrThrowDiagnostics logger diag_opts safeErrs++        -- No fatal warnings or errors: passed safe check+        let infPassed = isEmptyMessages infErrs+        tcg_env' <- case (not infPassed) of+          True  -> markUnsafeInfer tcg_env infErrs+          False -> return tcg_env+        when (packageTrustOn dflags) $ checkPkgTrust pkgReqs+        let newTrust = pkgTrustReqs dflags safePkgs infPkgs infPassed+        return tcg_env' { tcg_imports = impInfo `plusImportAvails` newTrust }    where     impInfo  = tcg_imports tcg_env     -- ImportAvails

@@ -105,7 +105,6 @@ import GHC.Types.SourceFile import GHC.Types.SourceError import GHC.Types.SrcLoc-import GHC.Types.Unique.FM import GHC.Types.PkgQual  import GHC.Unit@@ -343,7 +342,7 @@           TargetFile target_file _             | Just mod_file <- ml_hs_file (ms_location mod)             ->-             target_file == mod_file ||+             augmentByWorkingDirectory dflags target_file == mod_file ||               --  Don't warn on B.hs-boot if B.hs is specified (#16551)              addBootSuffix target_file == mod_file ||@@ -362,7 +361,7 @@                 (mgModSummaries mod_graph))      warn = singleMessage $ mkPlainMsgEnvelope diag_opts noSrcSpan-                         $ DriverMissingHomeModules missing (checkBuildingCabalPackage dflags)+                         $ DriverMissingHomeModules (homeUnitId_ dflags) missing (checkBuildingCabalPackage dflags)  -- Check that any modules we want to reexport or hide are actually in the package. warnUnknownModules :: HscEnv -> DynFlags -> ModuleGraph -> IO DriverMessages@@ -390,14 +389,14 @@         _ -> return True  -    warn flag mod = singleMessage $ mkPlainMsgEnvelope diag_opts noSrcSpan-                         $ flag mod+    warn diagnostic = singleMessage $ mkPlainMsgEnvelope diag_opts noSrcSpan+                         $ diagnostic      final_msgs hidden_warns reexported_warns           =         unionManyMessages $-          [warn DriverUnknownHiddenModules (Set.toList hidden_warns) | not (Set.null hidden_warns)]-          ++ [warn DriverUnknownReexportedModules reexported_warns | not (null reexported_warns)]+          [warn (DriverUnknownHiddenModules (homeUnitId_ dflags) (Set.toList hidden_warns)) | not (Set.null hidden_warns)]+          ++ [warn (DriverUnknownReexportedModules (homeUnitId_ dflags) reexported_warns) | not (null reexported_warns)]  -- | Describes which modules of the module graph need to be loaded. data LoadHowMuch@@ -445,6 +444,9 @@ data CachedIface = CachedIface { cached_modiface :: !ModIface                                , cached_linkable :: !(Maybe Linkable) } +instance Outputable CachedIface where+  ppr (CachedIface mi ln) = hsep [text "CachedIface", ppr (miKey mi), ppr ln]+ noIfaceCache :: Maybe ModIfaceCache noIfaceCache = Nothing @@ -815,15 +817,19 @@                            , cached_linkable = linkable                            }) = HomeModInfo iface emptyModDetails linkable'           where-           modl = moduleName (mi_module iface)+           modl = miKey iface            linkable'-                | Just ms <- lookupUFM ms_map modl+                | Just ms <- M.lookup modl ms_map                 , mi_src_hash iface /= ms_hs_hash ms                 = Nothing                 | otherwise                 = linkable -        ms_map = listToUFM [(ms_mod_name ms, ms) | ms <- summ]+        -- Using UFM Module is safe for determinism because the map is just used for a transient lookup. The cache should be unique and a key clash is an error.+        ms_map = M.fromListWith+                  (\ms1 ms2 -> assertPpr False (text "prune_cache" $$ (ppr ms1 <+> ppr ms2))+                               ms2)+                  [(msKey ms, ms) | ms <- summ]  -- --------------------------------------------------------------------------- --@@ -1490,11 +1496,13 @@         logger = hsc_logger hsc_env         roots  = hsc_targets hsc_env -        -- A cache from file paths to the already summarised modules.+        -- A cache from file paths to the already summarised modules. The same file+        -- can be used in multiple units so the map is also keyed by which unit the+        -- file was used in.         -- Reuse these if we can because the most expensive part of downsweep is         -- reading the headers.-        old_summary_map :: M.Map FilePath ModSummary-        old_summary_map = M.fromList [(msHsFilePath ms, ms) | ms <- old_summaries]+        old_summary_map :: M.Map (UnitId, FilePath) ModSummary+        old_summary_map = M.fromList [((ms_unitid ms, msHsFilePath ms), ms) | ms <- old_summaries]          getRootSummary :: Target -> IO (Either (UnitId, DriverMessages) ModSummary)         getRootSummary Target { targetId = TargetFile file mb_phase@@ -1809,7 +1817,7 @@ summariseFile         :: HscEnv         -> HomeUnit-        -> M.Map FilePath ModSummary    -- old summaries+        -> M.Map (UnitId, FilePath) ModSummary    -- old summaries         -> FilePath                     -- source file name         -> Maybe Phase                  -- start phase         -> Maybe (StringBuffer,UTCTime)@@ -1817,9 +1825,8 @@  summariseFile hsc_env' home_unit old_summaries src_fn mb_phase maybe_buf         -- we can use a cached summary if one is available and the-        -- source file hasn't changed,  But we have to look up the summary-        -- by source file, rather than module name as we do in summarise.-   | Just old_summary <- M.lookup src_fn old_summaries+        -- source file hasn't changed,+   | Just old_summary <- M.lookup (homeUnitId home_unit, src_fn) old_summaries    = do         let location = ms_location $ old_summary @@ -1928,7 +1935,7 @@ summariseModule           :: HscEnv           -> HomeUnit-          -> M.Map FilePath ModSummary+          -> M.Map (UnitId, FilePath) ModSummary           -- ^ Map of old summaries           -> IsBootInterface    -- True <=> a {-# SOURCE #-} import           -> Located ModuleName -- Imported module to be summarised@@ -1989,7 +1996,7 @@               Right ms -> FoundHome ms      new_summary_cache_check loc mod src_fn h-      | Just old_summary <- Map.lookup src_fn old_summary_map =+      | Just old_summary <- Map.lookup ((toUnitId (moduleUnit mod), src_fn)) old_summary_map =           -- check the hash on the source file, and          -- return the cached summary if it hasn't changed.  If the

@@ -478,21 +478,33 @@       next_phase = hscPostBackendPhase src_flavour (backend dflags)   case result of       HscUpdate iface ->-          do-             case src_flavour of-               HsigFile -> do-                 -- We need to create a REAL but empty .o file-                 -- because we are going to attempt to put it in a library-                 let input_fn = expectJust "runPhase" (ml_hs_file location)-                     basename = dropExtension input_fn-                 compileEmptyStub dflags hsc_env basename location mod_name+          if | NoBackend <- backend dflags  ->+                panic "HscUpdate not relevant for NoBackend"+             | Interpreter <- backend dflags -> do+                -- In Interpreter way, there is just no linkable for hs-boot files+                -- and we don't want to write an empty `o-boot` file when we're not+                -- supposed to be writing any .o files (#22669)+                return ([], iface, Nothing, o_file)+             | otherwise -> do+                 case src_flavour of+                   HsigFile -> do+                     -- We need to create a REAL but empty .o file+                     -- because we are going to attempt to put it in a library+                     let input_fn = expectJust "runPhase" (ml_hs_file location)+                         basename = dropExtension input_fn+                     compileEmptyStub dflags hsc_env basename location mod_name -               -- In the case of hs-boot files, generate a dummy .o-boot-               -- stamp file for the benefit of Make-               HsBootFile -> touchObjectFile logger dflags o_file-               HsSrcFile -> panic "HscUpdate not relevant for HscSrcFile"+                   -- In the case of hs-boot files, generate a dummy .o-boot+                   -- stamp file for the benefit of Make+                   HsBootFile -> touchObjectFile logger dflags o_file+                   HsSrcFile -> panic "HscUpdate not relevant for HscSrcFile" -             return ([], iface, Nothing, o_file)+                     -- MP: I wonder if there are any lurking bugs here because we+                     -- return Linkable == emptyHomeModInfoLinkable, despite the fact that there is a+                     -- linkable (.o-boot) which we check for in `Iface/Recomp.hs` and+                     -- then will carry around the linkable if we're doing+                     -- recompilation.+                 return ([], iface, Nothing, o_file)       HscRecomp { hscs_guts = cgguts,                   hscs_mod_location = mod_location,                   hscs_partial_iface = partial_iface,

@@ -912,7 +912,7 @@                        emptyLocalBinds]  -- | Make a prefix, non-strict function 'HsMatchContext'-mkPrefixFunRhs :: LIdP p -> HsMatchContext p+mkPrefixFunRhs :: LIdP (NoGhcTc p) -> HsMatchContext p mkPrefixFunRhs n = FunRhs { mc_fun = n                           , mc_fixity = Prefix                           , mc_strictness = NoSrcStrict }

@@ -35,6 +35,7 @@ import Data.List (sortBy) import Data.Map (Map) import qualified Data.Map as Map+import qualified Data.Set as Set  import GHC.Linker.Types import GHC.Unit.Finder@@ -173,7 +174,7 @@           case miface of             Nothing -> pprPanic "mkObjectUsage" (ppr m)             Just iface ->-              return $ UsageHomeModuleInterface (moduleName m) (mi_iface_hash (mi_final_exts iface))+              return $ UsageHomeModuleInterface (moduleName m) (toUnitId $ moduleUnit m) (mi_iface_hash (mi_final_exts iface))      librarySpecToUsage :: LibrarySpec -> IO [Usage]     librarySpecToUsage (Objects os) = traverse (fing Nothing) os@@ -193,6 +194,7 @@     hpt = hsc_HUG hsc_env     dflags = hsc_dflags hsc_env     home_unit = hsc_home_unit hsc_env+    home_unit_ids = hsc_all_home_unit_ids hsc_env      used_mods    = moduleEnvKeys ent_map     dir_imp_mods = moduleEnvKeys direct_imports@@ -238,7 +240,7 @@                                         -- things in *this* module       = Nothing -      | not (isHomeModule home_unit mod)+      | toUnitId (moduleUnit mod) `Set.notMember` home_unit_ids       = Just UsagePackageModule{ usg_mod      = mod,                                  usg_mod_hash = mod_hash,                                  usg_safe     = imp_safe }@@ -256,6 +258,7 @@       | otherwise       = Just UsageHomeModule {                       usg_mod_name = moduleName mod,+                      usg_unit_id  = toUnitId (moduleUnit mod),                       usg_mod_hash = mod_hash,                       usg_exports  = export_hash,                       usg_entities = Map.toList ent_hashs,

@@ -943,7 +943,7 @@       name' :: LocatedN Name       name' = case hiePass @p of         HieRn -> name-        HieTc -> mapLoc varName name+        HieTc -> name   toHie (StmtCtxt a) = toHie a   toHie _ = pure [] 

@@ -1164,7 +1164,7 @@ pprUsage usage@UsagePackageModule{}   = pprUsageImport usage usg_mod pprUsage usage@UsageHomeModule{}-  = pprUsageImport usage usg_mod_name $$+  = pprUsageImport usage (\u -> mkModule (usg_unit_id u) (usg_mod_name u)) $$     nest 2 (         maybe Outputable.empty (\v -> text "exports: " <> ppr v) (usg_exports usage) $$         vcat [ ppr n <+> ppr v | (n,v) <- usg_entities usage ]@@ -1176,7 +1176,9 @@ pprUsage usage@UsageMergedRequirement{}   = hsep [text "merged", ppr (usg_mod usage), ppr (usg_mod_hash usage)] pprUsage usage@UsageHomeModuleInterface{}-  = hsep [text "implementation", ppr (usg_mod_name usage), ppr (usg_iface_hash usage)]+  = hsep [text "implementation", ppr (usg_mod_name usage)+                               , ppr (usg_unit_id usage)+                               , ppr (usg_iface_hash usage)]  pprUsageImport :: Outputable a => Usage -> (Usage -> a) -> SDoc pprUsageImport usage usg_mod'

@@ -399,7 +399,7 @@        when (isOneShot (ghcMode (hsc_dflags hsc_env))) $ do {           ; updateEps_ $ \eps  -> eps { eps_is_boot = mkModDeps $ dep_boot_mods (mi_deps iface) }        }-       ; recomp <- checkList [checkModUsage (hsc_FC hsc_env) (homeUnitAsUnit home_unit) u+       ; recomp <- checkList [checkModUsage (hsc_FC hsc_env) u                              | u <- mi_usages iface]        ; case recomp of (NeedsRecompile reason) -> return $ OutOfDateItem reason (Just iface) ; _ -> do {        ; return $ UpToDateItem iface@@ -679,7 +679,7 @@   = do  -- Load the imported interface if possible     logger <- getLogger     let doc_str = sep [text doc_msg, ppr mod]-    liftIO $ trace_hi_diffs logger (text "Checking interface for module" <+> ppr mod)+    liftIO $ trace_hi_diffs logger (text "Checking interface for module" <+> ppr mod <+> ppr (moduleUnit mod))      mb_iface <- loadInterface doc_str mod ImportBySystem         -- Load the interface, but don't complain on failure;@@ -698,8 +698,8 @@ -- | Given the usage information extracted from the old -- M.hi file for the module being compiled, figure out -- whether M needs to be recompiled.-checkModUsage :: FinderCache -> Unit -> Usage -> IfG RecompileRequired-checkModUsage _ _this_pkg UsagePackageModule{+checkModUsage :: FinderCache -> Usage -> IfG RecompileRequired+checkModUsage _ UsagePackageModule{                                 usg_mod = mod,                                 usg_mod_hash = old_mod_hash } = do   logger <- getLogger@@ -711,25 +711,28 @@         -- recompile.  This is safe but may entail more recompilation when         -- a dependent package has changed. -checkModUsage _ _ UsageMergedRequirement{ usg_mod = mod, usg_mod_hash = old_mod_hash } = do+checkModUsage _ UsageMergedRequirement{ usg_mod = mod, usg_mod_hash = old_mod_hash } = do   logger <- getLogger   needInterface mod $ \iface -> do     let reason = ModuleChangedRaw (moduleName mod)     checkModuleFingerprint logger reason old_mod_hash (mi_mod_hash (mi_final_exts iface))-checkModUsage _ this_pkg UsageHomeModuleInterface{ usg_mod_name = mod_name, usg_iface_hash = old_mod_hash } = do-  let mod = mkModule this_pkg mod_name+checkModUsage _  UsageHomeModuleInterface{ usg_mod_name = mod_name+                                                 , usg_unit_id = uid+                                                 , usg_iface_hash = old_mod_hash } = do+  let mod = mkModule (RealUnit (Definite uid)) mod_name   logger <- getLogger   needInterface mod $ \iface -> do     let reason = ModuleChangedIface mod_name     checkIfaceFingerprint logger reason old_mod_hash (mi_iface_hash (mi_final_exts iface)) -checkModUsage _ this_pkg UsageHomeModule{+checkModUsage _ UsageHomeModule{                                 usg_mod_name = mod_name,+                                usg_unit_id  = uid,                                 usg_mod_hash = old_mod_hash,                                 usg_exports = maybe_old_export_hash,                                 usg_entities = old_decl_hash }   = do-    let mod = mkModule this_pkg mod_name+    let mod = mkModule (RealUnit (Definite uid)) mod_name     logger <- getLogger     needInterface mod $ \iface -> do      let@@ -754,9 +757,9 @@            , up_to_date logger (text "  Great!  The bits I use are up to date")            ] -checkModUsage fc _this_pkg UsageFile{ usg_file_path = file,-                                   usg_file_hash = old_hash,-                                   usg_file_label = mlabel } =+checkModUsage fc UsageFile{ usg_file_path = file,+                            usg_file_hash = old_hash,+                            usg_file_label = mlabel } =   liftIO $     handleIO handler $ do       new_hash <- lookupFileCache fc file

@@ -1073,7 +1073,8 @@   -- we have to update the name cache in a nice atomic fashion    | local  && internal = do uniq <- takeUniqFromNameCache name_cache-                            let new_local_name = mkInternalName uniq occ' loc+                            -- See #19619+                            let new_local_name = occ' `seq` mkInternalName uniq occ' loc                             return (occ_env', new_local_name)         -- Even local, internal names must get a unique occurrence, because         -- if we do -split-objs we externalise the name later, in the code generator

@@ -11,6 +11,8 @@ {-# LANGUAGE FlexibleContexts #-}  {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}  module GHC.IfaceToCore (         tcLookupImported_maybe,@@ -22,11 +24,16 @@         tcIfaceAnnotations, tcIfaceCompleteMatches,         tcIfaceExpr,    -- Desired by HERMIT (#7683)         tcIfaceGlobal,-        tcIfaceOneShot+        tcIfaceOneShot,+        hydrateCgBreakInfo  ) where  import GHC.Prelude +import GHC.ByteCode.Types++import Data.Word+ import GHC.Driver.Env import GHC.Driver.Session @@ -2069,3 +2076,12 @@ bindIfaceTyConBinderX bind_tv (Bndr tv vis) thing_inside   = bind_tv tv $ \tv' ->     thing_inside (Bndr tv' vis)++-- CgBreakInfo++hydrateCgBreakInfo :: CgBreakInfo -> IfL ([Maybe (Id, Word16)], Type)+hydrateCgBreakInfo CgBreakInfo{..} = do+  bindIfaceTyVars cgb_tyvars $ \_ -> do+    result_ty <- tcIfaceType cgb_resty+    mbVars <- mapM (traverse (\(if_gbl, offset) -> (,offset) <$> bindIfaceId if_gbl return)) cgb_vars+    return (mbVars, result_ty)

@@ -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.4-src/ghc-9.4.4/compiler/GHC/Parser/HaddockLex.x" #-}+{-# LINE 1 "_build/source-dist/ghc-9.4.5-src/ghc-9.4.5/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.4-src/ghc-9.4.4/compiler/GHC/Parser/HaddockLex.x" #-}+{-# LINE 87 "_build/source-dist/ghc-9.4.5-src/ghc-9.4.5/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.4-src/ghc-9.4.4/compiler/GHC/Parser/Lexer.x" #-}+{-# LINE 43 "_build/source-dist/ghc-9.4.5-src/ghc-9.4.5/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.4-src/ghc-9.4.4/compiler/GHC/Parser/Lexer.x" #-}+{-# LINE 700 "_build/source-dist/ghc-9.4.5-src/ghc-9.4.5/compiler/GHC/Parser/Lexer.x" #-} -- ----------------------------------------------------------------------------- -- The token type 

@@ -875,17 +875,15 @@         -- Rename the pragmas and signatures        -- Annoyingly the type variables /are/ in scope for signatures, but-       -- /are not/ in scope in the SPECIALISE instance pramas; e.g.-       --    instance Eq a => Eq (T a) where-       --       (==) :: a -> a -> a-       --       {-# SPECIALISE instance Eq a => Eq (T [a]) #-}-       ; let (spec_inst_prags, other_sigs) = partition isSpecInstLSig sigs+       -- /are not/ in scope in SPECIALISE and SPECIALISE instance pragmas.+       -- See Note [Type variable scoping in SPECIALISE pragmas].+       ; let (spec_prags, other_sigs) = partition (isSpecLSig <||> isSpecInstLSig) sigs              bound_nms = mkNameSet (collectHsBindsBinders CollNoDictBinders binds')              sig_ctxt | is_cls_decl = ClsDeclCtxt cls                       | otherwise   = InstDeclCtxt bound_nms-       ; (spec_inst_prags', sip_fvs) <- renameSigs sig_ctxt spec_inst_prags-       ; (other_sigs',      sig_fvs) <- bindLocalNamesFV ktv_names $-                                        renameSigs sig_ctxt other_sigs+       ; (spec_prags', spg_fvs) <- renameSigs sig_ctxt spec_prags+       ; (other_sigs', sig_fvs) <- bindLocalNamesFV ktv_names $+                                      renameSigs sig_ctxt other_sigs         -- Rename the bindings RHSs.  Again there's an issue about whether the        -- type variables from the class/instance head are in scope.@@ -896,8 +894,47 @@                                            emptyFVs binds_w_dus                  ; return (mapBag fstOf3 binds_w_dus, bind_fvs) } -       ; return ( binds'', spec_inst_prags' ++ other_sigs'-                , sig_fvs `plusFV` sip_fvs `plusFV` bind_fvs) }+       ; return ( binds'', spec_prags' ++ other_sigs'+                , sig_fvs `plusFV` spg_fvs `plusFV` bind_fvs) }++{- Note [Type variable scoping in SPECIALISE pragmas]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When renaming the methods of a class or instance declaration, we must be careful+with the scoping of the type variables that occur in SPECIALISE and SPECIALISE instance+pragmas: the type variables from the class/instance header DO NOT scope over these,+unlike class/instance method type signatures.++Examples:++  1. SPECIALISE++    class C a where+      meth :: a+    instance C (Maybe a) where+      meth = Nothing+      {-# SPECIALISE INLINE meth :: Maybe [a] #-}++  2. SPECIALISE instance++    instance Eq a => Eq (T a) where+       (==) :: a -> a -> a+       {-# SPECIALISE instance Eq a => Eq (T [a]) #-}++  In both cases, the type variable `a` mentioned in the PRAGMA is NOT the same+  as the type variable `a` from the instance header.+  For example, the SPECIALISE instance pragma above is a shorthand for++      {-# SPECIALISE instance forall a. Eq a => Eq (T [a]) #-}++  which is alpha-equivalent to++      {-# SPECIALISE instance forall b. Eq b => Eq (T [b]) #-}++  This shows that the type variables are not bound in the header.++  Getting this scoping wrong can lead to out-of-scope type variable errors from+  Core Lint, see e.g. #22913.+-}  rnMethodBindLHS :: Bool -> Name                 -> LHsBindLR GhcPs GhcPs

@@ -136,6 +136,7 @@ import GHC.Tc.Utils.Monad import GHC.Core.Class (classTyCon) import GHC.Unit.Env+import GHC.IfaceToCore  -- ----------------------------------------------------------------------------- -- running a statement interactively@@ -562,11 +563,18 @@        breaks    = getModBreaks hmi        info      = expectJust "bindLocalsAtBreakpoint2" $                      IntMap.lookup breakInfo_number (modBreaks_breakInfo breaks)-       mbVars    = cgb_vars info-       result_ty = cgb_resty info        occs      = modBreaks_vars breaks ! breakInfo_number        span      = modBreaks_locs breaks ! breakInfo_number        decl      = intercalate "." $ modBreaks_decls breaks ! breakInfo_number++  -- Rehydrate to understand the breakpoint info relative to the current environment.+  -- This design is critical to preventing leaks (#22530)+   (mbVars, result_ty) <- initIfaceLoad hsc_env+                            $ initIfaceLcl breakInfo_module (text "debugger") NotBoot+                            $ hydrateCgBreakInfo info+++   let             -- Filter out any unboxed ids by changing them to Nothings;            -- we can't bind these at the prompt

@@ -90,6 +90,7 @@  import GHC.Stg.Syntax import qualified Data.IntSet as IntSet+import GHC.CoreToIface  -- ----------------------------------------------------------------------------- -- Generating byte code for a complete module@@ -371,10 +372,8 @@         this_mod <- moduleName <$> getCurrentModule         platform <- profilePlatform <$> getProfile         let idOffSets = getVarOffSets platform d p fvs-        let breakInfo = CgBreakInfo-                        { cgb_vars = idOffSets-                        , cgb_resty = tick_ty-                        }+            ty_vars   = tyCoVarsOfTypesWellScoped (tick_ty:map idType fvs)+        let breakInfo = dehydrateCgBreakInfo ty_vars idOffSets tick_ty         newBreakInfo tick_no breakInfo         hsc_env <- getHscEnv         let cc | Just interp <- hsc_interp hsc_env

@@ -172,7 +172,7 @@ tc_cmd env cmd@(HsCmdLamCase x lc_variant match) cmd_ty   = addErrCtxt (cmdCtxt cmd)       do { let match_ctxt = ArrowLamCaseAlt lc_variant-         ; checkPatCounts (ArrowMatchCtxt match_ctxt) match+         ; checkArgCounts (ArrowMatchCtxt match_ctxt) match          ; (wrap, match') <-              tcCmdMatchLambda env match_ctxt match cmd_ty          ; return (mkHsCmdWrap wrap (HsCmdLamCase x lc_variant match')) }

@@ -75,7 +75,7 @@ import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic import GHC.Builtin.Names( ipClassName )-import GHC.Tc.Validity (checkValidType)+import GHC.Tc.Validity (checkValidType, checkEscapingKind) import GHC.Types.Unique.FM import GHC.Types.Unique.DSet import GHC.Types.Unique.Set@@ -615,7 +615,7 @@                 --    See Note [Relevant bindings and the binder stack]                  setSrcSpanA bind_loc $-                tcMatchesFun (L nm_loc mono_id) matches+                tcMatchesFun (L nm_loc (idName mono_id)) matches                              (mkCheckExpType rho_ty)         -- We make a funny AbsBinds, abstracting over nothing,@@ -844,7 +844,8 @@                                           , ppr inferred_poly_ty])        ; unless insoluble $          addErrCtxtM (mk_inf_msg poly_name inferred_poly_ty) $-         checkValidType (InfSigCtxt poly_name) inferred_poly_ty+         do { checkEscapingKind inferred_poly_ty+            ; checkValidType (InfSigCtxt poly_name) inferred_poly_ty }          -- See Note [Validity of inferred types]          -- If we found an insoluble error in the function definition, don't          -- do this check; otherwise (#14000) we may report an ambiguity@@ -1182,18 +1183,14 @@   | NonRecursive <- is_rec   -- ...binder isn't mentioned in RHS   , Nothing <- sig_fn name   -- ...with no type signature   = setSrcSpanA b_loc    $-    do  { ((co_fn, matches'), mono_id, _) <- fixM $ \ ~(_, _, rhs_ty) ->-                                          -- See Note [fixM for rhs_ty in tcMonoBinds]-            do  { mono_id <- newLetBndr no_gen name Many rhs_ty-                ; (matches', rhs_ty')-                    <- tcInfer $ \ exp_ty ->+    do  { ((co_fn, matches'), rhs_ty')+            <- tcInfer $ \ exp_ty ->                        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                           -- type of the thing whose rhs we are type checking-                       tcMatchesFun (L nm_loc mono_id) matches exp_ty-                ; return (matches', mono_id, rhs_ty')-                }+                       tcMatchesFun (L nm_loc name) matches exp_ty+       ; mono_id <- newLetBndr no_gen name Many rhs_ty'          ; return (unitBag $ L b_loc $                      FunBind { fun_id = L nm_loc mono_id,@@ -1307,19 +1304,6 @@ type.  There seems to be no way to do this.  So currently we only switch to inference when we have no signature for any of the binders. -Note [fixM for rhs_ty in tcMonoBinds]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In order to create mono_id we need rhs_ty but we don't have it yet,-we only get it from tcMatchesFun later (which needs mono_id to put-into HsMatchContext for pretty printing). To solve this, create-a thunk of rhs_ty with fixM that we fill in later.--This is fine only because neither newLetBndr or tcMatchesFun look-at the varType field of the Id. tcMatchesFun only looks at idName-of mono_id.--Also see #20415 for the bigger picture of why tcMatchesFun needs-mono_id in the first place. -}  @@ -1447,7 +1431,7 @@   = tcExtendIdBinderStackForRhs [info]  $     tcExtendTyVarEnvForRhs mb_sig       $     do  { traceTc "tcRhs: fun bind" (ppr mono_id $$ ppr (idType mono_id))-        ; (co_fn, matches') <- tcMatchesFun (L (noAnnSrcSpan loc) mono_id)+        ; (co_fn, matches') <- tcMatchesFun (L (noAnnSrcSpan loc) (idName mono_id))                                  matches (mkCheckExpType $ idType mono_id)         ; return ( FunBind { fun_id = L (noAnnSrcSpan loc) mono_id                            , fun_matches = matches'

@@ -31,7 +31,7 @@    , tcBody    , tcDoStmt    , tcGuardStmt-   , checkPatCounts+   , checkArgCounts    ) where @@ -93,12 +93,12 @@ same number of arguments before using @tcMatches@ to do the work. -} -tcMatchesFun :: LocatedN Id -- MatchContext Id+tcMatchesFun :: LocatedN Name -- MatchContext Id              -> MatchGroup GhcRn (LHsExpr GhcRn)              -> ExpRhoType    -- Expected type of function              -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))                                 -- Returns type of body-tcMatchesFun fun_id matches exp_ty+tcMatchesFun fun_name matches exp_ty   = do  {  -- Check that they all have the same no of arguments            -- Location is in the monad, set the caller so that            -- any inter-equation error messages get some vaguely@@ -106,9 +106,7 @@            -- ann-grabbing, because we don't always have annotations in            -- hand when we call tcMatchesFun...           traceTc "tcMatchesFun" (ppr fun_name $$ ppr exp_ty)-           -- We can't easily call checkPatCounts here because fun_id can be an-           -- unfilled thunk-        ; checkArgCounts fun_name matches+        ; checkArgCounts what matches          ; matchExpectedFunTys herald ctxt arity exp_ty $ \ pat_tys rhs_ty ->              -- NB: exp_type may be polymorphic, but@@ -122,17 +120,11 @@           -- a multiplicity argument, and scale accordingly.           tcMatches match_ctxt pat_tys rhs_ty matches }   where-    fun_name = idName (unLoc fun_id)     arity  = matchGroupArity matches-    herald = ExpectedFunTyMatches (NameThing fun_name) matches+    herald = ExpectedFunTyMatches (NameThing (unLoc fun_name)) matches     ctxt   = GenSigCtxt  -- Was: FunSigCtxt fun_name True                          -- But that's wrong for f :: Int -> forall a. blah-    what   = FunRhs { mc_fun = fun_id, mc_fixity = Prefix, mc_strictness = strictness }-                    -- Careful: this fun_id could be an unfilled-                    -- thunk from fixM in tcMonoBinds, so we're-                    -- not allowed to look at it, except for-                    -- idName.-                    -- See Note [fixM for rhs_ty in tcMonoBinds]+    what   = FunRhs { mc_fun = fun_name, mc_fixity = Prefix, mc_strictness = strictness }     match_ctxt = MC { mc_what = what, mc_body = tcBody }     strictness       | [L _ match] <- unLoc $ mg_alts matches@@ -164,7 +156,7 @@               -> ExpRhoType               -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc)) tcMatchLambda herald match_ctxt match res_ty-  =  do { checkPatCounts (mc_what match_ctxt) match+  =  do { checkArgCounts (mc_what match_ctxt) match         ; matchExpectedFunTys herald GenSigCtxt n_pats res_ty $ \ pat_tys rhs_ty -> do             -- checking argument counts since this is also used for \cases             tcMatches match_ctxt pat_tys rhs_ty match }@@ -1136,39 +1128,28 @@ \subsection{Errors and contexts} *                                                                      * ************************************************************************--@checkArgCounts@ takes a @[RenamedMatch]@ and decides whether the same-number of args are used in each equation. -} +-- | @checkArgCounts@ takes a @[RenamedMatch]@ and decides whether the same+-- number of args are used in each equation. checkArgCounts :: AnnoBody body-               => Name -> MatchGroup GhcRn (LocatedA (body GhcRn)) -> TcM ()-checkArgCounts = check_match_pats . (text "Equations for" <+>) . quotes . ppr---- @checkPatCounts@ takes a @[RenamedMatch]@ and decides whether the same--- number of patterns are used in each alternative-checkPatCounts :: AnnoBody body-               => HsMatchContext GhcTc -> MatchGroup GhcRn (LocatedA (body GhcRn))-               -> TcM ()-checkPatCounts = check_match_pats . pprMatchContextNouns--check_match_pats :: AnnoBody body-                 => SDoc -> MatchGroup GhcRn (LocatedA (body GhcRn))-                 -> TcM ()-check_match_pats _ (MG { mg_alts = L _ [] })-    = return ()-check_match_pats err_msg (MG { mg_alts = L _ (match1:matches) })-    | null bad_matches+          => HsMatchContext GhcTc -> MatchGroup GhcRn (LocatedA (body GhcRn))+          -> TcM ()+checkArgCounts _ (MG { mg_alts = L _ [] })     = return ()-    | otherwise+checkArgCounts matchContext (MG { mg_alts = L _ (match1:matches) })+    | not (null bad_matches)     = failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $       (vcat [ err_msg <+>               text "have different numbers of arguments"             , nest 2 (ppr (getLocA match1))             , nest 2 (ppr (getLocA (head bad_matches)))])+    | otherwise+    = return ()   where     n_args1 = args_in_match match1     bad_matches = [m | m <- matches, args_in_match m /= n_args1]+    err_msg = pprMatchContextNouns matchContext      args_in_match :: (LocatedA (Match GhcRn body1) -> Int)     args_in_match (L _ (Match { m_pats = pats })) = length pats

@@ -5,13 +5,13 @@ import GHC.Tc.Types     ( TcM ) import GHC.Hs.Extension ( GhcRn, GhcTc ) import GHC.Parser.Annotation ( LocatedN )-import GHC.Types.Id (Id)+import GHC.Types.Name (Name)  tcGRHSsPat    :: GRHSs GhcRn (LHsExpr GhcRn)               -> ExpRhoType               -> TcM (GRHSs GhcTc (LHsExpr GhcTc)) -tcMatchesFun :: LocatedN Id+tcMatchesFun :: LocatedN Name              -> MatchGroup GhcRn (LHsExpr GhcRn)              -> ExpSigmaType              -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))

@@ -442,8 +442,8 @@   ppr KeepInert = text "keep inert"   ppr KeepWork  = text "keep work-item" -solveOneFromTheOther :: CtEvidence  -- Inert    (Dict or Irred)-                     -> CtEvidence  -- WorkItem (same predicate as inert)+solveOneFromTheOther :: Ct  -- Inert    (Dict or Irred)+                     -> Ct  -- WorkItem (same predicate as inert)                      -> TcS InteractResult -- Precondition: -- * inert and work item represent evidence for the /same/ predicate@@ -453,24 +453,41 @@ -- although we don't rewrite wanteds with wanteds, we can combine -- two wanteds into one by solving one from the other -solveOneFromTheOther ev_i ev_w+solveOneFromTheOther ct_i ct_w   | CtWanted { ctev_loc = loc_w } <- ev_w   , prohibitedSuperClassSolve loc_i loc_w-  = -- inert must be Given+  = -- Inert must be Given     do { traceTcS "prohibitedClassSolve1" (ppr ev_i $$ ppr ev_w)        ; return KeepWork }    | CtWanted {} <- ev_w-       -- Inert is Given or Wanted-  = return $ case ev_i of-               CtWanted {} -> choose_better_loc-                 -- both are Wanted; choice of which to keep is-                 -- arbitrary. So we look at the context to choose-                 -- which would make a better error message+  = -- Inert is Given or Wanted+    case ev_i of+      CtGiven {} -> return KeepInert+        -- work is Wanted; inert is Given: easy choice. -               _           -> KeepInert-                 -- work is Wanted; inert is Given: easy choice.+      CtWanted {} -- Both are Wanted+        -- If only one has no pending superclasses, use it+        -- Otherwise we can get infinite superclass expansion (#22516)+        -- in silly cases like   class C T b => C a b where ...+        | not is_psc_i, is_psc_w     -> return KeepInert+        | is_psc_i,     not is_psc_w -> return KeepWork +        -- If only one is a WantedSuperclassOrigin (arising from expanding+        -- a Wanted class constraint), keep the other: wanted superclasses+        -- may be unexpected by users+        | not is_wsc_orig_i, is_wsc_orig_w     -> return KeepInert+        | is_wsc_orig_i,     not is_wsc_orig_w -> return KeepWork++        -- otherwise, just choose the lower span+        -- reason: if we have something like (abs 1) (where the+        -- Num constraint cannot be satisfied), it's better to+        -- get an error about abs than about 1.+        -- This test might become more elaborate if we see an+        -- opportunity to improve the error messages+        | ((<) `on` ctLocSpan) loc_i loc_w -> return KeepInert+        | otherwise                        -> return KeepWork+   -- From here on the work-item is Given    | CtWanted { ctev_loc = loc_i } <- ev_i@@ -492,31 +509,21 @@   | otherwise   -- Both are Given, levels differ   = return different_level_strategy   where+     ev_i  = ctEvidence ct_i+     ev_w  = ctEvidence ct_w+      pred  = ctEvPred ev_i+      loc_i = ctEvLoc ev_i      loc_w = ctEvLoc ev_w      lvl_i = ctLocLevel loc_i      lvl_w = ctLocLevel loc_w -     choose_better_loc-       -- if only one is a WantedSuperclassOrigin (arising from expanding-       -- a Wanted class constraint), keep the other: wanted superclasses-       -- may be unexpected by users-       | is_wanted_superclass_loc loc_i-       , not (is_wanted_superclass_loc loc_w) = KeepWork--       | not (is_wanted_superclass_loc loc_i)-       , is_wanted_superclass_loc loc_w = KeepInert--        -- otherwise, just choose the lower span-        -- reason: if we have something like (abs 1) (where the-        -- Num constraint cannot be satisfied), it's better to-        -- get an error about abs than about 1.-        -- This test might become more elaborate if we see an-        -- opportunity to improve the error messages-       | ((<) `on` ctLocSpan) loc_i loc_w = KeepInert-       | otherwise                        = KeepWork+     is_psc_w = isPendingScDict ct_w+     is_psc_i = isPendingScDict ct_i +     is_wsc_orig_i = is_wanted_superclass_loc loc_i+     is_wsc_orig_w = is_wanted_superclass_loc loc_w      is_wanted_superclass_loc = isWantedSuperclassOrigin . ctLocOrigin       different_level_strategy  -- Both Given@@ -644,28 +651,28 @@ -- mean that (ty1 ~ ty2) interactIrred :: InertCans -> Ct -> TcS (StopOrContinue Ct) -interactIrred inerts workItem@(CIrredCan { cc_ev = ev_w, cc_reason = reason })+interactIrred inerts ct_w@(CIrredCan { cc_ev = ev_w, cc_reason = reason })   | isInsolubleReason reason                -- For insolubles, don't allow the constraint to be dropped                -- which can happen with solveOneFromTheOther, so that                -- we get distinct error messages with -fdefer-type-errors-  = continueWith workItem+  = continueWith ct_w    | let (matching_irreds, others) = findMatchingIrreds (inert_irreds inerts) ev_w   , ((ct_i, swap) : _rest) <- bagToList matching_irreds         -- See Note [Multiple matching irreds]   , let ev_i = ctEvidence ct_i-  = do { what_next <- solveOneFromTheOther ev_i ev_w-       ; traceTcS "iteractIrred" (ppr workItem $$ ppr what_next $$ ppr ct_i)+  = do { what_next <- solveOneFromTheOther ct_i ct_w+       ; traceTcS "iteractIrred" (ppr ct_w $$ ppr what_next $$ ppr ct_i)        ; case what_next of             KeepInert -> do { setEvBindIfWanted ev_w (swap_me swap ev_i)                             ; return (Stop ev_w (text "Irred equal" <+> parens (ppr what_next))) }             KeepWork ->  do { setEvBindIfWanted ev_i (swap_me swap ev_w)                             ; updInertIrreds (\_ -> others)-                            ; continueWith workItem } }+                            ; continueWith ct_w } }    | otherwise-  = continueWith workItem+  = continueWith ct_w    where     swap_me :: SwapFlag -> CtEvidence -> EvTerm@@ -995,7 +1002,7 @@ -}  interactDict :: InertCans -> Ct -> TcS (StopOrContinue Ct)-interactDict inerts workItem@(CDictCan { cc_ev = ev_w, cc_class = cls, cc_tyargs = tys })+interactDict inerts ct_w@(CDictCan { cc_ev = ev_w, cc_class = cls, cc_tyargs = tys })   | Just ct_i <- lookupInertDict inerts (ctEvLoc ev_w) cls tys   , let ev_i = ctEvidence ct_i   = -- There is a matching dictionary in the inert set@@ -1009,22 +1016,22 @@      do { -- Ths short-cut solver didn't fire, so we          -- solve ev_w from the matching inert ev_i we found-         what_next <- solveOneFromTheOther ev_i ev_w+         what_next <- solveOneFromTheOther ct_i ct_w        ; traceTcS "lookupInertDict" (ppr what_next)        ; case what_next of            KeepInert -> do { setEvBindIfWanted ev_w (ctEvTerm ev_i)                            ; return $ Stop ev_w (text "Dict equal" <+> parens (ppr what_next)) }            KeepWork  -> do { setEvBindIfWanted ev_i (ctEvTerm ev_w)                            ; updInertDicts $ \ ds -> delDict ds cls tys-                           ; continueWith workItem } } }+                           ; continueWith ct_w } } }    | cls `hasKey` ipClassKey   , isGiven ev_w-  = interactGivenIP inerts workItem+  = interactGivenIP inerts ct_w    | otherwise   = do { addFunDepWork inerts ev_w cls-       ; continueWith workItem  }+       ; continueWith ct_w  }  interactDict _ wi = pprPanic "interactDict" (ppr wi) 

@@ -538,7 +538,7 @@     get_pending :: Ct -> [Ct] -> [Ct]  -- Get dicts with cc_pend_sc = True                                        -- but flipping the flag     get_pending dict dicts-        | Just dict' <- isPendingScDict dict+        | Just dict' <- pendingScDict_maybe dict         , belongs_to_this_level (ctEvidence dict)         = dict' : dicts         | otherwise@@ -551,7 +551,7 @@      get_pending_inst :: [Ct] -> QCInst -> ([Ct], QCInst)     get_pending_inst cts qci@(QCI { qci_ev = ev })-       | Just qci' <- isPendingScInst qci+       | Just qci' <- pendingScInst_maybe qci        , belongs_to_this_level ev        = (CQuantCan qci' : cts, qci')        | otherwise

@@ -275,21 +275,29 @@   | debugIsOn   = case ct of       CEqCan { cc_lhs = TyVarLHS tv } ->-        let shares_lhs (CEqCan { cc_lhs = TyVarLHS old_tv }) = tv == old_tv-            shares_lhs _other                                = False-        in-        assert (all shares_lhs old_eqs) $-        assert (null ([ (ct1, ct2) | ct1 <- ct : old_eqs-                                   , ct2 <- ct : old_eqs-                                   , let { fr1 = ctFlavourRole ct1-                                         ; fr2 = ctFlavourRole ct2 }-                                   , fr1 `eqCanRewriteFR` fr2 ])) $+        assert (all (shares_lhs tv) old_eqs) $+        assertPpr (null bad_prs)+                  (vcat [ text "bad_prs" <+> ppr bad_prs+                        , text "ct:old_eqs" <+> ppr (ct : old_eqs) ]) $         (ct : old_eqs)        _ -> pprPanic "addToEqualCtList not CEqCan" (ppr ct)    | otherwise   = ct : old_eqs+  where+    shares_lhs tv (CEqCan { cc_lhs = TyVarLHS old_tv }) = tv == old_tv+    shares_lhs _ _ = False+    bad_prs = filter is_bad_pair (distinctPairs (ct : old_eqs))+    is_bad_pair (ct1,ct2) = ctFlavourRole ct1 `eqCanRewriteFR` ctFlavourRole ct2++distinctPairs :: [a] -> [(a,a)]+-- distinctPairs [x1,...xn] is the list of all pairs [ ...(xi, xj)...]+--                             where i /= j+-- NB: does not return pairs (xi,xi), which would be stupid in the+--     context of addToEqualCtList (#22645)+distinctPairs []     = []+distinctPairs (x:xs) = concatMap (\y -> [(x,y),(y,x)]) xs ++ distinctPairs xs  -- returns Nothing when the new list is empty, to keep the environments smaller filterEqualCtList :: (Ct -> Bool) -> EqualCtList -> Maybe EqualCtList

@@ -4384,10 +4384,7 @@           --  e.g. reject this:   MkT :: T (forall a. a->a)           -- Reason: it's really the argument of an equality constraint         ; checkValidMonoType orig_res_ty--        -- Check for an escaping result kind-        -- See Note [Check for escaping result kind]-        ; checkEscapingKind con+        ; checkEscapingKind (dataConWrapperType con)          -- For /data/ types check that each argument has a fixed runtime rep         -- If we are dealing with a /newtype/, we allow representation@@ -4557,46 +4554,6 @@     ok_mult One = True     ok_mult _   = False ---- | Reject nullary data constructors where a type variables--- would escape through the result kind--- See Note [Check for escaping result kind]-checkEscapingKind :: DataCon -> TcM ()-checkEscapingKind data_con-  | null eq_spec, null theta, null arg_tys-  , let tau_kind = tcTypeKind res_ty-  , Nothing <- occCheckExpand (univ_tvs ++ ex_tvs) tau_kind-    -- Ensure that none of the tvs occur in the kind of the forall-    -- /after/ expanding type synonyms.-    -- See Note [Phantom type variables in kinds] in GHC.Core.Type-  = failWithTc $ TcRnForAllEscapeError (dataConWrapperType data_con) tau_kind-  | otherwise-  = return ()-  where-    (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, res_ty)-      = dataConFullSig data_con--{- Note [Check for escaping result kind]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider:-  type T :: TYPE (BoxedRep l)-  data T = MkT-This is not OK: we get-  MkT :: forall l. T @l :: TYPE (BoxedRep l)-which is ill-kinded.--For ordinary type signatures f :: blah, we make this check as part of kind-checking-the type signature; see Note [Escaping kind in type signatures] in GHC.Tc.Gen.HsType.-But for data constructors we check the type piecemeal, and there is no very-convenient place to do it.  For example, note that it only applies for /nullary/-constructors.  If we had-  data T = MkT Int-then the type of MkT would be MkT :: forall l. Int -> T @l, which is fine.--So we make the check in checkValidDataCon.--Historical note: we used to do the check in checkValidType (#20929 discusses).--}  ------------------------------- checkValidClass :: Class -> TcM ()

@@ -840,7 +840,7 @@                        , mg_ext = MatchGroupTc (map unrestricted [pat_ty, cont_ty, fail_ty]) res_ty                        , mg_origin = Generated                        }-             match = mkMatch (mkPrefixFunRhs (L loc patsyn_id)) []+             match = mkMatch (mkPrefixFunRhs (L loc (idName patsyn_id))) []                              (mkHsLams (rr_tv:res_tv:univ_tvs)                                        req_dicts body')                              (EmptyLocalBinds noExtField)

@@ -9,14 +9,15 @@ -- in the type-checker and constraint solver. module GHC.Tc.Types.Constraint (         -- QCInst-        QCInst(..), isPendingScInst,+        QCInst(..), pendingScInst_maybe,          -- Canonical constraints         Xi, Ct(..), Cts,         emptyCts, andCts, andManyCts, pprCts,         singleCt, listToCts, ctsElts, consCts, snocCts, extendCtsList,         isEmptyCts,-        isPendingScDict, superClassesMightHelp, getPendingWantedScs,+        isPendingScDict, pendingScDict_maybe,+        superClassesMightHelp, getPendingWantedScs,         isWantedCt, isGivenCt,         isUserTypeError, getUserTypeErrorMsg,         ctEvidence, ctLoc, ctPred, ctFlavour, ctEqRel, ctOrigin,@@ -899,18 +900,24 @@                              Just _ -> True                              _      -> False -isPendingScDict :: Ct -> Maybe Ct+isPendingScDict :: Ct -> Bool+isPendingScDict (CDictCan { cc_pend_sc = psc }) = psc+-- Says whether this is a CDictCan with cc_pend_sc is True;+-- i.e. pending un-expanded superclasses+isPendingScDict _ = False++pendingScDict_maybe :: Ct -> Maybe Ct -- Says whether this is a CDictCan with cc_pend_sc is True, -- AND if so flips the flag-isPendingScDict ct@(CDictCan { cc_pend_sc = True })-                  = Just (ct { cc_pend_sc = False })-isPendingScDict _ = Nothing+pendingScDict_maybe ct@(CDictCan { cc_pend_sc = True })+                      = Just (ct { cc_pend_sc = False })+pendingScDict_maybe _ = Nothing -isPendingScInst :: QCInst -> Maybe QCInst+pendingScInst_maybe :: QCInst -> Maybe QCInst -- Same as isPendingScDict, but for QCInsts-isPendingScInst qci@(QCI { qci_pend_sc = True })-                  = Just (qci { qci_pend_sc = False })-isPendingScInst _ = Nothing+pendingScInst_maybe qci@(QCI { qci_pend_sc = True })+                      = Just (qci { qci_pend_sc = False })+pendingScInst_maybe _ = Nothing  superClassesMightHelp :: WantedConstraints -> Bool -- ^ True if taking superclasses of givens, or of wanteds (to perhaps@@ -932,7 +939,7 @@ getPendingWantedScs simples   = mapAccumBagL get [] simples   where-    get acc ct | Just ct' <- isPendingScDict ct+    get acc ct | Just ct' <- pendingScDict_maybe ct                = (ct':acc, ct')                | otherwise                = (acc,     ct)

@@ -13,7 +13,7 @@   Rank(..), UserTypeCtxt(..), checkValidType, checkValidMonoType,   checkValidTheta,   checkValidInstance, checkValidInstHead, validDerivPred,-  checkTySynRhs,+  checkTySynRhs, checkEscapingKind,   checkValidCoAxiom, checkValidCoAxBranch,   checkValidTyFamEqn, checkValidAssocTyFamDeflt, checkConsistentFamInst,   arityErr,@@ -460,6 +460,53 @@   where     actual_kind = tcTypeKind ty +{- Note [Check for escaping result kind]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider:+  type T :: TYPE (BoxedRep l)+  data T = MkT+This is not OK: we get+  MkT :: forall l. T @l :: TYPE (BoxedRep l)+which is ill-kinded.++For ordinary /user-written type signatures f :: blah, we make this+check as part of kind-checking the type signature in tcHsSigType; see+Note [Escaping kind in type signatures] in GHC.Tc.Gen.HsType.++But in two other places we need to check for an escaping result kind:++* For data constructors we check the type piecemeal, and there is no+  very convenient place to do it.  For example, note that it only+  applies for /nullary/ constructors.  If we had+    data T = MkT Int+  then the type of MkT would be MkT :: forall l. Int -> T @l, which is fine.++  So we make the check in checkValidDataCon.++* When inferring the type of a function, there is no user-written type+  that we are checking.  Forgetting this led to #22743.  Now we call+  checkEscapingKind in GHC.Tc.Gen.Bind.mkInferredPolyId++Historical note: we used to do the escaping-kind check in+checkValidType (#20929 discusses), but that is now redundant.+-}++checkEscapingKind :: Type -> TcM ()+-- Give a sigma-type (forall a1 .. an. ty), where (ty :: ki),+-- check that `ki` does not mention any of the binders a1..an.+-- Otherwise the type is ill-kinded+-- See Note [Check for escaping result kind]+checkEscapingKind poly_ty+  | (tvs, tau) <- splitForAllTyVars poly_ty+  , let tau_kind = typeKind tau+  , Nothing <- occCheckExpand tvs tau_kind+    -- Ensure that none of the tvs occur in the kind of the forall+    -- /after/ expanding type synonyms.+    -- See Note [Phantom type variables in kinds] in GHC.Core.Type+  = failWithTc $ TcRnForAllEscapeError poly_ty tau_kind+  | otherwise+  = return ()+ funArgResRank :: Rank -> (Rank, Rank)             -- Function argument and result funArgResRank (LimitedRank _ arg_rank) = (arg_rank, LimitedRank (forAllAllowed arg_rank) arg_rank) funArgResRank other_rank               = (other_rank, other_rank)@@ -757,6 +804,9 @@         ; check_type (ve{ve_tidy_env = env'}) tau                 -- Allow foralls to right of arrow +        -- Note: skolem-escape in types (e.g. forall r (a::r). a) is handled+        --       by tcHsSigType and the constraint solver, so no need to+        --       check it here; c.f. #20929         }   where     (tvbs, phi)   = tcSplitForAllTyVarBinders ty

@@ -1537,7 +1537,7 @@ cvtSigTypeKind :: String -> TH.Type -> CvtM (LHsSigType GhcPs) cvtSigTypeKind ty_str ty = do   ty' <- cvtTypeKind ty_str ty-  pure $ hsTypeToHsSigType ty'+  pure $ hsTypeToHsSigType $ parenthesizeHsType sigPrec ty'  cvtTypeKind :: String -> TH.Type -> CvtM (LHsType GhcPs) cvtTypeKind ty_str ty

@@ -151,7 +151,7 @@   ppr  System         = text "system"  instance NFData Name where-  rnf Name{..} = rnf n_sort+  rnf Name{..} = rnf n_sort `seq` rnf n_occ `seq` n_uniq `seq` rnf n_loc  instance NFData NameSort where   rnf (External m) = rnf m

@@ -12,6 +12,7 @@     , ue_setUnits     , ue_setUnitFlags     , ue_unit_dbs+    , ue_all_home_unit_ids     , ue_setUnitDbs     , ue_hpt     , ue_homeUnit@@ -417,7 +418,8 @@ ue_unitHomeUnit :: UnitId -> UnitEnv -> HomeUnit ue_unitHomeUnit uid ue_env = homeUnitEnv_unsafeHomeUnit $ ue_findHomeUnitEnv uid ue_env -+ue_all_home_unit_ids :: UnitEnv -> Set.Set UnitId+ue_all_home_unit_ids = unitEnv_keys . ue_home_unit_graph -- ------------------------------------------------------- -- Query and modify the currently active unit -- -------------------------------------------------------@@ -436,6 +438,7 @@  ue_currentUnit :: UnitEnv -> UnitId ue_currentUnit = ue_current_unit+  -- ------------------------------------------------------- -- Operations on arbitrary elements of the home unit graph

@@ -180,7 +180,10 @@       | otherwise =         findHomePackageModule fc opts uid mod_name -    any_home_import = foldr orIfNotFound home_import (map home_pkg_import other_fopts)+    -- Do not be smart and change this to `foldr orIfNotFound home_import hs` as+    -- that is not the same!! home_import is first because we need to look within ourselves+    -- first before looking at the packages in order.+    any_home_import = foldr1 orIfNotFound (home_import: map home_pkg_import other_fopts)      pkg_import    = findExposedPackageModule fc fopts units  mod_name mb_pkg 

@@ -256,6 +256,8 @@   | UsageHomeModule {         usg_mod_name :: ModuleName,             -- ^ Name of the module+        usg_unit_id :: UnitId,+        -- ^ UnitId of the HomeUnit the module is from         usg_mod_hash :: Fingerprint,             -- ^ Cached module ABI fingerprint (corresponds to mi_mod_hash).             -- This may be out dated after recompilation was avoided, but is@@ -292,6 +294,8 @@   | UsageHomeModuleInterface {         usg_mod_name :: ModuleName         -- ^ Name of the module+        , usg_unit_id :: UnitId+        -- ^ UnitId of the HomeUnit the module is from         , usg_iface_hash :: Fingerprint         -- ^ The *interface* hash of the module, not the ABI hash.         -- This changes when anything about the interface (and hence the@@ -331,6 +335,7 @@     put_ bh usg@UsageHomeModule{} = do         putByte bh 1         put_ bh (usg_mod_name usg)+        put_ bh (usg_unit_id  usg)         put_ bh (usg_mod_hash usg)         put_ bh (usg_exports  usg)         put_ bh (usg_entities usg)@@ -350,6 +355,7 @@     put_ bh usg@UsageHomeModuleInterface{} = do         putByte bh 4         put_ bh (usg_mod_name usg)+        put_ bh (usg_unit_id  usg)         put_ bh (usg_iface_hash usg)      get bh = do@@ -362,11 +368,12 @@             return UsagePackageModule { usg_mod = nm, usg_mod_hash = mod, usg_safe = safe }           1 -> do             nm    <- get bh+            uid    <- get bh             mod   <- get bh             exps  <- get bh             ents  <- get bh             safe  <- get bh-            return UsageHomeModule { usg_mod_name = nm, usg_mod_hash = mod,+            return UsageHomeModule { usg_mod_name = nm, usg_mod_hash = mod, usg_unit_id = uid,                      usg_exports = exps, usg_entities = ents, usg_safe = safe }           2 -> do             fp   <- get bh@@ -379,8 +386,9 @@             return UsageMergedRequirement { usg_mod = mod, usg_mod_hash = hash }           4 -> do             mod <- get bh+            uid <- get bh             hash <- get bh-            return UsageHomeModuleInterface { usg_mod_name = mod, usg_iface_hash = hash }+            return UsageHomeModuleInterface { usg_mod_name = mod, usg_unit_id = uid, usg_iface_hash = hash }           i -> error ("Binary.get(Usage): " ++ show i)  

@@ -99,7 +99,7 @@ instance Outputable ModuleGraphNode where   ppr = \case     InstantiationNode _ iuid -> ppr iuid-    ModuleNode nks ms -> ppr (ms_mnwib ms) <+> ppr nks+    ModuleNode nks ms -> ppr (msKey ms) <+> ppr nks     LinkNode uid _     -> text "LN:" <+> ppr uid  instance Eq ModuleGraphNode where@@ -126,8 +126,8 @@ nodeKeyUnitId (NodeKey_Module mk) = mnkUnitId mk nodeKeyUnitId (NodeKey_Link uid)  = uid -data ModNodeKeyWithUid = ModNodeKeyWithUid { mnkModuleName :: ModuleNameWithIsBoot-                                           , mnkUnitId     :: UnitId } deriving (Eq, Ord)+data ModNodeKeyWithUid = ModNodeKeyWithUid { mnkModuleName :: !ModuleNameWithIsBoot+                                           , mnkUnitId     :: !UnitId } deriving (Eq, Ord)  instance Outputable ModNodeKeyWithUid where   ppr (ModNodeKeyWithUid mnwib uid) = ppr uid <> colon <> ppr mnwib

@@ -1680,7 +1680,10 @@   = FunRhs     -- ^ A pattern matching on an argument of a     -- function binding-      { mc_fun        :: LIdP p    -- ^ function binder of @f@+      { mc_fun        :: LIdP (NoGhcTc p)    -- ^ function binder of @f@+                                             -- See Note [mc_fun field of FunRhs]+                                             -- See #20415 for a long discussion about+                                             -- this field and why it uses NoGhcTc.       , mc_fixity     :: LexicalFixity -- ^ fixing of @f@       , mc_strictness :: SrcStrictness -- ^ was @f@ banged?                                        -- See Note [FunBind vs PatBind]@@ -1707,6 +1710,21 @@   | ThPatQuote             -- ^A Template Haskell pattern quotation [p| (a,b) |]   | PatSyn                 -- ^A pattern synonym declaration +{-+Note [mc_fun field of FunRhs]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The mc_fun field of FunRhs has type `LIdP (NoGhcTc p)`, which means it will be+a `RdrName` in pass `GhcPs`, a `Name` in `GhcRn`, and (importantly) still a+`Name` in `GhcTc` -- not an `Id`.  See Note [NoGhcTc] in GHC.Hs.Extension.++Why a `Name` in the typechecker phase?  Because:+* A `Name` is all we need, as it turns out.+* Using an `Id` involves knot-tying in the monad, which led to #22695.++See #20415 for a long discussion.++-}+ isPatSynCtxt :: HsMatchContext p -> Bool isPatSynCtxt ctxt =   case ctxt of@@ -1801,7 +1819,7 @@ matchSeparator ThPatQuote   = panic "unused" matchSeparator PatSyn       = panic "unused" -pprMatchContext :: (Outputable (IdP p), UnXRec p)+pprMatchContext :: (Outputable (IdP (NoGhcTc p)), UnXRec (NoGhcTc p))                 => HsMatchContext p -> SDoc pprMatchContext ctxt   | want_an ctxt = text "an" <+> pprMatchContextNoun ctxt@@ -1812,10 +1830,10 @@     want_an (ArrowMatchCtxt KappaExpr) = True     want_an _                          = False -pprMatchContextNoun :: forall p. (Outputable (IdP p), UnXRec p)+pprMatchContextNoun :: forall p. (Outputable (IdP (NoGhcTc p)), UnXRec (NoGhcTc p))                     => HsMatchContext p -> SDoc pprMatchContextNoun (FunRhs {mc_fun=fun})   = text "equation for"-                                              <+> quotes (ppr (unXRec @p fun))+                                              <+> quotes (ppr (unXRec @(NoGhcTc p) fun)) pprMatchContextNoun CaseAlt                 = text "case alternative" pprMatchContextNoun (LamCaseAlt lc_variant) = lamCaseKeyword lc_variant                                               <+> text "alternative"@@ -1831,10 +1849,10 @@                                               $$ pprAStmtContext ctxt pprMatchContextNoun PatSyn                  = text "pattern synonym declaration" -pprMatchContextNouns :: forall p. (Outputable (IdP p), UnXRec p)+pprMatchContextNouns :: forall p. (Outputable (IdP (NoGhcTc p)), UnXRec (NoGhcTc p))                      => HsMatchContext p -> SDoc pprMatchContextNouns (FunRhs {mc_fun=fun})   = text "equations for"-                                               <+> quotes (ppr (unXRec @p fun))+                                               <+> quotes (ppr (unXRec @(NoGhcTc p) fun)) pprMatchContextNouns PatBindGuards           = text "pattern binding guards" pprMatchContextNouns (ArrowMatchCtxt c)      = pprArrowMatchContextNouns c pprMatchContextNouns (StmtCtxt ctxt)         = text "pattern bindings in"@@ -1855,7 +1873,7 @@ pprArrowMatchContextNouns ctxt                         = pprArrowMatchContextNoun ctxt <> char 's'  ------------------pprAStmtContext, pprStmtContext :: (Outputable (IdP p), UnXRec p)+pprAStmtContext, pprStmtContext :: (Outputable (IdP (NoGhcTc p)), UnXRec (NoGhcTc p))                                 => HsStmtContext p -> SDoc pprAStmtContext (HsDoStmt flavour) = pprAHsDoFlavour flavour pprAStmtContext ctxt = text "a" <+> pprStmtContext ctxt

@@ -1,15 +1,35 @@ #include <Rts.h>+#include <ghcversion.h> +// Note [keepCAFsForGHCi]+// ~~~~~~~~~~~~~~~~~~~~~~ // This file is only included in the dynamic library. // It contains an __attribute__((constructor)) function (run prior to main()) // which sets the keepCAFs flag in the RTS, before any Haskell code is run. // This is required so that GHCi can use dynamic libraries instead of HSxyz.o // files.+//+// For static builds we have to guarantee that the linker loads this object file+// to ensure the constructor gets run and not discarded. If the object is part of+// an archive and not otherwise referenced the linker would ignore the object.+// To avoid this:+// * When initializing a GHC session in initGhcMonad we assert keeping cafs has been+//   enabled by calling keepCAFsForGHCi.+// * This causes the GHC module from the ghc package to carry a reference to this object+//   file.+// * Which in turn ensures the linker doesn't discard this object file, causing+//   the constructor to be run, allowing the assertion to succeed in the first place+//   as keepCAFs will have been set already during initialization of constructors. -static void keepCAFsForGHCi(void) __attribute__((constructor)); -static void keepCAFsForGHCi(void)++bool keepCAFsForGHCi(void) __attribute__((constructor));++bool keepCAFsForGHCi(void) {-    keepCAFs = 1;+    bool was_set = keepCAFs;+    setKeepCAFs();+    return was_set; }+ 

@@ -3,7 +3,7 @@ #define __GHC_LLVM_VERSION_H__  /* The maximum supported LLVM version number */-#define sUPPORTED_LLVM_VERSION_MAX (14)+#define sUPPORTED_LLVM_VERSION_MAX (15)  /* The minimum supported LLVM version number */ #define sUPPORTED_LLVM_VERSION_MIN (10)

@@ -3,7 +3,7 @@ -- ./configure.  Make sure you are editing ghc.cabal.in, not ghc.cabal.  Name: ghc-Version: 9.4.4+Version: 9.4.5 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.4,-                   ghc-heap   == 9.4.4,-                   ghci == 9.4.4+                   ghc-boot   == 9.4.5,+                   ghc-heap   == 9.4.5,+                   ghci == 9.4.5      if os(windows)         Build-Depends: Win32  >= 2.3 && < 2.13