ghc-lib 9.8.2.20240223 → 9.8.3.20241022

raw patch · 53 files changed

+732/−325 lines, 53 filesdep ~ghc-lib-parserPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: ghc-lib-parser

API changes (from Hackage documentation)

Files

• compiler/GHC.hs +5/−3
• compiler/GHC/ByteCode/Instr.hs +1/−1
• compiler/GHC/ByteCode/Linker.hs +48/−21
• compiler/GHC/Cmm/Opt.hs +18/−1
• compiler/GHC/CmmToAsm/AArch64.hs +1/−0
• compiler/GHC/CmmToAsm/AArch64/CodeGen.hs +1/−1
• compiler/GHC/CmmToAsm/AArch64/Instr.hs +10/−0
• compiler/GHC/CmmToAsm/AArch64/Ppr.hs +1/−0
• compiler/GHC/CmmToAsm/AArch64/Regs.hs +1/−0
• compiler/GHC/CmmToAsm/BlockLayout.hs +2/−3
• compiler/GHC/CmmToAsm/Instr.hs +7/−1
• compiler/GHC/CmmToAsm/Monad.hs +26/−0
• compiler/GHC/CmmToAsm/PPC.hs +1/−0
• compiler/GHC/CmmToAsm/PPC/CodeGen.hs +1/−1
• compiler/GHC/CmmToAsm/PPC/Instr.hs +8/−0
• compiler/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs +2/−1
• compiler/GHC/CmmToAsm/Reg/Linear/AArch64.hs +3/−3
• compiler/GHC/CmmToAsm/Reg/Liveness.hs +5/−0
• compiler/GHC/CmmToAsm/X86.hs +1/−0
• compiler/GHC/CmmToAsm/X86/CodeGen.hs +44/−13
• compiler/GHC/CmmToAsm/X86/Instr.hs +12/−0
• compiler/GHC/Core/Opt/DmdAnal.hs +1/−1
• compiler/GHC/CoreToStg.hs +33/−34
• compiler/GHC/Driver/Config/Core/Opt/Simplify.hs +35/−0
• compiler/GHC/Driver/Main.hs +1/−1
• compiler/GHC/Driver/Make.hs +97/−90
• compiler/GHC/Driver/Pipeline/Execute.hs +17/−9
• compiler/GHC/HsToCore/Foreign/C.hs +21/−11
• compiler/GHC/Iface/Recomp/Flags.hs +4/−1
• compiler/GHC/Iface/Tidy.hs +5/−2
• compiler/GHC/Linker/Loader.hs +34/−26
• compiler/GHC/Linker/MacOS.hs +2/−2
• compiler/GHC/Rename/Module.hs +2/−0
• compiler/GHC/Runtime/Eval.hs +4/−2
• compiler/GHC/Runtime/Interpreter.hs +58/−22
• compiler/GHC/Runtime/Interpreter/JS.hs +0/−3
• compiler/GHC/Runtime/Utils.hs +1/−1
• compiler/GHC/Settings/IO.hs +29/−7
• compiler/GHC/Stg/Subst.hs +2/−2
• compiler/GHC/StgToCmm/Prim.hs +2/−2
• compiler/GHC/StgToCmm/Ticky.hs +1/−1
• compiler/GHC/StgToJS/Apply.hs +0/−18
• compiler/GHC/StgToJS/Expr.hs +34/−1
• compiler/GHC/StgToJS/Literal.hs +42/−2
• compiler/GHC/SysTools/Cpp.hs +11/−5
• compiler/GHC/Tc/Deriv/Generate.hs +1/−1
• compiler/GHC/Tc/Deriv/Utils.hs +1/−1
• compiler/GHC/Tc/Errors.hs +2/−0
• compiler/GHC/Tc/Gen/HsType.hs +72/−23
• compiler/GHC/Tc/Solver/Monad.hs +12/−1
• compiler/GHC/ThToHs.hs +2/−1
• ghc-lib.cabal +7/−5
• ghc-lib/stage0/lib/settings +1/−1

@@ -397,6 +397,7 @@ import GHC.Types.TypeEnv import GHC.Types.BreakInfo import GHC.Types.PkgQual+import GHC.Types.Unique.FM  import GHC.Unit import GHC.Unit.Env@@ -676,6 +677,7 @@ setTopSessionDynFlags dflags = do   hsc_env <- getSession   logger  <- getLogger+  lookup_cache  <- liftIO $ newMVar emptyUFM    -- Interpreter   interp <- if@@ -705,7 +707,7 @@             }          s <- liftIO $ newMVar InterpPending          loader <- liftIO Loader.uninitializedLoader-         return (Just (Interp (ExternalInterp (ExtIServ (ExtInterpState conf s))) loader))+         return (Just (Interp (ExternalInterp (ExtIServ (ExtInterpState conf s))) loader lookup_cache))      -- JavaScript interpreter     | ArchJavaScript <- platformArch (targetPlatform dflags)@@ -723,7 +725,7 @@               , jsInterpFinderOpts  = initFinderOpts dflags               , jsInterpFinderCache = hsc_FC hsc_env               }-         return (Just (Interp (ExternalInterp (ExtJS (ExtInterpState cfg s))) loader))+         return (Just (Interp (ExternalInterp (ExtJS (ExtInterpState cfg s))) loader lookup_cache))      -- Internal interpreter     | otherwise@@ -731,7 +733,7 @@ #if defined(HAVE_INTERNAL_INTERPRETER)      do       loader <- liftIO Loader.uninitializedLoader-      return (Just (Interp InternalInterp loader))+      return (Just (Interp InternalInterp loader lookup_cache)) #else       return Nothing #endif

@@ -82,7 +82,7 @@    | PUSH16_W !ByteOff    | PUSH32_W !ByteOff -   -- Push a ptr  (these all map to PUSH_G really)+   -- Push a (heap) ptr  (these all map to PUSH_G really)    | PUSH_G       Name    | PUSH_PRIMOP  PrimOp    | PUSH_BCO     (ProtoBCO Name)

@@ -25,6 +25,7 @@ import GHCi.BreakArray  import GHC.Builtin.PrimOps+import GHC.Builtin.PrimOps.Ids import GHC.Builtin.Names  import GHC.Unit.Types@@ -40,6 +41,8 @@  import GHC.Types.Name import GHC.Types.Name.Env+import qualified GHC.Types.Id as Id+import GHC.Types.Unique.DFM  import Language.Haskell.Syntax.Module.Name @@ -54,32 +57,33 @@  linkBCO   :: Interp+  -> PkgsLoaded   -> LinkerEnv   -> NameEnv Int   -> RemoteRef BreakArray   -> UnlinkedBCO   -> IO ResolvedBCO-linkBCO interp le bco_ix breakarray+linkBCO interp pkgs_loaded le bco_ix breakarray            (UnlinkedBCO _ arity insns bitmap lits0 ptrs0) = do   -- fromIntegral Word -> Word64 should be a no op if Word is Word64   -- otherwise it will result in a cast to longlong on 32bit systems.-  lits <- mapM (fmap fromIntegral . lookupLiteral interp le) (ssElts lits0)-  ptrs <- mapM (resolvePtr interp le bco_ix breakarray) (ssElts ptrs0)+  lits <- mapM (fmap fromIntegral . lookupLiteral interp pkgs_loaded le) (ssElts lits0)+  ptrs <- mapM (resolvePtr interp pkgs_loaded le bco_ix breakarray) (ssElts ptrs0)   return (ResolvedBCO isLittleEndian arity insns bitmap               (listArray (0, fromIntegral (sizeSS lits0)-1) lits)               (addListToSS emptySS ptrs)) -lookupLiteral :: Interp -> LinkerEnv -> BCONPtr -> IO Word-lookupLiteral interp le ptr = case ptr of+lookupLiteral :: Interp -> PkgsLoaded -> LinkerEnv -> BCONPtr -> IO Word+lookupLiteral interp pkgs_loaded le ptr = case ptr of   BCONPtrWord lit -> return lit   BCONPtrLbl  sym -> do     Ptr a# <- lookupStaticPtr interp sym     return (W# (int2Word# (addr2Int# a#)))   BCONPtrItbl nm -> do-    Ptr a# <- lookupIE interp (itbl_env le) nm+    Ptr a# <- lookupIE interp pkgs_loaded (itbl_env le) nm     return (W# (int2Word# (addr2Int# a#)))   BCONPtrAddr nm -> do-    Ptr a# <- lookupAddr interp (addr_env le) nm+    Ptr a# <- lookupAddr interp pkgs_loaded (addr_env le) nm     return (W# (int2Word# (addr2Int# a#)))   BCONPtrStr _ ->     -- should be eliminated during assembleBCOs@@ -93,19 +97,19 @@     Nothing  -> linkFail "GHC.ByteCode.Linker: can't find label"                   (unpackFS addr_of_label_string) -lookupIE :: Interp -> ItblEnv -> Name -> IO (Ptr ())-lookupIE interp ie con_nm =+lookupIE :: Interp -> PkgsLoaded -> ItblEnv -> Name -> IO (Ptr ())+lookupIE interp pkgs_loaded ie con_nm =   case lookupNameEnv ie con_nm of     Just (_, ItblPtr a) -> return (fromRemotePtr (castRemotePtr a))     Nothing -> do -- try looking up in the object files.        let sym_to_find1 = nameToCLabel con_nm "con_info"-       m <- lookupSymbol interp sym_to_find1+       m <- lookupHsSymbol interp pkgs_loaded con_nm "con_info"        case m of           Just addr -> return addr           Nothing              -> do -- perhaps a nullary constructor?                    let sym_to_find2 = nameToCLabel con_nm "static_info"-                   n <- lookupSymbol interp sym_to_find2+                   n <- lookupHsSymbol interp pkgs_loaded con_nm "static_info"                    case n of                       Just addr -> return addr                       Nothing   -> linkFail "GHC.ByteCode.Linker.lookupIE"@@ -113,35 +117,36 @@                                        unpackFS sym_to_find2)  -- see Note [Generating code for top-level string literal bindings] in GHC.StgToByteCode-lookupAddr :: Interp -> AddrEnv -> Name -> IO (Ptr ())-lookupAddr interp ae addr_nm = do+lookupAddr :: Interp -> PkgsLoaded -> AddrEnv -> Name -> IO (Ptr ())+lookupAddr interp pkgs_loaded ae addr_nm = do   case lookupNameEnv ae addr_nm of     Just (_, AddrPtr ptr) -> return (fromRemotePtr ptr)     Nothing -> do -- try looking up in the object files.       let sym_to_find = nameToCLabel addr_nm "bytes"                           -- see Note [Bytes label] in GHC.Cmm.CLabel-      m <- lookupSymbol interp sym_to_find+      m <- lookupHsSymbol interp pkgs_loaded addr_nm "bytes"       case m of         Just ptr -> return ptr         Nothing -> linkFail "GHC.ByteCode.Linker.lookupAddr"                      (unpackFS sym_to_find) -lookupPrimOp :: Interp -> PrimOp -> IO (RemotePtr ())-lookupPrimOp interp primop = do+lookupPrimOp :: Interp -> PkgsLoaded -> PrimOp -> IO (RemotePtr ())+lookupPrimOp interp pkgs_loaded primop = do   let sym_to_find = primopToCLabel primop "closure"-  m <- lookupSymbol interp (mkFastString sym_to_find)+  m <- lookupHsSymbol interp pkgs_loaded (Id.idName $ primOpId primop) "closure"   case m of     Just p -> return (toRemotePtr p)     Nothing -> linkFail "GHC.ByteCode.Linker.lookupCE(primop)" sym_to_find  resolvePtr   :: Interp+  -> PkgsLoaded   -> LinkerEnv   -> NameEnv Int   -> RemoteRef BreakArray   -> BCOPtr   -> IO ResolvedBCOPtr-resolvePtr interp le bco_ix breakarray ptr = case ptr of+resolvePtr interp pkgs_loaded le bco_ix breakarray ptr = case ptr of   BCOPtrName nm     | Just ix <- lookupNameEnv bco_ix nm     -> return (ResolvedBCORef ix) -- ref to another BCO in this group@@ -153,19 +158,41 @@     -> assertPpr (isExternalName nm) (ppr nm) $        do           let sym_to_find = nameToCLabel nm "closure"-          m <- lookupSymbol interp sym_to_find+          m <- lookupHsSymbol interp pkgs_loaded nm "closure"           case m of             Just p -> return (ResolvedBCOStaticPtr (toRemotePtr p))             Nothing -> linkFail "GHC.ByteCode.Linker.lookupCE" (unpackFS sym_to_find)    BCOPtrPrimOp op-    -> ResolvedBCOStaticPtr <$> lookupPrimOp interp op+    -> ResolvedBCOStaticPtr <$> lookupPrimOp interp pkgs_loaded op    BCOPtrBCO bco-    -> ResolvedBCOPtrBCO <$> linkBCO interp le bco_ix breakarray bco+    -> ResolvedBCOPtrBCO <$> linkBCO interp pkgs_loaded le bco_ix breakarray bco    BCOPtrBreakArray     -> return (ResolvedBCOPtrBreakArray breakarray)++-- | Look up the address of a Haskell symbol in the currently+-- loaded units.+--+-- See Note [Looking up symbols in the relevant objects].+lookupHsSymbol :: Interp -> PkgsLoaded -> Name -> String -> IO (Maybe (Ptr ()))+lookupHsSymbol interp pkgs_loaded nm sym_suffix = do+  massertPpr (isExternalName nm) (ppr nm)+  let sym_to_find = nameToCLabel nm sym_suffix+      pkg_id = moduleUnitId $ nameModule nm+      loaded_dlls = maybe [] loaded_pkg_hs_dlls $ lookupUDFM pkgs_loaded pkg_id++      go (dll:dlls) = do+        mb_ptr <- lookupSymbolInDLL interp dll sym_to_find+        case mb_ptr of+          Just ptr -> pure (Just ptr)+          Nothing -> go dlls+      go [] =+        -- See Note [Symbols may not be found in pkgs_loaded] in GHC.Linker.Types+        lookupSymbol interp sym_to_find++  go loaded_dlls  linkFail :: String -> String -> IO a linkFail who what

