- ghc-commits - Haskell.org

[Git][ghc/ghc][wip/warning-for-last-and-init] Re CLC issue 292 Warn GHC.Internal.List.{init,last} are partial
by Bodigrim (＠Bodigrim) 12 Jul '25

12 Jul '25

Bodigrim pushed to branch wip/warning-for-last-and-init at Glasgow Haskell Compiler / GHC Commits: 8f16552d by Mike Pilgrem at 2025-07-12T01:04:22+01:00 Re CLC issue 292 Warn GHC.Internal.List.{init,last} are partial Also corrects the warning for `tail` to refer to `Data.List.uncons` (like the existing warning for `head`). In module `Settings.Warnings`, applies `-Wno-unrecognised-warning-flags` `-Wno-x-partial` to the `Cabal`, `filepath`, `hsc2hs`, `hpc`, `parsec`, `text` and `time` packages (outside GHC's repository). - - - - - 17 changed files: - compiler/GHC/Core/Utils.hs - compiler/GHC/Driver/Session/Units.hs - compiler/GHC/Prelude/Basic.hs - ghc/GHCi/UI.hs - ghc/Main.hs - libraries/ghc-boot-th/GHC/Boot/TH/Ppr.hs - libraries/ghc-internal/src/GHC/Internal/Float.hs - libraries/ghc-internal/src/GHC/Internal/List.hs - libraries/ghc-internal/src/GHC/Internal/System/IO.hs - libraries/ghc-internal/src/GHC/Internal/TH/Syntax.hs - libraries/template-haskell/vendored-filepath/System/FilePath/Posix.hs - libraries/template-haskell/vendored-filepath/System/FilePath/Windows.hs - testsuite/tests/driver/j-space/jspace.hs - testsuite/tests/rts/KeepCafsBase.hs - utils/check-exact/Utils.hs - utils/haddock/haddock-api/src/Haddock/Backends/Xhtml.hs - utils/haddock/haddock-library/src/Documentation/Haddock/Parser.hs Changes: ===================================== compiler/GHC/Core/Utils.hs ===================================== @@ -112,8 +112,7 @@ import GHC.Utils.Misc import Data.ByteString ( ByteString ) import Data.Function ( on ) -import Data.List ( sort, sortBy, partition, zipWith4, mapAccumL ) -import qualified Data.List as Partial ( init, last ) +import Data.List ( sort, sortBy, partition, zipWith4, mapAccumL, unsnoc ) import Data.Ord ( comparing ) import Control.Monad ( guard ) import qualified Data.Set as Set @@ -1871,10 +1870,10 @@ app_ok fun_ok primop_ok fun args PrimOpId op _ | primOpIsDiv op - , Lit divisor <- Partial.last args + , Just (initArgs, Lit divisor) <- unsnoc args -- there can be 2 args (most div primops) or 3 args -- (WordQuotRem2Op), hence the use of last/init - -> not (isZeroLit divisor) && all (expr_ok fun_ok primop_ok) (Partial.init args) + -> not (isZeroLit divisor) && all (expr_ok fun_ok primop_ok) initArgs -- Special case for dividing operations that fail -- In general they are NOT ok-for-speculation -- (which primop_ok will catch), but they ARE OK ===================================== compiler/GHC/Driver/Session/Units.hs ===================================== @@ -183,7 +183,7 @@ checkUnitCycles dflags graph = processSCCs (HUG.hugSCCs graph) processSCCs [] = return () processSCCs (AcyclicSCC _: other_sccs) = processSCCs other_sccs - processSCCs (CyclicSCC uids: _) = throwGhcException $ CmdLineError $ showSDoc dflags (cycle_err uids) + processSCCs (NECyclicSCC uids: _) = throwGhcException $ CmdLineError $ showSDoc dflags (cycle_err uids) cycle_err uids = @@ -195,8 +195,8 @@ checkUnitCycles dflags graph = processSCCs (HUG.hugSCCs graph) (map (\uid -> text "-" <+> ppr uid <+> text "depends on") start) ++ [text "-" <+> ppr final] where - start = init uids - final = last uids + start = NE.init uids + final = NE.last uids -- | Check that we don't have multiple units with the same UnitId. checkDuplicateUnits :: DynFlags -> [(FilePath, DynFlags)] -> Ghc () ===================================== compiler/GHC/Prelude/Basic.hs ===================================== @@ -2,8 +2,8 @@ {-# OPTIONS_HADDOCK not-home #-} {-# OPTIONS_GHC -O2 #-} -- See Note [-O2 Prelude] --- See Note [Proxies for head and tail] -{-# OPTIONS_GHC -Wno-unrecognised-warning-flags -Wno-x-partial #-} +-- See Note [Proxies for partial list functions] +{-# OPTIONS_GHC -Wno-x-partial #-} -- | Custom minimal GHC "Prelude" -- @@ -24,7 +24,7 @@ module GHC.Prelude.Basic , bit , shiftL, shiftR , setBit, clearBit - , head, tail, unzip + , head, tail, init, last, unzip , strictGenericLength ) where @@ -59,7 +59,7 @@ NoImplicitPrelude. There are two motivations for this: -} import qualified Prelude -import Prelude as X hiding ((<>), Applicative(..), Foldable(..), head, tail, unzip) +import Prelude as X hiding ((<>), Applicative(..), Foldable(..), head, tail, init, last, unzip) import Control.Applicative (Applicative(..)) import Data.Foldable as X (Foldable (elem, foldMap, foldl, foldl', foldr, length, null, product, sum)) import Data.Foldable1 as X hiding (head, last) @@ -118,24 +118,35 @@ setBit = \ x i -> x Bits..|. bit i clearBit :: (Num a, Bits.Bits a) => a -> Int -> a clearBit = \ x i -> x Bits..&. Bits.complement (bit i) -{- Note [Proxies for head and tail] +{- Note [Proxies for partial list functions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Prelude.head and Prelude.tail have recently acquired {-# WARNING in "x-partial" #-}, +Prelude.head, Prelude.tail, Prelude.init and Prelude.last +have recently acquired {-# WARNING in "x-partial" #-}, but the GHC codebase uses them fairly extensively and insists on building warning-free. Thus, instead of adding {-# OPTIONS_GHC -Wno-x-partial #-} to every module which employs them, we define warning-less proxies and export them from GHC.Prelude. -} --- See Note [Proxies for head and tail] +-- See Note [Proxies for partial list functions] head :: HasCallStack => [a] -> a head = Prelude.head {-# INLINE head #-} --- See Note [Proxies for head and tail] +-- See Note [Proxies for partial list functions] tail :: HasCallStack => [a] -> [a] tail = Prelude.tail {-# INLINE tail #-} +-- See Note [Proxies for partial list functions] +init :: HasCallStack => [a] -> [a] +init = Prelude.init +{-# INLINE init #-} + +-- See Note [Proxies for partial list functions] +last :: HasCallStack => [a] -> a +last = Prelude.last +{-# INLINE last #-} + {- | The 'genericLength' function defined in base can't be specialised due to the NOINLINE pragma. ===================================== ghc/GHCi/UI.hs ===================================== @@ -133,7 +133,7 @@ import Data.Char import Data.Function import qualified Data.Foldable as Foldable import Data.IORef ( IORef, modifyIORef, newIORef, readIORef, writeIORef ) -import Data.List ( find, intercalate, intersperse, +import Data.List ( find, intercalate, intersperse, unsnoc, isPrefixOf, isSuffixOf, nub, partition, sort, sortBy, (\\) ) import qualified Data.List.NonEmpty as NE import qualified Data.Set as S @@ -2399,9 +2399,9 @@ setContextAfterLoad keep_ctxt (Just graph) = do [] -> let graph' = flattenSCCs $ filterToposortToModules $ GHC.topSortModuleGraph True (GHC.mkModuleGraph loaded_graph) Nothing - in case graph' of - [] -> setContextKeepingPackageModules keep_ctxt [] - xs -> load_this (last xs) + in case unsnoc graph' of + Nothing -> setContextKeepingPackageModules keep_ctxt [] + Just (_, lst) -> load_this lst (m:_) -> load_this m where ===================================== ghc/Main.hs ===================================== @@ -88,7 +88,7 @@ import System.Exit import Control.Monad import Control.Monad.Trans.Class import Control.Monad.Trans.Except (throwE, runExceptT) -import Data.List ( isPrefixOf, partition, intercalate ) +import Data.List ( isPrefixOf, partition, intercalate, unsnoc ) import Prelude import qualified Data.List.NonEmpty as NE @@ -115,8 +115,7 @@ main = do argv0 <- getArgs let (minusB_args, argv1) = partition ("-B" `isPrefixOf`) argv0 - mbMinusB | null minusB_args = Nothing - | otherwise = Just (drop 2 (last minusB_args)) + mbMinusB = drop 2 . snd <$> unsnoc minusB_args let argv2 = map (mkGeneralLocated "on the commandline") argv1 ===================================== libraries/ghc-boot-th/GHC/Boot/TH/Ppr.hs ===================================== @@ -13,7 +13,7 @@ import GHC.Boot.TH.PprLib import GHC.Boot.TH.Syntax import Data.Word ( Word8 ) import Data.Char ( toLower, chr ) -import Data.List ( intersperse ) +import Data.List ( intersperse, unsnoc ) import GHC.Show ( showMultiLineString ) import GHC.Lexeme( isVarSymChar ) import Data.Ratio ( numerator, denominator ) @@ -214,9 +214,10 @@ pprExp i (MDoE m ss_) = parensIf (i > noPrec) $ pprStms [s] = ppr s pprStms ss = braces (semiSep ss) -pprExp _ (CompE []) = text "<<Empty CompExp>>" -- This will probably break with fixity declarations - would need a ';' -pprExp _ (CompE ss) = +pprExp _ (CompE ss) = case unsnoc ss of + Nothing -> text "<<Empty CompExp>>" + Just (ss', s) -> if null ss' -- If there are no statements in a list comprehension besides the last -- one, we simply treat it like a normal list. @@ -225,8 +226,6 @@ pprExp _ (CompE ss) = <+> bar <+> commaSep ss' <> text "]" - where s = last ss - ss' = init ss pprExp _ (ArithSeqE d) = ppr d pprExp _ (ListE es) = brackets (commaSep es) pprExp i (SigE e t) = parensIf (i > noPrec) $ pprExp sigPrec e ===================================== libraries/ghc-internal/src/GHC/Internal/Float.hs ===================================== @@ -13,6 +13,9 @@ {-# OPTIONS_HADDOCK not-home #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +-- For init in formatRealFloatAlt +{-# OPTIONS_GHC -Wno-x-partial #-} + ----------------------------------------------------------------------------- -- | -- Module : GHC.Internal.Float ===================================== libraries/ghc-internal/src/GHC/Internal/List.hs ===================================== @@ -190,12 +190,18 @@ tail :: HasCallStack => [a] -> [a] tail (_:xs) = xs tail [] = errorEmptyList "tail" -{-# WARNING in "x-partial" tail "This is a partial function, it throws an error on empty lists. Replace it with 'drop' 1, or use pattern matching or 'GHC.Internal.Data.List.uncons' instead. Consider refactoring to use \"Data.List.NonEmpty\"." #-} +{-# WARNING in "x-partial" tail "This is a partial function, it throws an error on empty lists. Replace it with 'drop' 1, or use pattern matching or 'Data.List.uncons' instead. Consider refactoring to use \"Data.List.NonEmpty\"." #-} -- | $\mathcal{O}(n)$. Extract the last element of a list, which must be -- finite and non-empty. -- --- WARNING: This function is partial. Consider using 'unsnoc' instead. +-- To disable the warning about partiality put +-- @{-# OPTIONS_GHC -Wno-x-partial -Wno-unrecognised-warning-flags #-}@ +-- at the top of the file. To disable it throughout a package put the same +-- options into @ghc-options@ section of Cabal file. To disable it in GHCi +-- put @:set -Wno-x-partial -Wno-unrecognised-warning-flags@ into @~/.ghci@ +-- config file. See also the +-- [migration guide](https://github.com/haskell/core-libraries-committee/blob/main/guides…. -- -- ==== __Examples__ -- @@ -218,10 +224,18 @@ last xs = foldl (\_ x -> x) lastError xs lastError :: HasCallStack => a lastError = errorEmptyList "last" +{-# WARNING in "x-partial" last "This is a partial function, it throws an error on empty lists. Use 'Data.List.unsnoc' instead. Consider refactoring to use \"Data.List.NonEmpty\"." #-} + -- | $\mathcal{O}(n)$. Return all the elements of a list except the last one. -- The list must be non-empty. -- --- WARNING: This function is partial. Consider using 'unsnoc' instead. +-- To disable the warning about partiality put +-- @{-# OPTIONS_GHC -Wno-x-partial -Wno-unrecognised-warning-flags #-}@ +-- at the top of the file. To disable it throughout a package put the same +-- options into @ghc-options@ section of Cabal file. To disable it in GHCi +-- put @:set -Wno-x-partial -Wno-unrecognised-warning-flags@ into @~/.ghci@ +-- config file. See also the +-- [migration guide](https://github.com/haskell/core-libraries-committee/blob/main/guides…. -- -- ==== __Examples__ -- @@ -240,6 +254,8 @@ init (x:xs) = init' x xs where init' _ [] = [] init' y (z:zs) = y : init' z zs +{-# WARNING in "x-partial" init "This is a partial function, it throws an error on empty lists. Use 'Data.List.unsnoc' instead. Consider refactoring to use \"Data.List.NonEmpty\"." #-} + -- | $\mathcal{O}(1)$. Test whether a list is empty. -- -- >>> null [] ===================================== libraries/ghc-internal/src/GHC/Internal/System/IO.hs ===================================== @@ -825,11 +825,12 @@ output_flags = std_flags where -- XXX bits copied from System.FilePath, since that's not available here - combine a b - | null b = a - | null a = b - | pathSeparator [last a] = a ++ b - | otherwise = a ++ [pathSeparatorChar] ++ b + combine a [] = a + combine a b = case unsnoc a of + Nothing -> b + Just (_, lastA) + | pathSeparator [lastA] -> a ++ b + | otherwise -> a ++ [pathSeparatorChar] ++ b tempCounter :: IORef Int tempCounter = unsafePerformIO $ newIORef 0 ===================================== libraries/ghc-internal/src/GHC/Internal/TH/Syntax.hs ===================================== @@ -54,6 +54,7 @@ import GHC.Internal.Base hiding (NonEmpty(..),Type, Module, sequence) import GHC.Internal.Data.Data hiding (Fixity(..)) import GHC.Internal.Data.NonEmpty (NonEmpty(..)) import GHC.Internal.Data.Traversable +import GHC.Internal.List (unsnoc) import GHC.Internal.Word import GHC.Internal.Generics (Generic) import GHC.Internal.IORef @@ -73,7 +74,7 @@ import GHC.Internal.Control.Monad.Fix import GHC.Internal.Control.Exception import GHC.Internal.Num import GHC.Internal.IO.Unsafe -import GHC.Internal.List (dropWhile, break, replicate, reverse, last) +import GHC.Internal.List (dropWhile, break, replicate, reverse) import GHC.Internal.MVar import GHC.Internal.IO.Exception import GHC.Internal.Unicode @@ -82,6 +83,16 @@ import qualified GHC.Internal.Types as Kind (Type) import GHC.Internal.ForeignSrcLang import GHC.Internal.LanguageExtensions +#ifdef BOOTSTRAP_TH +#if MIN_VERSION_base(4,19,0) +import Data.List (unsnoc) +#else +import Data.Maybe (maybe) +unsnoc :: [a] -> Maybe ([a], a) +unsnoc = foldr (\x -> Just . maybe ([], x) (\(~(a, b)) -> (x : a, b))) Nothing +#endif +#endif + ----------------------------------------------------- -- -- The Quasi class @@ -1296,7 +1307,7 @@ mkName str -- (i.e. non-empty, starts with capital, all alpha) is_rev_mod_name rev_mod_str | (compt, rest) <- break (== '.') rev_mod_str - , not (null compt), isUpper (last compt), all is_mod_char compt + , Just (_, lastCompt) <- unsnoc compt, isUpper lastCompt, all is_mod_char compt = case rest of [] -> True (_dot : rest') -> is_rev_mod_name rest' ===================================== libraries/template-haskell/vendored-filepath/System/FilePath/Posix.hs ===================================== @@ -104,7 +104,7 @@ module System.FilePath.Posix import Data.Char(toLower, toUpper, isAsciiLower, isAsciiUpper) import Data.Maybe(isJust) -import Data.List(stripPrefix, isSuffixOf) +import Data.List(stripPrefix, isSuffixOf, uncons, unsnoc) import System.Environment(getEnv) @@ -203,14 +203,20 @@ isExtSeparator = (== extSeparator) splitSearchPath :: String -> [FilePath] splitSearchPath = f where - f xs = case break isSearchPathSeparator xs of - (pre, [] ) -> g pre - (pre, _:post) -> g pre ++ f post - - g "" = ["." | isPosix] - g ('\"':x@(_:_)) | isWindows && last x == '\"' = [init x] - g x = [x] - + f xs = let (pre, post) = break isSearchPathSeparator xs + in case uncons post of + Nothing -> g pre + Just (_, t) -> g pre ++ f t + + g x = case uncons x of + Nothing -> ["." | isPosix] + Just (h, t) + | h == '"' + , Just{} <- uncons t -- >= 2 + , isWindows + , Just (i, l) <- unsnoc t + , l == '"' -> [i] + | otherwise -> [x] -- | Get a list of 'FilePath's in the $PATH variable. getSearchPath :: IO [FilePath] @@ -233,12 +239,17 @@ getSearchPath = fmap splitSearchPath (getEnv "PATH") -- > splitExtension "file/path.txt.bob.fred" == ("file/path.txt.bob",".fred") -- > splitExtension "file/path.txt/" == ("file/path.txt/","") splitExtension :: FilePath -> (String, String) -splitExtension x = case nameDot of - "" -> (x,"") - _ -> (dir ++ init nameDot, extSeparator : ext) - where - (dir,file) = splitFileName_ x - (nameDot,ext) = breakEnd isExtSeparator file +splitExtension x = case unsnoc nameDot of + -- Imagine x = "no-dots", then nameDot = "" + Nothing -> (x, mempty) + Just (initNameDot, _) + -- Imagine x = "\\shared.with.dots\no-dots" + | isWindows && null (dropDrive nameDot) -> (x, mempty) + -- Imagine x = "dir.with.dots/no-dots" + | any isPathSeparator ext -> (x, mempty) + | otherwise -> (initNameDot, extSeparator : ext) + where + (nameDot, ext) = breakEnd isExtSeparator x -- | Get the extension of a file, returns @\"\"@ for no extension, @.ext@ otherwise. -- @@ -594,9 +605,13 @@ replaceBaseName pth nam = combineAlways a (nam <.> ext) -- > hasTrailingPathSeparator "test" == False -- > hasTrailingPathSeparator "test/" == True hasTrailingPathSeparator :: FilePath -> Bool -hasTrailingPathSeparator "" = False -hasTrailingPathSeparator x = isPathSeparator (last x) +hasTrailingPathSeparator = isJust . getTrailingPathSeparator +getTrailingPathSeparator :: FilePath -> Maybe Char +getTrailingPathSeparator x = case unsnoc x of + Just (_, lastX) + | isPathSeparator lastX -> Just lastX + _ -> Nothing hasLeadingPathSeparator :: FilePath -> Bool hasLeadingPathSeparator "" = False @@ -619,12 +634,12 @@ addTrailingPathSeparator x = if hasTrailingPathSeparator x then x else x ++ [pat -- > Windows: dropTrailingPathSeparator "\\" == "\\" -- > Posix: not (hasTrailingPathSeparator (dropTrailingPathSeparator x)) || isDrive x dropTrailingPathSeparator :: FilePath -> FilePath -dropTrailingPathSeparator x = - if hasTrailingPathSeparator x && not (isDrive x) - then let x' = dropWhileEnd isPathSeparator x - in if null x' then [last x] else x' - else x - +dropTrailingPathSeparator x = case getTrailingPathSeparator x of + Just lastX + | not (isDrive x) + -> let x' = dropWhileEnd isPathSeparator x + in if null x' then [lastX] else x' + _ -> x -- | Get the directory name, move up one level. -- @@ -863,28 +878,37 @@ makeRelative root path -- > Posix: normalise "bob/fred/." == "bob/fred/" -- > Posix: normalise "//home" == "/home" normalise :: FilePath -> FilePath -normalise path = result ++ [pathSeparator | addPathSeparator] - where - (drv,pth) = splitDrive path - result = joinDrive' (normaliseDrive drv) (f pth) +normalise filepath = + result <> + (if addPathSeparator + then [pathSeparator] + else mempty) + where + (drv,pth) = splitDrive filepath + + result = joinDrive' (normaliseDrive drv) (f pth) - joinDrive' "" "" = "." - joinDrive' d p = joinDrive d p + joinDrive' d p + = if null d && null p + then "." + else joinDrive d p - addPathSeparator = isDirPath pth - && not (hasTrailingPathSeparator result) - && not (isRelativeDrive drv) + addPathSeparator = isDirPath pth + && not (hasTrailingPathSeparator result) + && not (isRelativeDrive drv) - isDirPath xs = hasTrailingPathSeparator xs - || not (null xs) && last xs == '.' && hasTrailingPathSeparator (init xs) + isDirPath xs = hasTrailingPathSeparator xs || case unsnoc xs of + Nothing -> False + Just (initXs, lastXs) -> lastXs == '.' && hasTrailingPathSeparator initXs - f = joinPath . dropDots . propSep . splitDirectories + f = joinPath . dropDots . propSep . splitDirectories - propSep (x:xs) | all isPathSeparator x = [pathSeparator] : xs - | otherwise = x : xs - propSep [] = [] + propSep (x:xs) + | all isPathSeparator x = [pathSeparator] : xs + | otherwise = x : xs + propSep [] = [] - dropDots = filter ("." /=) + dropDots = filter ("." /=) normaliseDrive :: FilePath -> FilePath normaliseDrive "" = "" ===================================== libraries/template-haskell/vendored-filepath/System/FilePath/Windows.hs ===================================== @@ -104,7 +104,7 @@ module System.FilePath.Windows import Data.Char(toLower, toUpper, isAsciiLower, isAsciiUpper) import Data.Maybe(isJust) -import Data.List(stripPrefix, isSuffixOf) +import Data.List(stripPrefix, isSuffixOf, uncons, unsnoc) import System.Environment(getEnv) @@ -203,14 +203,20 @@ isExtSeparator = (== extSeparator) splitSearchPath :: String -> [FilePath] splitSearchPath = f where - f xs = case break isSearchPathSeparator xs of - (pre, [] ) -> g pre - (pre, _:post) -> g pre ++ f post - - g "" = ["." | isPosix] - g ('\"':x@(_:_)) | isWindows && last x == '\"' = [init x] - g x = [x] - + f xs = let (pre, post) = break isSearchPathSeparator xs + in case uncons post of + Nothing -> g pre + Just (_, t) -> g pre ++ f t + + g x = case uncons x of + Nothing -> ["." | isPosix] + Just (h, t) + | h == '"' + , Just{} <- uncons t -- >= 2 + , isWindows + , Just (i, l) <- unsnoc t + , l == '"' -> [i] + | otherwise -> [x] -- | Get a list of 'FilePath's in the $PATH variable. getSearchPath :: IO [FilePath] @@ -233,12 +239,17 @@ getSearchPath = fmap splitSearchPath (getEnv "PATH") -- > splitExtension "file/path.txt.bob.fred" == ("file/path.txt.bob",".fred") -- > splitExtension "file/path.txt/" == ("file/path.txt/","") splitExtension :: FilePath -> (String, String) -splitExtension x = case nameDot of - "" -> (x,"") - _ -> (dir ++ init nameDot, extSeparator : ext) - where - (dir,file) = splitFileName_ x - (nameDot,ext) = breakEnd isExtSeparator file +splitExtension x = case unsnoc nameDot of + -- Imagine x = "no-dots", then nameDot = "" + Nothing -> (x, mempty) + Just (initNameDot, _) + -- Imagine x = "\\shared.with.dots\no-dots" + | isWindows && null (dropDrive nameDot) -> (x, mempty) + -- Imagine x = "dir.with.dots/no-dots" + | any isPathSeparator ext -> (x, mempty) + | otherwise -> (initNameDot, extSeparator : ext) + where + (nameDot, ext) = breakEnd isExtSeparator x -- | Get the extension of a file, returns @\"\"@ for no extension, @.ext@ otherwise. -- @@ -594,9 +605,13 @@ replaceBaseName pth nam = combineAlways a (nam <.> ext) -- > hasTrailingPathSeparator "test" == False -- > hasTrailingPathSeparator "test/" == True hasTrailingPathSeparator :: FilePath -> Bool -hasTrailingPathSeparator "" = False -hasTrailingPathSeparator x = isPathSeparator (last x) +hasTrailingPathSeparator = isJust . getTrailingPathSeparator +getTrailingPathSeparator :: FilePath -> Maybe Char +getTrailingPathSeparator x = case unsnoc x of + Just (_, lastX) + | isPathSeparator lastX -> Just lastX + _ -> Nothing hasLeadingPathSeparator :: FilePath -> Bool hasLeadingPathSeparator "" = False @@ -619,12 +634,12 @@ addTrailingPathSeparator x = if hasTrailingPathSeparator x then x else x ++ [pat -- > Windows: dropTrailingPathSeparator "\\" == "\\" -- > Posix: not (hasTrailingPathSeparator (dropTrailingPathSeparator x)) || isDrive x dropTrailingPathSeparator :: FilePath -> FilePath -dropTrailingPathSeparator x = - if hasTrailingPathSeparator x && not (isDrive x) - then let x' = dropWhileEnd isPathSeparator x - in if null x' then [last x] else x' - else x - +dropTrailingPathSeparator x = case getTrailingPathSeparator x of + Just lastX + | not (isDrive x) + -> let x' = dropWhileEnd isPathSeparator x + in if null x' then [lastX] else x' + _ -> x -- | Get the directory name, move up one level. -- @@ -863,28 +878,37 @@ makeRelative root path -- > Posix: normalise "bob/fred/." == "bob/fred/" -- > Posix: normalise "//home" == "/home" normalise :: FilePath -> FilePath -normalise path = result ++ [pathSeparator | addPathSeparator] - where - (drv,pth) = splitDrive path - result = joinDrive' (normaliseDrive drv) (f pth) +normalise filepath = + result <> + (if addPathSeparator + then [pathSeparator] + else mempty) + where + (drv,pth) = splitDrive filepath + + result = joinDrive' (normaliseDrive drv) (f pth) - joinDrive' "" "" = "." - joinDrive' d p = joinDrive d p + joinDrive' d p + = if null d && null p + then "." + else joinDrive d p - addPathSeparator = isDirPath pth - && not (hasTrailingPathSeparator result) - && not (isRelativeDrive drv) + addPathSeparator = isDirPath pth + && not (hasTrailingPathSeparator result) + && not (isRelativeDrive drv) - isDirPath xs = hasTrailingPathSeparator xs - || not (null xs) && last xs == '.' && hasTrailingPathSeparator (init xs) + isDirPath xs = hasTrailingPathSeparator xs || case unsnoc xs of + Nothing -> False + Just (initXs, lastXs) -> lastXs == '.' && hasTrailingPathSeparator initXs - f = joinPath . dropDots . propSep . splitDirectories + f = joinPath . dropDots . propSep . splitDirectories - propSep (x:xs) | all isPathSeparator x = [pathSeparator] : xs - | otherwise = x : xs - propSep [] = [] + propSep (x:xs) + | all isPathSeparator x = [pathSeparator] : xs + | otherwise = x : xs + propSep [] = [] - dropDots = filter ("." /=) + dropDots = filter ("." /=) normaliseDrive :: FilePath -> FilePath normaliseDrive "" = "" ===================================== testsuite/tests/driver/j-space/jspace.hs ===================================== @@ -7,7 +7,7 @@ import System.Environment import GHC.Driver.Env.Types import GHC.Profiling import System.Mem -import Data.List (isPrefixOf) +import Data.List (isPrefixOf, unsnoc) import Control.Monad import System.Exit import GHC.Platform @@ -41,7 +41,9 @@ initGhcM xs = do requestHeapCensus performGC [ys] <- filter (isPrefixOf (ghcUnitId <> ":GHC.Unit.Module.ModDetails.ModDetails")) . lines <$> readFile "jspace.hp" - let (n :: Int) = read (last (words ys)) + let (n :: Int) = case unsnoc (words ys) of + Nothing -> error "input is unexpectedly empty" + Just (_, lst) -> read lst -- The output should be 50 * 8 * word_size (i.e. 3600, or 1600 on 32-bit architectures): -- the test contains DEPTH + WIDTH + 2 = 50 modules J, H_0, .., H_DEPTH, W_1, .., W_WIDTH, -- and each ModDetails contains 1 (info table) + 8 word-sized fields. ===================================== testsuite/tests/rts/KeepCafsBase.hs ===================================== @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -Wno-x-partial #-} + module KeepCafsBase (x) where x :: Int ===================================== utils/check-exact/Utils.hs ===================================== @@ -37,7 +37,7 @@ import GHC.Base (NonEmpty(..)) import GHC.Parser.Lexer (allocateComments) import Data.Data hiding ( Fixity ) -import Data.List (sortBy, partition) +import Data.List (sortBy, partition, unsnoc) import qualified Data.Map.Strict as Map import Debug.Trace @@ -734,8 +734,9 @@ ghead info [] = error $ "ghead "++info++" []" ghead _info (h:_) = h glast :: String -> [a] -> a -glast info [] = error $ "glast " ++ info ++ " []" -glast _info h = last h +glast info xs = case unsnoc xs of + Nothing -> error $ "glast " ++ info ++ " []" + Just (_, lst) -> lst gtail :: String -> [a] -> [a] gtail info [] = error $ "gtail " ++ info ++ " []" ===================================== utils/haddock/haddock-api/src/Haddock/Backends/Xhtml.hs ===================================== @@ -755,7 +755,7 @@ ppHtmlIndex divAlphabet << unordList ( map (\str -> anchor ! [href (subIndexHtmlFile str)] << str) $ - [ [c] | c <- initialChars, any ((== c) . toUpper . head . fst) index + [ [c] | c <- initialChars, any (maybe False ((== c) . toUpper . fst) . List.uncons . fst) index ] ++ [merged_name] ) @@ -772,7 +772,7 @@ ppHtmlIndex writeUtf8File (joinPath [odir, subIndexHtmlFile [c]]) (renderToString debug html) where html = indexPage True (Just c) index_part - index_part = [(n, stuff) | (n, stuff) <- this_ix, toUpper (head n) == c] + index_part = [(n, stuff) | (n@(headN : _), stuff) <- this_ix, toUpper headN == c] index :: [(String, Map GHC.Name [(Module, Bool)])] index = sortBy cmp (Map.toAscList full_index) ===================================== utils/haddock/haddock-library/src/Documentation/Haddock/Parser.hs ===================================== @@ -30,7 +30,7 @@ import Control.Arrow (first) import Control.Monad import Data.Char (chr, isAlpha, isSpace, isUpper) import Data.Functor (($>)) -import Data.List (elemIndex, intercalate, intersperse, unfoldr) +import Data.List (elemIndex, intercalate, intersperse, unfoldr, unsnoc) import Data.Maybe (fromMaybe, mapMaybe) import Data.Monoid import qualified Data.Set as Set @@ -870,10 +870,10 @@ codeblock = DocCodeBlock . parseParagraph . dropSpaces <$> ("@" *> skipHorizontalSpace *> "\n" *> block' <* "@") where - dropSpaces xs = - case splitByNl xs of - [] -> xs - ys -> case T.uncons (last ys) of + dropSpaces xs = let ys = splitByNl xs in + case unsnoc ys of + Nothing -> xs + Just (_, lastYs) -> case T.uncons lastYs of Just (' ', _) -> case mapM dropSpace ys of Nothing -> xs Just zs -> T.intercalate "\n" zs View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8f16552d7617e1f41b5da85b8d2ed2a… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8f16552d7617e1f41b5da85b8d2ed2a… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] (Applicative docs typo: missing "one")
by Marge Bot (＠marge-bot) 11 Jul '25

11 Jul '25

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 2b4db9ba by Pi Delport at 2025-07-11T16:40:52-04:00 (Applicative docs typo: missing "one") - - - - - 1 changed file: - libraries/ghc-internal/src/GHC/Internal/Base.hs Changes: ===================================== libraries/ghc-internal/src/GHC/Internal/Base.hs ===================================== @@ -1047,7 +1047,7 @@ class Functor f where -- * sequence computations and combine their results ('<*>' and 'liftA2'). -- -- A minimal complete definition must include implementations of 'pure' --- and of either '<*>' or 'liftA2'. If it defines both, then they must behave +-- and one of either '<*>' or 'liftA2'. If it defines both, then they must behave -- the same as their default definitions: -- -- @('<*>') = 'liftA2' 'id'@ View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2b4db9bacf4a54552179154d067efc5… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2b4db9bacf4a54552179154d067efc5… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] 2 commits: Fix documentation for HEAP_PROF_SAMPLE_STRING
by Marge Bot (＠marge-bot) 11 Jul '25

11 Jul '25

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 01d3154e by Wen Kokke at 2025-07-10T17:06:36+01:00 Fix documentation for HEAP_PROF_SAMPLE_STRING - - - - - ac259c48 by Wen Kokke at 2025-07-10T17:06:38+01:00 Fix documentation for HEAP_PROF_SAMPLE_COST_CENTRE - - - - - 1 changed file: - docs/users_guide/eventlog-formats.rst Changes: ===================================== docs/users_guide/eventlog-formats.rst ===================================== @@ -779,9 +779,9 @@ the total time spent profiling. Cost-centre break-down ^^^^^^^^^^^^^^^^^^^^^^ -A variable-length packet encoding a heap profile sample broken down by, - * cost-centre (:rts-flag:`-hc`) - +A variable-length packet encoding a heap profile sample. +This event is only emitted when the heap profile type is set to :rts-flag:`-hc` or :rts-flag:`-hb`. +Otherwise, a :event-type:`HEAP_PROF_SAMPLE_STRING` event is emitted instead. .. event-type:: HEAP_PROF_SAMPLE_COST_CENTRE @@ -796,11 +796,19 @@ A variable-length packet encoding a heap profile sample broken down by, String break-down ^^^^^^^^^^^^^^^^^ -A variable-length event encoding a heap sample broken down by, +A variable-length event encoding a heap sample. +The content of the sample label varies depending on the heap profile type: + + * :rts-flag:`-hT` The sample label contains a closure type, e.g., ``"ghc-bignum:GHC.Num.Integer.IS"``. + * :rts-flag:`-hm` The sample label contains a module name, e.g., ``"GHC.Num.Integer"``. + * :rts-flag:`-hd` The sample label contains a closure description, e.g., ``"IS"``. + * :rts-flag:`-hy` The sample label contains a type description, e.g., ``"Integer"``. + * :rts-flag:`-he` The sample label contains a stringified era, e.g., ``"1"``. + * :rts-flag:`-hr` The sample label contains a retainer set description, e.g., ``"(184)$stoIntegralSized1"``. + * :rts-flag:`-hi` The sample label contains a stringified pointer, e.g., ``"0x1008b7588"``, + which can be matched to an info table description emitted by the :event-type:`IPE` event. - * type description (:rts-flag:`-hy`) - * closure description (:rts-flag:`-hd`) - * module (:rts-flag:`-hm`) +If the heap profile type is set to :rts-flag:`-hc` or :rts-flag:`-hb`, a :event-type:`HEAP_PROF_SAMPLE_COST_CENTRE` event is emitted instead. .. event-type:: HEAP_PROF_SAMPLE_STRING @@ -808,7 +816,7 @@ A variable-length event encoding a heap sample broken down by, :length: variable :field Word8: profile ID :field Word64: heap residency in bytes - :field String: type or closure description, or module name + :field String: sample label .. _time-profiler-events: View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ef03d8b8851a1cace5f792fe5a91b6… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ef03d8b8851a1cace5f792fe5a91b6… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/romes/24212] Fix windows failure
by Rodrigo Mesquita (＠alt-romes) 11 Jul '25