@@ -213,23 +213,33 @@   = Just $! CmmMachOp op [pic, CmmLit $ cmmOffsetLit lit off ]   where off = fromIntegral (narrowS rep n) --- Make a RegOff if we can+-- Make a RegOff if we can. We don't perform this optimization if rep is greater+-- than the host word size because we use an Int to store the offset. See+-- #24893 and #24700. This should be fixed to ensure that optimizations don't+-- depend on the compiler host platform. cmmMachOpFoldM _ (MO_Add _) [CmmReg reg, CmmLit (CmmInt n rep)]+  | validOffsetRep rep   = Just $! cmmRegOff reg (fromIntegral (narrowS rep n)) cmmMachOpFoldM _ (MO_Add _) [CmmRegOff reg off, CmmLit (CmmInt n rep)]+  | validOffsetRep rep   = Just $! cmmRegOff reg (off + fromIntegral (narrowS rep n)) cmmMachOpFoldM _ (MO_Sub _) [CmmReg reg, CmmLit (CmmInt n rep)]+  | validOffsetRep rep   = Just $! cmmRegOff reg (- fromIntegral (narrowS rep n)) cmmMachOpFoldM _ (MO_Sub _) [CmmRegOff reg off, CmmLit (CmmInt n rep)]+  | validOffsetRep rep   = Just $! cmmRegOff reg (off - fromIntegral (narrowS rep n))  -- Fold label(+/-)offset into a CmmLit where possible  cmmMachOpFoldM _ (MO_Add _) [CmmLit lit, CmmLit (CmmInt i rep)]+  | validOffsetRep rep   = Just $! CmmLit (cmmOffsetLit lit (fromIntegral (narrowU rep i))) cmmMachOpFoldM _ (MO_Add _) [CmmLit (CmmInt i rep), CmmLit lit]+  | validOffsetRep rep   = Just $! CmmLit (cmmOffsetLit lit (fromIntegral (narrowU rep i))) cmmMachOpFoldM _ (MO_Sub _) [CmmLit lit, CmmLit (CmmInt i rep)]+  | validOffsetRep rep   = Just $! CmmLit (cmmOffsetLit lit (fromIntegral (negate (narrowU rep i))))  @@ -409,6 +419,13 @@ -- Anything else is just too hard.  cmmMachOpFoldM _ _ _ = Nothing++-- | Check that a literal width is compatible with the host word size used to+-- store offsets. This should be fixed properly (using larger types to store+-- literal offsets). See #24893+validOffsetRep :: Width -> Bool+validOffsetRep rep = widthInBits rep <= finiteBitSize (undefined :: Int)+  {- Note [Comparison operators] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

@@ -47,6 +47,7 @@         patchRegsOfInstr        = AArch64.patchRegsOfInstr         isJumpishInstr          = AArch64.isJumpishInstr         jumpDestsOfInstr        = AArch64.jumpDestsOfInstr+        canFallthroughTo        = AArch64.canFallthroughTo         patchJumpInstr          = AArch64.patchJumpInstr         mkSpillInstr            = AArch64.mkSpillInstr         mkLoadInstr             = AArch64.mkLoadInstr

@@ -383,7 +383,7 @@  -- TODO OPT: we might be able give getRegister --          a hint, what kind of register we want.-getFloatReg :: HasCallStack => CmmExpr -> NatM (Reg, Format, InstrBlock)+getFloatReg :: HasDebugCallStack => CmmExpr -> NatM (Reg, Format, InstrBlock) getFloatReg expr = do   r <- getRegister expr   case r of

@@ -176,6 +176,8 @@         interesting _        (RegReal (RealRegSingle (-1))) = False         interesting platform (RegReal (RealRegSingle i))    = freeReg platform i +-- Note [AArch64 Register assignments]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- Save caller save registers -- This is x0-x18 --@@ -198,6 +200,8 @@ -- '---------------------------------------------------------------------------------------------------------------------------------------------------------------' -- IR: Indirect result location register, IP: Intra-procedure register, PL: Platform register, FP: Frame pointer, LR: Link register, SP: Stack pointer -- BR: Base, SL: SpLim+--+-- TODO: The zero register is currently mapped to -1 but should get it's own separate number. callerSavedRegisters :: [Reg] callerSavedRegisters     = map regSingle [0..18]@@ -327,6 +331,12 @@ jumpDestsOfInstr (BL t _ _) = [ id | TBlock id <- [t]] jumpDestsOfInstr (BCOND _ t) = [ id | TBlock id <- [t]] jumpDestsOfInstr _ = []++canFallthroughTo :: Instr -> BlockId -> Bool+canFallthroughTo (ANN _ i) bid = canFallthroughTo i bid+canFallthroughTo (J (TBlock target)) bid = bid == target+canFallthroughTo (B (TBlock target)) bid = bid == target+canFallthroughTo _ _ = False  -- | Change the destination of this jump instruction. -- Used in the linear allocator when adding fixup blocks for join

@@ -317,6 +317,7 @@          | w == W64 = text "sp"          | w == W32 = text "wsp" +    -- See Note [AArch64 Register assignments]     ppr_reg_no w i          | i < 0, w == W32 = text "wzr"          | i < 0, w == W64 = text "xzr"

@@ -17,6 +17,7 @@ import GHC.Utils.Panic import GHC.Platform +-- TODO: Should this include the zero register? allMachRegNos   :: [RegNo] allMachRegNos   = [0..31] ++ [32..63] -- allocatableRegs is allMachRegNos with the fixed-use regs removed.

@@ -777,10 +777,9 @@ dropJumps _    [] = [] dropJumps info (BasicBlock lbl ins:todo)     | Just ins <- nonEmpty ins --This can happen because of shortcutting-    , [dest] <- jumpDestsOfInstr (NE.last ins)     , BasicBlock nextLbl _ : _ <- todo-    , not (mapMember dest info)-    , nextLbl == dest+    , canFallthroughTo (NE.last ins) nextLbl+    , not (mapMember nextLbl info)     = BasicBlock lbl (NE.init ins) : dropJumps info todo     | otherwise     = BasicBlock lbl ins : dropJumps info todo

@@ -71,10 +71,16 @@                 :: instr -> Bool  -        -- | Give the possible destinations of this jump instruction.+        -- | Give the possible *local block* destinations of this jump instruction.         --      Must be defined for all jumpish instructions.         jumpDestsOfInstr                 :: instr -> [BlockId]++        -- | Check if the instr always transfers control flow+        -- to the given block. Used by code layout to eliminate+        -- jumps that can be replaced by fall through.+        canFallthroughTo+                :: instr -> BlockId -> Bool           -- | Change the destination of this jump instruction.

@@ -79,8 +79,15 @@     cmmTopCodeGen             :: RawCmmDecl -> NatM [NatCmmDecl statics instr],     generateJumpTableForInstr :: instr -> Maybe (NatCmmDecl statics instr),     getJumpDestBlockId        :: jumpDest -> Maybe BlockId,+    -- | Does this jump always jump to a single destination and is shortcutable?+    --+    -- We use this to determine shortcutable instructions - See Note [What is shortcutting]+    -- Note that if we return a destination here we *most* support the relevant shortcutting in+    -- shortcutStatics for jump tables and shortcutJump for the instructions itself.     canShortcut               :: instr -> Maybe jumpDest,+    -- | Replace references to blockIds with other destinations - used to update jump tables.     shortcutStatics           :: (BlockId -> Maybe jumpDest) -> statics -> statics,+    -- | Change the jump destination(s) of an instruction.     shortcutJump              :: (BlockId -> Maybe jumpDest) -> instr -> instr,     -- | 'Module' is only for printing internal labels. See Note [Internal proc     -- labels] in CLabel.@@ -105,6 +112,25 @@     -- ^ Turn the sequence of @jcc l1; jmp l2@ into @jncc l2; \<block_l1>@     -- when possible.     }++{- Note [supporting shortcutting]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For the concept of shortcutting see Note [What is shortcutting].++In order to support shortcutting across multiple backends uniformly we+use canShortcut, shortcutStatics and shortcutJump.++canShortcut tells us if the backend support shortcutting of a instruction+and if so what destination we should retarget instruction to instead.++shortcutStatics exists to allow us to update jump destinations in jump tables.++shortcutJump updates the instructions itself.++A backend can opt out of those by always returning Nothing for canShortcut+and implementing shortcutStatics/shortcutJump as \_ x -> x++-}  {- Note [pprNatCmmDeclS and pprNatCmmDeclH] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

@@ -46,6 +46,7 @@    patchRegsOfInstr    = PPC.patchRegsOfInstr    isJumpishInstr      = PPC.isJumpishInstr    jumpDestsOfInstr    = PPC.jumpDestsOfInstr+   canFallthroughTo    = PPC.canFallthroughTo    patchJumpInstr      = PPC.patchJumpInstr    mkSpillInstr        = PPC.mkSpillInstr    mkLoadInstr         = PPC.mkLoadInstr

@@ -1766,7 +1766,7 @@                                 _ -> panic "genCall': unknown calling conv."          argReps = map (cmmExprType platform) args-        (argHints, _) = foreignTargetHints target+        (_, argHints) = foreignTargetHints target          roundTo a x | x `mod` a == 0 = x                     | otherwise = x + a - (x `mod` a)

@@ -22,6 +22,7 @@    , patchJumpInstr    , patchRegsOfInstr    , jumpDestsOfInstr+   , canFallthroughTo    , takeRegRegMoveInstr    , takeDeltaInstr    , mkRegRegMoveInstr@@ -509,6 +510,13 @@     BL{}        -> True     JMP{}       -> True     _           -> False++canFallthroughTo :: Instr -> BlockId -> Bool+canFallthroughTo instr bid+ = case instr of+        BCC _ target _      -> target == bid+        BCCFAR _ target _   -> target == bid+        _                   -> False   -- | Checks whether this instruction is a jump/branch instruction.

@@ -179,7 +179,8 @@                             ArchPPC       -> 26                             ArchPPC_64 _  -> 20                             ArchARM _ _ _ -> panic "trivColorable ArchARM"-                            ArchAArch64   -> 32+                            ArchAArch64   -> 24 -- 32 - F1 .. F4, D1..D4 - it's odd but see Note [AArch64 Register assignments] for our reg use.+                                                -- Seems we reserve different registers for D1..D4 and F1 .. F4 somehow, we should fix this.                             ArchAlpha     -> panic "trivColorable ArchAlpha"                             ArchMipseb    -> panic "trivColorable ArchMipseb"                             ArchMipsel    -> panic "trivColorable ArchMipsel"

@@ -8,11 +8,11 @@  import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Misc( HasDebugCallStack ) import GHC.Platform  import Data.Word -import GHC.Stack -- AArch64 has 32 64bit general purpose register r0..r30, and zr/sp -- AArch64 has 32 128bit floating point registers v0..v31 as part of the NEON -- extension in Armv8-A.@@ -65,7 +65,7 @@ showBits w = map (\i -> if testBit w i then '1' else '0') [0..31]  -- FR instance implementation (See Linear.FreeRegs)-allocateReg :: HasCallStack => RealReg -> FreeRegs -> FreeRegs+allocateReg :: HasDebugCallStack => RealReg -> FreeRegs -> FreeRegs allocateReg (RealRegSingle r) (FreeRegs g f)     | r > 31 && testBit f (r - 32) = FreeRegs g (clearBit f (r - 32))     | r < 32 && testBit g r = FreeRegs (clearBit g r) f@@ -127,7 +127,7 @@ initFreeRegs :: Platform -> FreeRegs initFreeRegs platform = foldl' (flip releaseReg) noFreeRegs (allocatableRegs platform) -releaseReg :: HasCallStack => RealReg -> FreeRegs -> FreeRegs+releaseReg :: HasDebugCallStack => RealReg -> FreeRegs -> FreeRegs releaseReg (RealRegSingle r) (FreeRegs g f)   | r > 31 && testBit f (r - 32) = pprPanic "Linear.AArch64.releaseReg" (text  "can't release non-allocated reg v" <> int (r - 32))   | r < 32 && testBit g r = pprPanic "Linear.AArch64.releaseReg" (text "can't release non-allocated reg x" <> int r)

@@ -133,6 +133,11 @@                 Instr instr     -> isJumpishInstr instr                 _               -> False +        canFallthroughTo i bid+         = case i of+                Instr instr     -> canFallthroughTo instr bid+                _               -> False+         jumpDestsOfInstr i          = case i of                 Instr instr     -> jumpDestsOfInstr instr

@@ -51,6 +51,7 @@    patchRegsOfInstr        = X86.patchRegsOfInstr    isJumpishInstr          = X86.isJumpishInstr    jumpDestsOfInstr        = X86.jumpDestsOfInstr+   canFallthroughTo        = X86.canFallthroughTo    patchJumpInstr          = X86.patchJumpInstr    mkSpillInstr            = X86.mkSpillInstr    mkLoadInstr             = X86.mkLoadInstr

@@ -2441,10 +2441,11 @@            -> [CmmFormal]       -- ^ where to put the result            -> [CmmActual]       -- ^ arguments (of mixed type)            -> NatM InstrBlock-genCCall32 addr conv dest_regs args = do+genCCall32 addr conv@(ForeignConvention _ argHints _ _) dest_regs args = do         config <- getConfig         let platform = ncgPlatform config-            prom_args = map (maybePromoteCArg platform W32) args+            args_hints = zip args (argHints ++ repeat NoHint)+            prom_args = map (maybePromoteCArg platform W32) args_hints              -- If the size is smaller than the word, we widen things (see maybePromoteCArg)             arg_size_bytes :: CmmType -> Int@@ -2598,10 +2599,11 @@            -> [CmmFormal]       -- ^ where to put the result            -> [CmmActual]       -- ^ arguments (of mixed type)            -> NatM InstrBlock-genCCall64 addr conv dest_regs args = do+genCCall64 addr conv@(ForeignConvention _ argHints _ _) dest_regs args = do     platform <- getPlatform     -- load up the register arguments-    let prom_args = map (maybePromoteCArg platform W32) args+    let args_hints = zip args (argHints ++ repeat NoHint)+    let prom_args = map (maybePromoteCArg platform W32) args_hints      let load_args :: [CmmExpr]                   -> [Reg]         -- int regs avail for args@@ -2839,9 +2841,11 @@             assign_code dest_regs)  -maybePromoteCArg :: Platform -> Width -> CmmExpr -> CmmExpr-maybePromoteCArg platform wto arg- | wfrom < wto = CmmMachOp (MO_UU_Conv wfrom wto) [arg]+maybePromoteCArg :: Platform -> Width -> (CmmExpr, ForeignHint) -> CmmExpr+maybePromoteCArg platform wto (arg, hint)+ | wfrom < wto = case hint of+     SignedHint -> CmmMachOp (MO_SS_Conv wfrom wto) [arg]+     _          -> CmmMachOp (MO_UU_Conv wfrom wto) [arg]  | otherwise   = arg  where    wfrom = cmmExprWidth platform arg@@ -3205,7 +3209,6 @@             -> FMASign             -> CmmExpr -> CmmExpr -> CmmExpr -> NatM Register genFMA3Code w signs x y z = do-   -- For the FMA instruction, we want to compute x * y + z   --   -- There are three possible instructions we could emit:@@ -3226,17 +3229,45 @@   --   -- Currently we follow neither of these optimisations,   -- opting to always use fmadd213 for simplicity.+  --+  -- We would like to compute the result directly into the requested register.+  -- To do so we must first compute `x` into the destination register. This is+  -- only possible if the other arguments don't use the destination register.+  -- We check for this and if there is a conflict we move the result only after+  -- the computation. See #24496 how this went wrong in the past.   let rep = floatFormat w   (y_reg, y_code) <- getNonClobberedReg y-  (z_reg, z_code) <- getNonClobberedReg z+  (z_op, z_code) <- getNonClobberedOperand z   x_code <- getAnyReg x+  x_tmp <- getNewRegNat rep   let      fma213 = FMA3 rep signs FMA213-     code dst-        = y_code `appOL`++     code, code_direct, code_mov :: Reg -> InstrBlock+     -- Ideal: Compute the result directly into dst+     code_direct dst = x_code  dst   `snocOL`+                       fma213 z_op y_reg dst+     -- Fallback: Compute the result into a tmp reg and then move it.+     code_mov dst    = x_code x_tmp `snocOL`+                       fma213 z_op y_reg x_tmp `snocOL`+                       MOV rep (OpReg x_tmp) (OpReg dst)++     code dst =+         y_code `appOL`           z_code `appOL`-          x_code dst `snocOL`-          fma213 (OpReg z_reg) y_reg dst+          ( if arg_regs_conflict then code_mov dst else code_direct dst )++      where++        arg_regs_conflict =+          y_reg == dst ||+          case z_op of+            OpReg z_reg -> z_reg == dst+            OpAddr amode -> dst `elem` addrModeRegs amode+            OpImm {} -> False++  -- NB: Computing the result into a desired register using Any can be tricky.+  -- So for now, we keep it simple. (See #24496).   return (Any rep code)  -----------