11 Jul '25

Rodrigo Mesquita pushed to branch wip/romes/24212 at Glasgow Haskell Compiler / GHC Commits: d585fb63 by Rodrigo Mesquita at 2025-07-11T19:54:15+01:00 Fix windows failure - - - - - 1 changed file: - testsuite/tests/ghc-api/T20757.hs Changes: ===================================== testsuite/tests/ghc-api/T20757.hs ===================================== @@ -3,4 +3,4 @@ module Main where import GHC.SysTools.BaseDir main :: IO () -main = findToolDir False "/" >>= print +main = findToolDir "/" >>= print View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d585fb63786fb4aec7bb900855e80ad… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d585fb63786fb4aec7bb900855e80ad… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/romes/24212] .gitkeep that
by Rodrigo Mesquita (＠alt-romes) 11 Jul '25

11 Jul '25

Rodrigo Mesquita pushed to branch wip/romes/24212 at Glasgow Haskell Compiler / GHC Commits: f8f86d99 by Rodrigo Mesquita at 2025-07-11T19:49:40+01:00 .gitkeep that - - - - - 1 changed file: - + testsuite/tests/ghc-api/settings-escape/ghc-install-folder/lib with spaces/targets/.gitkeep Changes: ===================================== testsuite/tests/ghc-api/settings-escape/ghc-install-folder/lib with spaces/targets/.gitkeep ===================================== View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f8f86d9954e9d41d0518bc90457e92c… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f8f86d9954e9d41d0518bc90457e92c… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/romes/step-out-11] Working on it
by Rodrigo Mesquita (＠alt-romes) 11 Jul '25

11 Jul '25

Rodrigo Mesquita pushed to branch wip/romes/step-out-11 at Glasgow Haskell Compiler / GHC Commits: ef667857 by Rodrigo Mesquita at 2025-07-11T19:46:30+01:00 Working on it - - - - - 7 changed files: - compiler/GHC/ByteCode/Breakpoints.hs - compiler/GHC/CoreToIface.hs - compiler/GHC/Linker/Loader.hs - compiler/GHC/Runtime/Debugger/Breakpoints.hs - compiler/GHC/Runtime/Eval.hs - compiler/GHC/StgToByteCode.hs - ghc/GHCi/UI.hs Changes: ===================================== compiler/GHC/ByteCode/Breakpoints.hs ===================================== @@ -1,4 +1,5 @@ {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DerivingStrategies #-} -- | Breakpoint information constructed during ByteCode generation. -- @@ -15,6 +16,7 @@ module GHC.ByteCode.Breakpoints -- ** Internal breakpoint identifier , InternalBreakpointId(..), BreakInfoIndex + , InternalBreakLoc(..) -- * Operations @@ -23,7 +25,7 @@ module GHC.ByteCode.Breakpoints -- ** Source-level information operations , getBreakLoc, getBreakVars, getBreakDecls, getBreakCCS - , getBreakSourceId + , getBreakSourceId, getBreakSourceMod -- * Utils , seqInternalModBreaks @@ -165,7 +167,7 @@ data CgBreakInfo { cgb_tyvars :: ![IfaceTvBndr] -- ^ Type variables in scope at the breakpoint , cgb_vars :: ![Maybe (IfaceIdBndr, Word)] , cgb_resty :: !IfaceType - , cgb_tick_id :: !BreakpointId + , cgb_tick_id :: !(Either InternalBreakLoc BreakpointId) -- ^ This field records the original breakpoint tick identifier for this -- internal breakpoint info. It is used to convert a breakpoint -- *occurrence* index ('InternalBreakpointId') into a *definition* index @@ -173,9 +175,19 @@ data CgBreakInfo -- -- The modules of breakpoint occurrence and breakpoint definition are not -- necessarily the same: See Note [Breakpoint identifiers]. + -- + -- If there is no original tick identifier (that is, the breakpoint was + -- created during code generation), instead refer directly to the SrcSpan + -- we want to use for it. See Note [Internal Breakpoint Locations] } -- See Note [Syncing breakpoint info] in GHC.Runtime.Eval +-- | Breakpoints created during code generation don't have a source-level tick +-- location. Instead, we come up with one ourselves. +-- See Note [Internal Breakpoint Locations] +newtype InternalBreakLoc = InternalBreakLoc SrcSpan + deriving newtype (Eq, Show, NFData, Outputable) + -- | Get an internal breakpoint info by 'InternalBreakpointId' getInternalBreak :: InternalBreakpointId -> InternalModBreaks -> CgBreakInfo getInternalBreak (InternalBreakpointId mod ix) imbs = @@ -196,27 +208,36 @@ assert_modules_match ibi_mod imbs_mod = -- | Get the source module and tick index for this breakpoint -- (as opposed to the module where this breakpoint occurs, which is in 'InternalBreakpointId') -getBreakSourceId :: InternalBreakpointId -> InternalModBreaks -> BreakpointId +getBreakSourceId :: InternalBreakpointId -> InternalModBreaks -> Either InternalBreakLoc BreakpointId getBreakSourceId (InternalBreakpointId ibi_mod ibi_ix) imbs = assert_modules_match ibi_mod (imodBreaks_module imbs) $ let cgb = imodBreaks_breakInfo imbs IM.! ibi_ix in cgb_tick_id cgb +-- | Get the source module for this breakpoint (where the breakpoint is defined) +getBreakSourceMod :: InternalBreakpointId -> InternalModBreaks -> Module +getBreakSourceMod (InternalBreakpointId ibi_mod ibi_ix) imbs = + assert_modules_match ibi_mod (imodBreaks_module imbs) $ + let cgb = imodBreaks_breakInfo imbs IM.! ibi_ix + in case cgb_tick_id cgb of + Left InternalBreakLoc{} -> imodBreaks_module imbs + Right BreakpointId{bi_tick_mod} -> bi_tick_mod + -- | Get the source span for this breakpoint getBreakLoc :: (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO SrcSpan -getBreakLoc = getBreakXXX modBreaks_locs +getBreakLoc = getBreakXXX modBreaks_locs (\(InternalBreakLoc x) -> x) -- | Get the vars for this breakpoint getBreakVars :: (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO [OccName] -getBreakVars = getBreakXXX modBreaks_vars +getBreakVars = getBreakXXX modBreaks_vars (const []) -- | Get the decls for this breakpoint getBreakDecls :: (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO [String] -getBreakDecls = getBreakXXX modBreaks_decls +getBreakDecls = getBreakXXX modBreaks_decls (const []) -- | Get the decls for this breakpoint -getBreakCCS :: (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO (String, String) -getBreakCCS = getBreakXXX modBreaks_ccs +getBreakCCS :: (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO (Maybe (String, String)) +getBreakCCS = getBreakXXX (fmap Just . modBreaks_ccs) (const Nothing) -- | Internal utility to access a ModBreaks field at a particular breakpoint index -- @@ -228,14 +249,17 @@ getBreakCCS = getBreakXXX modBreaks_ccs -- 'ModBreaks'. When the tick module is different, we need to look up the -- 'ModBreaks' in the HUG for that other module. -- +-- When there is no tick module (the breakpoint was generated at codegen), use +-- the function on internal mod breaks. +-- -- To avoid cyclic dependencies, we instead receive a function that looks up -- the 'ModBreaks' given a 'Module' -getBreakXXX :: (ModBreaks -> Array BreakTickIndex a) -> (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO a -getBreakXXX view lookupModule (InternalBreakpointId ibi_mod ibi_ix) imbs = +getBreakXXX :: (ModBreaks -> Array BreakTickIndex a) -> (InternalBreakLoc -> a) -> (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO a +getBreakXXX view viewInternal lookupModule (InternalBreakpointId ibi_mod ibi_ix) imbs = assert_modules_match ibi_mod (imodBreaks_module imbs) $ do let cgb = imodBreaks_breakInfo imbs IM.! ibi_ix case cgb_tick_id cgb of - BreakpointId{bi_tick_mod, bi_tick_index} + Right BreakpointId{bi_tick_mod, bi_tick_index} | bi_tick_mod == ibi_mod -> do let these_mbs = imodBreaks_modBreaks imbs @@ -244,6 +268,8 @@ getBreakXXX view lookupModule (InternalBreakpointId ibi_mod ibi_ix) imbs = -> do other_mbs <- lookupModule bi_tick_mod return $ view other_mbs ! bi_tick_index + Left l -> + return $ viewInternal l -------------------------------------------------------------------------------- -- Instances ===================================== compiler/GHC/CoreToIface.hs ===================================== @@ -50,8 +50,6 @@ import GHC.Prelude import GHC.StgToCmm.Types -import GHC.ByteCode.Types - import GHC.Core import GHC.Core.TyCon hiding ( pprPromotionQuote ) import GHC.Core.Coercion.Axiom ===================================== compiler/GHC/Linker/Loader.hs ===================================== @@ -58,6 +58,7 @@ import GHCi.RemoteTypes import GHC.Iface.Load import GHCi.Message (ConInfoTable(..), LoadedDLL) +import GHC.ByteCode.Breakpoints import GHC.ByteCode.Linker import GHC.ByteCode.Asm import GHC.ByteCode.Types @@ -1711,8 +1712,10 @@ allocateCCS interp ce mbss let count = 1 + (maybe 0 fst $ IM.lookupMax imodBreaks_breakInfo) let ccs = IM.map (\info -> - fromMaybe (toRemotePtr nullPtr) - (M.lookup (cgb_tick_id info) ccss) + case cgb_tick_id info of + Right bi -> fromMaybe (toRemotePtr nullPtr) + (M.lookup bi ccss) + Left InternalBreakLoc{} -> toRemotePtr nullPtr ) imodBreaks_breakInfo assertPpr (count == length ccs) ===================================== compiler/GHC/Runtime/Debugger/Breakpoints.hs ===================================== @@ -253,8 +253,11 @@ mkBreakpointOccurrences = do let imod = modBreaks_module $ imodBreaks_modBreaks ibrks IntMap.foldrWithKey (\info_ix cgi bmp -> do let ibi = InternalBreakpointId imod info_ix - let BreakpointId tick_mod tick_ix = cgb_tick_id cgi - extendModuleEnvWith (IntMap.unionWith (S.<>)) bmp tick_mod (IntMap.singleton tick_ix [ibi]) + case cgb_tick_id cgi of + Right (BreakpointId tick_mod tick_ix) + -> extendModuleEnvWith (IntMap.unionWith (S.<>)) bmp tick_mod (IntMap.singleton tick_ix [ibi]) + Left _ + -> bmp ) bmp0 (imodBreaks_breakInfo ibrks) -------------------------------------------------------------------------------- @@ -287,7 +290,7 @@ getCurrentBreakModule = do Nothing -> pure Nothing Just ibi -> do brks <- readIModBreaks hug ibi - return $ Just $ bi_tick_mod $ getBreakSourceId ibi brks + return $ Just $ getBreakSourceMod ibi brks ix -> Just <$> getHistoryModule hug (resumeHistory r !! (ix-1)) ===================================== compiler/GHC/Runtime/Eval.hs ===================================== @@ -151,7 +151,7 @@ getHistoryModule :: HUG.HomeUnitGraph -> History -> IO Module getHistoryModule hug hist = do let ibi = historyBreakpointId hist brks <- readIModBreaks hug ibi - return $ bi_tick_mod $ getBreakSourceId ibi brks + return $ getBreakSourceMod ibi brks getHistorySpan :: HUG.HomeUnitGraph -> History -> IO SrcSpan getHistorySpan hug hist = do ===================================== compiler/GHC/StgToByteCode.hs ===================================== @@ -63,7 +63,7 @@ import GHC.StgToCmm.Closure ( NonVoid(..), fromNonVoid, idPrimRepU, assertNonVoidIds, assertNonVoidStgArgs ) import GHC.StgToCmm.Layout import GHC.Runtime.Heap.Layout hiding (WordOff, ByteOff, wordsToBytes) -import GHC.Runtime.Interpreter ( interpreterProfiled ) +import GHC.Runtime.Interpreter ( interpreterProfiled, readIModModBreaks ) import GHC.Data.Bitmap import GHC.Data.FlatBag as FlatBag import GHC.Data.OrdList @@ -99,6 +99,7 @@ import GHC.CoreToIface import Control.Monad.IO.Class import Control.Monad.Trans.Reader (ReaderT(..)) import Control.Monad.Trans.State (StateT(..)) +import Data.Array ((!)) -- ----------------------------------------------------------------------------- -- Generating byte code for a complete module @@ -393,26 +394,30 @@ schemeR_wrk fvs nm original_body (args, body) -- | Introduce break instructions for ticked expressions. -- If no breakpoint information is available, the instruction is omitted. schemeER_wrk :: StackDepth -> BCEnv -> CgStgExpr -> BcM BCInstrList -schemeER_wrk d p (StgTick (Breakpoint tick_ty tick_id fvs) rhs) = do - code <- schemeE d 0 p rhs - mb_current_mod_breaks <- getCurrentModBreaks - case mb_current_mod_breaks of - -- if we're not generating ModBreaks for this module for some reason, we - -- can't store breakpoint occurrence information. - Nothing -> pure code - Just current_mod_breaks -> do - platform <- profilePlatform <$> getProfile - let idOffSets = getVarOffSets platform d p fvs - ty_vars = tyCoVarsOfTypesWellScoped (tick_ty:map idType fvs) - toWord :: Maybe (Id, WordOff) -> Maybe (Id, Word) - toWord = fmap (\(i, wo) -> (i, fromIntegral wo)) - breakInfo = dehydrateCgBreakInfo ty_vars (map toWord idOffSets) tick_ty tick_id - - let info_mod = modBreaks_module current_mod_breaks - infox <- newBreakInfo breakInfo +schemeER_wrk d p (StgTick bp@(Breakpoint tick_ty tick_id fvs) rhs) = do + platform <- profilePlatform <$> getProfile + + -- When we find a tick surrounding a case expression we introduce a new BRK_FUN + -- instruction at the start of the case *continuation*, in addition to the + -- usual BRK_FUN surrounding the StgCase) + -- See Note [TODO] + code <- case rhs of + StgCase scrut bndr _ alts + -> doCase d 0 p (Just bp) scrut bndr alts + _ -> schemeE d 0 p rhs + + let idOffSets = getVarOffSets platform d p fvs + ty_vars = tyCoVarsOfTypesWellScoped (tick_ty:map idType fvs) + toWord :: Maybe (Id, WordOff) -> Maybe (Id, Word) + toWord = fmap (\(i, wo) -> (i, fromIntegral wo)) + breakInfo = dehydrateCgBreakInfo ty_vars (map toWord idOffSets) tick_ty (Right tick_id) + + mibi <- newBreakInfo breakInfo + + return $ case mibi of + Nothing -> code + Just ibi -> BRK_FUN ibi `consOL` code - let breakInstr = BRK_FUN (InternalBreakpointId info_mod infox) - return $ breakInstr `consOL` code schemeER_wrk d p rhs = schemeE d 0 p rhs getVarOffSets :: Platform -> StackDepth -> BCEnv -> [Id] -> [Maybe (Id, WordOff)] @@ -614,7 +619,7 @@ schemeE d s p (StgTick _ rhs) = schemeE d s p rhs schemeE d s p (StgCase scrut _ _ []) = schemeE d s p scrut schemeE d s p (StgCase scrut bndr _ alts) - = doCase d s p scrut bndr alts + = doCase d s p Nothing scrut bndr alts {- @@ -1106,11 +1111,15 @@ doCase :: StackDepth -> Sequel -> BCEnv + -> Maybe StgTickish + -- ^ The breakpoint surrounding the full case expression, if any (only + -- source-level cases get breakpoint ticks, and those are the only we care + -- about). See Note [TODO] -> CgStgExpr -> Id -> [CgStgAlt] -> BcM BCInstrList -doCase d s p scrut bndr alts +doCase d s p m_bid scrut bndr alts = do profile <- getProfile hsc_env <- getHscEnv @@ -1327,11 +1336,28 @@ doCase d s p scrut bndr alts let alt_final1 | ubx_tuple_frame = SLIDE 0 2 `consOL` alt_final0 | otherwise = alt_final0 - alt_final - | gopt Opt_InsertBreakpoints (hsc_dflags hsc_env) - -- See Note [Debugger: BRK_ALTS] - = BRK_ALTS False `consOL` alt_final1 - | otherwise = alt_final1 + + alt_final <- case m_bid of + Just (Breakpoint tick_ty tick_id fvs) + | gopt Opt_InsertBreakpoints (hsc_dflags hsc_env) + -- Construct an internal breakpoint to put at the start of this case + -- continuation BCO. + -- See Note [TODO] + -> do + internal_tick_loc <- makeCaseInternalBreakLoc tick_id + + -- same fvs available in the case expression are available in the case continuation + let idOffSets = getVarOffSets platform d p fvs + ty_vars = tyCoVarsOfTypesWellScoped (tick_ty:map idType fvs) + toWord :: Maybe (Id, WordOff) -> Maybe (Id, Word) + toWord = fmap (\(i, wo) -> (i, fromIntegral wo)) + breakInfo = dehydrateCgBreakInfo ty_vars (map toWord idOffSets) tick_ty (Left internal_tick_loc) + + mibi <- newBreakInfo breakInfo + return $ case mibi of + Nothing -> alt_final1 + Just ibi -> BRK_FUN ibi `consOL` alt_final1 + _ -> pure alt_final1 add_bco_name <- shouldAddBcoName let @@ -1351,6 +1377,24 @@ doCase d s p scrut bndr alts _ -> panic "schemeE(StgCase).push_alts" in return (PUSH_ALTS alt_bco scrut_rep `consOL` scrut_code) +makeCaseInternalBreakLoc :: BreakpointId -> BcM InternalBreakLoc +makeCaseInternalBreakLoc bid = do + hug <- hsc_HUG <$> getHscEnv + curr_mod <- getCurrentModule + mb_mod_brks <- getCurrentModBreaks + + -- TODO: Subtract the scrutinee loc from the case loc to get continuation loc + InternalBreakLoc <$> case bid of + BreakpointId{bi_tick_mod, bi_tick_index} + | bi_tick_mod == curr_mod + , Just these_mbs <- mb_mod_brks + -> do + return $ modBreaks_locs these_mbs ! bi_tick_index + | otherwise + -> do + other_mbs <- liftIO $ readIModModBreaks hug bi_tick_mod + return $ modBreaks_locs other_mbs ! bi_tick_index + {- Note [Debugger: BRK_ALTS] ~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2667,14 +2711,19 @@ getLabelsBc n = BcM $ \_ st -> let ctr = nextlabel st in return (coerce [ctr .. ctr+n-1], st{nextlabel = ctr+n}) -newBreakInfo :: CgBreakInfo -> BcM Int -newBreakInfo info = BcM $ \_ st -> - let ix = breakInfoIdx st - st' = st - { breakInfo = IntMap.insert ix info (breakInfo st) - , breakInfoIdx = ix + 1 - } - in return (ix, st') +newBreakInfo :: CgBreakInfo -> BcM (Maybe InternalBreakpointId) +newBreakInfo info = BcM $ \env st -> do + -- if we're not generating ModBreaks for this module for some reason, we + -- can't store breakpoint occurrence information. + case modBreaks env of + Nothing -> pure (Nothing, st) + Just modBreaks -> do + let ix = breakInfoIdx st + st' = st + { breakInfo = IntMap.insert ix info (breakInfo st) + , breakInfoIdx = ix + 1 + } + return (Just $ InternalBreakpointId (modBreaks_module modBreaks) ix, st') getCurrentModule :: BcM Module getCurrentModule = BcM $ \env st -> return (bcm_module env, st) @@ -2687,7 +2736,7 @@ tickFS = fsLit "ticked" -- Dehydrating CgBreakInfo -dehydrateCgBreakInfo :: [TyVar] -> [Maybe (Id, Word)] -> Type -> BreakpointId -> CgBreakInfo +dehydrateCgBreakInfo :: [TyVar] -> [Maybe (Id, Word)] -> Type -> Either InternalBreakLoc BreakpointId -> CgBreakInfo dehydrateCgBreakInfo ty_vars idOffSets tick_ty bid = CgBreakInfo { cgb_tyvars = map toIfaceTvBndr ty_vars ===================================== ghc/GHCi/UI.hs ===================================== @@ -45,7 +45,7 @@ import GHC.Runtime.Eval (mkTopLevEnv) import GHC.Runtime.Eval.Utils -- The GHC interface -import GHC.ByteCode.Breakpoints (imodBreaks_modBreaks, InternalBreakpointId(..), getBreakSourceId) +import GHC.ByteCode.Breakpoints (imodBreaks_modBreaks, InternalBreakpointId(..), getBreakSourceId, getBreakSourceMod) import GHC.Runtime.Interpreter import GHCi.RemoteTypes import GHCi.BreakArray( breakOn, breakOff ) @@ -1621,7 +1621,7 @@ toBreakIdAndLocation (Just inf) = do brks <- liftIO $ readIModBreaks hug inf let bi = getBreakSourceId inf brks return $ listToMaybe [ id_loc | id_loc@(_,loc) <- IntMap.assocs (breaks st), - breakId loc == bi ] + Right (breakId loc) == bi ] printStoppedAtBreakInfo :: GHC.GhcMonad m => Resume -> [Name] -> m () printStoppedAtBreakInfo res names = do @@ -3825,7 +3825,7 @@ pprStopped res = do hug <- hsc_HUG <$> GHC.getSession brks <- liftIO $ readIModBreaks hug ibi return $ Just $ moduleName $ - bi_tick_mod $ getBreakSourceId ibi brks + getBreakSourceMod ibi brks return $ text "Stopped in" <+> ((case mb_mod_name of View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ef66785749d8714122e529ac148bea7… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ef66785749d8714122e529ac148bea7… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/romes/step-out-11] Working on it
by Rodrigo Mesquita (＠alt-romes) 11 Jul '25

11 Jul '25

Rodrigo Mesquita pushed to branch wip/romes/step-out-11 at Glasgow Haskell Compiler / GHC Commits: 49b04226 by Rodrigo Mesquita at 2025-07-11T19:42:00+01:00 Working on it - - - - - 7 changed files: - compiler/GHC/ByteCode/Breakpoints.hs - compiler/GHC/CoreToIface.hs - compiler/GHC/Linker/Loader.hs - compiler/GHC/Runtime/Debugger/Breakpoints.hs - compiler/GHC/Runtime/Eval.hs - compiler/GHC/StgToByteCode.hs - ghc/GHCi/UI.hs Changes: ===================================== compiler/GHC/ByteCode/Breakpoints.hs ===================================== @@ -1,4 +1,5 @@ {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DerivingStrategies #-} -- | Breakpoint information constructed during ByteCode generation. -- @@ -15,6 +16,7 @@ module GHC.ByteCode.Breakpoints -- ** Internal breakpoint identifier , InternalBreakpointId(..), BreakInfoIndex + , InternalBreakLoc(..) -- * Operations @@ -23,7 +25,7 @@ module GHC.ByteCode.Breakpoints -- ** Source-level information operations , getBreakLoc, getBreakVars, getBreakDecls, getBreakCCS - , getBreakSourceId + , getBreakSourceId, getBreakSourceMod -- * Utils , seqInternalModBreaks @@ -165,7 +167,7 @@ data CgBreakInfo { cgb_tyvars :: ![IfaceTvBndr] -- ^ Type variables in scope at the breakpoint , cgb_vars :: ![Maybe (IfaceIdBndr, Word)] , cgb_resty :: !IfaceType - , cgb_tick_id :: !BreakpointId + , cgb_tick_id :: !(Either InternalBreakLoc BreakpointId) -- ^ This field records the original breakpoint tick identifier for this -- internal breakpoint info. It is used to convert a breakpoint -- *occurrence* index ('InternalBreakpointId') into a *definition* index @@ -173,9 +175,19 @@ data CgBreakInfo -- -- The modules of breakpoint occurrence and breakpoint definition are not -- necessarily the same: See Note [Breakpoint identifiers]. + -- + -- If there is no original tick identifier (that is, the breakpoint was + -- created during code generation), instead refer directly to the SrcSpan + -- we want to use for it. See Note [Internal Breakpoint Locations] } -- See Note [Syncing breakpoint info] in GHC.Runtime.Eval +-- | Breakpoints created during code generation don't have a source-level tick +-- location. Instead, we come up with one ourselves. +-- See Note [Internal Breakpoint Locations] +newtype InternalBreakLoc = InternalBreakLoc SrcSpan + deriving newtype (Eq, Show, NFData, Outputable) + -- | Get an internal breakpoint info by 'InternalBreakpointId' getInternalBreak :: InternalBreakpointId -> InternalModBreaks -> CgBreakInfo getInternalBreak (InternalBreakpointId mod ix) imbs = @@ -196,27 +208,36 @@ assert_modules_match ibi_mod imbs_mod = -- | Get the source module and tick index for this breakpoint -- (as opposed to the module where this breakpoint occurs, which is in 'InternalBreakpointId') -getBreakSourceId :: InternalBreakpointId -> InternalModBreaks -> BreakpointId +getBreakSourceId :: InternalBreakpointId -> InternalModBreaks -> Either InternalBreakLoc BreakpointId getBreakSourceId (InternalBreakpointId ibi_mod ibi_ix) imbs = assert_modules_match ibi_mod (imodBreaks_module imbs) $ let cgb = imodBreaks_breakInfo imbs IM.! ibi_ix in cgb_tick_id cgb +-- | Get the source module for this breakpoint (where the breakpoint is defined) +getBreakSourceMod :: InternalBreakpointId -> InternalModBreaks -> Module +getBreakSourceMod (InternalBreakpointId ibi_mod ibi_ix) imbs = + assert_modules_match ibi_mod (imodBreaks_module imbs) $ + let cgb = imodBreaks_breakInfo imbs IM.! ibi_ix + in case cgb_tick_id cgb of + Left InternalBreakLoc{} -> imodBreaks_module imbs + Right BreakpointId{bi_tick_mod} -> bi_tick_mod + -- | Get the source span for this breakpoint getBreakLoc :: (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO SrcSpan -getBreakLoc = getBreakXXX modBreaks_locs +getBreakLoc = getBreakXXX modBreaks_locs (\(InternalBreakLoc x) -> x) -- | Get the vars for this breakpoint getBreakVars :: (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO [OccName] -getBreakVars = getBreakXXX modBreaks_vars +getBreakVars = getBreakXXX modBreaks_vars (const []) -- | Get the decls for this breakpoint getBreakDecls :: (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO [String] -getBreakDecls = getBreakXXX modBreaks_decls +getBreakDecls = getBreakXXX modBreaks_decls (const []) -- | Get the decls for this breakpoint -getBreakCCS :: (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO (String, String) -getBreakCCS = getBreakXXX modBreaks_ccs +getBreakCCS :: (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO (Maybe (String, String)) +getBreakCCS = getBreakXXX (fmap Just . modBreaks_ccs) (const Nothing) -- | Internal utility to access a ModBreaks field at a particular breakpoint index -- @@ -228,14 +249,17 @@ getBreakCCS = getBreakXXX modBreaks_ccs -- 'ModBreaks'. When the tick module is different, we need to look up the -- 'ModBreaks' in the HUG for that other module. -- +-- When there is no tick module (the breakpoint was generated at codegen), use +-- the function on internal mod breaks. +-- -- To avoid cyclic dependencies, we instead receive a function that looks up -- the 'ModBreaks' given a 'Module' -getBreakXXX :: (ModBreaks -> Array BreakTickIndex a) -> (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO a -getBreakXXX view lookupModule (InternalBreakpointId ibi_mod ibi_ix) imbs = +getBreakXXX :: (ModBreaks -> Array BreakTickIndex a) -> (InternalBreakLoc -> a) -> (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO a +getBreakXXX view viewInternal lookupModule (InternalBreakpointId ibi_mod ibi_ix) imbs = assert_modules_match ibi_mod (imodBreaks_module imbs) $ do let cgb = imodBreaks_breakInfo imbs IM.! ibi_ix case cgb_tick_id cgb of - BreakpointId{bi_tick_mod, bi_tick_index} + Right BreakpointId{bi_tick_mod, bi_tick_index} | bi_tick_mod == ibi_mod -> do let these_mbs = imodBreaks_modBreaks imbs @@ -244,6 +268,8 @@ getBreakXXX view lookupModule (InternalBreakpointId ibi_mod ibi_ix) imbs = -> do other_mbs <- lookupModule bi_tick_mod return $ view other_mbs ! bi_tick_index + Left l -> + return $ viewInternal l -------------------------------------------------------------------------------- -- Instances ===================================== compiler/GHC/CoreToIface.hs ===================================== @@ -50,8 +50,6 @@ import GHC.Prelude import GHC.StgToCmm.Types -import GHC.ByteCode.Types - import GHC.Core import GHC.Core.TyCon hiding ( pprPromotionQuote ) import GHC.Core.Coercion.Axiom ===================================== compiler/GHC/Linker/Loader.hs ===================================== @@ -58,6 +58,7 @@ import GHCi.RemoteTypes import GHC.Iface.Load import GHCi.Message (ConInfoTable(..), LoadedDLL) +import GHC.ByteCode.Breakpoints import GHC.ByteCode.Linker import GHC.ByteCode.Asm import GHC.ByteCode.Types @@ -1711,8 +1712,10 @@ allocateCCS interp ce mbss let count = 1 + (maybe 0 fst $ IM.lookupMax imodBreaks_breakInfo) let ccs = IM.map (\info -> - fromMaybe (toRemotePtr nullPtr) - (M.lookup (cgb_tick_id info) ccss) + case cgb_tick_id info of + Right bi -> fromMaybe (toRemotePtr nullPtr) + (M.lookup bi ccss) + Left InternalBreakLoc{} -> toRemotePtr nullPtr ) imodBreaks_breakInfo assertPpr (count == length ccs) ===================================== compiler/GHC/Runtime/Debugger/Breakpoints.hs ===================================== @@ -253,8 +253,11 @@ mkBreakpointOccurrences = do let imod = modBreaks_module $ imodBreaks_modBreaks ibrks IntMap.foldrWithKey (\info_ix cgi bmp -> do let ibi = InternalBreakpointId imod info_ix - let BreakpointId tick_mod tick_ix = cgb_tick_id cgi - extendModuleEnvWith (IntMap.unionWith (S.<>)) bmp tick_mod (IntMap.singleton tick_ix [ibi]) + case cgb_tick_id cgi of + Right (BreakpointId tick_mod tick_ix) + -> extendModuleEnvWith (IntMap.unionWith (S.<>)) bmp tick_mod (IntMap.singleton tick_ix [ibi]) + Left _ + -> bmp ) bmp0 (imodBreaks_breakInfo ibrks) -------------------------------------------------------------------------------- @@ -287,7 +290,7 @@ getCurrentBreakModule = do Nothing -> pure Nothing Just ibi -> do brks <- readIModBreaks hug ibi - return $ Just $ bi_tick_mod $ getBreakSourceId ibi brks + return $ Just $ getBreakSourceMod ibi brks ix -> Just <$> getHistoryModule hug (resumeHistory r !! (ix-1)) ===================================== compiler/GHC/Runtime/Eval.hs ===================================== @@ -151,7 +151,7 @@ getHistoryModule :: HUG.HomeUnitGraph -> History -> IO Module getHistoryModule hug hist = do let ibi = historyBreakpointId hist brks <- readIModBreaks hug ibi - return $ bi_tick_mod $ getBreakSourceId ibi brks + return $ getBreakSourceMod ibi brks getHistorySpan :: HUG.HomeUnitGraph -> History -> IO SrcSpan getHistorySpan hug hist = do ===================================== compiler/GHC/StgToByteCode.hs ===================================== @@ -63,7 +63,7 @@ import GHC.StgToCmm.Closure ( NonVoid(..), fromNonVoid, idPrimRepU, assertNonVoidIds, assertNonVoidStgArgs ) import GHC.StgToCmm.Layout import GHC.Runtime.Heap.Layout hiding (WordOff, ByteOff, wordsToBytes) -import GHC.Runtime.Interpreter ( interpreterProfiled ) +import GHC.Runtime.Interpreter ( interpreterProfiled, readIModModBreaks ) import GHC.Data.Bitmap import GHC.Data.FlatBag as FlatBag import GHC.Data.OrdList @@ -99,6 +99,7 @@ import GHC.CoreToIface import Control.Monad.IO.Class import Control.Monad.Trans.Reader (ReaderT(..)) import Control.Monad.Trans.State (StateT(..)) +import Data.Array ((!)) -- ----------------------------------------------------------------------------- -- Generating byte code for a complete module @@ -393,26 +394,30 @@ schemeR_wrk fvs nm original_body (args, body) -- | Introduce break instructions for ticked expressions. -- If no breakpoint information is available, the instruction is omitted. schemeER_wrk :: StackDepth -> BCEnv -> CgStgExpr -> BcM BCInstrList -schemeER_wrk d p (StgTick (Breakpoint tick_ty tick_id fvs) rhs) = do - code <- schemeE d 0 p rhs - mb_current_mod_breaks <- getCurrentModBreaks - case mb_current_mod_breaks of - -- if we're not generating ModBreaks for this module for some reason, we - -- can't store breakpoint occurrence information. - Nothing -> pure code - Just current_mod_breaks -> do - platform <- profilePlatform <$> getProfile - let idOffSets = getVarOffSets platform d p fvs - ty_vars = tyCoVarsOfTypesWellScoped (tick_ty:map idType fvs) - toWord :: Maybe (Id, WordOff) -> Maybe (Id, Word) - toWord = fmap (\(i, wo) -> (i, fromIntegral wo)) - breakInfo = dehydrateCgBreakInfo ty_vars (map toWord idOffSets) tick_ty tick_id - - let info_mod = modBreaks_module current_mod_breaks - infox <- newBreakInfo breakInfo +schemeER_wrk d p (StgTick bp@(Breakpoint tick_ty tick_id fvs) rhs) = do + platform <- profilePlatform <$> getProfile + + -- When we find a tick surrounding a case expression we introduce a new BRK_FUN + -- instruction at the start of the case *continuation*, in addition to the + -- usual BRK_FUN surrounding the StgCase) + -- See Note [TODO] + code <- case rhs of + StgCase scrut bndr _ alts + -> doCase d 0 p (Just bp) scrut bndr alts + _ -> schemeE d 0 p rhs + + let idOffSets = getVarOffSets platform d p fvs + ty_vars = tyCoVarsOfTypesWellScoped (tick_ty:map idType fvs) + toWord :: Maybe (Id, WordOff) -> Maybe (Id, Word) + toWord = fmap (\(i, wo) -> (i, fromIntegral wo)) + breakInfo = dehydrateCgBreakInfo ty_vars (map toWord idOffSets) tick_ty (Right tick_id) + + mibi <- newBreakInfo breakInfo + + return $ case mibi of + Nothing -> code + Just ibi -> BRK_FUN ibi `consOL` code - let breakInstr = BRK_FUN (InternalBreakpointId info_mod infox) - return $ breakInstr `consOL` code schemeER_wrk d p rhs = schemeE d 0 p rhs getVarOffSets :: Platform -> StackDepth -> BCEnv -> [Id] -> [Maybe (Id, WordOff)] @@ -614,7 +619,7 @@ schemeE d s p (StgTick _ rhs) = schemeE d s p rhs schemeE d s p (StgCase scrut _ _ []) = schemeE d s p scrut schemeE d s p (StgCase scrut bndr _ alts) - = doCase d s p scrut bndr alts + = doCase d s p Nothing scrut bndr alts {- @@ -1106,11 +1111,15 @@ doCase :: StackDepth -> Sequel -> BCEnv + -> Maybe StgTickish + -- ^ The breakpoint surrounding the full case expression, if any (only + -- source-level cases get breakpoint ticks, and those are the only we care + -- about). See Note [TODO] -> CgStgExpr -> Id -> [CgStgAlt] -> BcM BCInstrList -doCase d s p scrut bndr alts +doCase d s p m_bid scrut bndr alts = do profile <- getProfile hsc_env <- getHscEnv @@ -1327,11 +1336,28 @@ doCase d s p scrut bndr alts let alt_final1 | ubx_tuple_frame = SLIDE 0 2 `consOL` alt_final0 | otherwise = alt_final0 - alt_final - | gopt Opt_InsertBreakpoints (hsc_dflags hsc_env) - -- See Note [Debugger: BRK_ALTS] - = BRK_ALTS False `consOL` alt_final1 - | otherwise = alt_final1 + + alt_final <- case m_bid of + Just (Breakpoint tick_ty tick_id fvs) + | gopt Opt_InsertBreakpoints (hsc_dflags hsc_env) + -- Construct an internal breakpoint to put at the start of this case + -- continuation BCO. + -- See Note [TODO] + -> do + internal_tick_loc <- makeCaseInternalBreakLoc tick_id + + -- same fvs available in the case expression are available in the case continuation + let idOffSets = getVarOffSets platform d p fvs + ty_vars = tyCoVarsOfTypesWellScoped (tick_ty:map idType fvs) + toWord :: Maybe (Id, WordOff) -> Maybe (Id, Word) + toWord = fmap (\(i, wo) -> (i, fromIntegral wo)) + breakInfo = dehydrateCgBreakInfo ty_vars (map toWord idOffSets) tick_ty (Left internal_tick_loc) + + mibi <- newBreakInfo breakInfo + return $ case mibi of + Nothing -> alt_final1 + Just ibi -> BRK_FUN ibi `consOL` alt_final1 + _ -> pure alt_final1 add_bco_name <- shouldAddBcoName let @@ -1351,6 +1377,24 @@ doCase d s p scrut bndr alts _ -> panic "schemeE(StgCase).push_alts" in return (PUSH_ALTS alt_bco scrut_rep `consOL` scrut_code) +makeCaseInternalBreakLoc :: BreakpointId -> BcM InternalBreakLoc +makeCaseInternalBreakLoc bid = do + hug <- hsc_HUG <$> getHscEnv + curr_mod <- getCurrentModule + mb_mod_brks <- getCurrentModBreaks + + -- TODO: Subtract the scrutinee loc from the case loc to get continuation loc + InternalBreakLoc <$> case bid of + BreakpointId{bi_tick_mod, bi_tick_index} + | bi_tick_mod == curr_mod + , Just these_mbs <- mb_mod_brks + -> do + return $ modBreaks_locs these_mbs ! bi_tick_index + | otherwise + -> do + other_mbs <- liftIO $ readIModModBreaks hug bi_tick_mod + return $ modBreaks_locs other_mbs ! bi_tick_index + {- Note [Debugger: BRK_ALTS] ~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2667,14 +2711,19 @@ getLabelsBc n = BcM $ \_ st -> let ctr = nextlabel st in return (coerce [ctr .. ctr+n-1], st{nextlabel = ctr+n}) -newBreakInfo :: CgBreakInfo -> BcM Int -newBreakInfo info = BcM $ \_ st -> - let ix = breakInfoIdx st - st' = st - { breakInfo = IntMap.insert ix info (breakInfo st) - , breakInfoIdx = ix + 1 - } - in return (ix, st') +newBreakInfo :: CgBreakInfo -> BcM (Maybe InternalBreakpointId) +newBreakInfo info = BcM $ \env st -> do + -- if we're not generating ModBreaks for this module for some reason, we + -- can't store breakpoint occurrence information. + case modBreaks env of + Nothing -> pure (Nothing, st) + Just modBreaks -> do + let ix = breakInfoIdx st + st' = st + { breakInfo = IntMap.insert ix info (breakInfo st) + , breakInfoIdx = ix + 1 + } + return (Just $ InternalBreakpointId (modBreaks_module modBreaks) ix, st') getCurrentModule :: BcM Module getCurrentModule = BcM $ \env st -> return (bcm_module env, st) @@ -2687,7 +2736,7 @@ tickFS = fsLit "ticked" -- Dehydrating CgBreakInfo -dehydrateCgBreakInfo :: [TyVar] -> [Maybe (Id, Word)] -> Type -> BreakpointId -> CgBreakInfo +dehydrateCgBreakInfo :: [TyVar] -> [Maybe (Id, Word)] -> Type -> Either InternalBreakLoc BreakpointId -> CgBreakInfo dehydrateCgBreakInfo ty_vars idOffSets tick_ty bid = CgBreakInfo { cgb_tyvars = map toIfaceTvBndr ty_vars ===================================== ghc/GHCi/UI.hs ===================================== @@ -3825,7 +3825,7 @@ pprStopped res = do hug <- hsc_HUG <$> GHC.getSession brks <- liftIO $ readIModBreaks hug ibi return $ Just $ moduleName $ - bi_tick_mod $ getBreakSourceId ibi brks + getBreakSourceMod ibi brks return $ text "Stopped in" <+> ((case mb_mod_name of View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/49b0422668f9a06191833239734fe4e… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/49b0422668f9a06191833239734fe4e… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/romes/step-out-11
by Rodrigo Mesquita (＠alt-romes) 11 Jul '25

11 Jul '25

Rodrigo Mesquita pushed new branch wip/romes/step-out-11 at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/romes/step-out-11 You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/haanss/depdir] update wording of comment
by Hassan Al-Awwadi (＠hassan.awwadi) 11 Jul '25

11 Jul '25

Hassan Al-Awwadi pushed to branch wip/haanss/depdir at Glasgow Haskell Compiler / GHC Commits: afe46598 by Hassan Al-Awwadi at 2025-07-11T19:13:54+02:00 update wording of comment - - - - - 1 changed file: - libraries/ghc-internal/src/GHC/Internal/TH/Syntax.hs Changes: ===================================== libraries/ghc-internal/src/GHC/Internal/TH/Syntax.hs ===================================== @@ -836,11 +836,11 @@ getPackageRoot = Q qGetPackageRoot -- -- * ghc -M does not know about these dependencies - it does not execute TH. -- --- * The dependency is shallow, just a hash of its direct contents. --- Basically, it only sees a list of names, and hashes those names. --- It does not look at directory metadata, recurse into subdirectories --- or look at file contents. As long as the list of names remains the same, --- the directory is considered unchanged. +-- * The dependency is shallow, based only on the direct content. +-- Basically, it only sees a list of names. It does not look at directory +-- metadata, recurse into subdirectories, or look at file contents. As +-- long as the list of names remains the same, the directory is considered +-- unchanged. -- -- * The state of the directory is read at the interface generation time, -- not at the time of the function call. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/afe4659892657df672b8cab9ecb0dec… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/afe4659892657df672b8cab9ecb0dec… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/haanss/depdir] updated comments for addDependentDirectory and addDependentFile
by Hassan Al-Awwadi (＠hassan.awwadi) 11 Jul '25