@@ -31,6 +31,7 @@    , mkSpillInstr    , mkRegRegMoveInstr    , jumpDestsOfInstr+   , canFallthroughTo    , patchRegsOfInstr    , patchJumpInstr    , isMetaInstr@@ -664,6 +665,17 @@         CALL{}          -> True         _               -> False +canFallthroughTo :: Instr -> BlockId -> Bool+canFallthroughTo insn bid+  = case insn of+    JXX _ target          -> bid == target+    JMP_TBL _ targets _ _ -> all isTargetBid targets+    _                     -> False+  where+    isTargetBid target = case target of+      Nothing                      -> True+      Just (DestBlockId target) -> target == bid+      _                  -> False  jumpDestsOfInstr         :: Instr

@@ -2349,7 +2349,7 @@         -- L demand doesn't get both'd with the Bot coming up from the inner         -- call to f.  So we just get an L demand for x for g. -setBndrsDemandInfo :: HasCallStack => [Var] -> [Demand] -> [Var]+setBndrsDemandInfo :: HasDebugCallStack => [Var] -> [Demand] -> [Var] setBndrsDemandInfo (b:bs) ds   | isTyVar b = b : setBndrsDemandInfo bs ds setBndrsDemandInfo (b:bs) (d:ds) =

@@ -19,8 +19,7 @@ import GHC.Prelude  import GHC.Core-import GHC.Core.Utils   ( exprType, findDefault, isJoinBind-                        , exprIsTickedString_maybe )+import GHC.Core.Utils import GHC.Core.Opt.Arity   ( manifestArity ) import GHC.Core.Type import GHC.Core.TyCon@@ -49,7 +48,7 @@ import GHC.Data.FastString import GHC.Platform        ( Platform ) import GHC.Platform.Ways-import GHC.Builtin.PrimOps ( PrimCall(..), primOpWrapperId )+import GHC.Builtin.PrimOps  import GHC.Utils.Outputable import GHC.Utils.Monad@@ -574,6 +573,19 @@ -- This is the guy that turns applications into A-normal form -- --------------------------------------------------------------------------- +getStgArgFromTrivialArg :: HasDebugCallStack => CoreArg -> StgArg+-- A (non-erased) trivial CoreArg corresponds to an atomic StgArg.+-- CoreArgs may not immediately look trivial, e.g., `case e of {}` or+-- `case unsafeequalityProof of UnsafeRefl -> e` might intervene.+-- Good thing we can just call `trivial_expr_fold` here.+getStgArgFromTrivialArg e+  | Just s <- exprIsTickedString_maybe e -- This case is just for backport to GHC 9.8,+  = StgLitArg (LitString s)              -- where we used to treat strings as valid StgArgs+  | otherwise+  = trivial_expr_fold StgVarArg StgLitArg panic panic e+  where+    panic = pprPanic "getStgArgFromTrivialArg" (ppr e)+ coreToStgArgs :: [CoreArg] -> CtsM ([StgArg], [StgTickish]) coreToStgArgs []   = return ([], [])@@ -586,42 +598,29 @@   = do { (args', ts) <- coreToStgArgs args        ; return (StgVarArg coercionTokenId : args', ts) } -coreToStgArgs (Tick t e : args)-  = assert (not (tickishIsCode t)) $-    do { (args', ts) <- coreToStgArgs (e : args)-       ; let !t' = coreToStgTick (exprType e) t-       ; return (args', t':ts) }- coreToStgArgs (arg : args) = do         -- Non-type argument     (stg_args, ticks) <- coreToStgArgs args-    arg' <- coreToStgExpr arg-    let-        (aticks, arg'') = stripStgTicksTop tickishFloatable arg'-        stg_arg = case arg'' of-           StgApp v []                  -> StgVarArg v-           StgConApp con _ [] _         -> StgVarArg (dataConWorkId con)-           StgOpApp (StgPrimOp op) [] _ -> StgVarArg (primOpWrapperId op)-           StgLit lit                   -> StgLitArg lit-           _ -> pprPanic "coreToStgArgs" (ppr arg $$ pprStgExpr panicStgPprOpts arg' $$ pprStgExpr panicStgPprOpts arg'')--        -- WARNING: what if we have an argument like (v `cast` co)-        --          where 'co' changes the representation type?-        --          (This really only happens if co is unsafe.)-        -- Then all the getArgAmode stuff in CgBindery will set the-        -- cg_rep of the CgIdInfo based on the type of v, rather-        -- than the type of 'co'.-        -- This matters particularly when the function is a primop-        -- or foreign call.-        -- Wanted: a better solution than this hacky warning-+    -- We know that `arg` must be trivial, but it may contain Ticks.+    -- Example from test case `decodeMyStack`:+    --   $ @... ((src<decodeMyStack.hs:18:26-28> Data.Tuple.snd) @Int @[..])+    -- Note that unfortunately the Tick is not at the top.+    -- So we'll traverse the expression twice:+    --   * Once with `stripTicksT` (which collects *all* ticks from the expression)+    --   * and another time with `getStgArgFromTrivialArg`.+    -- Since the argument is trivial, the only place the Tick can occur is+    -- somehow wrapping a variable (give or take type args, as above).     platform <- getPlatform-    let-        arg_rep = typePrimRep (exprType arg)-        stg_arg_rep = typePrimRep (stgArgType stg_arg)+    let arg_ty = exprType arg+        ticks' = map (coreToStgTick arg_ty) (stripTicksT (not . tickishIsCode) arg)+        arg' = getStgArgFromTrivialArg arg+        arg_rep = typePrimRep arg_ty+        stg_arg_rep = typePrimRep (stgArgType arg')         bad_args = not (primRepsCompatible platform arg_rep stg_arg_rep) -    warnPprTrace bad_args "Dangerous-looking argument. Probable cause: bad unsafeCoerce#" (ppr arg) $-     return (stg_arg : stg_args, ticks ++ aticks)+    massertPpr (length ticks' <= 1) (text "More than one Tick in trivial arg:" <+> ppr arg)+    warnPprTrace bad_args "Dangerous-looking argument. Probable cause: bad unsafeCoerce#" (ppr arg) (return ())++    return (arg' : stg_args, ticks' ++ ticks)  coreToStgTick :: Type -- type of the ticked expression               -> CoreTickish

@@ -80,6 +80,7 @@ initGentleSimplMode dflags = (initSimplMode dflags InitialPhase "Gentle")   { -- Don't do case-of-case transformations.     -- This makes full laziness work better+    -- See Note [Case-of-case and full laziness]     sm_case_case = False   } @@ -89,3 +90,37 @@     (True, True) -> FloatEnabled     (True, False)-> FloatNestedOnly     (False, _)   -> FloatDisabled+++{- Note [Case-of-case and full laziness]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Case-of-case can hide opportunities for let-floating (full laziness).+For example+   rec { f = \y. case (expensive x) of (a,b) -> blah }+We might hope to float the (expensive x) out of the \y-loop.+But if we inline `expensive` we might get+   \y. case (case x of I# x' -> body) of (a,b) -> blah+Now if we do case-of-case we get+   \y. case x if I# x2 ->+       case body of (a,b) -> blah++Sadly, at this point `body` mentions `x2`, so we can't float it out of the+\y-loop.++Solution: don't do case-of-case in the "gentle" simplification phase that+precedes the first float-out transformation.  Implementation:++  * `sm_case_case` field in SimplMode++  * Consult `sm_case_case` (via `seCaseCase`) before doing case-of-case+    in GHC.Core.Opt.Simplify.Iteration.rebuildCall.++Wrinkles++* This applies equally to the case-of-runRW# transformation:+    case (runRW# (\s. body)) of (a,b) -> blah+    --->+    runRW# (\s. case body of (a,b) -> blah)+  Again, don't do this when `sm_case_case` is off.  See #25055 for+  a motivating example.+-}

@@ -2647,7 +2647,7 @@    case interp of     -- always generate JS code for the JS interpreter (no bytecode!)-    Interp (ExternalInterp (ExtJS i)) _ ->+    Interp (ExternalInterp (ExtJS i)) _ _ ->       jsCodeGen hsc_env srcspan i this_mod stg_binds_with_deps binding_id      _ -> do

@@ -311,16 +311,16 @@  -- Note [Missing home modules] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- Sometimes user doesn't want GHC to pick up modules, not explicitly listed--- in a command line. For example, cabal may want to enable this warning--- when building a library, so that GHC warns user about modules, not listed--- neither in `exposed-modules`, nor in `other-modules`.+-- Sometimes we don't want GHC to process modules that weren't specified as+-- explicit targets. For example, cabal may want to enable this warning+-- when building a library, so that GHC warns the user about modules listed+-- neither in `exposed-modules` nor in `other-modules`. ----- Here "home module" means a module, that doesn't come from an other package.+-- Here "home module" means a module that doesn't come from another package. -- -- For example, if GHC is invoked with modules "A" and "B" as targets, -- but "A" imports some other module "C", then GHC will issue a warning--- about module "C" not being listed in a command line.+-- about module "C" not being listed in the command line. -- -- The warning in enabled by `-Wmissing-home-modules`. See #13129 warnMissingHomeModules ::  DynFlags -> [Target] -> ModuleGraph -> DriverMessages@@ -331,8 +331,6 @@   where     diag_opts = initDiagOpts dflags -    is_known_module mod = any (is_my_target mod) targets-     -- We need to be careful to handle the case where (possibly     -- path-qualified) filenames (aka 'TargetFile') rather than module     -- names are being passed on the GHC command-line.@@ -341,28 +339,30 @@     -- `ghc --make -isrc-exe Main` are supposed to be equivalent.     -- Note also that we can't always infer the associated module name     -- directly from the filename argument.  See #13727.-    is_my_target mod target =-      let tuid = targetUnitId target-      in case targetId target of-          TargetModule name-            -> moduleName (ms_mod mod) == name-                && tuid == ms_unitid mod-          TargetFile target_file _-            | Just mod_file <- ml_hs_file (ms_location mod)-            ->-             augmentByWorkingDirectory dflags target_file == mod_file ||+    is_known_module mod =+      (Map.lookup (moduleName (ms_mod mod)) mod_targets == Just (ms_unitid mod))+      ||+      maybe False is_file_target (ml_hs_file (ms_location mod)) -             --  Don't warn on B.hs-boot if B.hs is specified (#16551)-             addBootSuffix target_file == mod_file ||+    is_file_target file = Set.member (withoutExt file) file_targets -             --  We can get a file target even if a module name was-             --  originally specified in a command line because it can-             --  be converted in guessTarget (by appending .hs/.lhs).-             --  So let's convert it back and compare with module name-             mkModuleName (fst $ splitExtension target_file)-              == moduleName (ms_mod mod)-          _ -> False+    file_targets = Set.fromList (mapMaybe file_target targets) +    file_target Target {targetId} =+      case targetId of+        TargetModule _ -> Nothing+        TargetFile file _ ->+          Just (withoutExt (augmentByWorkingDirectory dflags file))++    mod_targets = Map.fromList (mod_target <$> targets)++    mod_target Target {targetUnitId, targetId} =+      case targetId of+        TargetModule name -> (name, targetUnitId)+        TargetFile file _ -> (mkModuleName (withoutExt file), targetUnitId)++    withoutExt = fst . splitExtension+     missing = map (moduleName . ms_mod) $       filter (not . is_known_module) $         (filter (\ms -> ms_unitid ms == homeUnitId_ dflags)@@ -1578,8 +1578,8 @@        let (root_errs, rootSummariesOk) = partitionEithers rootSummaries -- #17549            root_map = mkRootMap rootSummariesOk        checkDuplicates root_map-       (deps, pkg_deps, map0) <- loopSummaries rootSummariesOk (M.empty, Set.empty, root_map)-       let closure_errs = checkHomeUnitsClosed (hsc_unit_env hsc_env) (hsc_all_home_unit_ids hsc_env) (Set.toList pkg_deps)+       (deps, map0) <- loopSummaries rootSummariesOk (M.empty, root_map)+       let closure_errs = checkHomeUnitsClosed (hsc_unit_env hsc_env)        let unit_env = hsc_unit_env hsc_env        let tmpfs    = hsc_tmpfs    hsc_env @@ -1673,19 +1673,19 @@          -- This loops over all the mod summaries in the dependency graph, accumulates the actual dependencies for each module/unit         loopSummaries :: [ModSummary]-              -> (M.Map NodeKey ModuleGraphNode, Set.Set (UnitId, UnitId),+              -> (M.Map NodeKey ModuleGraphNode,                     DownsweepCache)-              -> IO ((M.Map NodeKey ModuleGraphNode), Set.Set (UnitId, UnitId), DownsweepCache)+              -> IO ((M.Map NodeKey ModuleGraphNode), DownsweepCache)         loopSummaries [] done = return done-        loopSummaries (ms:next) (done, pkgs, summarised)+        loopSummaries (ms:next) (done, summarised)           | Just {} <- M.lookup k done-          = loopSummaries next (done, pkgs, summarised)+          = loopSummaries next (done, summarised)           -- Didn't work out what the imports mean yet, now do that.           | otherwise = do-             (final_deps, pkgs1, done', summarised') <- loopImports (calcDeps ms) done summarised+             (final_deps, done', summarised') <- loopImports (calcDeps ms) done summarised              -- This has the effect of finding a .hs file if we are looking at the .hs-boot file.-             (_, _, done'', summarised'') <- loopImports (maybeToList hs_file_for_boot) done' summarised'-             loopSummaries next (M.insert k (ModuleNode final_deps ms) done'', pkgs1 `Set.union` pkgs, summarised'')+             (_, done'', summarised'') <- loopImports (maybeToList hs_file_for_boot) done' summarised'+             loopSummaries next (M.insert k (ModuleNode final_deps ms) done'', summarised'')           where             k = NodeKey_Module (msKey ms) @@ -1705,18 +1705,17 @@                         -- Visited set; the range is a list because                         -- the roots can have the same module names                         -- if allow_dup_roots is True-             -> IO ([NodeKey], Set.Set (UnitId, UnitId),-+             -> IO ([NodeKey],                   M.Map NodeKey ModuleGraphNode, DownsweepCache)                         -- The result is the completed NodeMap-        loopImports [] done summarised = return ([], Set.empty, done, summarised)+        loopImports [] done summarised = return ([], done, summarised)         loopImports ((home_uid,mb_pkg, gwib) : ss) done summarised           | Just summs <- M.lookup cache_key summarised           = case summs of               [Right ms] -> do                 let nk = NodeKey_Module (msKey ms)-                (rest, pkgs, summarised', done') <- loopImports ss done summarised-                return (nk: rest, pkgs, summarised', done')+                (rest, summarised', done') <- loopImports ss done summarised+                return (nk: rest, summarised', done')               [Left _err] ->                 loopImports ss done summarised               _errs ->  do@@ -1728,69 +1727,77 @@                                        Nothing excl_mods                case mb_s of                    NotThere -> loopImports ss done summarised-                   External uid -> do-                    (other_deps, pkgs, done', summarised') <- loopImports ss done summarised-                    return (other_deps, Set.insert (homeUnitId home_unit, uid) pkgs, done', summarised')+                   External _ -> do+                    (other_deps, done', summarised') <- loopImports ss done summarised+                    return (other_deps, done', summarised')                    FoundInstantiation iud -> do-                    (other_deps, pkgs, done', summarised') <- loopImports ss done summarised-                    return (NodeKey_Unit iud : other_deps, pkgs, done', summarised')+                    (other_deps, done', summarised') <- loopImports ss done summarised+                    return (NodeKey_Unit iud : other_deps, done', summarised')                    FoundHomeWithError (_uid, e) ->  loopImports ss done (Map.insert cache_key [(Left e)] summarised)                    FoundHome s -> do-                     (done', pkgs1, summarised') <--                       loopSummaries [s] (done, Set.empty, Map.insert cache_key [Right s] summarised)-                     (other_deps, pkgs2, final_done, final_summarised) <- loopImports ss done' summarised'+                     (done', summarised') <-+                       loopSummaries [s] (done, Map.insert cache_key [Right s] summarised)+                     (other_deps, final_done, final_summarised) <- loopImports ss done' summarised'                       -- MP: This assumes that we can only instantiate non home units, which is probably fair enough for now.-                     return (NodeKey_Module (msKey s) : other_deps, pkgs1 `Set.union` pkgs2, final_done, final_summarised)+                     return (NodeKey_Module (msKey s) : other_deps, final_done, final_summarised)           where             cache_key = (home_uid, mb_pkg, unLoc <$> gwib)             home_unit = ue_unitHomeUnit home_uid (hsc_unit_env hsc_env)             GWIB { gwib_mod = L loc mod, gwib_isBoot = is_boot } = gwib             wanted_mod = L loc mod --- This function checks then important property that if both p and q are home units+-- | This function checks then important property that if both p and q are home units -- then any dependency of p, which transitively depends on q is also a home unit.-checkHomeUnitsClosed ::  UnitEnv -> Set.Set UnitId -> [(UnitId, UnitId)] -> [DriverMessages]--- Fast path, trivially closed.-checkHomeUnitsClosed ue home_id_set home_imp_ids-  | Set.size home_id_set == 1 = []-  | otherwise =-  let res = foldMap loop home_imp_ids-  -- Now check whether everything which transitively depends on a home_unit is actually a home_unit-  -- These units are the ones which we need to load as home packages but failed to do for some reason,-  -- it's a bug in the tool invoking GHC.-      bad_unit_ids = Set.difference res home_id_set-  in if Set.null bad_unit_ids-        then []-        else [singleMessage $ mkPlainErrorMsgEnvelope rootLoc $ DriverHomePackagesNotClosed (Set.toList bad_unit_ids)]-+--+-- See Note [Multiple Home Units], section 'Closure Property'.+checkHomeUnitsClosed ::  UnitEnv -> [DriverMessages]+checkHomeUnitsClosed ue+    | Set.null bad_unit_ids = []+    | otherwise = [singleMessage $ mkPlainErrorMsgEnvelope rootLoc $ DriverHomePackagesNotClosed (Set.toList bad_unit_ids)]   where+    home_id_set = unitEnv_keys $ ue_home_unit_graph ue+    bad_unit_ids = upwards_closure Set.\\ home_id_set     rootLoc = mkGeneralSrcSpan (fsLit "<command line>")-    -- TODO: This could repeat quite a bit of work but I struggled to write this function.-    -- Which units transitively depend on a home unit-    loop :: (UnitId, UnitId) -> Set.Set UnitId -- The units which transitively depend on a home unit-    loop (from_uid, uid) =-      let us = ue_findHomeUnitEnv from_uid ue in-      let um = unitInfoMap (homeUnitEnv_units us) in-      case lookupUniqMap um uid of-        Nothing -> pprPanic "uid not found" (ppr uid)-        Just ui ->-          let depends = unitDepends ui-              home_depends = Set.fromList depends `Set.intersection` home_id_set-              other_depends = Set.fromList depends `Set.difference` home_id_set-          in-            -- Case 1: The unit directly depends on a home_id-            if not (null home_depends)-              then-                let res = foldMap (loop . (from_uid,)) other_depends-                in Set.insert uid res-             -- Case 2: Check the rest of the dependencies, and then see if any of them depended on-              else-                let res = foldMap (loop . (from_uid,)) other_depends-                in-                  if not (Set.null res)-                    then Set.insert uid res-                    else res++    graph :: Graph (Node UnitId UnitId)+    graph = graphFromEdgedVerticesUniq graphNodes++    -- downwards closure of graph+    downwards_closure+      = graphFromEdgedVerticesUniq [ DigraphNode uid uid (Set.toList deps)+                                   | (uid, deps) <- M.toList (allReachable graph node_key)]++    inverse_closure = transposeG downwards_closure++    upwards_closure = Set.fromList $ map node_key $ reachablesG inverse_closure [DigraphNode uid uid [] | uid <- Set.toList home_id_set]++    all_unit_direct_deps :: UniqMap UnitId (Set.Set UnitId)+    all_unit_direct_deps+      = unitEnv_foldWithKey go emptyUniqMap $ ue_home_unit_graph ue+      where+        go rest this this_uis =+           plusUniqMap_C Set.union+             (addToUniqMap_C Set.union external_depends this (Set.fromList $ this_deps))+             rest+           where+             external_depends = mapUniqMap (Set.fromList . unitDepends) (unitInfoMap this_units)+             this_units = homeUnitEnv_units this_uis+             this_deps = [ toUnitId unit | (unit,Just _) <- explicitUnits this_units]++    graphNodes :: [Node UnitId UnitId]+    graphNodes = go Set.empty home_id_set+      where+        go done todo+          = case Set.minView todo of+              Nothing -> []+              Just (uid, todo')+                | Set.member uid done -> go done todo'+                | otherwise -> case lookupUniqMap all_unit_direct_deps uid of+                    Nothing -> pprPanic "uid not found" (ppr (uid, all_unit_direct_deps))+                    Just depends ->+                      let todo'' = (depends Set.\\ done) `Set.union` todo'+                      in DigraphNode uid uid (Set.toList depends) : go (Set.insert uid done) todo''  -- | Update the every ModSummary that is depended on -- by a module that needs template haskell. We enable codegen to

@@ -999,7 +999,11 @@          attrs :: String         attrs = intercalate "," $ mattr-              ++ ["+sse42"   | isSse4_2Enabled dflags   ]+              ++ ["+sse4.2"  | isSse4_2Enabled dflags   ]+              ++ ["+popcnt"  | isSse4_2Enabled dflags   ]+                   -- LLVM gates POPCNT instructions behind the popcnt flag,+                   -- while the GHC NCG (as well as GCC, Clang) gates it+                   -- behind SSE4.2 instead.               ++ ["+sse2"    | isSse2Enabled platform   ]               ++ ["+sse"     | isSseEnabled platform    ]               ++ ["+avx512f" | isAvx512fEnabled dflags  ]@@ -1075,14 +1079,18 @@ The command used for object linking is set using the -pgmlm and -optlm command-line options. -Sadly, the LLD linker that we use on Windows does not support the `-r` flag-needed to support object merging (see #21068). For this reason on Windows we do-not support GHCi objects.  To deal with foreign stubs we build a static archive-of all of a module's object files instead merging them. Consequently, we can-end up producing `.o` files which are in fact static archives. However,-toolchains generally don't have a problem with this as they use file headers,-not the filename, to determine the nature of inputs.+However, `ld -r` is broken in some cases: + * The LLD linker that we use on Windows does not support the `-r`+   flag needed to support object merging (see #21068). For this reason+   on Windows we do not support GHCi objects.++In these cases, we bundle a module's own object file with its foreign+stub's object file, instead of merging them. Consequently, we can end+up producing `.o` files which are in fact static archives. This can+only work if `ar -L` is supported, so the archive `.o` files can be+properly added to the final static library.+ Note that this has somewhat non-obvious consequences when producing initializers and finalizers. See Note [Initializers and finalizers in Cmm] in GHC.Cmm.InitFini for details.@@ -1107,7 +1115,7 @@ -- | See Note [Object merging]. joinObjectFiles :: HscEnv -> [FilePath] -> FilePath -> IO () joinObjectFiles hsc_env o_files output_fn-  | can_merge_objs && not dashLSupported = do+  | can_merge_objs = do   let toolSettings' = toolSettings dflags       ldIsGnuLd = toolSettings_ldIsGnuLd toolSettings'       ld_r args = GHC.SysTools.runMergeObjects (hsc_logger hsc_env) (hsc_tmpfs hsc_env) (hsc_dflags hsc_env) (

@@ -401,17 +401,11 @@                    Int          -- total size of arguments                   ) mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc- = ( header_bits+ =+   ( header_bits    , CStub body [] []    , type_string,-    sum [ widthInBytes (typeWidth rep) | (_,_,_,rep) <- aug_arg_info] -- all the args-         -- NB. the calculation here isn't strictly speaking correct.-         -- We have a primitive Haskell type (eg. Int#, Double#), and-         -- we want to know the size, when passed on the C stack, of-         -- the associated C type (eg. HsInt, HsDouble).  We don't have-         -- this information to hand, but we know what GHC's conventions-         -- are for passing around the primitive Haskell types, so we-         -- use that instead.  I hope the two coincide --SDM+    aug_arg_size     )  where   platform = targetPlatform dflags@@ -450,6 +444,19 @@     | isNothing maybe_target = stable_ptr_arg : insertRetAddr platform cc arg_info     | otherwise              = arg_info +  aug_arg_size = sum [ widthInBytes (typeWidth rep) | (_,_,_,rep) <- aug_arg_info]+         -- NB. the calculation here isn't strictly speaking correct.+         -- We have a primitive Haskell type (eg. Int#, Double#), and+         -- we want to know the size, when passed on the C stack, of+         -- the associated C type (eg. HsInt, HsDouble).  We don't have+         -- this information to hand, but we know what GHC's conventions+         -- are for passing around the primitive Haskell types, so we+         -- use that instead.  I hope the two coincide --SDM+         -- AK: This seems just wrong, the code here uses widthInBytes, but when+         -- we pass args on the haskell stack we always extend to multiples of 8+         -- to my knowledge. Not sure if it matters though so I won't touch this+         -- for now.+   stable_ptr_arg =         (text "the_stableptr", text "StgStablePtr", undefined,          typeCmmType platform (mkStablePtrPrimTy alphaTy))@@ -605,8 +612,11 @@                         -> [(SDoc, SDoc, Type, CmmType)]               go 6 args = ret_addr_arg platform : args               go n (arg@(_,_,_,rep):args)-               | cmmEqType_ignoring_ptrhood rep b64 = arg : go (n+1) args-               | otherwise  = arg : go n     args+                -- Int type fitting into int register+                | (isBitsType rep && typeWidth rep <= W64 || isGcPtrType rep)+                = arg : go (n+1) args+                | otherwise+                = arg : go n args               go _ [] = []           in go 0 args       _ ->

@@ -70,7 +70,10 @@         -- Other flags which affect code generation         codegen = map (`gopt` dflags) (EnumSet.toList codeGenFlags) -        flags = ((mainis, safeHs, lang, cpp), (paths, prof, ticky, codegen, debugLevel, callerCcFilters))+        -- Did we include core for all bindings?+        fat_iface = gopt Opt_WriteIfSimplifiedCore dflags++        flags = ((mainis, safeHs, lang, cpp), (paths, prof, ticky, codegen, debugLevel, callerCcFilters, fat_iface))      in -- pprTrace "flags" (ppr flags) $        computeFingerprint nameio flags

@@ -615,8 +615,11 @@  getTyConImplicitBinds :: TyCon -> [CoreBind] getTyConImplicitBinds tc-  | isNewTyCon tc = []  -- See Note [Compulsory newtype unfolding] in GHC.Types.Id.Make-  | otherwise     = map get_defn (mapMaybe dataConWrapId_maybe (tyConDataCons tc))+  | isDataTyCon tc = map get_defn (mapMaybe dataConWrapId_maybe (tyConDataCons tc))+  | otherwise      = []+    -- The 'otherwise' includes family TyCons of course, but also (less obviously)+    --  * Newtypes: see Note [Compulsory newtype unfolding] in GHC.Types.Id.Make+    --  * type data: we don't want any code for type-only stuff (#24620)  getClassImplicitBinds :: Class -> [CoreBind] getClassImplicitBinds cls

@@ -56,6 +56,7 @@ import GHC.Runtime.Interpreter import GHCi.RemoteTypes import GHC.Iface.Load+import GHCi.Message (LoadedDLL)  import GHC.ByteCode.Linker import GHC.ByteCode.Asm@@ -145,7 +146,7 @@   --   -- The linker's symbol table is populated with RTS symbols using an   -- explicit list.  See rts/Linker.c for details.-  where init_pkgs = unitUDFM rtsUnitId (LoadedPkgInfo rtsUnitId [] [] emptyUniqDSet)+  where init_pkgs = unitUDFM rtsUnitId (LoadedPkgInfo rtsUnitId [] [] [] emptyUniqDSet)  extendLoadedEnv :: Interp -> [(Name,ForeignHValue)] -> IO () extendLoadedEnv interp new_bindings =@@ -194,8 +195,8 @@   -> SrcSpan   -> [Module]   -> IO (LoaderState, SuccessFlag, [Linkable], PkgsLoaded) -- ^ returns the set of linkables required+-- When called, the loader state must have been initialized (see `initLoaderState`) loadDependencies interp hsc_env pls span needed_mods = do---   initLoaderState (hsc_dflags hsc_env) dl    let opts = initLinkDepsOpts hsc_env     -- Find what packages and linkables are required@@ -485,25 +486,25 @@     DLL dll_unadorned -> do       maybe_errstr <- loadDLL interp (platformSOName platform dll_unadorned)       case maybe_errstr of-         Nothing -> maybePutStrLn logger "done"-         Just mm | platformOS platform /= OSDarwin ->+         Right _ -> maybePutStrLn logger "done"+         Left mm | platformOS platform /= OSDarwin ->            preloadFailed mm lib_paths lib_spec-         Just mm | otherwise -> do+         Left mm | otherwise -> do            -- As a backup, on Darwin, try to also load a .so file            -- since (apparently) some things install that way - see            -- ticket #8770.            let libfile = ("lib" ++ dll_unadorned) <.> "so"            err2 <- loadDLL interp libfile            case err2 of-             Nothing -> maybePutStrLn logger "done"-             Just _  -> preloadFailed mm lib_paths lib_spec+             Right _ -> maybePutStrLn logger "done"+             Left _  -> preloadFailed mm lib_paths lib_spec       return pls      DLLPath dll_path -> do       do maybe_errstr <- loadDLL interp dll_path          case maybe_errstr of-            Nothing -> maybePutStrLn logger "done"-            Just mm -> preloadFailed mm lib_paths lib_spec+            Right _ -> maybePutStrLn logger "done"+            Left mm -> preloadFailed mm lib_paths lib_spec          return pls      Framework framework ->@@ -588,7 +589,7 @@         let le = linker_env pls             nobreakarray = error "no break array"             bco_ix = mkNameEnv [(unlinkedBCOName root_ul_bco, 0)]-        resolved <- linkBCO interp le bco_ix nobreakarray root_ul_bco+        resolved <- linkBCO interp (pkgs_loaded pls) le bco_ix nobreakarray root_ul_bco         [root_hvref] <- createBCOs interp [resolved]         fhv <- mkFinalizedHValue interp root_hvref         return (pls, fhv)@@ -651,7 +652,7 @@                        , addr_env = plusNameEnv (addr_env le) bc_strs }            -- Link the necessary packages and linkables-          new_bindings <- linkSomeBCOs interp le2 [cbc]+          new_bindings <- linkSomeBCOs interp (pkgs_loaded pls) le2 [cbc]           nms_fhvs <- makeForeignNamedHValueRefs interp new_bindings           let ce2  = extendClosureEnv (closure_env le2) nms_fhvs               !pls2 = pls { linker_env = le2 { closure_env = ce2 } }@@ -832,8 +833,8 @@     changeTempFilesLifetime tmpfs TFL_GhcSession [soFile]     m <- loadDLL interp soFile     case m of-        Nothing -> return $! pls { temp_sos = (libPath, libName) : temp_sos }-        Just err -> linkFail msg err+      Right _ -> return $! pls { temp_sos = (libPath, libName) : temp_sos }+      Left err -> linkFail msg err   where     msg = "GHC.Linker.Loader.dynLoadObjs: Loading temp shared object failed" @@ -873,7 +874,7 @@             ae2 = foldr plusNameEnv (addr_env le1) (map bc_strs cbcs)             le2 = le1 { itbl_env = ie2, addr_env = ae2 } -        names_and_refs <- linkSomeBCOs interp le2 cbcs+        names_and_refs <- linkSomeBCOs interp (pkgs_loaded pls) le2 cbcs          -- We only want to add the external ones to the ClosureEnv         let (to_add, to_drop) = partition (isExternalName.fst) names_and_refs@@ -888,6 +889,7 @@  -- Link a bunch of BCOs and return references to their values linkSomeBCOs :: Interp+             -> PkgsLoaded              -> LinkerEnv              -> [CompiledByteCode]              -> IO [(Name,HValueRef)]@@ -895,7 +897,7 @@                         -- the incoming unlinked BCOs.  Each gives the                         -- value of the corresponding unlinked BCO -linkSomeBCOs interp le mods = foldr fun do_link mods []+linkSomeBCOs interp pkgs_loaded le mods = foldr fun do_link mods []  where   fun CompiledByteCode{..} inner accum =     case bc_breaks of@@ -908,7 +910,7 @@     let flat = [ (breakarray, bco) | (breakarray, bcos) <- mods, bco <- bcos ]         names = map (unlinkedBCOName . snd) flat         bco_ix = mkNameEnv (zip names [0..])-    resolved <- sequence [ linkBCO interp le bco_ix breakarray bco+    resolved <- sequence [ linkBCO interp pkgs_loaded le bco_ix breakarray bco                          | (breakarray, bco) <- flat ]     hvrefs <- createBCOs interp resolved     return (zip names hvrefs)@@ -1071,18 +1073,18 @@                -- Link dependents first              ; pkgs' <- link pkgs deps                 -- Now link the package itself-             ; (hs_cls, extra_cls) <- loadPackage interp hsc_env pkg_cfg+             ; (hs_cls, extra_cls, loaded_dlls) <- loadPackage interp hsc_env pkg_cfg              ; let trans_deps = unionManyUniqDSets [ addOneToUniqDSet (loaded_pkg_trans_deps loaded_pkg_info) dep_pkg                                                    | dep_pkg <- deps                                                    , Just loaded_pkg_info <- pure (lookupUDFM pkgs' dep_pkg)                                                    ]-             ; return (addToUDFM pkgs' new_pkg (LoadedPkgInfo new_pkg hs_cls extra_cls trans_deps)) }+             ; return (addToUDFM pkgs' new_pkg (LoadedPkgInfo new_pkg hs_cls extra_cls loaded_dlls trans_deps)) }          | otherwise         = throwGhcExceptionIO (CmdLineError ("unknown package: " ++ unpackFS (unitIdFS new_pkg)))  -loadPackage :: Interp -> HscEnv -> UnitInfo -> IO ([LibrarySpec], [LibrarySpec])+loadPackage :: Interp -> HscEnv -> UnitInfo -> IO ([LibrarySpec], [LibrarySpec], [RemotePtr LoadedDLL]) loadPackage interp hsc_env pkg    = do         let dflags    = hsc_dflags hsc_env@@ -1124,7 +1126,9 @@         let classifieds = hs_classifieds ++ extra_classifieds          -- Complication: all the .so's must be loaded before any of the .o's.-        let known_dlls = [ dll  | DLLPath dll    <- classifieds ]+        let known_hs_dlls    = [ dll | DLLPath dll <- hs_classifieds ]+            known_extra_dlls = [ dll | DLLPath dll <- extra_classifieds ]+            known_dlls       = known_hs_dlls ++ known_extra_dlls #if defined(CAN_LOAD_DLL)             dlls       = [ dll  | DLL dll        <- classifieds ] #endif@@ -1145,10 +1149,13 @@         loadFrameworks interp platform pkg         -- See Note [Crash early load_dyn and locateLib]         -- Crash early if can't load any of `known_dlls`-        mapM_ (load_dyn interp hsc_env True) known_dlls+        mapM_ (load_dyn interp hsc_env True) known_extra_dlls+        loaded_dlls <- mapMaybeM (load_dyn interp hsc_env True) known_hs_dlls         -- For remaining `dlls` crash early only when there is surely         -- no package's DLL around ... (not is_dyn)         mapM_ (load_dyn interp hsc_env (not is_dyn) . platformSOName platform) dlls+#else+        let loaded_dlls = [] #endif         -- After loading all the DLLs, we can load the static objects.         -- Ordering isn't important here, because we do one final link@@ -1168,7 +1175,7 @@         if succeeded ok            then do              maybePutStrLn logger "done."-             return (hs_classifieds, extra_classifieds)+             return (hs_classifieds, extra_classifieds, loaded_dlls)            else let errmsg = text "unable to load unit `"                              <> pprUnitInfoForUser pkg <> text "'"                  in throwGhcExceptionIO (InstallationError (showSDoc dflags errmsg))@@ -1221,19 +1228,20 @@ -- can be passed directly to loadDLL.  They are either fully-qualified -- ("/usr/lib/libfoo.so"), or unqualified ("libfoo.so").  In the latter case, -- loadDLL is going to search the system paths to find the library.-load_dyn :: Interp -> HscEnv -> Bool -> FilePath -> IO ()+load_dyn :: Interp -> HscEnv -> Bool -> FilePath -> IO (Maybe (RemotePtr LoadedDLL)) load_dyn interp hsc_env crash_early dll = do   r <- loadDLL interp dll   case r of-    Nothing  -> return ()-    Just err ->+    Right loaded_dll -> pure (Just loaded_dll)+    Left err ->       if crash_early         then cmdLineErrorIO err-        else+        else do           when (diag_wopt Opt_WarnMissedExtraSharedLib diag_opts)             $ logMsg logger                 (mkMCDiagnostic diag_opts (WarningWithFlag Opt_WarnMissedExtraSharedLib) Nothing)                   noSrcSpan $ withPprStyle defaultUserStyle (note err)+          pure Nothing   where     diag_opts = initDiagOpts (hsc_dflags hsc_env)     logger = hsc_logger hsc_env

@@ -172,6 +172,6 @@      findLoadDLL (p:ps) errs =        do { dll <- loadDLL interp (p </> fwk_file)           ; case dll of-              Nothing  -> return Nothing-              Just err -> findLoadDLL ps ((p ++ ": " ++ err):errs)+              Right _  -> return Nothing+              Left err -> findLoadDLL ps ((p ++ ": " ++ err):errs)           }

@@ -1970,6 +1970,8 @@      is never used (invariant (I1)), so it barely makes sense to talk about      the worker. A `type data` constructor only shows up in types, where it      appears as a TyCon, specifically a PromotedDataCon -- no Id in sight.+     See #24620 for an example of what happens if you accidentally include+     a wrapper.       See `wrapped_reqd` in GHC.Types.Id.Make.mkDataConRep` for the place where      this check is implemented.

@@ -626,8 +626,10 @@         -- saved/restored, but not the linker state.  See #1743, test break026.    mkNewId :: OccName -> Type -> Id -> IO Id    mkNewId occ ty old_id-     = do { name <- newInteractiveBinder hsc_env occ (getSrcSpan old_id)-          ; return (Id.mkVanillaGlobalWithInfo name ty (idInfo old_id)) }+     = do { name <- newInteractiveBinder hsc_env (mkVarOccFS (occNameFS occ)) (getSrcSpan old_id)+              -- NB: use variable namespace.+              -- Don't use record field namespaces, lest we cause #25109.+          ; return $ Id.mkVanillaGlobalWithInfo name ty (idInfo old_id) }     newTyVars :: UniqSupply -> [TcTyVar] -> Subst      -- Similarly, clone the type variables mentioned in the types

@@ -37,6 +37,7 @@   -- * The object-code linker   , initObjLinker   , lookupSymbol+  , lookupSymbolInDLL   , lookupClosure   , loadDLL   , loadArchive@@ -158,22 +159,22 @@   - implementation of Template Haskell (GHCi.TH)   - a few other things needed to run interpreted code -- top-level iserv directory, containing the codefor the external-  server.  This is a fairly simple wrapper, most of the functionality+- top-level iserv directory, containing the code for the external+  server. This is a fairly simple wrapper, most of the functionality   is provided by modules in libraries/ghci.  - This module which provides the interface to the server used   by the rest of GHC. -GHC works with and without -fexternal-interpreter.  With the flag, all-interpreted code is run by the iserv binary.  Without the flag,+GHC works with and without -fexternal-interpreter. With the flag, all+interpreted code is run by the iserv binary. Without the flag, interpreted code is run in the same process as GHC.  Things that do not work with -fexternal-interpreter ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~  dynCompileExpr cannot work, because we have no way to run code of an-unknown type in the remote process.  This API fails with an error+unknown type in the remote process. This API fails with an error message if it is used with -fexternal-interpreter.  Other Notes on Remote GHCi@@ -462,7 +463,7 @@       -- making cross-process LookupSymbol calls, so I added a GHC-side       -- cache which sped things up quite a lot.  We have to be careful       -- to purge this cache when unloading code though.-      cache <- readMVar (instLookupSymbolCache inst)+      cache <- readMVar (interpLookupSymbolCache interp)       case lookupUFM cache str of         Just p -> return (Just p)         Nothing -> do@@ -473,35 +474,72 @@             Just r -> do               let p        = fromRemotePtr r                   cache'   = addToUFM cache str p-              modifyMVar_ (instLookupSymbolCache inst) (const (pure cache'))+              modifyMVar_ (interpLookupSymbolCache interp) (const (pure cache'))               return (Just p)      ExtJS {} -> pprPanic "lookupSymbol not supported by the JS interpreter" (ppr str) +lookupSymbolInDLL :: Interp -> RemotePtr LoadedDLL -> FastString -> IO (Maybe (Ptr ()))+lookupSymbolInDLL interp dll str = withSymbolCache interp str $+  case interpInstance interp of+#if defined(HAVE_INTERNAL_INTERPRETER)+    InternalInterp -> fmap fromRemotePtr <$> run (LookupSymbolInDLL dll (unpackFS str))+#endif+    ExternalInterp ext -> case ext of+      ExtIServ i -> withIServ i $ \inst -> fmap fromRemotePtr <$> do+        uninterruptibleMask_ $+          sendMessage inst (LookupSymbolInDLL dll (unpackFS str))+      ExtJS {} -> pprPanic "lookupSymbol not supported by the JS interpreter" (ppr str)+ lookupClosure :: Interp -> String -> IO (Maybe HValueRef) lookupClosure interp str =   interpCmd interp (LookupClosure str) +-- | 'withSymbolCache' tries to find a symbol in the 'interpLookupSymbolCache'+-- which maps symbols to the address where they are loaded.+-- When there's a cache hit we simply return the cached address, when there is+-- a miss we run the action which determines the symbol's address and populate+-- the cache with the answer.+withSymbolCache :: Interp+                -> FastString+                -- ^ The symbol we are looking up in the cache+                -> IO (Maybe (Ptr ()))+                -- ^ An action which determines the address of the symbol we+                -- are looking up in the cache, which is run if there is a+                -- cache miss. The result will be cached.+                -> IO (Maybe (Ptr ()))+withSymbolCache interp str determine_addr = do++  -- Profiling of GHCi showed a lot of time and allocation spent+  -- making cross-process LookupSymbol calls, so I added a GHC-side+  -- cache which sped things up quite a lot. We have to be careful+  -- to purge this cache when unloading code though.+  --+  -- The analysis in #23415 further showed this cache should also benefit the+  -- internal interpreter's loading times, and needn't be used by the external+  -- interpreter only.+  cache <- readMVar (interpLookupSymbolCache interp)+  case lookupUFM cache str of+    Just p -> return (Just p)+    Nothing -> do++      maddr <- determine_addr+      case maddr of+        Nothing -> return Nothing+        Just p -> do+          let upd_cache cache' = addToUFM cache' str p+          modifyMVar_ (interpLookupSymbolCache interp) (pure . upd_cache)+          return (Just p)+ purgeLookupSymbolCache :: Interp -> IO ()-purgeLookupSymbolCache interp = case interpInstance interp of-#if defined(HAVE_INTERNAL_INTERPRETER)-  InternalInterp -> pure ()-#endif-  ExternalInterp ext -> withExtInterpMaybe ext $ \case-    Nothing   -> pure () -- interpreter stopped, nothing to do-    Just inst -> modifyMVar_ (instLookupSymbolCache inst) (const (pure emptyUFM))+purgeLookupSymbolCache interp = modifyMVar_ (interpLookupSymbolCache interp) (const (pure emptyUFM))  -- | loadDLL loads a dynamic library using the OS's native linker -- (i.e. dlopen() on Unix, LoadLibrary() on Windows).  It takes either -- an absolute pathname to the file, or a relative filename -- (e.g. "libfoo.so" or "foo.dll").  In the latter case, loadDLL -- searches the standard locations for the appropriate library.------ Returns:------ Nothing      => success--- Just err_msg => failure-loadDLL :: Interp -> String -> IO (Maybe String)+loadDLL :: Interp -> String -> IO (Either String (RemotePtr LoadedDLL)) loadDLL interp str = interpCmd interp (LoadDLL str)  loadArchive :: Interp -> String -> IO ()@@ -560,11 +598,9 @@                   }    pending_frees <- newMVar []-  lookup_cache  <- newMVar emptyUFM   let inst = ExtInterpInstance         { instProcess           = process         , instPendingFrees      = pending_frees-        , instLookupSymbolCache = lookup_cache         , instExtra             = ()         }   pure inst

@@ -41,7 +41,6 @@ import GHC.Utils.Error (logInfo) import GHC.Utils.Outputable (text) import GHC.Data.FastString-import GHC.Types.Unique.FM  import Control.Concurrent import Control.Monad@@ -178,11 +177,9 @@         }    pending_frees <- newMVar []-  lookup_cache  <- newMVar emptyUFM   let inst = ExtInterpInstance         { instProcess           = proc         , instPendingFrees      = pending_frees-        , instLookupSymbolCache = lookup_cache         , instExtra             = extra         } 

@@ -29,7 +29,7 @@    c__close :: CInt -> IO CInt  foreign import ccall unsafe "io.h _get_osfhandle"-   _get_osfhandle :: CInt -> IO CInt+   _get_osfhandle :: CInt -> IO CIntPtr  runWithPipesPOSIX :: (CreateProcess -> IO ProcessHandle)                   -> FilePath -> [String] -> [String] -> IO (ProcessHandle, Handle, Handle)

@@ -16,9 +16,11 @@ import GHC.Utils.Fingerprint import GHC.Platform import GHC.Utils.Panic+import GHC.ResponseFile import GHC.Settings import GHC.SysTools.BaseDir +import Data.Char import Control.Monad.Trans.Except import Control.Monad.IO.Class import qualified Data.Map as Map@@ -72,9 +74,13 @@   -- just partially applying those functions and throwing 'Left's; they're   -- written in a very portable style to keep ghc-boot light.   let getSetting key = either pgmError pure $-        getRawFilePathSetting top_dir settingsFile mySettings key+        -- Escape the 'top_dir', to make sure we don't accidentally introduce an+        -- unescaped space+        getRawFilePathSetting (escapeArg top_dir) settingsFile mySettings key       getToolSetting :: String -> ExceptT SettingsError m String-      getToolSetting key = expandToolDir useInplaceMinGW mtool_dir <$> getSetting key+        -- Escape the 'mtool_dir', to make sure we don't accidentally introduce+        -- an unescaped space+      getToolSetting key = expandToolDir useInplaceMinGW (fmap escapeArg mtool_dir) <$> getSetting key   targetPlatformString <- getSetting "target platform string"   cc_prog <- getToolSetting "C compiler command"   cxx_prog <- getToolSetting "C++ compiler command"@@ -89,9 +95,9 @@   let unreg_cc_args = if platformUnregisterised platform                       then ["-DNO_REGS", "-DUSE_MINIINTERPRETER"]                       else []-      cpp_args = map Option (words cpp_args_str)-      cc_args  = words cc_args_str ++ unreg_cc_args-      cxx_args = words cxx_args_str+      cpp_args = map Option (unescapeArgs cpp_args_str)+      cc_args  = unescapeArgs cc_args_str ++ unreg_cc_args+      cxx_args = unescapeArgs cxx_args_str        -- The extra flags we need to pass gcc when we invoke it to compile .hc code.       --@@ -138,12 +144,12 @@   let   as_prog  = cc_prog         as_args  = map Option cc_args         ld_prog  = cc_prog-        ld_args  = map Option (cc_args ++ words cc_link_args_str)+        ld_args  = map Option (cc_args ++ unescapeArgs cc_link_args_str)   ld_r_prog <- getToolSetting "Merge objects command"   ld_r_args <- getToolSetting "Merge objects flags"   let ld_r         | null ld_r_prog = Nothing-        | otherwise      = Just (ld_r_prog, map Option $ words ld_r_args)+        | otherwise      = Just (ld_r_prog, map Option $ unescapeArgs ld_r_args)    llvmTarget <- getSetting "LLVM target" @@ -265,3 +271,19 @@     , platformHasLibm = targetHasLibm     , platform_constants = Nothing -- will be filled later when loading (or building) the RTS unit     }++-- ----------------------------------------------------------------------------+-- Escape Args helpers+-- ----------------------------------------------------------------------------++-- | Just like 'GHC.ResponseFile.escapeArg', but it is not exposed from base.+escapeArg :: String -> String+escapeArg = reverse . foldl' escape []++escape :: String -> Char -> String+escape cs c+  |    isSpace c+    || '\\' == c+    || '\'' == c+    || '"'  == c = c:'\\':cs -- n.b., our caller must reverse the result+  | otherwise    = c:cs

@@ -55,7 +55,7 @@  -- | Substitutes an occurrence of an identifier for its counterpart recorded -- in the 'Subst'.-lookupIdSubst :: HasCallStack => Id -> Subst -> Id+lookupIdSubst :: HasDebugCallStack => Id -> Subst -> Id lookupIdSubst id (Subst in_scope env)   | not (isLocalId id) = id   | Just id' <- lookupVarEnv env id = id'@@ -65,7 +65,7 @@ -- | Substitutes an occurrence of an identifier for its counterpart recorded -- in the 'Subst'. Does not generate a debug warning if the identifier to -- to substitute wasn't in scope.-noWarnLookupIdSubst :: HasCallStack => Id -> Subst -> Id+noWarnLookupIdSubst :: HasDebugCallStack => Id -> Subst -> Id noWarnLookupIdSubst id (Subst in_scope env)   | not (isLocalId id) = id   | Just id' <- lookupVarEnv env id = id'

@@ -2074,8 +2074,8 @@                    -> CmmType  -- ^ index type                    -> AlignmentSpec alignmentFromTypes ty idx_ty-  | typeWidth ty < typeWidth idx_ty = NaturallyAligned-  | otherwise                       = Unaligned+  | typeWidth ty <= typeWidth idx_ty = NaturallyAligned+  | otherwise                        = Unaligned  doIndexOffAddrOp :: Maybe MachOp                  -> CmmType

@@ -809,7 +809,7 @@ bumpTickyAllocd :: CLabel -> Int -> FCode () bumpTickyAllocd lbl bytes = do   platform <- getPlatform-  bumpTickyLitBy (cmmLabelOffB lbl (pc_OFFSET_StgEntCounter_entry_count (platformConstants platform))) bytes+  bumpTickyLitBy (cmmLabelOffB lbl (pc_OFFSET_StgEntCounter_allocd (platformConstants platform))) bytes  bumpTickyTagSkip :: CLabel -> FCode () bumpTickyTagSkip lbl = do

@@ -44,7 +44,6 @@ import GHC.StgToJS.Stack import GHC.StgToJS.Ids -import GHC.Types.Literal import GHC.Types.Id import GHC.Types.Id.Info import GHC.Types.CostCentre@@ -58,7 +57,6 @@ import GHC.Core.DataCon import GHC.Core.Type hiding (typeSize) -import GHC.Utils.Encoding import GHC.Utils.Misc import GHC.Utils.Monad import GHC.Utils.Panic@@ -97,22 +95,6 @@   -> [StgArg]   -> G (JStat, ExprResult) genApp ctx i args--    -- Case: unpackCStringAppend# "some string"# str-    ---    -- Generates h$appendToHsStringA(str, "some string"), which has a faster-    -- decoding loop.-    | [StgLitArg (LitString bs), x] <- args-    , [top] <- concatMap typex_expr (ctxTarget ctx)-    , getUnique i == unpackCStringAppendIdKey-    , d <- utf8DecodeByteString bs-    = do-        prof <- csProf <$> getSettings-        let profArg = if prof then [jCafCCS] else []-        a <- genArg x-        return ( top |= app "h$appendToHsStringA" (toJExpr d : a ++ profArg)-               , ExprInline Nothing-               )      -- let-no-escape     | Just n <- ctxLneBindingStackSize ctx i

@@ -57,11 +57,13 @@ import GHC.Types.Id import GHC.Types.Unique.FM import GHC.Types.RepType+import GHC.Types.Literal  import GHC.Stg.Syntax import GHC.Stg.Utils  import GHC.Builtin.PrimOps+import GHC.Builtin.Names  import GHC.Core import GHC.Core.TyCon@@ -70,6 +72,7 @@ import GHC.Core.Type hiding (typeSize)  import GHC.Utils.Misc+import GHC.Utils.Encoding import GHC.Utils.Monad import GHC.Utils.Panic import GHC.Utils.Outputable (ppr, renderWithContext, defaultSDocContext)@@ -556,7 +559,37 @@         -> LiveVars         -> G (JStat, ExprResult) genCase ctx bnd e at alts l-  | snd (isInlineExpr (ctxEvaluatedIds ctx) e) = do+  -- For:      unpackCStringAppend# "some string"# str+  -- Generate: h$appendToHsStringA(str, "some string")+  --+  -- The latter has a faster decoding loop.+  --+  -- Since #23270 and 7e0c8b3bab30, literals strings aren't STG atoms and we+  -- need to match the following instead:+  --+  --    case "some string"# of b {+  --      DEFAULT -> unpackCStringAppend# b str+  --    }+  --+  -- Wrinkle: it doesn't kick in when literals are floated out to the top level.+  --+  | StgLit (LitString bs) <- e+  , [GenStgAlt DEFAULT _ rhs] <- alts+  , StgApp i args <- rhs+  , getUnique i == unpackCStringAppendIdKey+  , [StgVarArg b',x] <- args+  , bnd == b'+  , d <- utf8DecodeByteString bs+  , [top] <- concatMap typex_expr (ctxTarget ctx)+  = do+      prof <- csProf <$> getSettings+      let profArg = if prof then [jCafCCS] else []+      a <- genArg x+      return ( top |= app "h$appendToHsStringA" (toJExpr d : a ++ profArg)+             , ExprInline Nothing+             )++  | snd $ isInlineExpr (ctxEvaluatedIds ctx) e = do       bndi <- identsForId bnd       let ctx' = ctxSetTop bnd                   $ ctxSetTarget (assocIdExprs bnd (map toJExpr bndi))

@@ -20,6 +20,7 @@ import GHC.Data.FastString import GHC.Types.Literal import GHC.Types.Basic+import GHC.Types.RepType import GHC.Utils.Misc import GHC.Utils.Panic import GHC.Utils.Outputable@@ -66,7 +67,28 @@     | otherwise              -> return [ toJExpr (TxtI (mkRawSymbol True name))                                        , ValExpr (JInt 0)                                        ]-  LitRubbish {} -> return [ null_ ]+  LitRubbish _ rr_ty ->+    -- Generate appropriate rubbish literals, otherwise it might trip up the+    -- code generator when a primop is applied to a rubbish literal (see #24664)+    let reps = runtimeRepPrimRep (text "GHC.StgToJS.Literal.genLit") rr_ty+        rub  = \case+                  BoxedRep _ -> [ null_ ]+                  AddrRep    -> [ null_, ValExpr (JInt 0) ]+                  WordRep    -> [ ValExpr (JInt 0) ]+                  Word8Rep   -> [ ValExpr (JInt 0) ]+                  Word16Rep  -> [ ValExpr (JInt 0) ]+                  Word32Rep  -> [ ValExpr (JInt 0) ]+                  Word64Rep  -> [ ValExpr (JInt 0), ValExpr (JInt 0) ]+                  IntRep     -> [ ValExpr (JInt 0) ]+                  Int8Rep    -> [ ValExpr (JInt 0) ]+                  Int16Rep   -> [ ValExpr (JInt 0) ]+                  Int32Rep   -> [ ValExpr (JInt 0) ]+                  Int64Rep   -> [ ValExpr (JInt 0), ValExpr (JInt 0) ]+                  DoubleRep  -> [ ValExpr (JInt 0) ]+                  FloatRep   -> [ ValExpr (JInt 0) ]+                  VoidRep    -> panic "GHC.StgToJS.Literal.genLit: LitRubbish(VoidRep)"+                  VecRep _ _ -> panic "GHC.StgToJS.Literal.genLit: VecRep unsupported"+    in return (concatMap rub reps)  -- | generate a literal for the static init tables genStaticLit :: Literal -> G [StaticLit]@@ -92,7 +114,25 @@   LitDouble r              -> return [ DoubleLit . SaneDouble . r2d $ r ]   LitLabel name _size fod  -> return [ LabelLit (fod == IsFunction) (mkRawSymbol True name)                                      , IntLit 0 ]-  l -> pprPanic "genStaticLit" (ppr l)+  LitRubbish _ rep ->+    let prim_reps = runtimeRepPrimRep (text "GHC.StgToJS.Literal.genStaticLit") rep+    in case expectOnly "GHC.StgToJS.Literal.genStaticLit" prim_reps of -- Note [Post-unarisation invariants]+        BoxedRep _  -> pure [ NullLit ]+        AddrRep     -> pure [ NullLit, IntLit 0 ]+        IntRep      -> pure [ IntLit 0 ]+        Int8Rep     -> pure [ IntLit 0 ]+        Int16Rep    -> pure [ IntLit 0 ]+        Int32Rep    -> pure [ IntLit 0 ]+        Int64Rep    -> pure [ IntLit 0, IntLit 0 ]+        WordRep     -> pure [ IntLit 0 ]+        Word8Rep    -> pure [ IntLit 0 ]+        Word16Rep   -> pure [ IntLit 0 ]+        Word32Rep   -> pure [ IntLit 0 ]+        Word64Rep   -> pure [ IntLit 0, IntLit 0 ]+        FloatRep    -> pure [ DoubleLit (SaneDouble 0) ]+        DoubleRep   -> pure [ DoubleLit (SaneDouble 0) ]+        VoidRep     -> panic "GHC.StgToJS.Literal.getStaticLit: LitRubbish(VoidRep)"+        VecRep {}   -> pprPanic "GHC.StgToJS.Literal.genStaticLit: LitRubbish(VecRep) isn't supported" (ppr rep)  -- make an unsigned 32 bit number from this unsigned one, lower 32 bits toU32Expr :: Integer -> JExpr

@@ -203,11 +203,17 @@ -- | Find out path to @ghcversion.h@ file getGhcVersionPathName :: DynFlags -> UnitEnv -> IO FilePath getGhcVersionPathName dflags unit_env = do-  candidates <- case ghcVersionFile dflags of-    Just path -> return [path]-    Nothing -> do-        ps <- mayThrowUnitErr (preloadUnitsInfo' unit_env [rtsUnitId])-        return ((</> "ghcversion.h") <$> collectIncludeDirs ps)+  let candidates = case ghcVersionFile dflags of+        -- the user has provided an explicit `ghcversion.h` file to use.+        Just path -> [path]+        -- otherwise, try to find it in the rts' include-dirs.+        -- Note: only in the RTS include-dirs! not all preload units less we may+        -- use a wrong file. See #25106 where a globally installed+        -- /usr/include/ghcversion.h file was used instead of the one provided+        -- by the rts.+        Nothing -> case lookupUnitId (ue_units unit_env) rtsUnitId of+          Nothing   -> []+          Just info -> (</> "ghcversion.h") <$> collectIncludeDirs [info]    found <- filterM doesFileExist candidates   case found of

@@ -2466,7 +2466,7 @@     ]  -- | Lookup `Type` in an association list.-assoc_ty_id :: HasCallStack => String           -- The class involved+assoc_ty_id :: HasDebugCallStack => String           -- The class involved             -> [(Type,a)]       -- The table             -> Type             -- The type             -> a                -- The result of the lookup

@@ -643,7 +643,7 @@                , sps_type_or_kind = t_or_k                }) -substPredSpec :: HasCallStack => Subst -> PredSpec -> PredSpec+substPredSpec :: HasDebugCallStack => Subst -> PredSpec -> PredSpec substPredSpec subst ps =   case ps of     SimplePredSpec { sps_pred = pred

@@ -469,6 +469,8 @@              flav = ctFlavour ct         ; (suppress, m_evdest) <- case ctEvidence ct of+         -- For this `suppress` stuff+         -- see Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint            CtGiven {} -> return (False, Nothing)            CtWanted { ctev_rewriters = rewriters, ctev_dest = dest }              -> do { rewriters' <- zonkRewriterSet rewriters

@@ -2551,9 +2551,11 @@        ; traceTc "kcCheckDeclHeader_sig {" $            vcat [ text "sig_kind:" <+> ppr sig_kind                 , text "sig_tcbs:" <+> ppr sig_tcbs-                , text "sig_res_kind:" <+> ppr sig_res_kind ]+                , text "sig_res_kind:" <+> ppr sig_res_kind+                , text "implict_nms:" <+> ppr implicit_nms+                , text "hs_tv_bndrs:" <+> ppr hs_tv_bndrs ] -       ; (tclvl, wanted, (implicit_tvs, (skol_tcbs, (extra_tcbs, tycon_res_kind))))+       ; (tclvl, wanted, (implicit_tvs, (skol_tcbs, skol_scoped_tvs, (extra_tcbs, tycon_res_kind))))            <- pushLevelAndSolveEqualitiesX "kcCheckDeclHeader_sig" $  -- #16687               bindImplicitTKBndrs_Q_Tv implicit_nms                $  -- Q means don't clone               matchUpSigWithDecl name sig_tcbs sig_res_kind hs_tv_bndrs $ \ excess_sig_tcbs sig_res_kind ->@@ -2605,9 +2607,18 @@         -- Here p and q both map to the same kind variable k.  We don't allow this         -- so we must check that they are distinct.  A similar thing happens         -- in GHC.Tc.TyCl.swizzleTcTyConBinders during inference.+        --+        -- With visible dependent quantification, one of the binders involved+        -- may be explicit.  Consider #24604+        --    type UF :: forall zk -> zk -> Constraint+        --    class UF kk (xb :: k)+        -- Here `k` and `kk` both denote the same variable; but only `k` is implicit+        -- Hence we need to add skol_scoped_tvs         ; implicit_tvs <- liftZonkM $ zonkTcTyVarsToTcTyVars implicit_tvs         ; let implicit_prs = implicit_nms `zip` implicit_tvs-        ; checkForDuplicateScopedTyVars implicit_prs+              dup_chk_prs  = implicit_prs ++ mkTyVarNamePairs skol_scoped_tvs+        ; unless (null implicit_nms) $  -- No need if no implicit tyvars+          checkForDuplicateScopedTyVars dup_chk_prs         ; checkForDisconnectedScopedTyVars flav all_tcbs implicit_prs          -- Swizzle the Names so that the TyCon uses the user-declared implicit names@@ -2676,6 +2687,7 @@   -> ([TcTyConBinder] -> TcKind -> TcM a)  -- All user-written binders are in scope                                            --   Argument is excess TyConBinders and tail kind   -> TcM ( [TcTyConBinder]       -- Skolemised binders, with TcTyVars+         , [TcTyVar]             -- Skolem tyvars brought into lexical scope by this matching-up          , a ) -- See Note [Matching a kind signature with a declaration] -- Invariant: Length of returned TyConBinders + length of excess TyConBinders@@ -2686,7 +2698,7 @@     go subst tcbs []       = do { let (subst', tcbs') = substTyConBindersX subst tcbs            ; res <- thing_inside tcbs' (substTy subst' sig_res_kind)-           ; return ([], res) }+           ; return ([], [], res) }      go _ [] hs_bndrs       = failWithTc (TcRnTooManyBinders sig_res_kind hs_bndrs)@@ -2702,17 +2714,22 @@                    -- that come from the type declaration, not the kind signature                  subst' = extendTCvSubstWithClone subst tv tv'            ; tc_hs_bndr (unLoc hs_bndr) (tyVarKind tv')-           ; (tcbs', res) <- tcExtendTyVarEnv [tv'] $-                             go subst' tcbs' hs_bndrs'-           ; return (Bndr tv' vis : tcbs', res) }+           ; traceTc "musd1" (ppr tcb $$ ppr hs_bndr $$ ppr tv')+           ; (tcbs', tvs, res) <- tcExtendTyVarEnv [tv'] $+                                  go subst' tcbs' hs_bndrs'+           ; return (Bndr tv' vis : tcbs', tv':tvs, res) }+             -- We do a tcExtendTyVarEnv [tv'], so we return tv' in+             -- the list of lexically-scoped skolem type variables        | skippable (binderFlag tcb)       = -- Invisible TyConBinder, so do not consume one of the hs_bndrs         do { let (subst', tcb') = substTyConBinderX subst tcb-           ; (tcbs', res) <- go subst' tcbs' hs_bndrs+           ; traceTc "musd2" (ppr tcb $$ ppr hs_bndr $$ ppr tcb')+           ; (tcbs', tvs, res) <- go subst' tcbs' hs_bndrs                    -- NB: pass on hs_bndrs unchanged; we do not consume a                    --     HsTyVarBndr for an invisible TyConBinder-           ; return (tcb' : tcbs', res) }+           ; return (tcb' : tcbs', tvs, res) }+                   -- Return `tvs`; no new lexically-scoped TyVars brought into scope        | otherwise =           -- At this point we conclude that:@@ -2726,14 +2743,19 @@       = return ()     tc_hs_bndr (KindedTyVar _ _ (L _ hs_nm) lhs_kind) expected_kind       = do { sig_kind <- tcLHsKindSig (TyVarBndrKindCtxt hs_nm) lhs_kind+           ; traceTc "musd3:unifying" (ppr sig_kind $$ ppr expected_kind)            ; discardResult $ -- See Note [discardResult in kcCheckDeclHeader_sig]              unifyKind (Just (NameThing hs_nm)) sig_kind expected_kind }      -- See GHC Proposal #425, section "Kind checking",     -- where zippable and skippable are defined.+    -- In particular: we match up if+    -- (a) HsBndr looks like @k, and TyCon binder is forall k. (NamedTCB Specified)+    -- (b) HsBndr looks like a,  and TyCon binder is forall k -> (NamedTCB Required)+    --                                            or k -> (AnonTCB)     zippable :: TyConBndrVis -> HsBndrVis GhcRn -> Bool-    zippable vis HsBndrRequired      = isVisibleTcbVis vis-    zippable vis (HsBndrInvisible _) = isInvisSpecTcbVis vis+    zippable vis (HsBndrInvisible _) = isInvisSpecTcbVis vis  -- (a)+    zippable vis  HsBndrRequired     = isVisibleTcbVis vis    -- (b)      -- See GHC Proposal #425, section "Kind checking",     -- where zippable and skippable are defined.@@ -3026,15 +3048,7 @@  checkForDuplicateScopedTyVars :: [(Name,TcTyVar)] -> TcM () -- Check for duplicates--- E.g. data SameKind (a::k) (b::k)---      data T (a::k1) (b::k2) c = MkT (SameKind a b) c--- Here k1 and k2 start as TyVarTvs, and get unified with each other--- If this happens, things get very confused later, so fail fast------ In the CUSK case k1 and k2 are skolems so they won't unify;--- but in the inference case (see generaliseTcTyCon),--- and the type-sig case (see kcCheckDeclHeader_sig), they are--- TcTyVars, so we must check.+-- See Note [Aliasing in type and class declarations] checkForDuplicateScopedTyVars scoped_prs   = unless (null err_prs) $     do { mapM_ report_dup err_prs; failM }@@ -3054,8 +3068,43 @@         addErrTc $ TcRnDifferentNamesForTyVar n1 n2  -{- Note [Disconnected type variables]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+{- Note [Aliasing in type and class declarations]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+  data SameKind (a::k) (b::k)+  data T1 (a::k1) (b::k2) c = MkT (SameKind a b) c+We do not allow this, because `k1` and `k2` would both stand for the same type+variable -- they are both aliases for `k`.++Other examples+  data T2 (a::k1)                 = MkT2 (SameKind a Int) -- k1 stands for Type+  data T3 @k1 @k2 (a::k1) (b::k2) = MkT (SameKind a b)    -- k1 and k2 are aliases++  type UF :: forall zk. zk -> Constraint+  class UF @kk (xb :: k) where   -- kk and k are aliases+    op :: (xs::kk) -> Bool++See #24604 for an example that crashed GHC.++There is a design choice here. It would be possible to allow implicit type variables+like `k1` and `k2` in T1's declartion to stand for /abitrary kinds/.  This is in fact+the rule we use in /terms/ pattern signatures:+    f :: [Int] -> Int+    f ((x::a) : xs) = ...+Here `a` stands for `Int`.  But in type /signatures/ we make a different choice:+    f1 :: forall (a::k1) (b::k2). SameKind a b -> blah+    f2 :: forall (a::k). SameKind a Int -> blah++Here f1's signature is rejected because `k1` and `k2` are aliased; and f2's is+rejected because `k` stands for `Int`.++Our current choice is that type and class declarations behave more like signatures;+we do not allow aliasing.  That is what `checkForDuplicateScopedTyVars` checks.+See !12328 for some design discussion.+++Note [Disconnected type variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ This note applies when kind-checking the header of a type/class decl that has a separate, standalone kind signature.  See #24083. @@ -3501,7 +3550,7 @@   | SMDSkolemTv SkolemInfo  -smVanilla :: HasCallStack => SkolemMode+smVanilla :: HasDebugCallStack => SkolemMode smVanilla = SM { sm_clone  = panic "sm_clone"  -- We always override this                , sm_parent = False                , sm_tvtv   = pprPanic "sm_tvtv" callStackDoc -- We always override this

@@ -1197,6 +1197,9 @@ -- Getters and setters of GHC.Tc.Utils.Env fields -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +getUnifiedRef :: TcS (IORef Int)+getUnifiedRef = TcS (return . tcs_unified)+ -- Getter of inerts and worklist getInertSetRef :: TcS (IORef InertSet) getInertSetRef = TcS (return . tcs_inerts)@@ -2001,7 +2004,8 @@ -- unified the process; the (Bag Ct) are the deferred constraints.  wrapUnifierTcS ev role do_unifications-  = do { (cos, unified, rewriters, cts) <- wrapTcS $+  = do { unif_count_ref <- getUnifiedRef+       ; (cos, unified, rewriters, cts) <- wrapTcS $              do { defer_ref   <- TcM.newTcRef emptyBag                 ; unified_ref <- TcM.newTcRef []                 ; rewriters <- TcM.zonkRewriterSet (ctEvRewriters ev)@@ -2015,6 +2019,13 @@                  ; cts     <- TcM.readTcRef defer_ref                 ; unified <- TcM.readTcRef unified_ref+++                -- Don't forget to update the count of variables+                -- unified, lest we forget to iterate (#24146)+                ; unless (null unified) $+                  TcM.updTcRef unif_count_ref (+ (length unified))+                 ; return (cos, unified, rewriters, cts) }         -- Emit the deferred constraints

@@ -1476,7 +1476,8 @@                             ; return                                    $ ListPat noAnn ps'} cvtp (SigP p t)        = do { p' <- cvtPat p; t' <- cvtType t-                            ; return $ SigPat noAnn p' (mkHsPatSigType noAnn t') }+                            ; let pp = parenthesizePat sigPrec p'+                            ; return $ SigPat noAnn pp (mkHsPatSigType noAnn t') } cvtp (ViewP e p)       = do { e' <- cvtl e; p' <- cvtPat p                             ; return $ ViewPat noAnn e' p'} 

@@ -1,7 +1,7 @@ cabal-version: 3.0 build-type: Simple name: ghc-lib-version: 9.8.2.20240223+version: 9.8.3.20241022 license: BSD-3-Clause license-file: LICENSE category: Development@@ -54,7 +54,7 @@     manual: True     description: Pass -DTHREADED_RTS to the C toolchain library-    default-language:   Haskell2010+    default-language: Haskell2010     exposed: False     include-dirs:         rts/include@@ -62,6 +62,8 @@         ghc-lib/stage0/compiler/build         compiler         libraries/containers/containers/include+    if impl(ghc >= 8.8.1)+        ghc-options: -fno-safe-haskell     if flag(threaded-rts)         ghc-options: -fobject-code -package=ghc-boot-th -optc-DTHREADED_RTS         cc-options: -DTHREADED_RTS@@ -79,10 +81,10 @@         containers >= 0.6.2.1 && < 0.7,         bytestring >= 0.11.4 && < 0.13,         time >= 1.4 && < 1.13,+        filepath >= 1 && < 1.5,         exceptions == 0.10.*,         parsec,         binary == 0.8.*,-        filepath >= 1 && < 1.5,         directory >= 1 && < 1.4,         array >= 0.1 && < 0.6,         deepseq >= 1.4 && < 1.6,@@ -93,8 +95,8 @@         semaphore-compat,         rts,         hpc >= 0.6 && < 0.8,-        ghc-lib-parser == 9.8.2.20240223-    build-tool-depends: alex:alex >= 3.1, happy:happy >= 1.19.4+        ghc-lib-parser == 9.8.3.20241022+    build-tool-depends: alex:alex >= 3.1, happy:happy > 1.20 && < 2.0     other-extensions:         BangPatterns         CPP

@@ -2,7 +2,7 @@ ,("C compiler flags", "--target=x86_64-apple-darwin  -Qunused-arguments") ,("C++ compiler command", "/usr/bin/g++") ,("C++ compiler flags", "--target=x86_64-apple-darwin ")-,("C compiler link flags", "--target=x86_64-apple-darwin -Wl,-no_fixup_chains -Wl,-no_warn_duplicate_libraries")+,("C compiler link flags", "--target=x86_64-apple-darwin   -Wl,-no_fixup_chains -Wl,-no_warn_duplicate_libraries") ,("C compiler supports -no-pie", "NO") ,("Haskell CPP command", "/usr/bin/gcc") ,("Haskell CPP flags", "-E -undef -traditional -Wno-invalid-pp-token -Wno-unicode -Wno-trigraphs")