11 Jul '25

Hassan Al-Awwadi pushed to branch wip/haanss/depdir at Glasgow Haskell Compiler / GHC Commits: 1cb08157 by Hassan Al-Awwadi at 2025-07-11T19:09:34+02:00 updated comments for addDependentDirectory and addDependentFile - - - - - 2 changed files: - docs/users_guide/separate_compilation.rst - libraries/ghc-internal/src/GHC/Internal/TH/Syntax.hs Changes: ===================================== docs/users_guide/separate_compilation.rst ===================================== @@ -732,12 +732,14 @@ be recompiled. When using Template Haskell or plugins, you can use the functions ``addDependentFile`` and ``addDependentDirectory`` to add additional -dependencies to the module being compiled. When adding a file, this means -that the contents of the file changing between compilations will trigger a -recompilation of the module. When adding a directory, this means that any -file or subdirectory *added* to or *removed* from the directory will trigger -recompilation of the module, so it is not a recursive dependency. - +dependencies to the module being compiled. + +- When adding a file, this means that the contents of the file changing between + compilations will trigger a recompilation of the module. +- When adding a directory, this means that any file or subdirectory *added* to or + *removed* from the directory will trigger recompilation of the module, so + it is not a recursive dependency. + .. _mutual-recursion: Mutually recursive modules and hs-boot files ===================================== libraries/ghc-internal/src/GHC/Internal/TH/Syntax.hs ===================================== @@ -836,13 +836,17 @@ getPackageRoot = Q qGetPackageRoot -- -- * ghc -M does not know about these dependencies - it does not execute TH. -- --- * The dependency is shallow, just a hash of its direct contents. It returns --- a list of the contents (absolute paths), files and subdirectories both, so --- you can manually depend on (a subset of) those, if you wish. +-- * The dependency is shallow, just a hash of its direct contents. +-- Basically, it only sees a list of names, and hashes those names. +-- It does not look at directory metadata, recurse into subdirectories +-- or look at file contents. As long as the list of names remains the same, +-- the directory is considered unchanged. +-- +-- * The state of the directory is read at the interface generation time, +-- not at the time of the function call. addDependentDirectory :: FilePath -> Q () addDependentDirectory dp = Q (qAddDependentDirectory dp) - -- | Record external files that runIO is using (dependent upon). -- The compiler can then recognize that it should re-compile the Haskell file -- when an external file changes. @@ -853,7 +857,11 @@ addDependentDirectory dp = Q (qAddDependentDirectory dp) -- -- * ghc -M does not know about these dependencies - it does not execute TH. -- --- * The dependency is based on file content, not a modification time +-- * The dependency is based on file content, not a modification time or +-- any other metadata associated with the file (e.g. permissions). +-- +-- * The state of the file is read at the interface generation time, +-- not at the time of the function call. addDependentFile :: FilePath -> Q () addDependentFile fp = Q (qAddDependentFile fp) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1cb0815780f2af72d2659806816f42c… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1cb0815780f2af72d2659806816f42c… You're receiving this email because of your account on gitlab.haskell.org.

1 0