July 2025 - ghc-commits

[Git][ghc/ghc][wip/fendor/backtraces-decoders] Extend Backtraces to allow configuration of stack decoders
by Hannes Siebenhandl (＠fendor) 17 Jul '25

17 Jul '25

Hannes Siebenhandl pushed to branch wip/fendor/backtraces-decoders at Glasgow Haskell Compiler / GHC Commits: 42c8f304 by fendor at 2025-07-17T19:11:12+02:00 Extend Backtraces to allow configuration of stack decoders Allow the user to overwrite the default stack-decoders in `Backtraces`. Users can then experiment with custom stack decoders, or tweak the output of the stack trace to their liking. We store the stack decoders for each of the supported backtraces in `DisplayBacktraceMechanisms` in a global `IORef`. When collecting `Backtraces`, we also ask for the currently configured stack decoders (specified via `DisplayBacktraceMechanisms`) and use them for printing the `Backtraces`. - - - - - 2 changed files: - libraries/base/src/Control/Exception/Backtrace.hs - libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs Changes: ===================================== libraries/base/src/Control/Exception/Backtrace.hs ===================================== @@ -50,6 +50,10 @@ module Control.Exception.Backtrace BacktraceMechanism(..) , getBacktraceMechanismState , setBacktraceMechanismState + -- * Display Backtrace mechanisms + , DisplayBacktraceMechanisms(..) + , getDisplayBacktraceMechanisms + , setDisplayBacktraceMechanismsState -- * Collecting backtraces , Backtraces(..) , displayBacktraces ===================================== libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs ===================================== @@ -11,9 +11,9 @@ import GHC.Internal.IORef import GHC.Internal.IO.Unsafe (unsafePerformIO) import GHC.Internal.Exception.Context import GHC.Internal.Ptr +import GHC.Internal.Data.Maybe (fromMaybe) import GHC.Internal.Stack.Types as GHC.Stack (CallStack) import qualified GHC.Internal.Stack as HCS -import qualified GHC.Internal.ExecutionStack as ExecStack import qualified GHC.Internal.ExecutionStack.Internal as ExecStack import qualified GHC.Internal.Stack.CloneStack as CloneStack import qualified GHC.Internal.Stack.CCS as CCS @@ -86,37 +86,69 @@ setBacktraceMechanismState bm enabled = do _ <- atomicModifyIORef'_ enabledBacktraceMechanismsRef (setBacktraceMechanismEnabled bm enabled) return () --- | A collection of backtraces. +-- | How to display a backtrace when an exception is thrown. +data DisplayBacktraceMechanisms = + DisplayBacktraceMechanisms + { displayCostCentreBacktrace :: Ptr CCS.CostCentreStack -> String + , displayHasCallStackBacktrace :: HCS.CallStack -> String + , displayExecutionBacktrace :: ExecStack.StackTrace -> String + , displayIpeBacktrace :: CloneStack.StackSnapshot -> String + } + +defaultDisplayBacktraceMechanisms :: DisplayBacktraceMechanisms +defaultDisplayBacktraceMechanisms = DisplayBacktraceMechanisms + { displayCostCentreBacktrace = unlines . map (indent 2) . unsafePerformIO . CCS.ccsToStrings + , displayHasCallStackBacktrace = unlines . map (indent 2 . prettyCallSite) . HCS.getCallStack + , displayExecutionBacktrace = unlines . map (indent 2 . flip ExecStack.showLocation "") . fromMaybe [] . ExecStack.stackFrames + , displayIpeBacktrace = unlines . map (indent 2 . CloneStack.prettyStackEntry) . unsafePerformIO . CloneStack.decode + } + where + indent :: Int -> String -> String + indent n s = replicate n ' ' ++ s + + prettyCallSite (f, loc) = f ++ ", called at " ++ HCS.prettySrcLoc loc + + +displayBacktraceMechanismsRef :: IORef DisplayBacktraceMechanisms +displayBacktraceMechanismsRef = + unsafePerformIO $ newIORef defaultDisplayBacktraceMechanisms +{-# NOINLINE displayBacktraceMechanismsRef #-} + +-- | How are the 'Backtraces' going to be displayed? +getDisplayBacktraceMechanisms :: IO DisplayBacktraceMechanisms +getDisplayBacktraceMechanisms = readIORef displayBacktraceMechanismsRef + +-- | Specify how the 'Backtraces' are displayed. +setDisplayBacktraceMechanismsState :: DisplayBacktraceMechanisms -> IO () +setDisplayBacktraceMechanismsState dbm = do + _ <- atomicModifyIORef'_ displayBacktraceMechanismsRef (const dbm) + return () + +-- | A collection of backtraces, paired with a way to display each respective backtrace. data Backtraces = Backtraces { btrCostCentre :: Maybe (Ptr CCS.CostCentreStack), + btrDisplayCostCentre :: Ptr CCS.CostCentreStack -> String, btrHasCallStack :: Maybe HCS.CallStack, - btrExecutionStack :: Maybe [ExecStack.Location], - btrIpe :: Maybe [CloneStack.StackEntry] + btrDisplayHasCallStack :: HCS.CallStack -> String, + btrExecutionStack :: Maybe ExecStack.StackTrace, + btrDisplayExecutionStack :: ExecStack.StackTrace -> String, + btrIpe :: Maybe CloneStack.StackSnapshot, + btrDisplayIpe :: CloneStack.StackSnapshot -> String } -- | Render a set of backtraces to a human-readable string. displayBacktraces :: Backtraces -> String displayBacktraces bts = concat - [ displayOne "Cost-centre stack backtrace" btrCostCentre displayCc - , displayOne "Native stack backtrace" btrExecutionStack displayExec - , displayOne "IPE backtrace" btrIpe displayIpe - , displayOne "HasCallStack backtrace" btrHasCallStack displayHsc + [ displayOne "Cost-centre stack backtrace" btrCostCentre btrDisplayCostCentre + , displayOne "Native stack backtrace" btrExecutionStack btrDisplayExecutionStack + , displayOne "IPE backtrace" btrIpe btrDisplayIpe + , displayOne "HasCallStack backtrace" btrHasCallStack btrDisplayHasCallStack ] where - indent :: Int -> String -> String - indent n s = replicate n ' ' ++ s - - -- The unsafePerformIO here is safe as we don't currently unload cost-centres. - displayCc = unlines . map (indent 2) . unsafePerformIO . CCS.ccsToStrings - displayExec = unlines . map (indent 2 . flip ExecStack.showLocation "") - displayIpe = unlines . map (indent 2 . CloneStack.prettyStackEntry) - displayHsc = unlines . map (indent 2 . prettyCallSite) . HCS.getCallStack - where prettyCallSite (f, loc) = f ++ ", called at " ++ HCS.prettySrcLoc loc - - displayOne :: String -> (Backtraces -> Maybe rep) -> (rep -> String) -> String + displayOne :: String -> (Backtraces -> Maybe rep) -> (Backtraces -> rep -> String) -> String displayOne label getBt displ - | Just bt <- getBt bts = concat [label, ":\n", displ bt] + | Just bt <- getBt bts = concat [label, ":\n", displ bts bt] | otherwise = "" instance ExceptionAnnotation Backtraces where @@ -125,12 +157,14 @@ instance ExceptionAnnotation Backtraces where -- | Collect a set of 'Backtraces'. collectBacktraces :: (?callStack :: CallStack) => IO Backtraces collectBacktraces = HCS.withFrozenCallStack $ do - getEnabledBacktraceMechanisms >>= collectBacktraces' + bm <- getEnabledBacktraceMechanisms + dpm <- getDisplayBacktraceMechanisms + collectBacktraces' bm dpm collectBacktraces' :: (?callStack :: CallStack) - => EnabledBacktraceMechanisms -> IO Backtraces -collectBacktraces' enabled = HCS.withFrozenCallStack $ do + => EnabledBacktraceMechanisms -> DisplayBacktraceMechanisms -> IO Backtraces +collectBacktraces' enabled renderers = HCS.withFrozenCallStack $ do let collect :: BacktraceMechanism -> IO (Maybe a) -> IO (Maybe a) collect mech f | backtraceMechanismEnabled mech enabled = f @@ -140,18 +174,21 @@ collectBacktraces' enabled = HCS.withFrozenCallStack $ do Just `fmap` CCS.getCurrentCCS () exec <- collect ExecutionBacktrace $ do - ExecStack.getStackTrace + ExecStack.collectStackTrace ipe <- collect IPEBacktrace $ do stack <- CloneStack.cloneMyStack - stackEntries <- CloneStack.decode stack - return (Just stackEntries) + return (Just stack) hcs <- collect HasCallStackBacktrace $ do return (Just ?callStack) return (Backtraces { btrCostCentre = ccs + , btrDisplayCostCentre = displayCostCentreBacktrace renderers , btrHasCallStack = hcs + , btrDisplayHasCallStack = displayHasCallStackBacktrace renderers , btrExecutionStack = exec + , btrDisplayExecutionStack = displayExecutionBacktrace renderers , btrIpe = ipe + , btrDisplayIpe = displayIpeBacktrace renderers }) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/42c8f3046d06e4b5f0d8ef913a6b5fe… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/42c8f3046d06e4b5f0d8ef913a6b5fe… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] EPA: Update exact printing based on GHC 9.14 tests
by Marge Bot (＠marge-bot) 17 Jul '25

17 Jul '25

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: f4e8466c by Alan Zimmerman at 2025-07-17T12:31:55-04:00 EPA: Update exact printing based on GHC 9.14 tests As a result of migrating the GHC ghc-9.14 branch tests to ghc-exactprint in https://github.com/alanz/ghc-exactprint/tree/ghc-9.14, a couple of discrepancies were picked up - The opening paren for a DefaultDecl was printed in the wrong place - The import declaration level specifiers were not printed. This commit adds those fixes, and some tests for them. The tests brought to light that the ImportDecl ppr instance had not been updated for level specifiers, so it updates that too. - - - - - 7 changed files: - compiler/GHC/Hs/ImpExp.hs - compiler/GHC/Parser.y - testsuite/tests/printer/Makefile - + testsuite/tests/printer/TestLevelImports.hs - + testsuite/tests/printer/TestNamedDefaults.hs - testsuite/tests/printer/all.T - utils/check-exact/ExactPrint.hs Changes: ===================================== compiler/GHC/Hs/ImpExp.hs ===================================== @@ -149,10 +149,14 @@ instance (OutputableBndrId p ppr (ImportDecl { ideclExt = impExt, ideclName = mod' , ideclPkgQual = pkg , ideclSource = from, ideclSafe = safe + , ideclLevelSpec = level , ideclQualified = qual , ideclAs = as, ideclImportList = spec }) - = hang (hsep [text "import", ppr_imp impExt from, pp_implicit impExt, pp_safe safe, - pp_qual qual False, ppr pkg, ppr mod', pp_qual qual True, pp_as as]) + = hang (hsep [text "import", ppr_imp impExt from, pp_implicit impExt, + pp_level level False, pp_safe safe, pp_qual qual False, + ppr pkg, ppr mod', + pp_level level True, pp_qual qual True, + pp_as as]) 4 (pp_spec spec) where pp_implicit ext = @@ -169,6 +173,15 @@ instance (OutputableBndrId p pp_qual QualifiedPost False = empty -- Postpositive qualifier/prepositive position. pp_qual NotQualified _ = empty + pp_level (LevelStylePre sty) False = pp_level_style sty + pp_level (LevelStylePost _) False = empty + pp_level (LevelStylePre _) True = empty + pp_level (LevelStylePost sty) True = pp_level_style sty + pp_level NotLevelled _ = empty + + pp_level_style ImportDeclQuote = text "quote" + pp_level_style ImportDeclSplice = text "splice" + pp_safe False = empty pp_safe True = text "safe" ===================================== compiler/GHC/Parser.y ===================================== @@ -1123,7 +1123,7 @@ importdecls_semi | {- empty -} { [] } importdecl :: { LImportDecl GhcPs } - : 'import' maybe_src maybe_splice maybe_safe optqualified maybe_pkg modid maybe_splice optqualified maybeas maybeimpspec + : 'import' maybe_src maybe_level maybe_safe optqualified maybe_pkg modid maybe_level optqualified maybeas maybeimpspec {% do { ; let { ; mPreQual = $5 ; mPostQual = $9 @@ -1163,7 +1163,7 @@ maybe_safe :: { (Maybe (EpToken "safe"),Bool) } : 'safe' { (Just (epTok $1),True) } | {- empty -} { (Nothing, False) } -maybe_splice :: { (Maybe EpAnnLevel) } +maybe_level :: { (Maybe EpAnnLevel) } : 'splice' { (Just (EpAnnLevelSplice (epTok $1))) } | 'quote' { (Just (EpAnnLevelQuote (epTok $1))) } | {- empty -} { (Nothing) } ===================================== testsuite/tests/printer/Makefile ===================================== @@ -901,3 +901,14 @@ Test25467: Test25885: $(CHECK_PPR) $(LIBDIR) Test25885.hs $(CHECK_EXACT) $(LIBDIR) Test25885.hs + +.PHONY: TestLevelImports +TestLevelImports: + $(CHECK_PPR) $(LIBDIR) TestLevelImports.hs + $(CHECK_EXACT) $(LIBDIR) TestLevelImports.hs + + +.PHONY: TestNamedDefaults +TestNamedDefaults: + $(CHECK_PPR) $(LIBDIR) TestNamedDefaults.hs + $(CHECK_EXACT) $(LIBDIR) TestNamedDefaults.hs ===================================== testsuite/tests/printer/TestLevelImports.hs ===================================== @@ -0,0 +1,42 @@ + +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ExplicitLevelImports #-} +{-# LANGUAGE NoMonomorphismRestriction #-} + +module TestLevelImports where +-- Based on test SI26 and SI01 + +------------------------------------------------ +-- SI26 + +-- Test using 'quote' as a post-qualifier in imports +import Prelude quote +import Prelude quote qualified as P +import quote Prelude qualified as P2 +import quote qualified Prelude as P3 + +-- Test using 'splice' as a post-qualifier in imports +import Language.Haskell.TH.Syntax splice + +import splice Language.Haskell.TH.Syntax qualified as TH +import Language.Haskell.TH.Syntax splice qualified as TH2 + +-- Using a splice imported thing, inside an untyped and typed splice works +import splice SI01A + +-- Use the imported modules +testQuote = [| id |] +testQuote2 = [| P.id |] +testQuote3 = [| P2.id |] + +testSplice = $(lift "Hello from splice") +testSplice2 = $(TH.lift "Hello from splice2") +testSplice3 = $(TH2.lift "Hello from splice3") + +------------------------------------------------ +-- SI01 + +main :: IO () +main = $( sid [| pure () |]) >> $$( sid [|| pure () ||]) ===================================== testsuite/tests/printer/TestNamedDefaults.hs ===================================== @@ -0,0 +1,35 @@ +{-# LANGUAGE NamedDefaults #-} +module NamedDefaults ( + Stringify(..), + default Stringify, + Bingify(..), + default Bingify + ) where + +class Stringify a where + stringify :: a -> String + +instance Stringify Int where + stringify n = "Int" + +instance Stringify Bool where + stringify b = "Bool" + +instance Stringify [Char] where + stringify s = "String" + +class Bingify a where + bingify :: a -> String + +instance Bingify Int where + bingify n = "Int" + +instance Bingify Bool where + bingify b = "Bool" + +instance Bingify [Char] where + bingify s = "String" + +default Stringify (Int) +default Bingify (Int) + ===================================== testsuite/tests/printer/all.T ===================================== @@ -215,4 +215,7 @@ test('Test25467', [ignore_stderr, req_ppr_deps], makefile_test, ['Test25467']) test('T24237', normal, compile_fail, ['']) test('Test25454', [ignore_stderr, req_ppr_deps], makefile_test, ['Test25454']) -test('Test25885', [ignore_stderr, req_ppr_deps], makefile_test, ['Test25885']) \ No newline at end of file +test('Test25885', [ignore_stderr, req_ppr_deps], makefile_test, ['Test25885']) + +test('TestLevelImports', [ignore_stderr, req_ppr_deps], makefile_test, ['TestLevelImports']) +test('TestNamedDefaults', [ignore_stderr, req_ppr_deps], makefile_test, ['TestNamedDefaults']) \ No newline at end of file ===================================== utils/check-exact/ExactPrint.hs ===================================== @@ -802,6 +802,7 @@ markLensBracketsC' a l = c' <- markEpUniToken c return (set l (ListBanana o c') a) ListNone -> return (set l ListNone a) + -- ------------------------------------- markEpToken :: forall m w tok . (Monad m, Monoid w, KnownSymbol tok) @@ -937,6 +938,7 @@ lam_where k annsModule = fmap (\newAnns -> annsModule { am_where = newAnns }) -- { importDeclAnnImport :: EpToken "import" -- ^ The location of the @import@ keyword -- , importDeclAnnPragma :: Maybe (EpaLocation, EpToken "#-}") -- ^ The locations of @{-# SOURCE@ and @#-}@ respectively -- , importDeclAnnSafe :: Maybe (EpToken "safe") -- ^ The location of the @safe@ keyword +-- , importDeclAnnLevel :: Maybe EpAnnLevel -- ^ The location of the @splice@ or @quote@ keyword -- , importDeclAnnQualified :: Maybe (EpToken "qualified") -- ^ The location of the @qualified@ keyword -- , importDeclAnnPackage :: Maybe EpaLocation -- ^ The location of the package name (when using @-XPackageImports@) -- , importDeclAnnAs :: Maybe (EpToken "as") -- ^ The location of the @as@ keyword @@ -954,6 +956,10 @@ limportDeclAnnSafe :: Lens EpAnnImportDecl (Maybe (EpToken "safe")) limportDeclAnnSafe k annImp = fmap (\new -> annImp { importDeclAnnSafe = new }) (k (importDeclAnnSafe annImp)) +limportDeclAnnLevel :: Lens EpAnnImportDecl (Maybe EpAnnLevel) +limportDeclAnnLevel k annImp = fmap (\new -> annImp { importDeclAnnLevel = new }) + (k (importDeclAnnLevel annImp)) + limportDeclAnnQualified :: Lens EpAnnImportDecl (Maybe (EpToken "qualified")) limportDeclAnnQualified k annImp = fmap (\new -> annImp { importDeclAnnQualified = new }) (k (importDeclAnnQualified annImp)) @@ -1625,9 +1631,15 @@ instance ExactPrint (ImportDecl GhcPs) where printStringAtLsDelta (SameLine 1) "#-}" return Nothing NoSourceText -> return (importDeclAnnPragma an) + -- pre level + ann0' <- case st of + LevelStylePre _ -> markLensFun' ann0 limportDeclAnnLevel (\mt -> mapM markEpAnnLevel mt) + _ -> return ann0 + + ann1 <- if safeflag - then markLensFun' ann0 limportDeclAnnSafe (\mt -> mapM markEpToken mt) - else return ann0 + then markLensFun' ann0' limportDeclAnnSafe (\mt -> mapM markEpToken mt) + else return ann0' ann2 <- case qualFlag of QualifiedPre -- 'qualified' appears in prepositive position. @@ -1640,11 +1652,16 @@ instance ExactPrint (ImportDecl GhcPs) where _ -> return ann2 modname' <- markAnnotated modname + -- post level + ann3' <- case st of + LevelStylePost _ -> markLensFun' ann3 limportDeclAnnLevel (\mt -> mapM markEpAnnLevel mt) + _ -> return ann3 + ann4 <- case qualFlag of QualifiedPost -- 'qualified' appears in postpositive position. - -> markLensFun' ann3 limportDeclAnnQualified (\ml -> mapM markEpToken ml) - _ -> return ann3 + -> markLensFun' ann3' limportDeclAnnQualified (\ml -> mapM markEpToken ml) + _ -> return ann3' (importDeclAnnAs', mAs') <- case mAs of @@ -1669,6 +1686,9 @@ instance ExactPrint (ImportDecl GhcPs) where return (ImportDecl (XImportDeclPass (EpAnn anc' an2 cs') msrc impl) modname' mpkg src st safeflag qualFlag mAs' hiding') +markEpAnnLevel :: (Monad m, Monoid w) => EpAnnLevel -> EP w m EpAnnLevel +markEpAnnLevel (EpAnnLevelSplice tok) = EpAnnLevelSplice <$> markEpToken tok +markEpAnnLevel (EpAnnLevelQuote tok) = EpAnnLevelQuote <$> markEpToken tok -- --------------------------------------------------------------------- @@ -2717,8 +2737,8 @@ instance ExactPrint (DefaultDecl GhcPs) where exact (DefaultDecl (d,op,cp) cl tys) = do d' <- markEpToken d - op' <- markEpToken op cl' <- markAnnotated cl + op' <- markEpToken op tys' <- markAnnotated tys cp' <- markEpToken cp return (DefaultDecl (d',op',cp') cl' tys') View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f4e8466cf2164fd9ecf8d02d8cb417c… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f4e8466cf2164fd9ecf8d02d8cb417c… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] base: Deprecate GHC.Weak.Finalize.runFinalizerBatch
by Marge Bot (＠marge-bot) 17 Jul '25

17 Jul '25

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 360fa82c by Duncan Coutts at 2025-07-17T12:31:14-04:00 base: Deprecate GHC.Weak.Finalize.runFinalizerBatch https://github.com/haskell/core-libraries-committee/issues/342 - - - - - 2 changed files: - libraries/base/changelog.md - libraries/base/src/GHC/Weak/Finalize.hs Changes: ===================================== libraries/base/changelog.md ===================================== @@ -4,6 +4,8 @@ * Add `Data.List.NonEmpty.mapMaybe`. ([CLC proposal #337](https://github.com/haskell/core-libraries-committee/issues/337)) ## 4.22.0.0 *TBA* + * Shipped with GHC 9.14.1 + * The internal `GHC.Weak.Finalize.runFinalizerBatch` function has been deprecated ([CLC proposal #342](https://github.com/haskell/core-libraries-committee/issues/342)) * Define `displayException` of `SomeAsyncException` to unwrap the exception. ([CLC proposal #309](https://github.com/haskell/core-libraries-committee/issues/309)) * Restrict `Data.List.NonEmpty.unzip` to `NonEmpty (a, b) -> (NonEmpty a, NonEmpty b)`. ([CLC proposal #86](https://github.com/haskell/core-libraries-committee/issues/86)) ===================================== libraries/base/src/GHC/Weak/Finalize.hs ===================================== @@ -1,3 +1,4 @@ +{-# LANGUAGE MagicHash #-} module GHC.Weak.Finalize ( -- * Handling exceptions -- | When an exception is thrown by a finalizer called by the @@ -8,7 +9,30 @@ module GHC.Weak.Finalize , getFinalizerExceptionHandler , printToHandleFinalizerExceptionHandler -- * Internal - , runFinalizerBatch + , GHC.Weak.Finalize.runFinalizerBatch ) where import GHC.Internal.Weak.Finalize + +-- These imports can be removed once runFinalizerBatch is removed, +-- as can MagicHash above. +import GHC.Internal.Base (Int, Array#, IO, State#, RealWorld) + + +{-# DEPRECATED runFinalizerBatch + "This function is internal to GHC. It will not be exported in future." #-} +-- | Run a batch of finalizers from the garbage collector. Given an +-- array of finalizers and the length of the array, just call each one +-- in turn. +-- +-- This is an internal detail of the GHC RTS weak pointer finaliser +-- mechanism. It should no longer be exported from base. There is no +-- good reason to use it. It will be removed in the next major version +-- of base (4.23.*). +-- +-- See <https://github.com/haskell/core-libraries-committee/issues/342> +-- +runFinalizerBatch :: Int + -> Array# (State# RealWorld -> State# RealWorld) + -> IO () +runFinalizerBatch = GHC.Internal.Weak.Finalize.runFinalizerBatch View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/360fa82cc0e06163c7d712a22e7a33c… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/360fa82cc0e06163c7d712a22e7a33c… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] Add Data.List.NonEmpty.mapMaybe
by Marge Bot (＠marge-bot) 17 Jul '25

17 Jul '25

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: cc650b4b by Andrew Lelechenko at 2025-07-17T12:30:24-04:00 Add Data.List.NonEmpty.mapMaybe As per https://github.com/haskell/core-libraries-committee/issues/337 - - - - - 6 changed files: - libraries/base/changelog.md - libraries/base/src/Data/List/NonEmpty.hs - testsuite/tests/interface-stability/base-exports.stdout - testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs - testsuite/tests/interface-stability/base-exports.stdout-mingw32 - testsuite/tests/interface-stability/base-exports.stdout-ws-32 Changes: ===================================== libraries/base/changelog.md ===================================== @@ -1,5 +1,8 @@ # Changelog for [`base` package](http://hackage.haskell.org/package/base) +## 4.23.0.0 *TBA* + * Add `Data.List.NonEmpty.mapMaybe`. ([CLC proposal #337](https://github.com/haskell/core-libraries-committee/issues/337)) + ## 4.22.0.0 *TBA* * Define `displayException` of `SomeAsyncException` to unwrap the exception. ([CLC proposal #309](https://github.com/haskell/core-libraries-committee/issues/309)) ===================================== libraries/base/src/Data/List/NonEmpty.hs ===================================== @@ -78,6 +78,7 @@ module Data.List.NonEmpty ( , span -- :: (a -> Bool) -> NonEmpty a -> ([a], [a]) , break -- :: (a -> Bool) -> NonEmpty a -> ([a], [a]) , filter -- :: (a -> Bool) -> NonEmpty a -> [a] + , mapMaybe -- :: (a -> Maybe b) -> NonEmpty a -> [b] , partition -- :: (a -> Bool) -> NonEmpty a -> ([a],[a]) , group -- :: (Foldable f, Eq a) => f a -> [NonEmpty a] , groupBy -- :: Foldable f => (a -> a -> Bool) -> f a -> [NonEmpty a] @@ -118,6 +119,7 @@ import qualified Prelude import Control.Applicative (Applicative (..), Alternative (many)) import qualified Data.List as List +import qualified Data.Maybe as List (mapMaybe) import GHC.Internal.Data.Foldable hiding (length, toList) import qualified GHC.Internal.Data.Foldable as Foldable import GHC.Internal.Data.Function (on) @@ -442,6 +444,14 @@ break p = span (not . p) filter :: (a -> Bool) -> NonEmpty a -> [a] filter p = List.filter p . toList +-- | The 'mapMaybe' function is a version of 'map' which can throw +-- out elements. In particular, the functional argument returns +-- something of type @'Maybe' b@. If this is 'Nothing', no element +-- is added on to the result list. If it is @'Just' b@, then @b@ is +-- included in the result list. +mapMaybe :: (a -> Maybe b) -> NonEmpty a -> [b] +mapMaybe f (x :| xs) = maybe id (:) (f x) $ List.mapMaybe f xs + -- | The 'partition' function takes a predicate @p@ and a stream -- @xs@, and returns a pair of lists. The first list corresponds to the -- elements of @xs@ for which @p@ holds; the second corresponds to the ===================================== testsuite/tests/interface-stability/base-exports.stdout ===================================== @@ -1467,6 +1467,7 @@ module Data.List.NonEmpty where last :: forall a. NonEmpty a -> a length :: forall a. NonEmpty a -> GHC.Internal.Types.Int map :: forall a b. (a -> b) -> NonEmpty a -> NonEmpty b + mapMaybe :: forall a b. (a -> GHC.Internal.Maybe.Maybe b) -> NonEmpty a -> [b] nonEmpty :: forall a. [a] -> GHC.Internal.Maybe.Maybe (NonEmpty a) nub :: forall a. GHC.Internal.Classes.Eq a => NonEmpty a -> NonEmpty a nubBy :: forall a. (a -> a -> GHC.Internal.Types.Bool) -> NonEmpty a -> NonEmpty a ===================================== testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs ===================================== @@ -1467,6 +1467,7 @@ module Data.List.NonEmpty where last :: forall a. NonEmpty a -> a length :: forall a. NonEmpty a -> GHC.Internal.Types.Int map :: forall a b. (a -> b) -> NonEmpty a -> NonEmpty b + mapMaybe :: forall a b. (a -> GHC.Internal.Maybe.Maybe b) -> NonEmpty a -> [b] nonEmpty :: forall a. [a] -> GHC.Internal.Maybe.Maybe (NonEmpty a) nub :: forall a. GHC.Internal.Classes.Eq a => NonEmpty a -> NonEmpty a nubBy :: forall a. (a -> a -> GHC.Internal.Types.Bool) -> NonEmpty a -> NonEmpty a ===================================== testsuite/tests/interface-stability/base-exports.stdout-mingw32 ===================================== @@ -1467,6 +1467,7 @@ module Data.List.NonEmpty where last :: forall a. NonEmpty a -> a length :: forall a. NonEmpty a -> GHC.Internal.Types.Int map :: forall a b. (a -> b) -> NonEmpty a -> NonEmpty b + mapMaybe :: forall a b. (a -> GHC.Internal.Maybe.Maybe b) -> NonEmpty a -> [b] nonEmpty :: forall a. [a] -> GHC.Internal.Maybe.Maybe (NonEmpty a) nub :: forall a. GHC.Internal.Classes.Eq a => NonEmpty a -> NonEmpty a nubBy :: forall a. (a -> a -> GHC.Internal.Types.Bool) -> NonEmpty a -> NonEmpty a ===================================== testsuite/tests/interface-stability/base-exports.stdout-ws-32 ===================================== @@ -1467,6 +1467,7 @@ module Data.List.NonEmpty where last :: forall a. NonEmpty a -> a length :: forall a. NonEmpty a -> GHC.Internal.Types.Int map :: forall a b. (a -> b) -> NonEmpty a -> NonEmpty b + mapMaybe :: forall a b. (a -> GHC.Internal.Maybe.Maybe b) -> NonEmpty a -> [b] nonEmpty :: forall a. [a] -> GHC.Internal.Maybe.Maybe (NonEmpty a) nub :: forall a. GHC.Internal.Classes.Eq a => NonEmpty a -> NonEmpty a nubBy :: forall a. (a -> a -> GHC.Internal.Types.Bool) -> NonEmpty a -> NonEmpty a View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/cc650b4be2aea55ec0277d1ae8ffd28… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/cc650b4be2aea55ec0277d1ae8ffd28… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T26115] 3 commits: Error message changes
by Simon Peyton Jones (＠simonpj) 17 Jul '25

17 Jul '25

Simon Peyton Jones pushed to branch wip/T26115 at Glasgow Haskell Compiler / GHC Commits: 553b9080 by Simon Peyton Jones at 2025-07-17T17:09:47+01:00 Error message changes - - - - - 91333dbb by Simon Peyton Jones at 2025-07-17T17:09:47+01:00 Document use of TrySolveImplication (SF6) - - - - - 3a32ba49 by Simon Peyton Jones at 2025-07-17T17:09:47+01:00 Improve solveOneFromTheOther ...to account for rewriter sets - - - - - 10 changed files: - compiler/GHC/Tc/Solver/Equality.hs - compiler/GHC/Tc/Solver/InertSet.hs - testsuite/tests/deriving/should_fail/T12768.stderr - testsuite/tests/deriving/should_fail/T1496.stderr - testsuite/tests/deriving/should_fail/T5498.stderr - testsuite/tests/deriving/should_fail/T7148.stderr - testsuite/tests/deriving/should_fail/T7148a.stderr - testsuite/tests/roles/should_fail/RolesIArray.stderr - + testsuite/tests/simplCore/should_compile/T2117.hs - + testsuite/tests/simplCore/should_compile/T26117.stderr Changes: ===================================== compiler/GHC/Tc/Solver/Equality.hs ===================================== @@ -532,6 +532,8 @@ can_eq_nc_forall ev eq_rel s1 s2 unifyForAllBody ev (eqRelRole eq_rel) $ \uenv -> go uenv skol_tvs init_subst2 bndrs1 bndrs2 + -- Solve the implication right away, using `trySolveImplication` + -- See (SF6) in Note [Solving forall equalities] ; traceTcS "Trying to solve the implication" (ppr s1 $$ ppr s2 $$ ppr wanteds) ; ev_binds_var <- newNoTcEvBinds ; solved <- trySolveImplication $ @@ -620,6 +622,21 @@ There are lots of wrinkles of course: especially Refl ones. We use the `unifyForAllBody` wrapper for `uType`, because we want to /gather/ the equality constraint (to put in the implication) rather than /emit/ them into the monad, as `wrapUnifierTcS` does. + +(SF6) We solve the implication on the spot, using `trySolveImplication`. In + the past we instead generated an `Implication` to be solved later. Nice in + some ways but it added complexity: + - We needed a `wl_implics` field of `WorkList` to collect + these emitted implications + - The types of `solveSimpleWanteds` and friends were more complicated + - Trickily, an `EvFun` had to contain an `EvBindsVar` ref-cell, which made + `evVarsOfTerm` harder. Now an `EvFun` just contains the bindings. + The disadvantage of solve-on-the-spot is that if we fail we are simply + left with an unsolved (forall a. blah) ~ (forall b. blah), and it may + not be clear /why we couldn't solve it. But on balance the error messages + improve: it is easier to undertand that + (forall a. a->a) ~ (forall b. b->Int) + is insoluble than it is to understand a message about matching `a` with `Int`. -} {- Note [Unwrap newtypes first] @@ -2706,7 +2723,7 @@ tryInertEqs :: EqCt -> SolverStage () tryInertEqs work_item@(EqCt { eq_ev = ev, eq_eq_rel = eq_rel }) = Stage $ do { inerts <- getInertCans - ; if | Just (ev_i, swapped) <- inertsCanDischarge inerts work_item + ; if | Just (ev_i, swapped) <- inertsEqsCanDischarge inerts work_item -> do { setEvBindIfWanted ev EvCanonical $ evCoercion (maybeSymCo swapped $ downgradeRole (eqRelRole eq_rel) @@ -2717,10 +2734,10 @@ tryInertEqs work_item@(EqCt { eq_ev = ev, eq_eq_rel = eq_rel }) | otherwise -> continueWith () } -inertsCanDischarge :: InertCans -> EqCt - -> Maybe ( CtEvidence -- The evidence for the inert - , SwapFlag ) -- Whether we need mkSymCo -inertsCanDischarge inerts (EqCt { eq_lhs = lhs_w, eq_rhs = rhs_w +inertsEqsCanDischarge :: InertCans -> EqCt + -> Maybe ( CtEvidence -- The evidence for the inert + , SwapFlag ) -- Whether we need mkSymCo +inertsEqsCanDischarge inerts (EqCt { eq_lhs = lhs_w, eq_rhs = rhs_w , eq_ev = ev_w, eq_eq_rel = eq_rel }) | (ev_i : _) <- [ ev_i | EqCt { eq_ev = ev_i, eq_rhs = rhs_i , eq_eq_rel = eq_rel } @@ -2766,7 +2783,7 @@ inertsCanDischarge inerts (EqCt { eq_lhs = lhs_w, eq_rhs = rhs_w -- Prefer the one that has no rewriters -- See (CE4) in Note [Combining equalities] -inertsCanDischarge _ _ = Nothing +inertsEqsCanDischarge _ _ = Nothing ===================================== compiler/GHC/Tc/Solver/InertSet.hs ===================================== @@ -1960,6 +1960,9 @@ solveOneFromTheOther :: Ct -- Inert (Dict or Irred) -- We can always solve one from the other: even if both are wanted, -- although we don't rewrite wanteds with wanteds, we can combine -- two wanteds into one by solving one from the other +-- +-- Compare the corresponding function for equalities: +-- GHC.Tc.Solver.Equality.inertEqsCanDischarge solveOneFromTheOther ct_i ct_w | CtWanted {} <- ev_w @@ -1968,32 +1971,37 @@ solveOneFromTheOther ct_i ct_w = -- Inert must be Given KeepWork - | CtWanted {} <- ev_w + | CtWanted (WantedCt { ctev_rewriters = rw_w }) <- ev_w = -- Inert is Given or Wanted case ev_i of CtGiven {} -> KeepInert -- work is Wanted; inert is Given: easy choice. - CtWanted {} -- Both are Wanted + CtWanted (WantedCt { ctev_rewriters = rw_i }) -- Both are Wanted -- If only one has no pending superclasses, use it -- Otherwise we can get infinite superclass expansion (#22516) -- in silly cases like class C T b => C a b where ... - | not is_psc_i, is_psc_w -> KeepInert - | is_psc_i, not is_psc_w -> KeepWork + | Just res <- better (not is_psc_i) (not is_psc_w) + -> res + + -- If only one has an empty rewriter set, use it + | Just res <- better (isEmptyRewriterSet rw_i) (isEmptyRewriterSet rw_w) + -> res -- If only one is a WantedSuperclassOrigin (arising from expanding -- a Wanted class constraint), keep the other: wanted superclasses -- may be unexpected by users - | not is_wsc_orig_i, is_wsc_orig_w -> KeepInert - | is_wsc_orig_i, not is_wsc_orig_w -> KeepWork + | Just res <- better (not is_wsc_orig_i) (not is_wsc_orig_w) + -> res - -- otherwise, just choose the lower span + -- Otherwise, just choose the lower span -- reason: if we have something like (abs 1) (where the -- Num constraint cannot be satisfied), it's better to -- get an error about abs than about 1. -- This test might become more elaborate if we see an -- opportunity to improve the error messages | ((<) `on` ctLocSpan) loc_i loc_w -> KeepInert + | otherwise -> KeepWork -- From here on the work-item is Given @@ -2016,6 +2024,15 @@ solveOneFromTheOther ct_i ct_w | otherwise -- Both are Given, levels differ = different_level_strategy where + better :: Bool -> Bool -> Maybe InteractResult + -- (better inert-is-good wanted-is-good) returns + -- Just KeepWork if wanted is strictly better than inert + -- Just KeepInert if inert is strictly better than wanted + -- Nothing if they are the same + better True False = Just KeepInert + better False True = Just KeepWork + better _ _ = Nothing + ev_i = ctEvidence ct_i ev_w = ctEvidence ct_w ===================================== testsuite/tests/deriving/should_fail/T12768.stderr ===================================== @@ -1,10 +1,9 @@ -T12768.hs:9:33: error: [GHC-39999] - • Could not deduce ‘D [a]’ - arising from the head of a quantified constraint +T12768.hs:9:33: error: [GHC-05617] + • Could not deduce ‘D (N a) => + (Coercible ([a] -> [a]) (N a -> N a), D [a])’ arising from the coercion of the method ‘op’ from type ‘D [a] => [a] -> [a]’ to type ‘D (N a) => N a -> N a’ from the context: C a bound by the deriving clause for ‘C (N a)’ at T12768.hs:9:33 - or from: D (N a) bound by a quantified context at T12768.hs:9:33 • When deriving the instance for (C (N a)) ===================================== testsuite/tests/deriving/should_fail/T1496.stderr ===================================== @@ -1,11 +1,8 @@ -T1496.hs:10:32: error: [GHC-18872] - • Couldn't match representation of type: c Int - with that of: c Moo - arising from the head of a quantified constraint +T1496.hs:10:32: error: [GHC-05617] + • Could not solve: ‘forall (c :: * -> *). + Coercible (c Int -> c Int) (c Int -> c Moo)’ arising from the coercion of the method ‘isInt’ from type ‘forall (c :: * -> *). c Int -> c Int’ to type ‘forall (c :: * -> *). c Int -> c Moo’ - Note: We cannot know what roles the parameters to ‘c’ have; - we must assume that the role is nominal. • When deriving the instance for (IsInt Moo) ===================================== testsuite/tests/deriving/should_fail/T5498.stderr ===================================== @@ -1,11 +1,11 @@ -T5498.hs:30:39: error: [GHC-18872] - • Couldn't match representation of type: c a - with that of: c (Down a) - arising from the head of a quantified constraint +T5498.hs:30:39: error: [GHC-05617] + • Could not deduce ‘forall (c :: * -> *). + Coercible (c a -> c Int) (c (Down a) -> c Int)’ arising from the coercion of the method ‘intIso’ from type ‘forall (c :: * -> *). c a -> c Int’ to type ‘forall (c :: * -> *). c (Down a) -> c Int’ - Note: We cannot know what roles the parameters to ‘c’ have; - we must assume that the role is nominal. + from the context: IntIso a + bound by the deriving clause for ‘IntIso (Down a)’ + at T5498.hs:30:39-44 • When deriving the instance for (IntIso (Down a)) ===================================== testsuite/tests/deriving/should_fail/T7148.stderr ===================================== @@ -1,22 +1,13 @@ -T7148.hs:27:40: error: [GHC-25897] - • Couldn't match type ‘b’ with ‘Tagged a b’ - arising from the head of a quantified constraint - arising from the coercion of the method ‘iso2’ - from type ‘forall b1. SameType b1 () -> SameType b1 b’ - to type ‘forall b1. SameType b1 () -> SameType b1 (Tagged a b)’ - ‘b’ is a rigid type variable bound by - the deriving clause for ‘IsoUnit (Tagged a b)’ - at T7148.hs:27:40-46 - • When deriving the instance for (IsoUnit (Tagged a b)) - -T7148.hs:27:40: error: [GHC-25897] - • Couldn't match type ‘b’ with ‘Tagged a b’ - arising from the head of a quantified constraint +T7148.hs:27:40: error: [GHC-05617] + • Could not deduce ‘forall b1. + Coercible + (SameType () b1 -> SameType b b1) + (SameType () b1 -> SameType (Tagged a b) b1)’ arising from the coercion of the method ‘iso1’ from type ‘forall b1. SameType () b1 -> SameType b b1’ to type ‘forall b1. SameType () b1 -> SameType (Tagged a b) b1’ - ‘b’ is a rigid type variable bound by - the deriving clause for ‘IsoUnit (Tagged a b)’ + from the context: IsoUnit b + bound by the deriving clause for ‘IsoUnit (Tagged a b)’ at T7148.hs:27:40-46 • When deriving the instance for (IsoUnit (Tagged a b)) ===================================== testsuite/tests/deriving/should_fail/T7148a.stderr ===================================== @@ -1,13 +1,13 @@ -T7148a.hs:19:50: error: [GHC-10283] - • Couldn't match representation of type ‘b’ - with that of ‘Result a b’ - arising from the head of a quantified constraint +T7148a.hs:19:50: error: [GHC-05617] + • Could not deduce ‘forall b. + Coercible + (Proxy b -> a -> Result a b) (Proxy b -> IS_NO_LONGER a -> b)’ arising from the coercion of the method ‘coerce’ from type ‘forall b. Proxy b -> a -> Result a b’ to type ‘forall b. Proxy b -> IS_NO_LONGER a -> Result (IS_NO_LONGER a) b’ - ‘b’ is a rigid type variable bound by - a quantified context + from the context: Convert a + bound by the deriving clause for ‘Convert (IS_NO_LONGER a)’ at T7148a.hs:19:50-56 • When deriving the instance for (Convert (IS_NO_LONGER a)) ===================================== testsuite/tests/roles/should_fail/RolesIArray.stderr ===================================== @@ -1,68 +1,8 @@ -RolesIArray.hs:10:13: error: [GHC-18872] - • Couldn't match type ‘Word64’ with ‘N’ - arising from the head of a quantified constraint - arising from the coercion of the method ‘Data.Array.Base.unsafeAccumArray’ - from type ‘forall i e'. - Ix i => - (Word64 -> e' -> Word64) - -> Word64 -> (i, i) -> [(Int, e')] -> UArray i Word64’ - to type ‘forall i e'. - Ix i => - (N -> e' -> N) -> N -> (i, i) -> [(Int, e')] -> UArray i N’ - • When deriving the instance for (IArray UArray N) - -RolesIArray.hs:10:13: error: [GHC-18872] - • Couldn't match type ‘Word64’ with ‘N’ - arising from the head of a quantified constraint - arising from the coercion of the method ‘Data.Array.Base.unsafeAccum’ - from type ‘forall i e'. - Ix i => - (Word64 -> e' -> Word64) - -> UArray i Word64 -> [(Int, e')] -> UArray i Word64’ - to type ‘forall i e'. - Ix i => - (N -> e' -> N) -> UArray i N -> [(Int, e')] -> UArray i N’ - • When deriving the instance for (IArray UArray N) - -RolesIArray.hs:10:13: error: [GHC-18872] - • Couldn't match type ‘Word64’ with ‘N’ - arising from the head of a quantified constraint - arising from the coercion of the method ‘Data.Array.Base.unsafeReplace’ - from type ‘forall i. - Ix i => - UArray i Word64 -> [(Int, Word64)] -> UArray i Word64’ - to type ‘forall i. Ix i => UArray i N -> [(Int, N)] -> UArray i N’ - • When deriving the instance for (IArray UArray N) - -RolesIArray.hs:10:13: error: [GHC-18872] - • Couldn't match type ‘Word64’ with ‘N’ - arising from the head of a quantified constraint - arising from the coercion of the method ‘Data.Array.Base.unsafeAt’ - from type ‘forall i. Ix i => UArray i Word64 -> Int -> Word64’ - to type ‘forall i. Ix i => UArray i N -> Int -> N’ - • When deriving the instance for (IArray UArray N) - -RolesIArray.hs:10:13: error: [GHC-18872] - • Couldn't match type ‘Word64’ with ‘N’ - arising from the head of a quantified constraint - arising from the coercion of the method ‘Data.Array.Base.unsafeArray’ - from type ‘forall i. - Ix i => - (i, i) -> [(Int, Word64)] -> UArray i Word64’ - to type ‘forall i. Ix i => (i, i) -> [(Int, N)] -> UArray i N’ - • When deriving the instance for (IArray UArray N) - -RolesIArray.hs:10:13: error: [GHC-18872] - • Couldn't match type ‘Word64’ with ‘N’ - arising from the head of a quantified constraint - arising from the coercion of the method ‘Data.Array.Base.numElements’ - from type ‘forall i. Ix i => UArray i Word64 -> Int’ - to type ‘forall i. Ix i => UArray i N -> Int’ - • When deriving the instance for (IArray UArray N) - -RolesIArray.hs:10:13: error: [GHC-18872] - • Couldn't match type ‘Word64’ with ‘N’ - arising from the head of a quantified constraint +RolesIArray.hs:10:13: error: [GHC-05617] + • Could not solve: ‘forall i. + Ix i => + (Coercible (UArray i Word64 -> (i, i)) (UArray i N -> (i, i)), + Ix i)’ arising from the coercion of the method ‘bounds’ from type ‘forall i. Ix i => UArray i Word64 -> (i, i)’ to type ‘forall i. Ix i => UArray i N -> (i, i)’ ===================================== testsuite/tests/simplCore/should_compile/T2117.hs ===================================== @@ -0,0 +1,15 @@ +{-# LANGUAGE UndecidableInstances, TypeFamilies #-} + +module T26117 where + +type family F a +type instance F Int = Bool + +class Eq (F a) => D a b where { dop1, dop2 :: a -> b -> b } + +class C a b where { op1,op2 :: F a -> a -> b -> Int } + +instance (Eq (F a), D a b) => C a [b] where + op1 x _ _ | x==x = 3 + | otherwise = 4 + {-# SPECIALISE instance D Int b => C Int [b] #-} ===================================== testsuite/tests/simplCore/should_compile/T26117.stderr ===================================== @@ -0,0 +1,433 @@ +T26117.hs:17:10: warning: [GHC-06201] [-Wmissing-methods (in -Wdefault)] + • No explicit implementation for + ‘op2’ + • In the instance declaration for ‘C a [b]’ + + +==================== Tidy Core ==================== +Result size of Tidy Core + = {terms: 196, types: 296, coercions: 2, joins: 0/0} + +-- RHS size: {terms: 7, types: 18, coercions: 0, joins: 0/0} +op1 [InlPrag=[~]] :: forall a b. C a b => F a -> a -> b -> Int +[GblId[ClassOp], + Arity=1, + Str=<S!P(SL,A)>, + Unf=Unf{Src=StableSystem, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=ALWAYS_IF(arity=1,unsat_ok=False,boring_ok=False) + Tmpl= \ (@a) (@b) (v [Occ=Once1!] :: C a b) -> + case v of { T26117.C:C v2 [Occ=Once1] _ [Occ=Dead] -> v2 }}] +op1 + = \ (@a) (@b) (v :: C a b) -> + case v of v1 { T26117.C:C v2 v3 -> v2 } + +-- RHS size: {terms: 7, types: 18, coercions: 0, joins: 0/0} +op2 [InlPrag=[~]] :: forall a b. C a b => F a -> a -> b -> Int +[GblId[ClassOp], + Arity=1, + Str=<S!P(A,SL)>, + Unf=Unf{Src=StableSystem, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=ALWAYS_IF(arity=1,unsat_ok=False,boring_ok=False) + Tmpl= \ (@a) (@b) (v [Occ=Once1!] :: C a b) -> + case v of { T26117.C:C _ [Occ=Dead] v3 [Occ=Once1] -> v3 }}] +op2 + = \ (@a) (@b) (v :: C a b) -> + case v of v1 { T26117.C:C v2 v3 -> v3 } + +-- RHS size: {terms: 7, types: 17, coercions: 0, joins: 0/0} +T26117.$p1D [InlPrag=[~]] :: forall a b. D a b => Eq (F a) +[GblId[ClassOp], + Arity=1, + Str=<S!P(SL,A,A)>, + Unf=Unf{Src=StableSystem, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=ALWAYS_IF(arity=1,unsat_ok=False,boring_ok=False) + Tmpl= \ (@a) (@b) (v [Occ=Once1!] :: D a b) -> + case v of { T26117.C:D v2 [Occ=Once1] _ [Occ=Dead] _ [Occ=Dead] -> + v2 + }}] +T26117.$p1D + = \ (@a) (@b) (v :: D a b) -> + case v of v1 { T26117.C:D v2 v3 v4 -> v2 } + +-- RHS size: {terms: 7, types: 17, coercions: 0, joins: 0/0} +dop1 [InlPrag=[~]] :: forall a b. D a b => a -> b -> b +[GblId[ClassOp], + Arity=1, + Str=<S!P(A,SL,A)>, + Unf=Unf{Src=StableSystem, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=ALWAYS_IF(arity=1,unsat_ok=False,boring_ok=False) + Tmpl= \ (@a) (@b) (v [Occ=Once1!] :: D a b) -> + case v of { T26117.C:D _ [Occ=Dead] v3 [Occ=Once1] _ [Occ=Dead] -> + v3 + }}] +dop1 + = \ (@a) (@b) (v :: D a b) -> + case v of v1 { T26117.C:D v2 v3 v4 -> v3 } + +-- RHS size: {terms: 7, types: 17, coercions: 0, joins: 0/0} +dop2 [InlPrag=[~]] :: forall a b. D a b => a -> b -> b +[GblId[ClassOp], + Arity=1, + Str=<S!P(A,A,SL)>, + Unf=Unf{Src=StableSystem, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=ALWAYS_IF(arity=1,unsat_ok=False,boring_ok=False) + Tmpl= \ (@a) (@b) (v [Occ=Once1!] :: D a b) -> + case v of { T26117.C:D _ [Occ=Dead] _ [Occ=Dead] v4 [Occ=Once1] -> + v4 + }}] +dop2 + = \ (@a) (@b) (v :: D a b) -> + case v of v1 { T26117.C:D v2 v3 v4 -> v4 } + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +T26117.$fCaList1 :: GHC.Internal.Prim.Addr# +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=IF_ARGS [] 70 0}] +T26117.$fCaList1 = "T26117.hs:17:10-37|\CANop2\EM"# + +-- RHS size: {terms: 6, types: 15, coercions: 0, joins: 0/0} +T26117.$fCaList_$cop2 [InlPrag=[2]] + :: forall a b. (Eq (F a), D a b) => F a -> a -> [b] -> Int +[GblId, + Arity=2, + Str=<B><B>b, + Cpr=b, + Unf=Unf{Src=StableSystem, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=ALWAYS_IF(arity=2,unsat_ok=True,boring_ok=True) + Tmpl= \ (@a) (@b) _ [Occ=Dead] _ [Occ=Dead] -> + GHC.Internal.Control.Exception.Base.noMethodBindingError + @GHC.Internal.Types.LiftedRep + @(F a -> a -> [b] -> Int) + T26117.$fCaList1}] +T26117.$fCaList_$cop2 + = \ (@a) (@b) _ [Occ=Dead] _ [Occ=Dead] -> + GHC.Internal.Control.Exception.Base.noMethodBindingError + @GHC.Internal.Types.LiftedRep + @(F a -> a -> [b] -> Int) + T26117.$fCaList1 + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +T26117.$fCaList3 :: Int +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=IF_ARGS [] 10 10}] +T26117.$fCaList3 = GHC.Internal.Types.I# 4# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +T26117.$fCaList2 :: Int +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=IF_ARGS [] 10 10}] +T26117.$fCaList2 = GHC.Internal.Types.I# 3# + +-- RHS size: {terms: 8, types: 7, coercions: 2, joins: 0/0} +lvl :: forall b. F Int -> Int -> [b] -> Int +[GblId, Arity=3, Str=<1A><A><A>, Cpr=1, Unf=OtherCon []] +lvl + = \ (@b) (x :: F Int) _ [Occ=Dead] _ [Occ=Dead] -> + case x `cast` (Sub T26117.D:R:FInt :: F Int ~R# Bool) of lwild + { __DEFAULT -> + T26117.$fCaList2 + } + +-- RHS size: {terms: 3, types: 8, coercions: 0, joins: 0/0} +lvl1 :: forall b. F Int -> Int -> [b] -> Int +[GblId, Str=b, Cpr=b] +lvl1 + = \ (@b) -> + GHC.Internal.Control.Exception.Base.noMethodBindingError + @GHC.Internal.Types.LiftedRep + @(F Int -> Int -> [b] -> Int) + T26117.$fCaList1 + +-- RHS size: {terms: 4, types: 6, coercions: 0, joins: 0/0} +lvl2 :: forall b. C Int [b] +[GblId, Unf=OtherCon []] +lvl2 = \ (@b) -> T26117.C:C @Int @[b] (lvl @b) (lvl1 @b) + +-- RHS size: {terms: 3, types: 5, coercions: 0, joins: 0/0} +T26117.$fCaList_$s$fCaList [InlPrag=CONLIKE] + :: forall b. D Int b => C Int [b] +[GblId[DFunId], + Arity=1, + Str=<A>, + Unf=DFun: \ (@b) ($dD :: D Int b) -> + T26117.C:C TYPE: Int + TYPE: [b] + \ (x :: F Int) _ [Occ=Dead] _ [Occ=Dead] -> + case GHC.Internal.Prim.dataToTagSmall# + @GHC.Internal.Types.Lifted + @Bool + (x `cast` (Sub T26117.D:R:FInt :: F Int ~R# Bool)) + of a# [Occ=Once1] + { __DEFAULT -> + case GHC.Internal.Prim.dataToTagSmall# + @GHC.Internal.Types.Lifted + @Bool + (x `cast` (Sub T26117.D:R:FInt :: F Int ~R# Bool)) + of b# [Occ=Once1] + { __DEFAULT -> + case GHC.Internal.Prim.==# a# b# of { + __DEFAULT -> GHC.Internal.Types.I# 4#; + 1# -> GHC.Internal.Types.I# 3# + } + } + } + GHC.Internal.Control.Exception.Base.noMethodBindingError + @GHC.Internal.Types.LiftedRep + @(F Int -> Int -> [b] -> Int) + "T26117.hs:17:10-37|\CANop2\EM"#] +T26117.$fCaList_$s$fCaList = \ (@b) _ [Occ=Dead] -> lvl2 @b + +-- RHS size: {terms: 4, types: 9, coercions: 0, joins: 0/0} +lvl3 :: forall b a. F a -> a -> [b] -> Int +[GblId, Str=b, Cpr=b] +lvl3 + = \ (@b) (@a) -> + GHC.Internal.Control.Exception.Base.noMethodBindingError + @GHC.Internal.Types.LiftedRep + @(F a -> a -> [b] -> Int) + T26117.$fCaList1 + +-- RHS size: {terms: 18, types: 21, coercions: 0, joins: 0/0} +T26117.$fCaList [InlPrag=CONLIKE] + :: forall a b. (Eq (F a), D a b) => C a [b] +[GblId[DFunId], + Arity=2, + Str=<LP(SC(S,C(1,L)),A)><A>, + Unf=DFun: \ (@a) (@b) (v :: Eq (F a)) (v1 :: D a b) -> + T26117.C:C TYPE: a + TYPE: [b] + \ (x :: F a) _ [Occ=Dead] _ [Occ=Dead] -> + case == @(F a) v x x of { + False -> T26117.$fCaList3; + True -> T26117.$fCaList2 + } + T26117.$fCaList_$cop2 @a @b v v1] +T26117.$fCaList + = \ (@a) (@b) ($dEq :: Eq (F a)) _ [Occ=Dead] -> + T26117.C:C + @a + @[b] + (\ (x :: F a) _ [Occ=Dead] _ [Occ=Dead] -> + case == @(F a) $dEq x x of { + False -> T26117.$fCaList3; + True -> T26117.$fCaList2 + }) + (lvl3 @b @a) + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +T26117.$trModule4 :: GHC.Internal.Prim.Addr# +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=IF_ARGS [] 20 0}] +T26117.$trModule4 = "main"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +T26117.$trModule3 :: GHC.Internal.Types.TrName +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=IF_ARGS [] 10 10}] +T26117.$trModule3 = GHC.Internal.Types.TrNameS T26117.$trModule4 + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +T26117.$trModule2 :: GHC.Internal.Prim.Addr# +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=IF_ARGS [] 30 0}] +T26117.$trModule2 = "T26117"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +T26117.$trModule1 :: GHC.Internal.Types.TrName +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=IF_ARGS [] 10 10}] +T26117.$trModule1 = GHC.Internal.Types.TrNameS T26117.$trModule2 + +-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} +T26117.$trModule :: GHC.Internal.Types.Module +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=IF_ARGS [] 10 10}] +T26117.$trModule + = GHC.Internal.Types.Module T26117.$trModule3 T26117.$trModule1 + +-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} +$krep :: GHC.Internal.Types.KindRep +[GblId, Unf=OtherCon []] +$krep + = GHC.Internal.Types.KindRepFun + GHC.Internal.Types.krep$* GHC.Internal.Types.krep$Constraint + +-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} +T26117.$tcC1 [InlPrag=[~]] :: GHC.Internal.Types.KindRep +[GblId, Unf=OtherCon []] +T26117.$tcC1 + = GHC.Internal.Types.KindRepFun GHC.Internal.Types.krep$* $krep + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +$krep1 :: GHC.Internal.Types.KindRep +[GblId, Unf=OtherCon []] +$krep1 = GHC.Internal.Types.KindRepVar 1# + +-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} +$krep2 :: GHC.Internal.Types.KindRep +[GblId, Unf=OtherCon []] +$krep2 = GHC.Internal.Types.KindRepFun $krep1 $krep1 + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +$krep3 :: GHC.Internal.Types.KindRep +[GblId, Unf=OtherCon []] +$krep3 = GHC.Internal.Types.KindRepVar 0# + +-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} +$krep4 :: GHC.Internal.Types.KindRep +[GblId, Unf=OtherCon []] +$krep4 = GHC.Internal.Types.KindRepFun $krep3 $krep2 + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +T26117.$tcD2 :: GHC.Internal.Prim.Addr# +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=IF_ARGS [] 20 0}] +T26117.$tcD2 = "D"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +T26117.$tcD1 :: GHC.Internal.Types.TrName +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=IF_ARGS [] 10 10}] +T26117.$tcD1 = GHC.Internal.Types.TrNameS T26117.$tcD2 + +-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0} +T26117.$tcD :: GHC.Internal.Types.TyCon +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=IF_ARGS [] 10 10}] +T26117.$tcD + = GHC.Internal.Types.TyCon + 18427868686024955676#Word64 + 4087453451394481638#Word64 + T26117.$trModule + T26117.$tcD1 + 0# + T26117.$tcC1 + +-- RHS size: {terms: 3, types: 2, coercions: 0, joins: 0/0} +$krep5 :: [GHC.Internal.Types.KindRep] +[GblId, Unf=OtherCon []] +$krep5 + = GHC.Internal.Types.: + @GHC.Internal.Types.KindRep + $krep1 + (GHC.Internal.Types.[] @GHC.Internal.Types.KindRep) + +-- RHS size: {terms: 3, types: 1, coercions: 0, joins: 0/0} +$krep6 :: [GHC.Internal.Types.KindRep] +[GblId, Unf=OtherCon []] +$krep6 + = GHC.Internal.Types.: @GHC.Internal.Types.KindRep $krep3 $krep5 + +-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} +$krep7 :: GHC.Internal.Types.KindRep +[GblId, Unf=OtherCon []] +$krep7 = GHC.Internal.Types.KindRepTyConApp T26117.$tcD $krep6 + +-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} +$krep8 :: GHC.Internal.Types.KindRep +[GblId, Unf=OtherCon []] +$krep8 = GHC.Internal.Types.KindRepFun $krep4 $krep7 + +-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} +T26117.$tc'C:D1 [InlPrag=[~]] :: GHC.Internal.Types.KindRep +[GblId, Unf=OtherCon []] +T26117.$tc'C:D1 = GHC.Internal.Types.KindRepFun $krep4 $krep8 + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +T26117.$tc'C:D3 :: GHC.Internal.Prim.Addr# +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=IF_ARGS [] 20 0}] +T26117.$tc'C:D3 = "'C:D"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +T26117.$tc'C:D2 :: GHC.Internal.Types.TrName +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=IF_ARGS [] 10 10}] +T26117.$tc'C:D2 = GHC.Internal.Types.TrNameS T26117.$tc'C:D3 + +-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0} +T26117.$tc'C:D :: GHC.Internal.Types.TyCon +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=IF_ARGS [] 10 10}] +T26117.$tc'C:D + = GHC.Internal.Types.TyCon + 14714477993590114477#Word64 + 17388374250742016296#Word64 + T26117.$trModule + T26117.$tc'C:D2 + 2# + T26117.$tc'C:D1 + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +T26117.$tcC3 :: GHC.Internal.Prim.Addr# +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=IF_ARGS [] 20 0}] +T26117.$tcC3 = "C"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +T26117.$tcC2 :: GHC.Internal.Types.TrName +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=IF_ARGS [] 10 10}] +T26117.$tcC2 = GHC.Internal.Types.TrNameS T26117.$tcC3 + +-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0} +T26117.$tcC :: GHC.Internal.Types.TyCon +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=IF_ARGS [] 10 10}] +T26117.$tcC + = GHC.Internal.Types.TyCon + 6116531860557468422#Word64 + 17953227584944457497#Word64 + T26117.$trModule + T26117.$tcC2 + 0# + T26117.$tcC1 + + +------ Local rules for imported ids -------- +"USPEC $fCaList @Int @_" + forall (@b) ($dD :: D Int b) ($dEq :: Eq (F Int)). + T26117.$fCaList @Int @b $dEq $dD + = T26117.$fCaList_$s$fCaList @b $dD + + View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c8241b8a27c5682347d3923453996a… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c8241b8a27c5682347d3923453996a… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/fendor/backtraces-decoders
by Hannes Siebenhandl (＠fendor) 17 Jul '25

17 Jul '25

Hannes Siebenhandl pushed new branch wip/fendor/backtraces-decoders at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/fendor/backtraces-decoders You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/andreask/llvm-check
by Andreas Klebinger (＠AndreasK) 17 Jul '25

17 Jul '25

Andreas Klebinger pushed new branch wip/andreask/llvm-check at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/andreask/llvm-check You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/fendor/ann-frame] 3 commits: WIP: Introduce stack frame annotation helpers and extend ghc-heap stack decoder
by Hannes Siebenhandl (＠fendor) 17 Jul '25

17 Jul '25

Hannes Siebenhandl pushed to branch wip/fendor/ann-frame at Glasgow Haskell Compiler / GHC Commits: d4002865 by fendor at 2025-07-17T15:24:57+02:00 WIP: Introduce stack frame annotation helpers and extend ghc-heap stack decoder - - - - - bf1f28d0 by fendor at 2025-07-17T15:25:01+02:00 WIP: base: extend Backtraces to allow configuration of stack decoders - - - - - 7235ceab by fendor at 2025-07-17T15:25:02+02:00 WIP: move iterator based stack decoder to ghc-internal - - - - - 25 changed files: - libraries/ghc-experimental/src/GHC/Stack/Annotation/Experimental.hs - libraries/ghc-heap/GHC/Exts/Heap/InfoTable.hsc - libraries/ghc-heap/GHC/Exts/Stack/Decode.hs - libraries/ghc-heap/cbits/Stack.cmm - libraries/ghc-heap/tests/stack-annotation/all.T - libraries/ghc-heap/tests/stack-annotation/ann_frame001.hs - libraries/ghc-heap/tests/stack-annotation/ann_frame002.hs - libraries/ghc-heap/tests/stack-annotation/ann_frame002.stdout - + libraries/ghc-heap/tests/stack-annotation/ann_frame003.hs - + libraries/ghc-heap/tests/stack-annotation/ann_frame004.hs - + libraries/ghc-internal/cbits/HeapPrim.cmm - + libraries/ghc-internal/cbits/Stack.cmm - + libraries/ghc-internal/cbits/Stack_c.c - libraries/ghc-internal/ghc-internal.cabal.in - libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs - + libraries/ghc-internal/src/GHC/Internal/Heap/Closures.hs - + libraries/ghc-internal/src/GHC/Internal/Heap/Constants.hsc - + libraries/ghc-internal/src/GHC/Internal/Heap/InfoTable.hsc - + libraries/ghc-internal/src/GHC/Internal/Heap/InfoTable/Types.hsc - + libraries/ghc-internal/src/GHC/Internal/Heap/InfoTableProf.hsc - + libraries/ghc-internal/src/GHC/Internal/Heap/ProfInfo/Types.hs - + libraries/ghc-internal/src/GHC/Internal/Stack/Annotation.hs - libraries/ghc-internal/src/GHC/Internal/Stack/CloneStack.hs - + libraries/ghc-internal/src/GHC/Internal/Stack/Constants.hsc - + libraries/ghc-internal/src/GHC/Internal/Stack/Decode.hs Changes: ===================================== libraries/ghc-experimental/src/GHC/Stack/Annotation/Experimental.hs ===================================== @@ -3,65 +3,93 @@ {-# LANGUAGE MagicHash #-} {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE ImplicitParams #-} -module GHC.Stack.Annotation.Experimental where +module GHC.Stack.Annotation.Experimental ( + IsStackAnnotation(..), + SomeStackAnnotation(..), + -- * Source Location annotations + SrcLocAnnotation, + UnknownSrcLocAnnotation, + -- * Stack annotations + annotateStack, + annotateShow, + annotateCallStack, + annotateStackM, + annotateStringM, + annotateStackShowM, + annotateCallStackM, + ) where import Data.Typeable import GHC.Exts import GHC.IO -import GHC.Internal.Stack.Types +import GHC.Internal.Stack +import GHC.Internal.Stack.Annotation -data StackAnnotation where - StackAnnotation :: forall a. (Typeable a, Show a) => a -> StackAnnotation +data StringAnnotation where + StringAnnotation :: String -> StringAnnotation -class IsStackAnnotation a where - display :: a -> String +instance IsStackAnnotation StringAnnotation where + displayStackAnnotation (StringAnnotation str) = str -instance IsStackAnnotation StackAnnotation where - display (StackAnnotation a) = show a +-- ---------------------------------------------------------------------------- +-- Source location annotations +-- ---------------------------------------------------------------------------- -newtype SrcLocAnno = MkSrcLocAnno SrcLoc +newtype SrcLocAnnotation = SrcLocAnnotation SrcLoc -data UnknownSrcLocAnno = UnknownSrcLocAnno +data UnknownSrcLocAnnotation = UnknownSrcLocAnnotation deriving Show -instance Show SrcLocAnno where - show (MkSrcLocAnno l) = - concat - [ srcLocPackage l - , ":" - , srcLocModule l - , " " - , srcLocFile l - , ":" - , show $ srcLocStartLine l - , "-" - , show $ srcLocStartCol l - , ":" - , show $ srcLocEndLine l - , "-" - , show $ srcLocEndCol l - ] - -instance IsStackAnnotation SrcLocAnno where - display = show - -instance IsStackAnnotation UnknownSrcLocAnno where - display UnknownSrcLocAnno = "UnknownSrcLocAnno" +instance Show SrcLocAnnotation where + show (SrcLocAnnotation l) = prettySrcLoc l + +instance IsStackAnnotation SrcLocAnnotation where + displayStackAnnotation = show + +instance IsStackAnnotation UnknownSrcLocAnnotation where + displayStackAnnotation UnknownSrcLocAnnotation = "<no location info>" + +-- ---------------------------------------------------------------------------- +-- Annotate the CallStack! +-- ---------------------------------------------------------------------------- {-# NOINLINE annotateStack #-} -annotateStack :: forall a b. (Typeable a, Show a) => a -> b -> b +-- TODO @fendor: it seems the pure interface doesnt work, +-- investigate more and then decide what to do +annotateStack :: forall a b. (Typeable a, IsStackAnnotation a) => a -> b -> b annotateStack ann b = unsafePerformIO $ annotateStackM ann (pure b) -annotateStackM :: forall a b . (Typeable a, Show a) => a -> IO b -> IO b +{-# NOINLINE annotateCallStack #-} +-- TODO @fendor: it seems the pure interface doesnt work, +-- investigate more and then decide what to do +annotateCallStack :: HasCallStack => b -> b +annotateCallStack b = unsafePerformIO $ + annotateCallStackM (pure b) + +-- TODO @fendor: it seems the pure interface doesnt work, +-- investigate more and then decide what to do +annotateShow :: forall a b . (Typeable a, Show a) => a -> b -> b +annotateShow ann = + annotateStack (StringAnnotation $ show ann) + +annotateStackM :: forall a b . (Typeable a, IsStackAnnotation a) => a -> IO b -> IO b annotateStackM ann (IO act) = - IO $ \s -> annotateStack# (StackAnnotation ann) act s + IO $ \s -> annotateStack# (SomeStackAnnotation ann) act s + +annotateStringM :: forall b . String -> IO b -> IO b +annotateStringM ann = + annotateStackM (StringAnnotation ann) + +annotateStackShowM :: forall a b . (Typeable a, Show a) => a -> IO b -> IO b +annotateStackShowM ann = + annotateStringM (show ann) annotateCallStackM :: HasCallStack => IO a -> IO a annotateCallStackM act = let cs = getCallStack ?callStack in case cs of - [] -> annotateStackM UnknownSrcLocAnno act - [(_, srcLoc)] -> annotateStackM (MkSrcLocAnno srcLoc) act - (_:(_, srcLoc):_) -> annotateStackM (MkSrcLocAnno srcLoc) act + [] -> annotateStackM UnknownSrcLocAnnotation act + [(_, srcLoc)] -> annotateStackM (SrcLocAnnotation srcLoc) act + (_:(_, srcLoc):_) -> annotateStackM (SrcLocAnnotation srcLoc) act ===================================== libraries/ghc-heap/GHC/Exts/Heap/InfoTable.hsc ===================================== @@ -24,7 +24,7 @@ import Foreign -- | Read an InfoTable from the heap into a haskell type. -- WARNING: This code assumes it is passed a pointer to a "standard" info --- table. If tables_next_to_code is enabled, it will look 1 byte before the +-- table. If tables_next_to_code is disabled, it will look 1 word before the -- start for the entry field. peekItbl :: Ptr StgInfoTable -> IO StgInfoTable peekItbl a0 = do ===================================== libraries/ghc-heap/GHC/Exts/Stack/Decode.hs ===================================== @@ -15,6 +15,7 @@ module GHC.Exts.Stack.Decode ( decodeStack, + decodeStackWithIpe, ) where @@ -23,10 +24,10 @@ import Data.Bits import Data.Maybe import Foreign import GHC.Exts -import GHC.Exts.Heap (Box (..)) import GHC.Exts.Heap.ClosureTypes import GHC.Exts.Heap.Closures - ( StackFrame, + ( Box (..), + StackFrame, GenStackFrame (..), StgStackClosure, GenStgStackClosure (..), @@ -36,6 +37,7 @@ import GHC.Exts.Heap.Closures import GHC.Exts.Heap.Constants (wORD_SIZE_IN_BITS) import GHC.Exts.Heap.InfoTable import GHC.Exts.Stack.Constants +import qualified GHC.Internal.InfoProv.Types as IPE import GHC.Stack.CloneStack import GHC.Word import Prelude @@ -150,14 +152,17 @@ foreign import prim "getSmallBitmapzh" getSmallBitmap# :: SmallBitmapGetter foreign import prim "getRetFunSmallBitmapzh" getRetFunSmallBitmap# :: SmallBitmapGetter -foreign import prim "getInfoTableAddrzh" getInfoTableAddr# :: StackSnapshot# -> Word# -> Addr# +foreign import prim "getInfoTableAddrszh" getInfoTableAddrs# :: StackSnapshot# -> Word# -> (# Addr#, Addr# #) foreign import prim "getStackInfoTableAddrzh" getStackInfoTableAddr# :: StackSnapshot# -> Addr# -getInfoTableOnStack :: StackSnapshot# -> WordOffset -> IO StgInfoTable +-- | Get the 'StgInfoTable' of the stack frame. +-- Additionally, provides 'IPE.InfoProv' for the 'StgInfoTable' if there is any. +getInfoTableOnStack :: StackSnapshot# -> WordOffset -> IO (StgInfoTable, Maybe IPE.InfoProv) getInfoTableOnStack stackSnapshot# index = - let infoTablePtr = Ptr (getInfoTableAddr# stackSnapshot# (wordOffsetToWord# index)) - in peekItbl infoTablePtr + let !(# itbl_struct#, itbl_ptr# #) = getInfoTableAddrs# stackSnapshot# (wordOffsetToWord# index) + in + (,) <$> peekItbl (Ptr itbl_struct#) <*> IPE.lookupIPE (Ptr itbl_ptr#) getInfoTableForStack :: StackSnapshot# -> IO StgInfoTable getInfoTableForStack stackSnapshot# = @@ -276,18 +281,49 @@ decodeSmallBitmap getterFun# stackSnapshot# index relativePayloadOffset = (bitmapWordPointerness size bitmap) unpackStackFrame :: StackFrameLocation -> IO StackFrame -unpackStackFrame (StackSnapshot stackSnapshot#, index) = do - info <- getInfoTableOnStack stackSnapshot# index +unpackStackFrame stackFrameLoc = do + unpackStackFrameTo stackFrameLoc + (\ info nextChunk -> do + stackClosure <- decodeStack nextChunk + pure $ + UnderflowFrame + { info_tbl = info, + nextChunk = stackClosure + } + ) + (\ frame _ -> pure frame) + +unpackStackFrameWithIpe :: StackFrameLocation -> IO [(StackFrame, Maybe IPE.InfoProv)] +unpackStackFrameWithIpe stackFrameLoc = do + unpackStackFrameTo stackFrameLoc + (\ _ nextChunk -> do + decodeStackWithIpe nextChunk + ) + (\ frame mIpe -> pure [(frame, mIpe)]) + +unpackStackFrameTo :: + StackFrameLocation -> + (StgInfoTable -> StackSnapshot -> IO a) -> + (StackFrame -> Maybe IPE.InfoProv -> IO a) -> + IO a +unpackStackFrameTo (StackSnapshot stackSnapshot#, index) unpackUnderflowFrame finaliseStackFrame = do + (info, m_info_prov) <- getInfoTableOnStack stackSnapshot# index unpackStackFrame' info + unpackUnderflowFrame + (`finaliseStackFrame` m_info_prov) where - unpackStackFrame' :: StgInfoTable -> IO StackFrame - unpackStackFrame' info = + unpackStackFrame' :: + StgInfoTable -> + (StgInfoTable -> StackSnapshot -> IO a) -> + (StackFrame -> IO a) -> + IO a + unpackStackFrame' info unpackUnderflowFrame mkStackFrameResult = case tipe info of RET_BCO -> do let bco' = getClosureBox stackSnapshot# (index + offsetStgClosurePayload) -- The arguments begin directly after the payload's one element bcoArgs' <- decodeLargeBitmap getBCOLargeBitmap# stackSnapshot# index (offsetStgClosurePayload + 1) - pure + mkStackFrameResult RetBCO { info_tbl = info, bco = bco', @@ -296,14 +332,14 @@ unpackStackFrame (StackSnapshot stackSnapshot#, index) = do RET_SMALL -> let payload' = decodeSmallBitmap getSmallBitmap# stackSnapshot# index offsetStgClosurePayload in - pure $ + mkStackFrameResult $ RetSmall { info_tbl = info, stack_payload = payload' } RET_BIG -> do payload' <- decodeLargeBitmap getLargeBitmap# stackSnapshot# index offsetStgClosurePayload - pure $ + mkStackFrameResult $ RetBig { info_tbl = info, stack_payload = payload' @@ -315,7 +351,7 @@ unpackStackFrame (StackSnapshot stackSnapshot#, index) = do if isArgGenBigRetFunType stackSnapshot# index == True then decodeLargeBitmap getRetFunLargeBitmap# stackSnapshot# index offsetStgRetFunFramePayload else pure $ decodeSmallBitmap getRetFunSmallBitmap# stackSnapshot# index offsetStgRetFunFramePayload - pure $ + mkStackFrameResult $ RetFun { info_tbl = info, retFunSize = retFunSize', @@ -325,31 +361,26 @@ unpackStackFrame (StackSnapshot stackSnapshot#, index) = do UPDATE_FRAME -> let updatee' = getClosureBox stackSnapshot# (index + offsetStgUpdateFrameUpdatee) in - pure $ + mkStackFrameResult $ UpdateFrame { info_tbl = info, updatee = updatee' } CATCH_FRAME -> do let handler' = getClosureBox stackSnapshot# (index + offsetStgCatchFrameHandler) - pure $ + mkStackFrameResult $ CatchFrame { info_tbl = info, handler = handler' } UNDERFLOW_FRAME -> do let nextChunk' = getUnderflowFrameNextChunk stackSnapshot# index - stackClosure <- decodeStack nextChunk' - pure $ - UnderflowFrame - { info_tbl = info, - nextChunk = stackClosure - } - STOP_FRAME -> pure $ StopFrame {info_tbl = info} + unpackUnderflowFrame info nextChunk' + STOP_FRAME -> mkStackFrameResult $ StopFrame {info_tbl = info} ATOMICALLY_FRAME -> do let atomicallyFrameCode' = getClosureBox stackSnapshot# (index + offsetStgAtomicallyFrameCode) result' = getClosureBox stackSnapshot# (index + offsetStgAtomicallyFrameResult) - pure $ + mkStackFrameResult $ AtomicallyFrame { info_tbl = info, atomicallyFrameCode = atomicallyFrameCode', @@ -360,7 +391,7 @@ unpackStackFrame (StackSnapshot stackSnapshot#, index) = do first_code' = getClosureBox stackSnapshot# (index + offsetStgCatchRetryFrameRunningFirstCode) alt_code' = getClosureBox stackSnapshot# (index + offsetStgCatchRetryFrameAltCode) in - pure $ + mkStackFrameResult $ CatchRetryFrame { info_tbl = info, running_alt_code = running_alt_code', @@ -371,7 +402,7 @@ unpackStackFrame (StackSnapshot stackSnapshot#, index) = do let catchFrameCode' = getClosureBox stackSnapshot# (index + offsetStgCatchSTMFrameCode) handler' = getClosureBox stackSnapshot# (index + offsetStgCatchSTMFrameHandler) in - pure $ + mkStackFrameResult $ CatchStmFrame { info_tbl = info, catchFrameCode = catchFrameCode', @@ -380,7 +411,7 @@ unpackStackFrame (StackSnapshot stackSnapshot#, index) = do ANN_FRAME -> let annotation = getClosureBox stackSnapshot# (index + offsetStgAnnFrameAnn) in - pure $ + mkStackFrameResult $ AnnFrame { info_tbl = info, annotation = annotation @@ -410,19 +441,27 @@ type StackFrameLocation = (StackSnapshot, WordOffset) -- -- See /Note [Decoding the stack]/. decodeStack :: StackSnapshot -> IO StgStackClosure -decodeStack (StackSnapshot stack#) = do +decodeStack snapshot@(StackSnapshot stack#) = do + (stackInfo, ssc_stack) <- decodeStackWithFrameUnpack unpackStackFrame snapshot + pure + GenStgStackClosure + { ssc_info = stackInfo, + ssc_stack_size = getStackFields stack#, + ssc_stack = ssc_stack + } + +decodeStackWithIpe :: StackSnapshot -> IO [(StackFrame, Maybe IPE.InfoProv)] +decodeStackWithIpe snapshot = + concat . snd <$> decodeStackWithFrameUnpack unpackStackFrameWithIpe snapshot + +decodeStackWithFrameUnpack :: (StackFrameLocation -> IO a) -> StackSnapshot -> IO (StgInfoTable, [a]) +decodeStackWithFrameUnpack unpackFrame (StackSnapshot stack#) = do info <- getInfoTableForStack stack# case tipe info of STACK -> do - let stack_size' = getStackFields stack# - sfls = stackFrameLocations stack# - stack' <- mapM unpackStackFrame sfls - pure $ - GenStgStackClosure - { ssc_info = info, - ssc_stack_size = stack_size', - ssc_stack = stack' - } + let sfls = stackFrameLocations stack# + stack' <- mapM unpackFrame sfls + pure (info, stack') _ -> error $ "Expected STACK closure, got " ++ show info where stackFrameLocations :: StackSnapshot# -> [StackFrameLocation] ===================================== libraries/ghc-heap/cbits/Stack.cmm ===================================== @@ -146,14 +146,14 @@ isArgGenBigRetFunTypezh(P_ stack, W_ offsetWords) { return (type); } -// (StgInfoTable*) getInfoTableAddrzh(StgStack* stack, StgWord offsetWords) -getInfoTableAddrzh(P_ stack, W_ offsetWords) { - P_ p, info; +// (StgInfoTable*, StgInfoTable*) getInfoTableAddrszh(StgStack* stack, StgWord offsetWords) +getInfoTableAddrszh(P_ stack, W_ offsetWords) { + P_ p, info_struct, info_ptr; p = StgStack_sp(stack) + WDS(offsetWords); ASSERT(LOOKS_LIKE_CLOSURE_PTR(p)); - info = %GET_STD_INFO(UNTAG(p)); - - return (info); + info_struct = %GET_STD_INFO(UNTAG(p)); + info_ptr = %INFO_PTR(UNTAG(p)); + return (info_struct, info_ptr); } // (StgInfoTable*) getStackInfoTableAddrzh(StgStack* stack) ===================================== libraries/ghc-heap/tests/stack-annotation/all.T ===================================== @@ -1,2 +1,4 @@ test('ann_frame001', normal, compile_and_run, ['']) test('ann_frame002', normal, compile_and_run, ['']) +test('ann_frame003', normal, compile_and_run, ['']) +test('ann_frame004', normal, compile_and_run, ['']) ===================================== libraries/ghc-heap/tests/stack-annotation/ann_frame001.hs ===================================== @@ -7,7 +7,7 @@ import System.IO.Unsafe import Unsafe.Coerce hello :: Int -> Int -> Int -hello x y = annotateStack (x,y) $ +hello x y = annotateShow (x,y) $ decodeAndPrintAnnotationFrames $! x + y + 42 {-# OPAQUE hello #-} @@ -17,9 +17,9 @@ decodeAndPrintAnnotationFrames :: a -> a decodeAndPrintAnnotationFrames a = unsafePerformIO $ do stack <- GHC.Stack.CloneStack.cloneMyStack decoded <- GHC.Exts.Stack.Decode.decodeStack stack - print [ show a + print [ displayStackAnnotation a | Closures.AnnFrame _ (Box ann) <- Closures.ssc_stack decoded - , StackAnnotation a <- pure $ unsafeCoerce ann + , SomeStackAnnotation a <- pure $ unsafeCoerce ann ] pure a @@ -30,13 +30,13 @@ main = do {-# INLINE tailCallEx #-} tailCallEx :: Int -> Int -> Int -tailCallEx a b = annotateStack "tailCallEx" $ foo a b +tailCallEx a b = annotateShow "tailCallEx" $ foo a b {-# INLINE foo #-} foo :: Int -> Int -> Int -foo a b = annotateStack "foo" $ bar $ a * b +foo a b = annotateShow "foo" $ bar $ a * b -bar c = annotateStack "bar" $ +bar c = annotateShow "bar" $ decodeAndPrintAnnotationFrames $ c + c ===================================== libraries/ghc-heap/tests/stack-annotation/ann_frame002.hs ===================================== @@ -12,17 +12,7 @@ import qualified GHC.Internal.Stack.CloneStack as CloneStack import System.IO.Unsafe import Unsafe.Coerce - -{-# NOINLINE decodeAnnotationFrames #-} -decodeAnnotationFrames :: IO [String] -decodeAnnotationFrames = do - stack <- CloneStack.cloneMyStack - decoded <- Decode.decodeStack stack - pure - [ show a - | AnnFrame _ (Box ann) <- ssc_stack decoded - , StackAnnotation a <- [unsafeCoerce ann] - ] +import GHC.Exts.Heap.Closures (GenStgStackClosure) {-# NOINLINE printAnnotationStack #-} printAnnotationStack :: [String] -> IO () @@ -47,8 +37,8 @@ baz = annotateCallStackM $ do decodeAnnotationFrames >>= printAnnotationStack bar :: IO () -bar = annotateCallStackM $ annotateStackM "bar" $ do - putStrLn "Some more ork in bar" +bar = annotateCallStackM $ annotateStringM "bar" $ do + putStrLn "Some more work in bar" print (fib 21) decodeAnnotationFrames >>= printAnnotationStack @@ -56,3 +46,23 @@ fib :: Int -> Int fib n | n <= 1 = 1 | otherwise = fib (n - 1) + fib (n - 2) + +{-# NOINLINE decodeAnnotationFrames #-} +decodeAnnotationFrames :: IO [String] +decodeAnnotationFrames = do + stack <- CloneStack.cloneMyStack + decoded <- Decode.decodeStack stack + pure $ unwindStack decoded + +unwindStack :: GenStgStackClosure Box -> [String] +unwindStack stack_closure = + [ ann + | a <- ssc_stack stack_closure + , ann <- case a of + AnnFrame _ (Box ann) -> + [ displayStackAnnotation a + | SomeStackAnnotation a <- [unsafeCoerce ann] + ] + UnderflowFrame _ underflow_stack_closure -> unwindStack underflow_stack_closure + _ -> [] + ] ===================================== libraries/ghc-heap/tests/stack-annotation/ann_frame002.stdout ===================================== @@ -1,11 +1,11 @@ Start some work 10946 Annotation stack: -main:Main ann_frame002.hs:35-7:35-10 -main:Main ann_frame002.hs:35-3:35-6 +ann_frame002.hs:25:7 in main:Main +ann_frame002.hs:25:3 in main:Main Finish some work Some more ork in bar 17711 Annotation stack: -"bar" -main:Main ann_frame002.hs:50-7:50-25 +bar +ann_frame002.hs:40:7 in main:Main ===================================== libraries/ghc-heap/tests/stack-annotation/ann_frame003.hs ===================================== @@ -0,0 +1,28 @@ + +import GHC.Stack.Annotation.Experimental +import Control.Exception.Backtrace + +hello :: Int -> Int -> Int +hello x y = annotateShow (x,y) $ + x + y + 42 +{-# OPAQUE hello #-} + +main :: IO () +main = do + setBacktraceMechanismState IPEBacktrace True + print $ hello 2 3 + print $ tailCallEx 4 5 + +{-# INLINE tailCallEx #-} +tailCallEx :: Int -> Int -> Int +tailCallEx a b = annotateShow "tailCallEx" $ + foo a b + +{-# INLINE foo #-} +foo :: Int -> Int -> Int +foo a b = annotateShow "foo" $ + bar $ a * b + +bar c = annotateShow "bar" $ + error $ show $ c + c + ===================================== libraries/ghc-heap/tests/stack-annotation/ann_frame004.hs ===================================== @@ -0,0 +1,36 @@ + +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -ddump-to-file -ddump-stg-final -ddump-simpl -dsuppress-all #-} +import Control.Monad +import GHC.Stack.Types +import Control.Exception +import Control.Exception.Backtrace +import GHC.Stack.Annotation.Experimental + +main :: IO () +main = do + setBacktraceMechanismState IPEBacktrace True + -- foo baz + bar + +foo :: HasCallStack => IO () -> IO () +foo act = annotateCallStackM $ do + putStrLn "Start some work" + act + putStrLn "Finish some work" + +baz :: HasCallStack => IO () +baz = annotateCallStackM $ do + print (fib 20) + throwIO $ ErrorCall "baz is interrupted" + +bar :: IO () +bar = annotateCallStackM $ annotateStringM "bar" $ do + putStrLn "Some more work in bar" + print (annotateCallStack $ fib 21) + +fib :: Int -> Int +fib n + | n <= 1 = 1 + | n >= 21 = throw $ ErrorCall "This fib implementation supports only up to the 21st fibonacci number" + | otherwise = fib (n - 1) + fib (n - 2) ===================================== libraries/ghc-internal/cbits/HeapPrim.cmm ===================================== @@ -0,0 +1,13 @@ +#include "Cmm.h" + +aToWordzh (P_ clos) +{ + return (clos); +} + +reallyUnsafePtrEqualityUpToTag (W_ clos1, W_ clos2) +{ + clos1 = UNTAG(clos1); + clos2 = UNTAG(clos2); + return (clos1 == clos2); +} ===================================== libraries/ghc-internal/cbits/Stack.cmm ===================================== @@ -0,0 +1,182 @@ +// Uncomment to enable assertions during development +// #define DEBUG 1 + +#include "Cmm.h" + +// StgStack_marking was not available in the Stage0 compiler at the time of +// writing. Because, it has been added to derivedConstants when Stack.cmm was +// developed. +#if defined(StgStack_marking) + +// Returns the next stackframe's StgStack* and offset in it. And, an indicator +// if this frame is the last one (`hasNext` bit.) +// (StgStack*, StgWord, StgWord) advanceStackFrameLocationzh(StgStack* stack, StgWord offsetWords) +advanceStackFrameLocationzh (P_ stack, W_ offsetWords) { + W_ frameSize; + (frameSize) = ccall stackFrameSize(stack, offsetWords); + + P_ nextClosurePtr; + nextClosurePtr = (StgStack_sp(stack) + WDS(offsetWords) + WDS(frameSize)); + + P_ stackArrayPtr; + stackArrayPtr = stack + SIZEOF_StgHeader + OFFSET_StgStack_stack; + + P_ stackBottom; + W_ stackSize, stackSizeInBytes; + stackSize = TO_W_(StgStack_stack_size(stack)); + stackSizeInBytes = WDS(stackSize); + stackBottom = stackSizeInBytes + stackArrayPtr; + + P_ newStack; + W_ newOffsetWords, hasNext; + if(nextClosurePtr < stackBottom) (likely: True) { + newStack = stack; + newOffsetWords = offsetWords + frameSize; + hasNext = 1; + } else { + P_ underflowFrameStack; + (underflowFrameStack) = ccall getUnderflowFrameStack(stack, offsetWords); + if (underflowFrameStack == NULL) (likely: True) { + newStack = NULL; + newOffsetWords = NULL; + hasNext = NULL; + } else { + newStack = underflowFrameStack; + newOffsetWords = NULL; + hasNext = 1; + } + } + + return (newStack, newOffsetWords, hasNext); +} + +// (StgWord, StgWord) getSmallBitmapzh(StgStack* stack, StgWord offsetWords) +getSmallBitmapzh(P_ stack, W_ offsetWords) { + P_ c; + c = StgStack_sp(stack) + WDS(offsetWords); + ASSERT(LOOKS_LIKE_CLOSURE_PTR(c)); + + W_ bitmap, size; + (bitmap) = ccall getBitmapWord(c); + (size) = ccall getBitmapSize(c); + + return (bitmap, size); +} + + +// (StgWord, StgWord) getRetFunSmallBitmapzh(StgStack* stack, StgWord offsetWords) +getRetFunSmallBitmapzh(P_ stack, W_ offsetWords) { + P_ c; + c = StgStack_sp(stack) + WDS(offsetWords); + ASSERT(LOOKS_LIKE_CLOSURE_PTR(c)); + + W_ bitmap, size, specialType; + (bitmap) = ccall getRetFunBitmapWord(c); + (size) = ccall getRetFunBitmapSize(c); + + return (bitmap, size); +} + +// (StgWord*, StgWord) getLargeBitmapzh(StgStack* stack, StgWord offsetWords) +getLargeBitmapzh(P_ stack, W_ offsetWords) { + P_ c, words; + W_ size; + c = StgStack_sp(stack) + WDS(offsetWords); + ASSERT(LOOKS_LIKE_CLOSURE_PTR(c)); + + (words) = ccall getLargeBitmap(MyCapability(), c); + (size) = ccall getLargeBitmapSize(c); + + return (words, size); +} + +// (StgWord*, StgWord) getBCOLargeBitmapzh(StgStack* stack, StgWord offsetWords) +getBCOLargeBitmapzh(P_ stack, W_ offsetWords) { + P_ c, words; + W_ size; + c = StgStack_sp(stack) + WDS(offsetWords); + ASSERT(LOOKS_LIKE_CLOSURE_PTR(c)); + + (words) = ccall getBCOLargeBitmap(MyCapability(), c); + (size) = ccall getBCOLargeBitmapSize(c); + + return (words, size); +} + +// (StgWord*, StgWord) getRetFunLargeBitmapzh(StgStack* stack, StgWord offsetWords) +getRetFunLargeBitmapzh(P_ stack, W_ offsetWords) { + P_ c, words; + W_ size; + c = StgStack_sp(stack) + WDS(offsetWords); + ASSERT(LOOKS_LIKE_CLOSURE_PTR(c)); + + (words) = ccall getRetFunLargeBitmap(MyCapability(), c); + (size) = ccall getRetFunSize(c); + + return (words, size); +} + +// (StgWord) getWordzh(StgStack* stack, StgWord offsetWords) +getWordzh(P_ stack, W_ offsetWords) { + P_ wordAddr; + wordAddr = (StgStack_sp(stack) + WDS(offsetWords)); + return (W_[wordAddr]); +} + +// (StgStack*) getUnderflowFrameNextChunkzh(StgStack* stack, StgWord offsetWords) +getUnderflowFrameNextChunkzh(P_ stack, W_ offsetWords) { + P_ closurePtr; + closurePtr = (StgStack_sp(stack) + WDS(offsetWords)); + ASSERT(LOOKS_LIKE_CLOSURE_PTR(closurePtr)); + + P_ next_chunk; + (next_chunk) = ccall getUnderflowFrameNextChunk(closurePtr); + ASSERT(LOOKS_LIKE_CLOSURE_PTR(next_chunk)); + return (next_chunk); +} + +// (StgWord) getRetFunTypezh(StgStack* stack, StgWord offsetWords) +isArgGenBigRetFunTypezh(P_ stack, W_ offsetWords) { + P_ c; + c = StgStack_sp(stack) + WDS(offsetWords); + ASSERT(LOOKS_LIKE_CLOSURE_PTR(c)); + + W_ type; + (type) = ccall isArgGenBigRetFunType(c); + return (type); +} + +// (StgInfoTable*, StgInfoTable*) getInfoTableAddrszh(StgStack* stack, StgWord offsetWords) +getInfoTableAddrszh(P_ stack, W_ offsetWords) { + P_ p, info_struct, info_ptr; + p = StgStack_sp(stack) + WDS(offsetWords); + ASSERT(LOOKS_LIKE_CLOSURE_PTR(p)); + info_struct = %GET_STD_INFO(UNTAG(p)); + info_ptr = %INFO_PTR(UNTAG(p)); + return (info_struct, info_ptr); +} + +// (StgInfoTable*) getStackInfoTableAddrzh(StgStack* stack) +getStackInfoTableAddrzh(P_ stack) { + P_ info; + info = %GET_STD_INFO(UNTAG(stack)); + return (info); +} + +// (StgClosure*) getStackClosurezh(StgStack* stack, StgWord offsetWords) +getStackClosurezh(P_ stack, W_ offsetWords) { + P_ ptr; + ptr = StgStack_sp(stack) + WDS(offsetWords); + + P_ closure; + (closure) = ccall getStackClosure(ptr); + return (closure); +} + +// (bits32) getStackFieldszh(StgStack* stack) +getStackFieldszh(P_ stack){ + bits32 size; + size = StgStack_stack_size(stack); + return (size); +} +#endif ===================================== libraries/ghc-internal/cbits/Stack_c.c ===================================== @@ -0,0 +1,151 @@ +#include "MachDeps.h" +#include "Rts.h" +#include "RtsAPI.h" +#include "rts/Messages.h" +#include "rts/Types.h" +#include "rts/storage/ClosureTypes.h" +#include "rts/storage/Closures.h" +#include "rts/storage/FunTypes.h" +#include "rts/storage/InfoTables.h" + +StgWord stackFrameSize(StgStack *stack, StgWord offset) { + StgClosure *c = (StgClosure *)stack->sp + offset; + ASSERT(LOOKS_LIKE_CLOSURE_PTR(c)); + return stack_frame_sizeW(c); +} + +StgStack *getUnderflowFrameStack(StgStack *stack, StgWord offset) { + StgClosure *frame = (StgClosure *)stack->sp + offset; + ASSERT(LOOKS_LIKE_CLOSURE_PTR(frame)); + const StgRetInfoTable *info = get_ret_itbl((StgClosure *)frame); + + if (info->i.type == UNDERFLOW_FRAME) { + return ((StgUnderflowFrame *)frame)->next_chunk; + } else { + return NULL; + } +} + +// Only exists to make the get_itbl macro available in Haskell code (via FFI). +const StgInfoTable *getItbl(StgClosure *closure) { + ASSERT(LOOKS_LIKE_CLOSURE_PTR(closure)); + return get_itbl(closure); +}; + +StgWord getBitmapSize(StgClosure *c) { + ASSERT(LOOKS_LIKE_CLOSURE_PTR(c)); + + const StgInfoTable *info = get_itbl(c); + StgWord bitmap = info->layout.bitmap; + return BITMAP_SIZE(bitmap); +} + +StgWord getRetFunBitmapSize(StgRetFun *ret_fun) { + ASSERT(LOOKS_LIKE_CLOSURE_PTR(ret_fun)); + + const StgFunInfoTable *fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun)); + switch (fun_info->f.fun_type) { + case ARG_GEN: + return BITMAP_SIZE(fun_info->f.b.bitmap); + case ARG_GEN_BIG: + return GET_FUN_LARGE_BITMAP(fun_info)->size; + default: + return BITMAP_SIZE(stg_arg_bitmaps[fun_info->f.fun_type]); + } +} + +StgWord getBitmapWord(StgClosure *c) { + ASSERT(LOOKS_LIKE_CLOSURE_PTR(c)); + + const StgInfoTable *info = get_itbl(c); + StgWord bitmap = info->layout.bitmap; + StgWord bitmapWord = BITMAP_BITS(bitmap); + return bitmapWord; +} + +StgWord getRetFunBitmapWord(StgRetFun *ret_fun) { + ASSERT(LOOKS_LIKE_CLOSURE_PTR(ret_fun)); + + const StgFunInfoTable *fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun)); + fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun)); + switch (fun_info->f.fun_type) { + case ARG_GEN: + return BITMAP_BITS(fun_info->f.b.bitmap); + case ARG_GEN_BIG: + // Cannot do more than warn and exit. + errorBelch("Unexpected ARG_GEN_BIG StgRetFun closure %p", ret_fun); + stg_exit(EXIT_INTERNAL_ERROR); + default: + return BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]); + } +} + +StgWord getLargeBitmapSize(StgClosure *c) { + ASSERT(LOOKS_LIKE_CLOSURE_PTR(c)); + + const StgInfoTable *info = get_itbl(c); + StgLargeBitmap *bitmap = GET_LARGE_BITMAP(info); + return bitmap->size; +} + +StgWord getRetFunSize(StgRetFun *ret_fun) { + ASSERT(LOOKS_LIKE_CLOSURE_PTR(ret_fun)); + + const StgFunInfoTable *fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun)); + fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun)); + switch (fun_info->f.fun_type) { + case ARG_GEN: + return BITMAP_SIZE(fun_info->f.b.bitmap); + case ARG_GEN_BIG: + return GET_FUN_LARGE_BITMAP(fun_info)->size; + default: + return BITMAP_SIZE(stg_arg_bitmaps[fun_info->f.fun_type]); + } +} + +StgWord getBCOLargeBitmapSize(StgClosure *c) { + ASSERT(LOOKS_LIKE_CLOSURE_PTR(c)); + + StgBCO *bco = (StgBCO *)*c->payload; + + return BCO_BITMAP_SIZE(bco); +} + +StgWord *getLargeBitmap(Capability *cap, StgClosure *c) { + ASSERT(LOOKS_LIKE_CLOSURE_PTR(c)); + const StgInfoTable *info = get_itbl(c); + StgLargeBitmap *bitmap = GET_LARGE_BITMAP(info); + + return bitmap->bitmap; +} + +StgWord *getRetFunLargeBitmap(Capability *cap, StgRetFun *ret_fun) { + ASSERT(LOOKS_LIKE_CLOSURE_PTR(ret_fun)); + + const StgFunInfoTable *fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun)); + StgLargeBitmap *bitmap = GET_FUN_LARGE_BITMAP(fun_info); + + return bitmap->bitmap; +} + +StgWord *getBCOLargeBitmap(Capability *cap, StgClosure *c) { + ASSERT(LOOKS_LIKE_CLOSURE_PTR(c)); + + StgBCO *bco = (StgBCO *)*c->payload; + StgLargeBitmap *bitmap = BCO_BITMAP(bco); + + return bitmap->bitmap; +} + +StgStack *getUnderflowFrameNextChunk(StgUnderflowFrame *frame) { + return frame->next_chunk; +} + +StgWord isArgGenBigRetFunType(StgRetFun *ret_fun) { + ASSERT(LOOKS_LIKE_CLOSURE_PTR(ret_fun)); + + const StgFunInfoTable *fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun)); + return fun_info->f.fun_type == ARG_GEN_BIG; +} + +StgClosure *getStackClosure(StgClosure **c) { return *c; } ===================================== libraries/ghc-internal/ghc-internal.cabal.in ===================================== @@ -231,6 +231,12 @@ Library GHC.Internal.GHCi GHC.Internal.GHCi.Helpers GHC.Internal.Generics + GHC.Internal.Heap.Closures + GHC.Internal.Heap.Constants + GHC.Internal.Heap.InfoTable + GHC.Internal.Heap.InfoTable.Types + GHC.Internal.Heap.InfoTableProf + GHC.Internal.Heap.ProfInfo.Types GHC.Internal.InfoProv GHC.Internal.InfoProv.Types GHC.Internal.IO @@ -283,14 +289,17 @@ Library GHC.Internal.RTS.Flags GHC.Internal.RTS.Flags.Test GHC.Internal.ST - GHC.Internal.Stack.CloneStack GHC.Internal.StaticPtr GHC.Internal.STRef GHC.Internal.Show GHC.Internal.Stable GHC.Internal.StableName GHC.Internal.Stack + GHC.Internal.Stack.Annotation GHC.Internal.Stack.CCS + GHC.Internal.Stack.CloneStack + GHC.Internal.Stack.Constants + GHC.Internal.Stack.Decode GHC.Internal.Stack.Types GHC.Internal.Stats GHC.Internal.Storable @@ -449,9 +458,12 @@ Library cbits/popcnt.c cbits/vectorQuotRem.c cbits/word2float.c + cbits/Stack_c.c cmm-sources: cbits/StackCloningDecoding.cmm + cbits/Stack.cmm + cbits/HeapPrim.cmm if arch(javascript) js-sources: ===================================== libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs ===================================== @@ -7,6 +7,8 @@ module GHC.Internal.Exception.Backtrace where import GHC.Internal.Base import GHC.Internal.Data.OldList +import GHC.Internal.Data.Functor +import GHC.Internal.Data.Maybe import GHC.Internal.IORef import GHC.Internal.IO.Unsafe (unsafePerformIO) import GHC.Internal.Exception.Context @@ -16,6 +18,7 @@ import qualified GHC.Internal.Stack as HCS import qualified GHC.Internal.ExecutionStack as ExecStack import qualified GHC.Internal.ExecutionStack.Internal as ExecStack import qualified GHC.Internal.Stack.CloneStack as CloneStack +import qualified GHC.Internal.Stack.Decode as Decode import qualified GHC.Internal.Stack.CCS as CCS -- | How to collect a backtrace when an exception is thrown. @@ -37,6 +40,14 @@ data EnabledBacktraceMechanisms = , ipeBacktraceEnabled :: !Bool } +data DisplayBacktraceMechanisms = + DisplayBacktraceMechanisms + { displayCostCentreBacktrace :: Ptr CCS.CostCentreStack -> String + , displayHasCallStackBacktrace :: HCS.CallStack -> String + , displayExecutionBacktrace :: [ExecStack.Location] -> String + , displayIpeBacktrace :: CloneStack.StackSnapshot -> String + } + defaultEnabledBacktraceMechanisms :: EnabledBacktraceMechanisms defaultEnabledBacktraceMechanisms = EnabledBacktraceMechanisms { costCentreBacktraceEnabled = False @@ -45,6 +56,19 @@ defaultEnabledBacktraceMechanisms = EnabledBacktraceMechanisms , ipeBacktraceEnabled = False } +defaultDisplayBacktraceMechanisms :: DisplayBacktraceMechanisms +defaultDisplayBacktraceMechanisms = DisplayBacktraceMechanisms + { displayCostCentreBacktrace = unlines . map (indent 2) . unsafePerformIO . CCS.ccsToStrings + , displayHasCallStackBacktrace = unlines . map (indent 2 . prettyCallSite) . HCS.getCallStack + , displayExecutionBacktrace = unlines . map (indent 2 . flip ExecStack.showLocation "") + , displayIpeBacktrace = unlines . mapMaybe (fmap (indent 2) . Decode.prettyStackFrameWithIpe) . unsafePerformIO . Decode.decodeStackWithIpe + } + where + indent :: Int -> String -> String + indent n s = replicate n ' ' ++ s + + prettyCallSite (f, loc) = f ++ ", called at " ++ HCS.prettySrcLoc loc + backtraceMechanismEnabled :: BacktraceMechanism -> EnabledBacktraceMechanisms -> Bool backtraceMechanismEnabled bm = case bm of @@ -69,6 +93,11 @@ enabledBacktraceMechanismsRef = unsafePerformIO $ newIORef defaultEnabledBacktraceMechanisms {-# NOINLINE enabledBacktraceMechanismsRef #-} +displayBacktraceMechanismsRef :: IORef DisplayBacktraceMechanisms +displayBacktraceMechanismsRef = + unsafePerformIO $ newIORef defaultDisplayBacktraceMechanisms +{-# NOINLINE displayBacktraceMechanismsRef #-} + -- | Returns the currently enabled 'BacktraceMechanism's. getEnabledBacktraceMechanisms :: IO EnabledBacktraceMechanisms getEnabledBacktraceMechanisms = readIORef enabledBacktraceMechanismsRef @@ -86,37 +115,41 @@ setBacktraceMechanismState bm enabled = do _ <- atomicModifyIORef'_ enabledBacktraceMechanismsRef (setBacktraceMechanismEnabled bm enabled) return () +-- TODO @fendor +getDisplayBacktraceMechanisms :: IO DisplayBacktraceMechanisms +getDisplayBacktraceMechanisms = readIORef displayBacktraceMechanismsRef + +-- TODO @fendor: +setDisplayBacktraceMechanismsState :: DisplayBacktraceMechanisms -> IO () +setDisplayBacktraceMechanismsState dbm = do + _ <- atomicModifyIORef'_ displayBacktraceMechanismsRef (const dbm) + return () + -- | A collection of backtraces. data Backtraces = Backtraces { btrCostCentre :: Maybe (Ptr CCS.CostCentreStack), + btrDisplayCostCentre :: Ptr CCS.CostCentreStack -> String, btrHasCallStack :: Maybe HCS.CallStack, + btrDisplayHasCallStack :: HCS.CallStack -> String, btrExecutionStack :: Maybe [ExecStack.Location], - btrIpe :: Maybe [CloneStack.StackEntry] + btrDisplayExecutionStack :: [ExecStack.Location] -> String, + btrIpe :: Maybe CloneStack.StackSnapshot, + btrDisplayIpe :: CloneStack.StackSnapshot -> String } -- | Render a set of backtraces to a human-readable string. displayBacktraces :: Backtraces -> String displayBacktraces bts = concat - [ displayOne "Cost-centre stack backtrace" btrCostCentre displayCc - , displayOne "Native stack backtrace" btrExecutionStack displayExec - , displayOne "IPE backtrace" btrIpe displayIpe - , displayOne "HasCallStack backtrace" btrHasCallStack displayHsc + [ displayOne "Cost-centre stack backtrace" btrCostCentre btrDisplayCostCentre + , displayOne "Native stack backtrace" btrExecutionStack btrDisplayExecutionStack + , displayOne "IPE backtrace" btrIpe btrDisplayIpe + , displayOne "HasCallStack backtrace" btrHasCallStack btrDisplayHasCallStack ] where - indent :: Int -> String -> String - indent n s = replicate n ' ' ++ s - - -- The unsafePerformIO here is safe as we don't currently unload cost-centres. - displayCc = unlines . map (indent 2) . unsafePerformIO . CCS.ccsToStrings - displayExec = unlines . map (indent 2 . flip ExecStack.showLocation "") - displayIpe = unlines . map (indent 2 . CloneStack.prettyStackEntry) - displayHsc = unlines . map (indent 2 . prettyCallSite) . HCS.getCallStack - where prettyCallSite (f, loc) = f ++ ", called at " ++ HCS.prettySrcLoc loc - - displayOne :: String -> (Backtraces -> Maybe rep) -> (rep -> String) -> String + displayOne :: String -> (Backtraces -> Maybe rep) -> (Backtraces -> rep -> String) -> String displayOne label getBt displ - | Just bt <- getBt bts = concat [label, ":\n", displ bt] + | Just bt <- getBt bts = concat [label, ":\n", displ bts bt] | otherwise = "" instance ExceptionAnnotation Backtraces where @@ -125,12 +158,14 @@ instance ExceptionAnnotation Backtraces where -- | Collect a set of 'Backtraces'. collectBacktraces :: (?callStack :: CallStack) => IO Backtraces collectBacktraces = HCS.withFrozenCallStack $ do - getEnabledBacktraceMechanisms >>= collectBacktraces' + bm <- getEnabledBacktraceMechanisms + dpm <- getDisplayBacktraceMechanisms + collectBacktraces' bm dpm collectBacktraces' :: (?callStack :: CallStack) - => EnabledBacktraceMechanisms -> IO Backtraces -collectBacktraces' enabled = HCS.withFrozenCallStack $ do + => EnabledBacktraceMechanisms -> DisplayBacktraceMechanisms -> IO Backtraces +collectBacktraces' enabled renderers = HCS.withFrozenCallStack $ do let collect :: BacktraceMechanism -> IO (Maybe a) -> IO (Maybe a) collect mech f | backtraceMechanismEnabled mech enabled = f @@ -144,14 +179,17 @@ collectBacktraces' enabled = HCS.withFrozenCallStack $ do ipe <- collect IPEBacktrace $ do stack <- CloneStack.cloneMyStack - stackEntries <- CloneStack.decode stack - return (Just stackEntries) + return (Just stack) hcs <- collect HasCallStackBacktrace $ do return (Just ?callStack) return (Backtraces { btrCostCentre = ccs + , btrDisplayCostCentre = displayCostCentreBacktrace renderers , btrHasCallStack = hcs + , btrDisplayHasCallStack = displayHasCallStackBacktrace renderers , btrExecutionStack = exec + , btrDisplayExecutionStack = displayExecutionBacktrace renderers , btrIpe = ipe + , btrDisplayIpe = displayIpeBacktrace renderers }) ===================================== libraries/ghc-internal/src/GHC/Internal/Heap/Closures.hs ===================================== @@ -0,0 +1,669 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE GHCForeignImportPrim #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE UnliftedFFITypes #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +-- Late cost centres introduce a thunk in the asBox function, which leads to +-- an additional wrapper being added to any value placed inside a box. +-- This can be removed once our boot compiler is no longer affected by #25212 +{-# OPTIONS_GHC -fno-prof-late #-} +{-# LANGUAGE NamedFieldPuns #-} + +module GHC.Internal.Heap.Closures ( + -- * Closures + Closure + , GenClosure(..) + , getClosureInfoTbl + , getClosureInfoTbl_maybe + , getClosurePtrArgs + , getClosurePtrArgs_maybe + , PrimType(..) + , WhatNext(..) + , WhyBlocked(..) + , TsoFlags(..) + , allClosures + , closureSize + + -- * Stack + , StgStackClosure + , GenStgStackClosure(..) + , StackFrame + , GenStackFrame(..) + , StackField + , GenStackField(..) + + -- * Boxes + , Box(..) + , areBoxesEqual + , asBox + ) where + +import GHC.Internal.Base +import GHC.Internal.Show + +import GHC.Internal.Heap.Constants +#if defined(PROFILING) +import GHC.Internal.Heap.InfoTable () -- see Note [No way-dependent imports] +import GHC.Internal.Heap.InfoTableProf +#else +import GHC.Internal.Heap.InfoTable +import GHC.Internal.Heap.InfoTableProf () -- see Note [No way-dependent imports] + +{- +Note [No way-dependent imports] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +`ghc -M` currently assumes that the imports for a module are the same +in every way. This is arguably a bug, but breaking this assumption by +importing different things in different ways can cause trouble. For +example, this module in the profiling way imports and uses +GHC.Exts.Heap.InfoTableProf. When it was not also imported in the +vanilla way, there were intermittent build failures due to this module +being compiled in the profiling way before GHC.Exts.Heap.InfoTableProf +in the profiling way. (#15197) +-} +#endif + +import GHC.Internal.Heap.ProfInfo.Types + +import GHC.Internal.Data.Bits +import GHC.Internal.Data.Foldable (Foldable, toList) +import GHC.Internal.Data.Traversable (Traversable) +import GHC.Internal.Int +import GHC.Internal.Num +import GHC.Internal.Real +import GHC.Internal.Word +import GHC.Internal.Exts +import GHC.Internal.Generics +import GHC.Internal.Numeric +import GHC.Internal.Stack (HasCallStack) + +------------------------------------------------------------------------ +-- Boxes + +foreign import prim "aToWordzh" aToWord# :: Any -> Word# + +foreign import prim "reallyUnsafePtrEqualityUpToTag" + reallyUnsafePtrEqualityUpToTag# :: Any -> Any -> Int# + +-- | An arbitrary Haskell value in a safe Box. The point is that even +-- unevaluated thunks can safely be moved around inside the Box, and when +-- required, e.g. in 'getBoxedClosureData', the function knows how far it has +-- to evaluate the argument. +data Box = Box Any + +instance Show Box where +-- From libraries/base/GHC/Ptr.lhs + showsPrec _ (Box a) rs = + -- unsafePerformIO (print "↓" >> pClosure a) `seq` + pad_out (showHex addr "") ++ (if tag>0 then "/" ++ show tag else "") ++ rs + where + ptr = W# (aToWord# a) + tag = ptr .&. fromIntegral tAG_MASK -- ((1 `shiftL` TAG_BITS) -1) + addr = ptr - tag + pad_out ls = '0':'x':ls + +-- |This takes an arbitrary value and puts it into a box. +-- Note that calls like +-- +-- > asBox (head list) +-- +-- will put the thunk \"head list\" into the box, /not/ the element at the head +-- of the list. For that, use careful case expressions: +-- +-- > case list of x:_ -> asBox x +asBox :: a -> Box +asBox x = Box (unsafeCoerce# x) + +-- | Boxes can be compared, but this is not pure, as different heap objects can, +-- after garbage collection, become the same object. +areBoxesEqual :: Box -> Box -> IO Bool +areBoxesEqual (Box a) (Box b) = case reallyUnsafePtrEqualityUpToTag# a b of + 0# -> pure False + _ -> pure True + + +------------------------------------------------------------------------ +-- Closures +type Closure = GenClosure Box + +-- | This is the representation of a Haskell value on the heap. It reflects +-- <https://gitlab.haskell.org/ghc/ghc/blob/master/rts/include/rts/storage/Clos…> +-- +-- The data type is parametrized by `b`: the type to store references in. +-- Usually this is a 'Box' with the type synonym 'Closure'. +-- +-- All Heap objects have the same basic layout. A header containing a pointer to +-- the info table and a payload with various fields. The @info@ field below +-- always refers to the info table pointed to by the header. The remaining +-- fields are the payload. +-- +-- See +-- <https://gitlab.haskell.org/ghc/ghc/wikis/commentary/rts/storage/heap-objects> +-- for more information. +data GenClosure b + = -- | A data constructor + ConstrClosure + { info :: !StgInfoTable + , ptrArgs :: ![b] -- ^ Pointer arguments + , dataArgs :: ![Word] -- ^ Non-pointer arguments + , pkg :: !String -- ^ Package name + , modl :: !String -- ^ Module name + , name :: !String -- ^ Constructor name + } + + -- | A function + | FunClosure + { info :: !StgInfoTable + , ptrArgs :: ![b] -- ^ Pointer arguments + , dataArgs :: ![Word] -- ^ Non-pointer arguments + } + + -- | A thunk, an expression not obviously in head normal form + | ThunkClosure + { info :: !StgInfoTable + , ptrArgs :: ![b] -- ^ Pointer arguments + , dataArgs :: ![Word] -- ^ Non-pointer arguments + } + + -- | A thunk which performs a simple selection operation + | SelectorClosure + { info :: !StgInfoTable + , selectee :: !b -- ^ Pointer to the object being + -- selected from + } + + -- | An unsaturated function application + | PAPClosure + { info :: !StgInfoTable + , arity :: !HalfWord -- ^ Arity of the partial application + , n_args :: !HalfWord -- ^ Size of the payload in words + , fun :: !b -- ^ Pointer to a 'FunClosure' + , payload :: ![b] -- ^ Sequence of already applied + -- arguments + } + + -- In GHCi, if Linker.h would allow a reverse lookup, we could for exported + -- functions fun actually find the name here. + -- At least the other direction works via "lookupSymbol + -- base_GHCziBase_zpzp_closure" and yields the same address (up to tags) + -- | A function application + | APClosure + { info :: !StgInfoTable + , arity :: !HalfWord -- ^ Always 0 + , n_args :: !HalfWord -- ^ Size of payload in words + , fun :: !b -- ^ Pointer to a 'FunClosure' + , payload :: ![b] -- ^ Sequence of already applied + -- arguments + } + + -- | A suspended thunk evaluation + | APStackClosure + { info :: !StgInfoTable + , fun :: !b -- ^ Function closure + , payload :: ![b] -- ^ Stack right before suspension + } + + -- | A pointer to another closure, introduced when a thunk is updated + -- to point at its value + | IndClosure + { info :: !StgInfoTable + , indirectee :: !b -- ^ Target closure + } + + -- | A byte-code object (BCO) which can be interpreted by GHC's byte-code + -- interpreter (e.g. as used by GHCi) + | BCOClosure + { info :: !StgInfoTable + , instrs :: !b -- ^ A pointer to an ArrWords + -- of instructions + , literals :: !b -- ^ A pointer to an ArrWords + -- of literals + , bcoptrs :: !b -- ^ A pointer to an ArrWords + -- of byte code objects + , arity :: !HalfWord -- ^ The arity of this BCO + , size :: !HalfWord -- ^ The size of this BCO in words + , bitmap :: ![Word] -- ^ An StgLargeBitmap describing the + -- pointerhood of its args/free vars + } + + -- | A thunk under evaluation by another thread + | BlackholeClosure + { info :: !StgInfoTable + , indirectee :: !b -- ^ The target closure + } + + -- | A @ByteArray#@ + | ArrWordsClosure + { info :: !StgInfoTable + , bytes :: !Word -- ^ Size of array in bytes + , arrWords :: ![Word] -- ^ Array payload + } + + -- | A @MutableByteArray#@ + | MutArrClosure + { info :: !StgInfoTable + , mccPtrs :: !Word -- ^ Number of pointers + , mccSize :: !Word -- ^ ?? Closures.h vs ClosureMacros.h + , mccPayload :: ![b] -- ^ Array payload + -- Card table ignored + } + + -- | A @SmallMutableArray#@ + -- + -- @since 8.10.1 + | SmallMutArrClosure + { info :: !StgInfoTable + , mccPtrs :: !Word -- ^ Number of pointers + , mccPayload :: ![b] -- ^ Array payload + } + + -- | An @MVar#@, with a queue of thread state objects blocking on them + | MVarClosure + { info :: !StgInfoTable + , queueHead :: !b -- ^ Pointer to head of queue + , queueTail :: !b -- ^ Pointer to tail of queue + , value :: !b -- ^ Pointer to closure + } + + -- | An @IOPort#@, with a queue of thread state objects blocking on them + | IOPortClosure + { info :: !StgInfoTable + , queueHead :: !b -- ^ Pointer to head of queue + , queueTail :: !b -- ^ Pointer to tail of queue + , value :: !b -- ^ Pointer to closure + } + + -- | A @MutVar#@ + | MutVarClosure + { info :: !StgInfoTable + , var :: !b -- ^ Pointer to contents + } + + -- | An STM blocking queue. + | BlockingQueueClosure + { info :: !StgInfoTable + , link :: !b -- ^ ?? Here so it looks like an IND + , blackHole :: !b -- ^ The blackhole closure + , owner :: !b -- ^ The owning thread state object + , queue :: !b -- ^ ?? + } + + | WeakClosure + { info :: !StgInfoTable + , cfinalizers :: !b + , key :: !b + , value :: !b + , finalizer :: !b + , weakLink :: !(Maybe b) -- ^ next weak pointer for the capability + } + + -- | Representation of StgTSO: A Thread State Object. The values for + -- 'what_next', 'why_blocked' and 'flags' are defined in @Constants.h@. + | TSOClosure + { info :: !StgInfoTable + -- pointers + , link :: !b + , global_link :: !b + , tsoStack :: !b -- ^ stackobj from StgTSO + , trec :: !b + , blocked_exceptions :: !b + , bq :: !b + , thread_label :: !(Maybe b) + -- values + , what_next :: !WhatNext + , why_blocked :: !WhyBlocked + , flags :: ![TsoFlags] + , threadId :: !Word64 + , saved_errno :: !Word32 + , tso_dirty :: !Word32 -- ^ non-zero => dirty + , alloc_limit :: !Int64 + , tot_stack_size :: !Word32 + , prof :: !(Maybe StgTSOProfInfo) + } + + -- | Representation of StgStack: The 'tsoStack ' of a 'TSOClosure'. + | StackClosure + { info :: !StgInfoTable + , stack_size :: !Word32 -- ^ stack size in *words* + , stack_dirty :: !Word8 -- ^ non-zero => dirty + , stack_marking :: !Word8 + } + + ------------------------------------------------------------ + -- Unboxed unlifted closures + + -- | Primitive Int + | IntClosure + { ptipe :: PrimType + , intVal :: !Int } + + -- | Primitive Word + | WordClosure + { ptipe :: PrimType + , wordVal :: !Word } + + -- | Primitive Int64 + | Int64Closure + { ptipe :: PrimType + , int64Val :: !Int64 } + + -- | Primitive Word64 + | Word64Closure + { ptipe :: PrimType + , word64Val :: !Word64 } + + -- | Primitive Addr + | AddrClosure + { ptipe :: PrimType + , addrVal :: !(Ptr ()) } + + -- | Primitive Float + | FloatClosure + { ptipe :: PrimType + , floatVal :: !Float } + + -- | Primitive Double + | DoubleClosure + { ptipe :: PrimType + , doubleVal :: !Double } + + ----------------------------------------------------------- + -- Anything else + + -- | Another kind of closure + | OtherClosure + { info :: !StgInfoTable + , hvalues :: ![b] + , rawWords :: ![Word] + } + + | UnsupportedClosure + { info :: !StgInfoTable + } + + -- | A primitive word from a bitmap encoded stack frame payload + -- + -- The type itself cannot be restored (i.e. it might represent a Word8# + -- or an Int#). + | UnknownTypeWordSizedPrimitive + { wordVal :: !Word } + deriving (Show, Generic, Functor, Foldable, Traversable) + +-- | Get the info table for a heap closure, or Nothing for a prim value +-- +-- @since 9.14.1 +getClosureInfoTbl_maybe :: GenClosure b -> Maybe StgInfoTable +{-# INLINE getClosureInfoTbl_maybe #-} -- Ensure we can get rid of the just box +getClosureInfoTbl_maybe closure = case closure of + ConstrClosure{info} ->Just info + FunClosure{info} ->Just info + ThunkClosure{info} ->Just info + SelectorClosure{info} ->Just info + PAPClosure{info} ->Just info + APClosure{info} ->Just info + APStackClosure{info} ->Just info + IndClosure{info} ->Just info + BCOClosure{info} ->Just info + BlackholeClosure{info} ->Just info + ArrWordsClosure{info} ->Just info + MutArrClosure{info} ->Just info + SmallMutArrClosure{info} ->Just info + MVarClosure{info} ->Just info + IOPortClosure{info} ->Just info + MutVarClosure{info} ->Just info + BlockingQueueClosure{info} ->Just info + WeakClosure{info} ->Just info + TSOClosure{info} ->Just info + StackClosure{info} ->Just info + + IntClosure{} -> Nothing + WordClosure{} -> Nothing + Int64Closure{} -> Nothing + Word64Closure{} -> Nothing + AddrClosure{} -> Nothing + FloatClosure{} -> Nothing + DoubleClosure{} -> Nothing + + OtherClosure{info} -> Just info + UnsupportedClosure {info} -> Just info + + UnknownTypeWordSizedPrimitive{} -> Nothing + +-- | Partial version of getClosureInfoTbl_maybe for when we know we deal with a +-- heap closure. +-- +-- @since 9.14.1 +getClosureInfoTbl :: HasCallStack => GenClosure b -> StgInfoTable +getClosureInfoTbl closure = case getClosureInfoTbl_maybe closure of + Just info -> info + Nothing -> error "getClosureInfoTbl - Closure without info table" + +-- | Get the info table for a heap closure, or Nothing for a prim value +-- +-- @since 9.14.1 +getClosurePtrArgs_maybe :: GenClosure b -> Maybe [b] +{-# INLINE getClosurePtrArgs_maybe #-} -- Ensure we can get rid of the just box +getClosurePtrArgs_maybe closure = case closure of + ConstrClosure{ptrArgs} -> Just ptrArgs + FunClosure{ptrArgs} -> Just ptrArgs + ThunkClosure{ptrArgs} -> Just ptrArgs + SelectorClosure{} -> Nothing + PAPClosure{} -> Nothing + APClosure{} -> Nothing + APStackClosure{} -> Nothing + IndClosure{} -> Nothing + BCOClosure{} -> Nothing + BlackholeClosure{} -> Nothing + ArrWordsClosure{} -> Nothing + MutArrClosure{} -> Nothing + SmallMutArrClosure{} -> Nothing + MVarClosure{} -> Nothing + IOPortClosure{} -> Nothing + MutVarClosure{} -> Nothing + BlockingQueueClosure{} -> Nothing + WeakClosure{} -> Nothing + TSOClosure{} -> Nothing + StackClosure{} -> Nothing + + IntClosure{} -> Nothing + WordClosure{} -> Nothing + Int64Closure{} -> Nothing + Word64Closure{} -> Nothing + AddrClosure{} -> Nothing + FloatClosure{} -> Nothing + DoubleClosure{} -> Nothing + + OtherClosure{} -> Nothing + UnsupportedClosure{} -> Nothing + + UnknownTypeWordSizedPrimitive{} -> Nothing + +-- | Partial version of getClosureInfoTbl_maybe for when we know we deal with a +-- heap closure. +-- +-- @since 9.14.1 +getClosurePtrArgs :: HasCallStack => GenClosure b -> [b] +getClosurePtrArgs closure = case getClosurePtrArgs_maybe closure of + Just ptrs -> ptrs + Nothing -> error "getClosurePtrArgs - Closure without ptrArgs field" + +type StgStackClosure = GenStgStackClosure Box + +-- | A decoded @StgStack@ with `StackFrame`s +-- +-- Stack related data structures (`GenStgStackClosure`, `GenStackField`, +-- `GenStackFrame`) are defined separately from `GenClosure` as their related +-- functions are very different. Though, both are closures in the sense of RTS +-- structures, their decoding logic differs: While it's safe to keep a reference +-- to a heap closure, the garbage collector does not update references to stack +-- located closures. +-- +-- Additionally, stack frames don't appear outside of the stack. Thus, keeping +-- `GenStackFrame` and `GenClosure` separated, makes these types more precise +-- (in the sense what values to expect.) +data GenStgStackClosure b = GenStgStackClosure + { ssc_info :: !StgInfoTable + , ssc_stack_size :: !Word32 -- ^ stack size in *words* + , ssc_stack :: ![GenStackFrame b] + } + deriving (Foldable, Functor, Generic, Show, Traversable) + +type StackField = GenStackField Box + +-- | Bitmap-encoded payload on the stack +data GenStackField b + -- | A non-pointer field + = StackWord !Word + -- | A pointer field + | StackBox !b + deriving (Foldable, Functor, Generic, Show, Traversable) + +type StackFrame = GenStackFrame Box + +-- | A single stack frame +data GenStackFrame b = + UpdateFrame + { info_tbl :: !StgInfoTable + , updatee :: !b + } + + | CatchFrame + { info_tbl :: !StgInfoTable + , handler :: !b + } + + | CatchStmFrame + { info_tbl :: !StgInfoTable + , catchFrameCode :: !b + , handler :: !b + } + + | CatchRetryFrame + { info_tbl :: !StgInfoTable + , running_alt_code :: !Word + , first_code :: !b + , alt_code :: !b + } + + | AtomicallyFrame + { info_tbl :: !StgInfoTable + , atomicallyFrameCode :: !b + , result :: !b + } + + | UnderflowFrame + { info_tbl :: !StgInfoTable + , nextChunk :: !(GenStgStackClosure b) + } + + | StopFrame + { info_tbl :: !StgInfoTable } + + | RetSmall + { info_tbl :: !StgInfoTable + , stack_payload :: ![GenStackField b] + } + + | RetBig + { info_tbl :: !StgInfoTable + , stack_payload :: ![GenStackField b] + } + + | RetFun + { info_tbl :: !StgInfoTable + , retFunSize :: !Word + , retFunFun :: !b + , retFunPayload :: ![GenStackField b] + } + + | RetBCO + { info_tbl :: !StgInfoTable + , bco :: !b -- ^ always a BCOClosure + , bcoArgs :: ![GenStackField b] + } + | AnnFrame + { info_tbl :: !StgInfoTable + , annotation :: !b + } + deriving (Foldable, Functor, Generic, Show, Traversable) + +data PrimType + = PInt + | PWord + | PInt64 + | PWord64 + | PAddr + | PFloat + | PDouble + deriving (Eq, Show, Generic, Ord) + +data WhatNext + = ThreadRunGHC + | ThreadInterpret + | ThreadKilled + | ThreadComplete + | WhatNextUnknownValue Word16 -- ^ Please report this as a bug + deriving (Eq, Show, Generic, Ord) + +data WhyBlocked + = NotBlocked + | BlockedOnMVar + | BlockedOnMVarRead + | BlockedOnBlackHole + | BlockedOnRead + | BlockedOnWrite + | BlockedOnDelay + | BlockedOnSTM + | BlockedOnDoProc + | BlockedOnCCall + | BlockedOnCCall_Interruptible + | BlockedOnMsgThrowTo + | ThreadMigrating + | WhyBlockedUnknownValue Word16 -- ^ Please report this as a bug + deriving (Eq, Show, Generic, Ord) + +data TsoFlags + = TsoLocked + | TsoBlockx + | TsoInterruptible + | TsoStoppedOnBreakpoint + | TsoMarked + | TsoSqueezed + | TsoAllocLimit + | TsoStopNextBreakpoint + | TsoStopAfterReturn + | TsoFlagsUnknownValue Word32 -- ^ Please report this as a bug + deriving (Eq, Show, Generic, Ord) + +-- | For generic code, this function returns all referenced closures. +allClosures :: GenClosure b -> [b] +allClosures (ConstrClosure {..}) = ptrArgs +allClosures (ThunkClosure {..}) = ptrArgs +allClosures (SelectorClosure {..}) = [selectee] +allClosures (IndClosure {..}) = [indirectee] +allClosures (BlackholeClosure {..}) = [indirectee] +allClosures (APClosure {..}) = fun:payload +allClosures (PAPClosure {..}) = fun:payload +allClosures (APStackClosure {..}) = fun:payload +allClosures (BCOClosure {..}) = [instrs,literals,bcoptrs] +allClosures (ArrWordsClosure {}) = [] +allClosures (MutArrClosure {..}) = mccPayload +allClosures (SmallMutArrClosure {..}) = mccPayload +allClosures (MutVarClosure {..}) = [var] +allClosures (MVarClosure {..}) = [queueHead,queueTail,value] +allClosures (IOPortClosure {..}) = [queueHead,queueTail,value] +allClosures (FunClosure {..}) = ptrArgs +allClosures (BlockingQueueClosure {..}) = [link, blackHole, owner, queue] +allClosures (WeakClosure {..}) = [cfinalizers, key, value, finalizer] ++ GHC.Internal.Data.Foldable.toList weakLink +allClosures (OtherClosure {..}) = hvalues +allClosures _ = [] + +-- | Get the size of the top-level closure in words. +-- Includes header and payload. Does not follow pointers. +-- +-- @since 8.10.1 +closureSize :: Box -> Int +closureSize (Box x) = I# (closureSize# x) ===================================== libraries/ghc-internal/src/GHC/Internal/Heap/Constants.hsc ===================================== @@ -0,0 +1,18 @@ +{-# LANGUAGE CPP #-} + +module GHC.Internal.Heap.Constants + ( wORD_SIZE + , tAG_MASK + , wORD_SIZE_IN_BITS + ) where + +#include "MachDeps.h" + +import GHC.Internal.Data.Bits +import GHC.Internal.Int +import GHC.Internal.Num + +wORD_SIZE, tAG_MASK, wORD_SIZE_IN_BITS :: Int +wORD_SIZE = #const SIZEOF_HSWORD +wORD_SIZE_IN_BITS = #const WORD_SIZE_IN_BITS +tAG_MASK = (1 `shift` #const TAG_BITS) - 1 ===================================== libraries/ghc-internal/src/GHC/Internal/Heap/InfoTable.hsc ===================================== @@ -0,0 +1,79 @@ +module GHC.Internal.Heap.InfoTable + ( module GHC.Internal.Heap.InfoTable.Types + , itblSize + , peekItbl + , pokeItbl + ) where + +#include "Rts.h" + +import GHC.Internal.Base +import GHC.Internal.Data.Either +import GHC.Internal.Real +import GHC.Internal.Enum + +import GHC.Internal.Heap.InfoTable.Types +#if !defined(TABLES_NEXT_TO_CODE) +import GHC.Internal.Heap.Constants +import GHC.Internal.Data.Maybe +#endif +import GHC.Internal.Foreign.Ptr +import GHC.Internal.Foreign.Storable +import GHC.Internal.Foreign.Marshal.Array + +------------------------------------------------------------------------- +-- Profiling specific code +-- +-- The functions that follow all rely on PROFILING. They are duplicated in +-- ghc-heap/GHC/Exts/Heap/InfoTableProf.hsc where PROFILING is defined. This +-- allows hsc2hs to generate values for both profiling and non-profiling builds. + +-- | Read an InfoTable from the heap into a haskell type. +-- WARNING: This code assumes it is passed a pointer to a "standard" info +-- table. If tables_next_to_code is disabled, it will look 1 word before the +-- start for the entry field. +peekItbl :: Ptr StgInfoTable -> IO StgInfoTable +peekItbl a0 = do +#if !defined(TABLES_NEXT_TO_CODE) + let ptr = a0 `plusPtr` (negate wORD_SIZE) + entry' <- Just <$> (#peek struct StgInfoTable_, entry) ptr +#else + let ptr = a0 + entry' = Nothing +#endif + ptrs' <- (#peek struct StgInfoTable_, layout.payload.ptrs) ptr + nptrs' <- (#peek struct StgInfoTable_, layout.payload.nptrs) ptr + tipe' <- (#peek struct StgInfoTable_, type) ptr + srtlen' <- (#peek struct StgInfoTable_, srt) a0 + return StgInfoTable + { entry = entry' + , ptrs = ptrs' + , nptrs = nptrs' + , tipe = toEnum (fromIntegral (tipe' :: HalfWord)) + , srtlen = srtlen' + , code = Nothing + } + +pokeItbl :: Ptr StgInfoTable -> StgInfoTable -> IO () +pokeItbl a0 itbl = do +#if !defined(TABLES_NEXT_TO_CODE) + (#poke StgInfoTable, entry) a0 (fromJust (entry itbl)) +#endif + (#poke StgInfoTable, layout.payload.ptrs) a0 (ptrs itbl) + (#poke StgInfoTable, layout.payload.nptrs) a0 (nptrs itbl) + (#poke StgInfoTable, type) a0 (toHalfWord (fromEnum (tipe itbl))) + (#poke StgInfoTable, srt) a0 (srtlen itbl) +#if defined(TABLES_NEXT_TO_CODE) + let code_offset = a0 `plusPtr` (#offset StgInfoTable, code) + case code itbl of + Nothing -> return () + Just (Left xs) -> pokeArray code_offset xs + Just (Right xs) -> pokeArray code_offset xs +#endif + where + toHalfWord :: Int -> HalfWord + toHalfWord i = fromIntegral i + +-- | Size in bytes of a standard InfoTable +itblSize :: Int +itblSize = (#size struct StgInfoTable_) ===================================== libraries/ghc-internal/src/GHC/Internal/Heap/InfoTable/Types.hsc ===================================== @@ -0,0 +1,53 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module GHC.Internal.Heap.InfoTable.Types + ( StgInfoTable(..) + , EntryFunPtr + , HalfWord(..) + , ItblCodes + ) where + +#include "Rts.h" + +import GHC.Internal.Base +import GHC.Internal.Generics +import GHC.Internal.ClosureTypes +import GHC.Internal.Foreign.Ptr +import GHC.Internal.Foreign.Storable +import GHC.Internal.Enum +import GHC.Internal.Num +import GHC.Internal.Word +import GHC.Internal.Show +import GHC.Internal.Real +import GHC.Internal.Data.Either + +type ItblCodes = Either [Word8] [Word32] + +#include "ghcautoconf.h" +-- Ultra-minimalist version specially for constructors +#if SIZEOF_VOID_P == 8 +type HalfWord' = Word32 +#elif SIZEOF_VOID_P == 4 +type HalfWord' = Word16 +#else +#error Unknown SIZEOF_VOID_P +#endif + +newtype HalfWord = HalfWord HalfWord' + deriving newtype (Enum, Eq, Integral, Num, Ord, Real, Show, Storable) + +type EntryFunPtr = FunPtr (Ptr () -> IO (Ptr ())) + +-- | This is a somewhat faithful representation of an info table. See +-- <https://gitlab.haskell.org/ghc/ghc/blob/master/rts/include/rts/storage/Info…> +-- for more details on this data structure. +data StgInfoTable = StgInfoTable { + entry :: Maybe EntryFunPtr, -- Just <=> not TABLES_NEXT_TO_CODE + ptrs :: HalfWord, + nptrs :: HalfWord, + tipe :: ClosureType, + srtlen :: HalfWord, + code :: Maybe ItblCodes -- Just <=> TABLES_NEXT_TO_CODE + } deriving (Eq, Show, Generic) ===================================== libraries/ghc-internal/src/GHC/Internal/Heap/InfoTableProf.hsc ===================================== @@ -0,0 +1,72 @@ +module GHC.Internal.Heap.InfoTableProf + ( module GHC.Internal.Heap.InfoTable.Types + , itblSize + , peekItbl + , pokeItbl + ) where + +-- This file overrides InfoTable.hsc's implementation of peekItbl and pokeItbl. +-- Manually defining PROFILING gives the #peek and #poke macros an accurate +-- representation of StgInfoTable_ when hsc2hs runs. +#define PROFILING +#include "Rts.h" + +import GHC.Internal.Base +import GHC.Internal.Data.Either +import GHC.Internal.Real +import GHC.Internal.Enum + +import GHC.Internal.Heap.InfoTable.Types +#if !defined(TABLES_NEXT_TO_CODE) +import GHC.Internal.Heap.Constants +import GHC.Internal.Data.Maybe +#endif +import GHC.Internal.Foreign.Ptr +import GHC.Internal.Foreign.Storable +import GHC.Internal.Foreign.Marshal.Array + +-- | Read an InfoTable from the heap into a haskell type. +-- WARNING: This code assumes it is passed a pointer to a "standard" info +-- table. If tables_next_to_code is enabled, it will look 1 byte before the +-- start for the entry field. +peekItbl :: Ptr StgInfoTable -> IO StgInfoTable +peekItbl a0 = do +#if !defined(TABLES_NEXT_TO_CODE) + let ptr = a0 `plusPtr` (negate wORD_SIZE) + entry' <- Just <$> (#peek struct StgInfoTable_, entry) ptr +#else + let ptr = a0 + entry' = Nothing +#endif + ptrs' <- (#peek struct StgInfoTable_, layout.payload.ptrs) ptr + nptrs' <- (#peek struct StgInfoTable_, layout.payload.nptrs) ptr + tipe' <- (#peek struct StgInfoTable_, type) ptr + srtlen' <- (#peek struct StgInfoTable_, srt) a0 + return StgInfoTable + { entry = entry' + , ptrs = ptrs' + , nptrs = nptrs' + , tipe = toEnum (fromIntegral (tipe' :: HalfWord)) + , srtlen = srtlen' + , code = Nothing + } + +pokeItbl :: Ptr StgInfoTable -> StgInfoTable -> IO () +pokeItbl a0 itbl = do +#if !defined(TABLES_NEXT_TO_CODE) + (#poke StgInfoTable, entry) a0 (fromJust (entry itbl)) +#endif + (#poke StgInfoTable, layout.payload.ptrs) a0 (ptrs itbl) + (#poke StgInfoTable, layout.payload.nptrs) a0 (nptrs itbl) + (#poke StgInfoTable, type) a0 (fromEnum (tipe itbl)) + (#poke StgInfoTable, srt) a0 (srtlen itbl) +#if defined(TABLES_NEXT_TO_CODE) + let code_offset = a0 `plusPtr` (#offset StgInfoTable, code) + case code itbl of + Nothing -> return () + Just (Left xs) -> pokeArray code_offset xs + Just (Right xs) -> pokeArray code_offset xs +#endif + +itblSize :: Int +itblSize = (#size struct StgInfoTable_) ===================================== libraries/ghc-internal/src/GHC/Internal/Heap/ProfInfo/Types.hs ===================================== @@ -0,0 +1,57 @@ +{-# LANGUAGE DeriveGeneric #-} + +module GHC.Internal.Heap.ProfInfo.Types where + +import GHC.Internal.Base +import GHC.Internal.Word +import GHC.Internal.Generics +import GHC.Internal.Show + +-- | This is a somewhat faithful representation of StgTSOProfInfo. See +-- <https://gitlab.haskell.org/ghc/ghc/blob/master/rts/include/rts/storage/TSO.h> +-- for more details on this data structure. +newtype StgTSOProfInfo = StgTSOProfInfo { + cccs :: Maybe CostCentreStack +} deriving (Show, Generic, Eq, Ord) + +-- | This is a somewhat faithful representation of CostCentreStack. See +-- <https://gitlab.haskell.org/ghc/ghc/blob/master/rts/include/rts/prof/CCS.h> +-- for more details on this data structure. +data CostCentreStack = CostCentreStack { + ccs_ccsID :: Int, + ccs_cc :: CostCentre, + ccs_prevStack :: Maybe CostCentreStack, + ccs_indexTable :: Maybe IndexTable, + ccs_root :: Maybe CostCentreStack, + ccs_depth :: Word, + ccs_scc_count :: Word64, + ccs_selected :: Word, + ccs_time_ticks :: Word, + ccs_mem_alloc :: Word64, + ccs_inherited_alloc :: Word64, + ccs_inherited_ticks :: Word +} deriving (Show, Generic, Eq, Ord) + +-- | This is a somewhat faithful representation of CostCentre. See +-- <https://gitlab.haskell.org/ghc/ghc/blob/master/rts/include/rts/prof/CCS.h> +-- for more details on this data structure. +data CostCentre = CostCentre { + cc_ccID :: Int, + cc_label :: String, + cc_module :: String, + cc_srcloc :: Maybe String, + cc_mem_alloc :: Word64, + cc_time_ticks :: Word, + cc_is_caf :: Bool, + cc_link :: Maybe CostCentre +} deriving (Show, Generic, Eq, Ord) + +-- | This is a somewhat faithful representation of IndexTable. See +-- <https://gitlab.haskell.org/ghc/ghc/blob/master/rts/include/rts/prof/CCS.h> +-- for more details on this data structure. +data IndexTable = IndexTable { + it_cc :: CostCentre, + it_ccs :: Maybe CostCentreStack, + it_next :: Maybe IndexTable, + it_back_edge :: Bool +} deriving (Show, Generic, Eq, Ord) ===================================== libraries/ghc-internal/src/GHC/Internal/Stack/Annotation.hs ===================================== @@ -0,0 +1,32 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +module GHC.Internal.Stack.Annotation ( + IsStackAnnotation(..), + SomeStackAnnotation(..), + ) + where + +import GHC.Internal.Base +import GHC.Internal.Data.Typeable + +-- ---------------------------------------------------------------------------- +-- IsStackAnnotation +-- ---------------------------------------------------------------------------- + +class IsStackAnnotation a where + displayStackAnnotation :: a -> String + +-- ---------------------------------------------------------------------------- +-- Annotations +-- ---------------------------------------------------------------------------- + +{- | +The @SomeStackAnnotation@ type is the root of the stack annotation type hierarchy. +When the call stack is annotated with a value of type @a@, behind the scenes it is +encapsulated in a @SomeStackAnnotation@. +-} +data SomeStackAnnotation where + SomeStackAnnotation :: forall a. (Typeable a, IsStackAnnotation a) => a -> SomeStackAnnotation + +instance IsStackAnnotation SomeStackAnnotation where + displayStackAnnotation (SomeStackAnnotation a) = displayStackAnnotation a ===================================== libraries/ghc-internal/src/GHC/Internal/Stack/CloneStack.hs ===================================== @@ -18,8 +18,8 @@ module GHC.Internal.Stack.CloneStack ( StackEntry(..), cloneMyStack, cloneThreadStack, - decode, - prettyStackEntry + decode, -- TODO @fendor: deprecate + toStackEntry, -- TODO @fendor: deprecate ) where import GHC.Internal.MVar @@ -40,7 +40,7 @@ import GHC.Internal.ClosureTypes -- -- @since base-4.17.0.0 data StackSnapshot = StackSnapshot !StackSnapshot# - +-- TODO @fendor: deprecate foreign import prim "stg_decodeStackzh" decodeStack# :: StackSnapshot# -> State# RealWorld -> (# State# RealWorld, ByteArray# #) foreign import prim "stg_cloneMyStackzh" cloneMyStack# :: State# RealWorld -> (# State# RealWorld, StackSnapshot# #) @@ -208,6 +208,7 @@ cloneThreadStack (ThreadId tid#) = do -- | Representation for the source location where a return frame was pushed on the stack. -- This happens every time when a @case ... of@ scrutinee is evaluated. +-- TODO @fendor: deprecate data StackEntry = StackEntry { functionName :: String, moduleName :: String, @@ -232,9 +233,11 @@ data StackEntry = StackEntry -- is evaluated.) -- -- @since base-4.17.0.0 +-- TODO @fendor: deprecate decode :: StackSnapshot -> IO [StackEntry] decode stackSnapshot = catMaybes `fmap` getDecodedStackArray stackSnapshot +-- TODO @fendor: deprecate toStackEntry :: InfoProv -> StackEntry toStackEntry infoProv = StackEntry @@ -244,6 +247,7 @@ toStackEntry infoProv = closureType = ipDesc infoProv } +-- TODO @fendor: deprecate getDecodedStackArray :: StackSnapshot -> IO [Maybe StackEntry] getDecodedStackArray (StackSnapshot s) = IO $ \s0 -> case decodeStack# s s0 of @@ -263,6 +267,7 @@ getDecodedStackArray (StackSnapshot s) = wordSize = sizeOf (nullPtr :: Ptr ()) +-- TODO @fendor: deprecate prettyStackEntry :: StackEntry -> String prettyStackEntry (StackEntry {moduleName=mod_nm, functionName=fun_nm, srcLoc=loc}) = " " ++ mod_nm ++ "." ++ fun_nm ++ " (" ++ loc ++ ")" ===================================== libraries/ghc-internal/src/GHC/Internal/Stack/Constants.hsc ===================================== @@ -0,0 +1,135 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module GHC.Internal.Stack.Constants where + +import GHC.Internal.Base +import GHC.Internal.Enum +import GHC.Internal.Num +import GHC.Internal.Show +import GHC.Internal.Real + +#include "Rts.h" +#undef BLOCK_SIZE +#undef MBLOCK_SIZE +#undef BLOCKS_PER_MBLOCK +#include "DerivedConstants.h" + +newtype ByteOffset = ByteOffset { offsetInBytes :: Int } + deriving newtype (Eq, Show, Integral, Real, Num, Enum, Ord) + +newtype WordOffset = WordOffset { offsetInWords :: Int } + deriving newtype (Eq, Show, Integral, Real, Num, Enum, Ord) + +offsetStgCatchFrameHandler :: WordOffset +offsetStgCatchFrameHandler = byteOffsetToWordOffset $ + (#const OFFSET_StgCatchFrame_handler) + (#size StgHeader) + +sizeStgCatchFrame :: Int +sizeStgCatchFrame = bytesToWords $ + (#const SIZEOF_StgCatchFrame_NoHdr) + (#size StgHeader) + +offsetStgCatchSTMFrameCode :: WordOffset +offsetStgCatchSTMFrameCode = byteOffsetToWordOffset $ + (#const OFFSET_StgCatchSTMFrame_code) + (#size StgHeader) + +offsetStgCatchSTMFrameHandler :: WordOffset +offsetStgCatchSTMFrameHandler = byteOffsetToWordOffset $ + (#const OFFSET_StgCatchSTMFrame_handler) + (#size StgHeader) + +sizeStgCatchSTMFrame :: Int +sizeStgCatchSTMFrame = bytesToWords $ + (#const SIZEOF_StgCatchSTMFrame_NoHdr) + (#size StgHeader) + +offsetStgUpdateFrameUpdatee :: WordOffset +offsetStgUpdateFrameUpdatee = byteOffsetToWordOffset $ + (#const OFFSET_StgUpdateFrame_updatee) + (#size StgHeader) + +sizeStgUpdateFrame :: Int +sizeStgUpdateFrame = bytesToWords $ + (#const SIZEOF_StgUpdateFrame_NoHdr) + (#size StgHeader) + +offsetStgAtomicallyFrameCode :: WordOffset +offsetStgAtomicallyFrameCode = byteOffsetToWordOffset $ + (#const OFFSET_StgAtomicallyFrame_code) + (#size StgHeader) + +offsetStgAtomicallyFrameResult :: WordOffset +offsetStgAtomicallyFrameResult = byteOffsetToWordOffset $ + (#const OFFSET_StgAtomicallyFrame_result) + (#size StgHeader) + +sizeStgAtomicallyFrame :: Int +sizeStgAtomicallyFrame = bytesToWords $ + (#const SIZEOF_StgAtomicallyFrame_NoHdr) + (#size StgHeader) + +offsetStgCatchRetryFrameRunningAltCode :: WordOffset +offsetStgCatchRetryFrameRunningAltCode = byteOffsetToWordOffset $ + (#const OFFSET_StgCatchRetryFrame_running_alt_code) + (#size StgHeader) + +offsetStgCatchRetryFrameRunningFirstCode :: WordOffset +offsetStgCatchRetryFrameRunningFirstCode = byteOffsetToWordOffset $ + (#const OFFSET_StgCatchRetryFrame_first_code) + (#size StgHeader) + +offsetStgCatchRetryFrameAltCode :: WordOffset +offsetStgCatchRetryFrameAltCode = byteOffsetToWordOffset $ + (#const OFFSET_StgCatchRetryFrame_alt_code) + (#size StgHeader) + +sizeStgCatchRetryFrame :: Int +sizeStgCatchRetryFrame = bytesToWords $ + (#const SIZEOF_StgCatchRetryFrame_NoHdr) + (#size StgHeader) + +offsetStgRetFunFrameSize :: WordOffset +-- StgRetFun has no header, but only a pointer to the info table at the beginning. +offsetStgRetFunFrameSize = byteOffsetToWordOffset (#const OFFSET_StgRetFun_size) + +offsetStgRetFunFrameFun :: WordOffset +offsetStgRetFunFrameFun = byteOffsetToWordOffset (#const OFFSET_StgRetFun_fun) + +offsetStgRetFunFramePayload :: WordOffset +offsetStgRetFunFramePayload = byteOffsetToWordOffset (#const OFFSET_StgRetFun_payload) + +sizeStgRetFunFrame :: Int +sizeStgRetFunFrame = bytesToWords (#const SIZEOF_StgRetFun) + +sizeStgAnnFrame :: Int +sizeStgAnnFrame = bytesToWords $ + (#const SIZEOF_StgAnnFrame_NoHdr) + (#size StgHeader) + +offsetStgAnnFrameAnn :: WordOffset +offsetStgAnnFrameAnn = byteOffsetToWordOffset $ + (#const OFFSET_StgAnnFrame_ann) + (#size StgHeader) + +offsetStgBCOFrameInstrs :: ByteOffset +offsetStgBCOFrameInstrs = (#const OFFSET_StgBCO_instrs) + (#size StgHeader) + +offsetStgBCOFrameLiterals :: ByteOffset +offsetStgBCOFrameLiterals = (#const OFFSET_StgBCO_literals) + (#size StgHeader) + +offsetStgBCOFramePtrs :: ByteOffset +offsetStgBCOFramePtrs = (#const OFFSET_StgBCO_ptrs) + (#size StgHeader) + +offsetStgBCOFrameArity :: ByteOffset +offsetStgBCOFrameArity = (#const OFFSET_StgBCO_arity) + (#size StgHeader) + +offsetStgBCOFrameSize :: ByteOffset +offsetStgBCOFrameSize = (#const OFFSET_StgBCO_size) + (#size StgHeader) + +offsetStgClosurePayload :: WordOffset +offsetStgClosurePayload = byteOffsetToWordOffset $ + (#const OFFSET_StgClosure_payload) + (#size StgHeader) + +sizeStgClosure :: Int +sizeStgClosure = bytesToWords (#size StgHeader) + +byteOffsetToWordOffset :: ByteOffset -> WordOffset +byteOffsetToWordOffset = WordOffset . bytesToWords . fromInteger . toInteger + +bytesToWords :: Int -> Int +bytesToWords b = + if b `mod` bytesInWord == 0 then + fromIntegral $ b `div` bytesInWord + else + error "Unexpected struct alignment!" + +bytesInWord :: Int +bytesInWord = (#const SIZEOF_VOID_P) + ===================================== libraries/ghc-internal/src/GHC/Internal/Stack/Decode.hs ===================================== @@ -0,0 +1,499 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GHCForeignImportPrim #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UnliftedFFITypes #-} + +module GHC.Internal.Stack.Decode ( + decodeStack, + decodeStackWithIpe, + prettyStackFrameWithIpe, + -- * StackEntry + StackEntry(..), + prettyStackEntry, + decode, + ) +where + +import GHC.Internal.Base +import GHC.Internal.Show +import GHC.Internal.Real +import GHC.Internal.Word +import GHC.Internal.Num +import GHC.Internal.Data.Bits +import GHC.Internal.Data.Functor +import GHC.Internal.Data.List +import GHC.Internal.Data.Tuple +import GHC.Internal.Foreign.Ptr +import GHC.Internal.Foreign.Storable +import GHC.Internal.Exts +import GHC.Internal.Unsafe.Coerce + +import GHC.Internal.ClosureTypes +import GHC.Internal.Heap.Closures + ( Box (..), + StackFrame, + GenStackFrame (..), + StgStackClosure, + GenStgStackClosure (..), + StackField, + GenStackField(..) + ) +import GHC.Internal.Heap.Constants (wORD_SIZE_IN_BITS) +import GHC.Internal.Heap.InfoTable +import GHC.Internal.Stack.Annotation +import GHC.Internal.Stack.Constants +import GHC.Internal.Stack.CloneStack +import GHC.Internal.InfoProv.Types (InfoProv (..), lookupIPE) + +{- Note [Decoding the stack] + ~~~~~~~~~~~~~~~~~~~~~~~~~ + +The stack is represented by a chain of StgStack closures. Each of these closures +is subject to garbage collection. I.e. they can be moved in memory (in a +simplified perspective) at any time. + +The array of closures inside an StgStack (that makeup the execution stack; the +stack frames) is moved as bare memory by the garbage collector. References +(pointers) to stack frames are not updated by the garbage collector. + +As the StgStack closure is moved as whole, the relative offsets inside it stay +the same. (Though, the absolute addresses change!) + +Decoding +======== + +Stack frames are defined by their `StackSnapshot#` (`StgStack*` in RTS) and +their relative offset. This tuple is described by `StackFrameLocation`. + +`StackFrame` is an ADT for decoded stack frames. Regarding payload and fields we +have to deal with three cases: + +- If the payload can only be a closure, we put it in a `Box` for later decoding + by the heap closure functions. + +- If the payload can either be a closure or a word-sized value (this happens for + bitmap-encoded payloads), we use a `StackField` which is a sum type to + represent either a `Word` or a `Box`. + +- Fields that are just simple (i.e. non-closure) values are decoded as such. + +The decoding happens in two phases: + +1. The whole stack is decoded into `StackFrameLocation`s. + +2. All `StackFrameLocation`s are decoded into `StackFrame`s. + +`StackSnapshot#` parameters are updated by the garbage collector and thus safe +to hand around. + +The head of the stack frame array has offset (index) 0. To traverse the stack +frames the latest stack frame's offset is incremented by the closure size. The +unit of the offset is machine words (32bit or 64bit.) + +IO +== + +Unfortunately, ghc-heap decodes `Closure`s in `IO`. This leads to `StackFrames` +also being decoded in `IO`, due to references to `Closure`s. + +Technical details +================= + +- All access to StgStack/StackSnapshot# closures is made through Cmm code. This + keeps the closure from being moved by the garbage collector during the + operation. + +- As StgStacks are mainly used in Cmm and C code, much of the decoding logic is + implemented in Cmm and C. It's just easier to reuse existing helper macros and + functions, than reinventing them in Haskell. + +- Offsets and sizes of closures are imported from DerivedConstants.h via HSC. + This keeps the code very portable. +-} + +foreign import prim "getUnderflowFrameNextChunkzh" + getUnderflowFrameNextChunk# :: + StackSnapshot# -> Word# -> StackSnapshot# + +getUnderflowFrameNextChunk :: StackSnapshot# -> WordOffset -> StackSnapshot +getUnderflowFrameNextChunk stackSnapshot# index = + StackSnapshot (getUnderflowFrameNextChunk# stackSnapshot# (wordOffsetToWord# index)) + +foreign import prim "getWordzh" + getWord# :: + StackSnapshot# -> Word# -> Word# + +getWord :: StackSnapshot# -> WordOffset -> Word +getWord stackSnapshot# index = + W# (getWord# stackSnapshot# (wordOffsetToWord# index)) + +foreign import prim "isArgGenBigRetFunTypezh" isArgGenBigRetFunType# :: StackSnapshot# -> Word# -> Int# + +isArgGenBigRetFunType :: StackSnapshot# -> WordOffset -> Bool +isArgGenBigRetFunType stackSnapshot# index = + I# (isArgGenBigRetFunType# stackSnapshot# (wordOffsetToWord# index)) > 0 + +-- | Gets contents of a `LargeBitmap` (@StgLargeBitmap@) +-- +-- The first two arguments identify the location of the frame on the stack. +-- Returned is the `Addr#` of the @StgWord[]@ (bitmap) and it's size. +type LargeBitmapGetter = StackSnapshot# -> Word# -> (# Addr#, Word# #) + +foreign import prim "getLargeBitmapzh" getLargeBitmap# :: LargeBitmapGetter + +foreign import prim "getBCOLargeBitmapzh" getBCOLargeBitmap# :: LargeBitmapGetter + +foreign import prim "getRetFunLargeBitmapzh" getRetFunLargeBitmap# :: LargeBitmapGetter + +-- | Gets contents of a small bitmap (fitting in one @StgWord@) +-- +-- The first two arguments identify the location of the frame on the stack. +-- Returned is the bitmap and it's size. +type SmallBitmapGetter = StackSnapshot# -> Word# -> (# Word#, Word# #) + +foreign import prim "getSmallBitmapzh" getSmallBitmap# :: SmallBitmapGetter + +foreign import prim "getRetFunSmallBitmapzh" getRetFunSmallBitmap# :: SmallBitmapGetter + +foreign import prim "getInfoTableAddrszh" getInfoTableAddrs# :: StackSnapshot# -> Word# -> (# Addr#, Addr# #) + +foreign import prim "getStackInfoTableAddrzh" getStackInfoTableAddr# :: StackSnapshot# -> Addr# + +-- | Get the 'StgInfoTable' of the stack frame. +-- Additionally, provides 'InfoProv' for the 'StgInfoTable' if there is any. +getInfoTableOnStack :: StackSnapshot# -> WordOffset -> IO (StgInfoTable, Maybe InfoProv) +getInfoTableOnStack stackSnapshot# index = + let !(# itbl_struct#, itbl_ptr# #) = getInfoTableAddrs# stackSnapshot# (wordOffsetToWord# index) + in + (,) <$> peekItbl (Ptr itbl_struct#) <*> lookupIPE (Ptr itbl_ptr#) + +getInfoTableForStack :: StackSnapshot# -> IO StgInfoTable +getInfoTableForStack stackSnapshot# = + peekItbl $ + Ptr (getStackInfoTableAddr# stackSnapshot#) + +foreign import prim "getStackClosurezh" + getStackClosure# :: + StackSnapshot# -> Word# -> Any + +foreign import prim "getStackFieldszh" + getStackFields# :: + StackSnapshot# -> Word32# + +getStackFields :: StackSnapshot# -> Word32 +getStackFields stackSnapshot# = + case getStackFields# stackSnapshot# of + sSize# -> W32# sSize# + +-- | `StackFrameLocation` of the top-most stack frame +stackHead :: StackSnapshot# -> StackFrameLocation +stackHead s# = (StackSnapshot s#, 0) -- GHC stacks are never empty + +-- | Advance to the next stack frame (if any) +-- +-- The last `Int#` in the result tuple is meant to be treated as bool +-- (has_next). +foreign import prim "advanceStackFrameLocationzh" + advanceStackFrameLocation# :: + StackSnapshot# -> Word# -> (# StackSnapshot#, Word#, Int# #) + +-- | Advance to the next stack frame (if any) +advanceStackFrameLocation :: StackFrameLocation -> Maybe StackFrameLocation +advanceStackFrameLocation ((StackSnapshot stackSnapshot#), index) = + let !(# s', i', hasNext #) = advanceStackFrameLocation# stackSnapshot# (wordOffsetToWord# index) + in if I# hasNext > 0 + then Just (StackSnapshot s', primWordToWordOffset i') + else Nothing + where + primWordToWordOffset :: Word# -> WordOffset + primWordToWordOffset w# = fromIntegral (W# w#) + +getClosureBox :: StackSnapshot# -> WordOffset -> Box +getClosureBox stackSnapshot# index = + case getStackClosure# stackSnapshot# (wordOffsetToWord# index) of + -- c needs to be strictly evaluated, otherwise a thunk gets boxed (and + -- will later be decoded as such) + !c -> Box c + +-- | Representation of @StgLargeBitmap@ (RTS) +data LargeBitmap = LargeBitmap + { largeBitmapSize :: Word, + largebitmapWords :: Ptr Word + } + +-- | Is a bitmap entry a closure pointer or a primitive non-pointer? +data Pointerness = Pointer | NonPointer + deriving (Show) + +decodeLargeBitmap :: LargeBitmapGetter -> StackSnapshot# -> WordOffset -> WordOffset -> IO [StackField] +decodeLargeBitmap getterFun# stackSnapshot# index relativePayloadOffset = do + let largeBitmap = case getterFun# stackSnapshot# (wordOffsetToWord# index) of + (# wordsAddr#, size# #) -> LargeBitmap (W# size#) (Ptr wordsAddr#) + bitmapWords <- largeBitmapToList largeBitmap + pure $ decodeBitmaps + stackSnapshot# + (index + relativePayloadOffset) + (bitmapWordsPointerness (largeBitmapSize largeBitmap) bitmapWords) + where + largeBitmapToList :: LargeBitmap -> IO [Word] + largeBitmapToList LargeBitmap {..} = + cWordArrayToList largebitmapWords $ + (usedBitmapWords . fromIntegral) largeBitmapSize + + cWordArrayToList :: Ptr Word -> Int -> IO [Word] + cWordArrayToList ptr size = mapM (peekElemOff ptr) [0 .. (size - 1)] + + usedBitmapWords :: Int -> Int + usedBitmapWords 0 = error "Invalid large bitmap size 0." + usedBitmapWords size = (size `div` fromIntegral wORD_SIZE_IN_BITS) + 1 + + bitmapWordsPointerness :: Word -> [Word] -> [Pointerness] + bitmapWordsPointerness size _ | size <= 0 = [] + bitmapWordsPointerness _ [] = [] + bitmapWordsPointerness size (w : wds) = + bitmapWordPointerness (min size (fromIntegral wORD_SIZE_IN_BITS)) w + ++ bitmapWordsPointerness (size - fromIntegral wORD_SIZE_IN_BITS) wds + +bitmapWordPointerness :: Word -> Word -> [Pointerness] +bitmapWordPointerness 0 _ = [] +bitmapWordPointerness bSize bitmapWord = + ( if (bitmapWord .&. 1) /= 0 + then NonPointer + else Pointer + ) + : bitmapWordPointerness + (bSize - 1) + (bitmapWord `shiftR` 1) + +decodeBitmaps :: StackSnapshot# -> WordOffset -> [Pointerness] -> [StackField] +decodeBitmaps stack# index ps = + zipWith toPayload ps [index ..] + where + toPayload :: Pointerness -> WordOffset -> StackField + toPayload p i = case p of + NonPointer -> StackWord (getWord stack# i) + Pointer -> StackBox (getClosureBox stack# i) + +decodeSmallBitmap :: SmallBitmapGetter -> StackSnapshot# -> WordOffset -> WordOffset -> [StackField] +decodeSmallBitmap getterFun# stackSnapshot# index relativePayloadOffset = + let (bitmap, size) = case getterFun# stackSnapshot# (wordOffsetToWord# index) of + (# b#, s# #) -> (W# b#, W# s#) + in decodeBitmaps + stackSnapshot# + (index + relativePayloadOffset) + (bitmapWordPointerness size bitmap) + +unpackStackFrame :: StackFrameLocation -> IO StackFrame +unpackStackFrame stackFrameLoc = do + unpackStackFrameTo stackFrameLoc + (\ info nextChunk -> do + stackClosure <- decodeStack nextChunk + pure $ + UnderflowFrame + { info_tbl = info, + nextChunk = stackClosure + } + ) + (\ frame _ -> pure frame) + +unpackStackFrameWithIpe :: StackFrameLocation -> IO [(StackFrame, Maybe InfoProv)] +unpackStackFrameWithIpe stackFrameLoc = do + unpackStackFrameTo stackFrameLoc + (\ _ nextChunk -> do + decodeStackWithIpe nextChunk + ) + (\ frame mIpe -> pure [(frame, mIpe)]) + +unpackStackFrameTo :: + forall a . + StackFrameLocation -> + (StgInfoTable -> StackSnapshot -> IO a) -> + (StackFrame -> Maybe InfoProv -> IO a) -> + IO a +unpackStackFrameTo (StackSnapshot stackSnapshot#, index) unpackUnderflowFrame finaliseStackFrame = do + (info, m_info_prov) <- getInfoTableOnStack stackSnapshot# index + unpackStackFrame' info + (`finaliseStackFrame` m_info_prov) + where + unpackStackFrame' :: + StgInfoTable -> + (StackFrame -> IO a) -> + IO a + unpackStackFrame' info mkStackFrameResult = + case tipe info of + RET_BCO -> do + let bco' = getClosureBox stackSnapshot# (index + offsetStgClosurePayload) + -- The arguments begin directly after the payload's one element + bcoArgs' <- decodeLargeBitmap getBCOLargeBitmap# stackSnapshot# index (offsetStgClosurePayload + 1) + mkStackFrameResult + RetBCO + { info_tbl = info, + bco = bco', + bcoArgs = bcoArgs' + } + RET_SMALL -> + let payload' = decodeSmallBitmap getSmallBitmap# stackSnapshot# index offsetStgClosurePayload + in + mkStackFrameResult $ + RetSmall + { info_tbl = info, + stack_payload = payload' + } + RET_BIG -> do + payload' <- decodeLargeBitmap getLargeBitmap# stackSnapshot# index offsetStgClosurePayload + mkStackFrameResult $ + RetBig + { info_tbl = info, + stack_payload = payload' + } + RET_FUN -> do + let retFunSize' = getWord stackSnapshot# (index + offsetStgRetFunFrameSize) + retFunFun' = getClosureBox stackSnapshot# (index + offsetStgRetFunFrameFun) + retFunPayload' <- + if isArgGenBigRetFunType stackSnapshot# index == True + then decodeLargeBitmap getRetFunLargeBitmap# stackSnapshot# index offsetStgRetFunFramePayload + else pure $ decodeSmallBitmap getRetFunSmallBitmap# stackSnapshot# index offsetStgRetFunFramePayload + mkStackFrameResult $ + RetFun + { info_tbl = info, + retFunSize = retFunSize', + retFunFun = retFunFun', + retFunPayload = retFunPayload' + } + UPDATE_FRAME -> + let updatee' = getClosureBox stackSnapshot# (index + offsetStgUpdateFrameUpdatee) + in + mkStackFrameResult $ + UpdateFrame + { info_tbl = info, + updatee = updatee' + } + CATCH_FRAME -> do + let handler' = getClosureBox stackSnapshot# (index + offsetStgCatchFrameHandler) + mkStackFrameResult $ + CatchFrame + { info_tbl = info, + handler = handler' + } + UNDERFLOW_FRAME -> do + let nextChunk' = getUnderflowFrameNextChunk stackSnapshot# index + unpackUnderflowFrame info nextChunk' + STOP_FRAME -> mkStackFrameResult $ StopFrame {info_tbl = info} + ATOMICALLY_FRAME -> do + let atomicallyFrameCode' = getClosureBox stackSnapshot# (index + offsetStgAtomicallyFrameCode) + result' = getClosureBox stackSnapshot# (index + offsetStgAtomicallyFrameResult) + mkStackFrameResult $ + AtomicallyFrame + { info_tbl = info, + atomicallyFrameCode = atomicallyFrameCode', + result = result' + } + CATCH_RETRY_FRAME -> + let running_alt_code' = getWord stackSnapshot# (index + offsetStgCatchRetryFrameRunningAltCode) + first_code' = getClosureBox stackSnapshot# (index + offsetStgCatchRetryFrameRunningFirstCode) + alt_code' = getClosureBox stackSnapshot# (index + offsetStgCatchRetryFrameAltCode) + in + mkStackFrameResult $ + CatchRetryFrame + { info_tbl = info, + running_alt_code = running_alt_code', + first_code = first_code', + alt_code = alt_code' + } + CATCH_STM_FRAME -> + let catchFrameCode' = getClosureBox stackSnapshot# (index + offsetStgCatchSTMFrameCode) + handler' = getClosureBox stackSnapshot# (index + offsetStgCatchSTMFrameHandler) + in + mkStackFrameResult $ + CatchStmFrame + { info_tbl = info, + catchFrameCode = catchFrameCode', + handler = handler' + } + ANN_FRAME -> + let annotation = getClosureBox stackSnapshot# (index + offsetStgAnnFrameAnn) + in + mkStackFrameResult $ + AnnFrame + { info_tbl = info, + annotation = annotation + } + x -> error $ "Unexpected closure type on stack: " ++ show x + +-- | Unbox 'Int#' from 'Int' +toInt# :: Int -> Int# +toInt# (I# i) = i + +-- | Convert `Int` to `Word#` +intToWord# :: Int -> Word# +intToWord# i = int2Word# (toInt# i) + +wordOffsetToWord# :: WordOffset -> Word# +wordOffsetToWord# wo = intToWord# (fromIntegral wo) + +-- | Location of a stackframe on the stack +-- +-- It's defined by the `StackSnapshot` (@StgStack@) and the offset to the bottom +-- of the stack. +type StackFrameLocation = (StackSnapshot, WordOffset) + +-- | Decode `StackSnapshot` to a `StgStackClosure` +-- +-- The return value is the representation of the @StgStack@ itself. +-- +-- See /Note [Decoding the stack]/. +decodeStack :: StackSnapshot -> IO StgStackClosure +decodeStack snapshot@(StackSnapshot stack#) = do + (stackInfo, ssc_stack) <- decodeStackWithFrameUnpack unpackStackFrame snapshot + pure + GenStgStackClosure + { ssc_info = stackInfo, + ssc_stack_size = getStackFields stack#, + ssc_stack = ssc_stack + } + +decodeStackWithIpe :: StackSnapshot -> IO [(StackFrame, Maybe InfoProv)] +decodeStackWithIpe snapshot = + concat . snd <$> decodeStackWithFrameUnpack unpackStackFrameWithIpe snapshot + +decodeStackWithFrameUnpack :: (StackFrameLocation -> IO a) -> StackSnapshot -> IO (StgInfoTable, [a]) +decodeStackWithFrameUnpack unpackFrame (StackSnapshot stack#) = do + info <- getInfoTableForStack stack# + case tipe info of + STACK -> do + let sfls = stackFrameLocations stack# + stack' <- mapM unpackFrame sfls + pure (info, stack') + _ -> error $ "Expected STACK closure, got " ++ show info + where + stackFrameLocations :: StackSnapshot# -> [StackFrameLocation] + stackFrameLocations s# = + stackHead s# + : go (advanceStackFrameLocation (stackHead s#)) + where + go :: Maybe StackFrameLocation -> [StackFrameLocation] + go Nothing = [] + go (Just r) = r : go (advanceStackFrameLocation r) + +prettyStackFrameWithIpe :: (StackFrame, Maybe InfoProv) -> Maybe String +prettyStackFrameWithIpe (frame, mipe) = + case frame of + AnnFrame _ (Box ann) -> + Just $ displayStackAnnotation (unsafeCoerce ann :: SomeStackAnnotation) + _ -> + (prettyStackEntry . toStackEntry) <$> mipe + + +-- TODO @fendor: deprecate +prettyStackEntry :: StackEntry -> String +prettyStackEntry (StackEntry {moduleName=mod_nm, functionName=fun_nm, srcLoc=loc}) = + mod_nm ++ "." ++ fun_nm ++ " (" ++ loc ++ ")" View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/dda9f19838c09d3253c62351a49aae… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/dda9f19838c09d3253c62351a49aae… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/haanss/depdir] 6 commits: NCG/LA64: Support finer-grained DBAR hints
by Hassan Al-Awwadi (＠hassan.awwadi) 17 Jul '25

17 Jul '25

Hassan Al-Awwadi pushed to branch wip/haanss/depdir at Glasgow Haskell Compiler / GHC Commits: bbaa44a7 by Peng Fan at 2025-07-16T16:50:42-04:00 NCG/LA64: Support finer-grained DBAR hints For LA664 and newer uarchs, they have made finer granularity hints available: Bit4: ordering or completion (0: completion, 1: ordering) Bit3: barrier for previous read (0: true, 1: false) Bit2: barrier for previous write (0: true, 1: false) Bit1: barrier for succeeding read (0: true, 1: false) Bit0: barrier for succeeding write (0: true, 1: false) And not affect the existing models because other hints are treated as 'dbar 0' there. - - - - - 7da86e16 by Andreas Klebinger at 2025-07-16T16:51:25-04:00 Disable -fprof-late-overloaded-calls for join points. Currently GHC considers cost centres as destructive to join contexts. Or in other words this is not considered valid: join f x = ... in ... -> scc<tick> jmp This makes the functionality of `-fprof-late-overloaded-calls` not feasible for join points in general. We used to try to work around this by putting the ticks on the rhs of the join point rather than around the jump. However beyond the loss of accuracy this was broken for recursive join points as we ended up with something like: rec-join f x = scc<tick> ... jmp f x Which similarly is not valid as the tick once again destroys the tail call. One might think we could limit ourselves to non-recursive tail calls and do something clever like: join f x = scc<tick> ... in ... jmp f x And sometimes this works! But sometimes the full rhs would look something like: join g x = .... join f x = scc<tick> ... -> jmp g x Which, would again no longer be valid. I believe in the long run we can make cost centre ticks non-destructive to join points. Or we could keep track of where we are/are not allowed to insert a cost centre. But in the short term I will simply disable the annotation of join calls under this flag. - - - - - 7ee22fd5 by ARATA Mizuki at 2025-07-17T06:05:30-04:00 x86 NCG: Better lowering for shuffleFloatX4# and shuffleDoubleX2# The new implementation * make use of specialized instructions like (V)UNPCK{L,H}{PS,PD}, and * do not require -mavx. Close #26096 Co-authored-by: sheaf <sam.derbyshire(a)gmail.com> - - - - - c6cd2da1 by Jappie Klooster at 2025-07-17T06:06:20-04:00 Update interact docs to explain about buffering We need to tell the user to set to the appropriate buffer format. Otherwise, this function may get randomly stuck, or just behave confusingly. issue: https://gitlab.haskell.org/ghc/ghc/-/issues/26131 NB, I'm running this with cabal *NOT* ghci. ghci messes with buffering anyway. ```haskell interaction :: String -> String interaction "jappie" = "hi" interaction "jakob" = "hello" interaction x = "unkown input: " <> x main :: IO () main = interact interaction ``` so in my input (prefixed by `>`) I get: ``` > jappie unkown input: jappie ``` we confirmed later this was due to lack of \n matching. Anyway movnig on to more unexpected stuff: ```haskell main :: IO () main = do interact (concatMap interaction . lines) ``` get's stuck forever. actually `^D` (ctrl+d) unstucks it and runs all input as expected. for example you can get: ``` > sdfkds > fakdsf unkown input: sdfkdsunkown input: fakdsf ``` This program works! ```haskell interaction :: String -> String interaction "jappie" = "hi \n" interaction "jakob" = "hello \n" interaction x = "unkown input: " <> x <> "\n" main :: IO () main = do interact (concatMap interaction . lines) ``` the reason is that linebuffering is set for both in and output by default. so lines eats the input lines, and all the \n postfixes make sure the buffer is put out. - - - - - 9fa590a6 by Zubin Duggal at 2025-07-17T06:07:03-04:00 fetch_gitlab: Ensure we copy users_guide.pdf and Haddock.pdf to the release docs directory Fixes #24093 - - - - - 029703a1 by Hassan Al-Awwadi at 2025-07-17T15:05:12+02:00 Adds the fucnction addDependentDirectory to Q, resolving issue #26148. This function adds a new directory to the list of things a module depends upon. That means that when the contents of the directory change, the recompilation checker will notice this and the module will be recompiled. Documentation has also been added for addDependentFunction and addDependentDirectory in the user guide. - - - - - 42 changed files: - .gitlab/rel_eng/fetch-gitlab-artifacts/fetch_gitlab.py - compiler/GHC/CmmToAsm/LA64/CodeGen.hs - compiler/GHC/CmmToAsm/LA64/Instr.hs - compiler/GHC/CmmToAsm/LA64/Ppr.hs - compiler/GHC/CmmToAsm/X86/CodeGen.hs - compiler/GHC/CmmToAsm/X86/Instr.hs - compiler/GHC/CmmToAsm/X86/Ppr.hs - compiler/GHC/Core/LateCC/OverloadedCalls.hs - compiler/GHC/HsToCore/Usage.hs - compiler/GHC/Iface/Make.hs - compiler/GHC/Iface/Recomp.hs - compiler/GHC/Iface/Recomp/Types.hs - compiler/GHC/Tc/Gen/Splice.hs - compiler/GHC/Tc/Types.hs - compiler/GHC/Tc/Utils/Monad.hs - compiler/GHC/Unit/Finder.hs - compiler/GHC/Unit/Finder/Types.hs - compiler/GHC/Unit/Module/Deps.hs - docs/users_guide/9.14.1-notes.rst - docs/users_guide/profiling.rst - docs/users_guide/separate_compilation.rst - libraries/ghc-internal/src/GHC/Internal/System/IO.hs - libraries/ghc-internal/src/GHC/Internal/TH/Syntax.hs - libraries/ghci/GHCi/Message.hs - libraries/ghci/GHCi/TH.hs - libraries/template-haskell/Language/Haskell/TH/Syntax.hs - testsuite/.gitignore - testsuite/tests/interface-stability/template-haskell-exports.stdout - testsuite/tests/simd/should_run/all.T - + testsuite/tests/simd/should_run/doublex2_shuffle.hs - + testsuite/tests/simd/should_run/doublex2_shuffle.stdout - + testsuite/tests/simd/should_run/doublex2_shuffle_baseline.hs - + testsuite/tests/simd/should_run/doublex2_shuffle_baseline.stdout - + testsuite/tests/simd/should_run/floatx4_shuffle.hs - + testsuite/tests/simd/should_run/floatx4_shuffle.stdout - + testsuite/tests/simd/should_run/floatx4_shuffle_baseline.hs - + testsuite/tests/simd/should_run/floatx4_shuffle_baseline.stdout - testsuite/tests/th/Makefile - + testsuite/tests/th/TH_Depends_Dir.hs - + testsuite/tests/th/TH_Depends_Dir.stdout - + testsuite/tests/th/TH_Depends_Dir_External.hs - testsuite/tests/th/all.T The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/519c8edebeebd4eca5aa36e5e732f5… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/519c8edebeebd4eca5aa36e5e732f5… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/stable-ipe-info] 79 commits: Consider `PromotedDataCon` in `tyConStupidTheta`
by Matthew Pickering (＠mpickering) 17 Jul '25

17 Jul '25

Matthew Pickering pushed to branch wip/stable-ipe-info at Glasgow Haskell Compiler / GHC Commits: 8d33d048 by Berk Özkütük at 2025-07-07T20:42:20-04:00 Consider `PromotedDataCon` in `tyConStupidTheta` Haddock checks data declarations for the stupid theta so as not to pretty-print them as empty contexts. Type data declarations end up as `PromotedDataCon`s by the time Haddock performs this check, causing a panic. This commit extends `tyConStupidTheta` so that it returns an empty list for `PromotedDataCon`s. This decision was guided by the fact that type data declarations never have data type contexts (see (R1) in Note [Type data declarations]). Fixes #25739. - - - - - a26243fd by Ryan Hendrickson at 2025-07-07T20:43:07-04:00 haddock: Document instances from other packages When attaching instances to `Interface`s, it isn't enough just to look for instances in the list of `Interface`s being processed. We also need to look in the modules on which they depend, including those outside of this package. Fixes #25147. Fixes #26079. - - - - - 0fb24420 by Rodrigo Mesquita at 2025-07-07T20:43:49-04:00 hadrian: Fallback logic for internal interpreter When determining whether to build the internal interpreter, the `make` build system had a fallback case for platforms not in the list of explicitly-supported operating systems and architectures. This fallback says we should try to build the internal interpreter if building dynamic GHC programs (if the architecture is unknown). Fixes #24098 - - - - - fe925bd4 by Ben Gamari at 2025-07-07T20:44:30-04:00 users-guide: Reference Wasm FFI section - - - - - 5856284b by Ben Gamari at 2025-07-07T20:44:30-04:00 users-guide: Fix too-short heading warning - - - - - a48dcdf3 by Duncan Coutts at 2025-07-07T20:45:18-04:00 Reorganise documentation for allocate* functions Consolodate interface information into the .h file, keeping just implementation details in the .c file. Use Notes stlye in the .h file and refer to notes from the .c file. - - - - - de5b528c by Duncan Coutts at 2025-07-07T20:45:18-04:00 Introduce common utilities for allocating arrays The intention is to share code among the several places that do this already. - - - - - b321319d by Duncan Coutts at 2025-07-07T20:45:18-04:00 Use new array alloc utils in Heap.c The CMM primop can now report heap overflow. - - - - - 1d557ffb by Duncan Coutts at 2025-07-07T20:45:18-04:00 Use new array alloc utils in ThreadLabels.c Replacing a local utility. - - - - - e59a1430 by Duncan Coutts at 2025-07-07T20:45:18-04:00 Use new array alloc utils in Threads.c Replacing local open coded version. - - - - - 482df1c9 by Duncan Coutts at 2025-07-07T20:45:18-04:00 Add exitHeapOverflow helper utility This will be useful with the array alloc functions, since unlike allocate/allocateMaybeFail, they do not come in two versions. So if it's not convenient to propagate failure, then one can use this. - - - - - 4d3ec8f9 by Duncan Coutts at 2025-07-07T20:45:18-04:00 Use new array alloc utils in Weak.c Also add a cpp macro CCS_SYSTEM_OR_NULL which does what it says. The benefit of this is that it allows us to referece CCS_SYSTEM even when we're not in PROFILING mode. That makes abstracting over profiling vs normal mode a lot easier. - - - - - 0c4f2fde by Duncan Coutts at 2025-07-07T20:45:18-04:00 Convert the array alloc primops to use the new array alloc utils - - - - - a3354ad9 by Duncan Coutts at 2025-07-07T20:45:18-04:00 While we're at it, add one missing 'likely' hint To a cmm primops that raises an exception, like the others now do. - - - - - 33b546bd by meooow25 at 2025-07-07T20:46:09-04:00 Keep scanl' strict in the head on rewrite `scanl'` forces elements to WHNF when the corresponding `(:)`s are forced. The rewrite rule for `scanl'` missed forcing the first element, which is fixed here with a `seq`. - - - - - 8a69196e by Rodrigo Mesquita at 2025-07-08T07:39:47-04:00 debugger/rts: Allow toggling step-in per thread The RTS global flag `rts_stop_next_breakpoint` globally sets the interpreter to stop at the immediate next breakpoint. With this commit, single step mode can additionally be set per thread in the TSO flag (TSO_STOP_NEXT_BREAKPOINT). Being able to toggle "stop at next breakpoint" per thread is an important requirement for implementing "stepping out" of a function in a multi-threaded context. And, more generally, having a per-thread flag for single-stepping paves the way for multi-threaded debugging. That said, when we want to enable "single step" mode for the whole interpreted program we still want to stop at the immediate next breakpoint, whichever thread it belongs to. That's why we also keep the global `rts_stop_next_breakpoint` flag, with `rts_enableStopNextBreakpointAll` and `rts_disableStopNextBreakpointAll` helpers. Preparation for #26042 - - - - - 73d3f864 by Rodrigo Mesquita at 2025-07-08T07:39:47-04:00 docs: Case continuation BCOs This commit documents a subtle interaction between frames for case BCOs and their parents frames. Namely, case continuation BCOs may refer to (non-local) variables that are part of the parent's frame. The note expanding a bit on these details is called [Case continuation BCOs] - - - - - d7aeddcf by Rodrigo Mesquita at 2025-07-08T07:39:47-04:00 debugger: Implement step-out feature Implements support for stepping-out of a function (aka breaking right after returning from a function) in the interactive debugger. It also introduces a GHCi command :stepout to step-out of a function being debugged in the interpreter. The feature is described as: Stop at the first breakpoint immediately after returning from the current function scope. Known limitations: because a function tail-call does not push a stack frame, if step-out is used inside of a function that was tail-called, execution will not be returned to its caller, but rather its caller's first non-tail caller. On the other hand, it means the debugger follows the more realistic execution of the program. In the following example: .. code-block:: none f = do a b <--- (1) set breakpoint then step in here c b = do ... d <--- (2) step-into this tail call d = do ... something <--- (3) step-out here ... Stepping-out will stop execution at the `c` invokation in `f`, rather than stopping at `b`. The key idea is simple: When step-out is enabled, traverse the runtime stack until a continuation BCO is found -- and enable the breakpoint heading that BCO explicitly using its tick-index. The details are specified in `Note [Debugger: Step-out]` in `rts/Interpreter.c`. Since PUSH_ALTS BCOs (representing case continuations) were never headed by a breakpoint (unlike the case alternatives they push), we introduced the BRK_ALTS instruction to allow the debugger to set a case continuation to stop at the breakpoint heading the alternative that is taken. This is further described in `Note [Debugger: BRK_ALTS]`. Fixes #26042 - - - - - 5d9adf51 by Rodrigo Mesquita at 2025-07-08T07:39:47-04:00 debugger: Filter step-out stops by SrcSpan To implement step-out, the RTS looks for the first continuation frame on the stack and explicitly enables its entry breakpoint. However, some continuations will be contained in the function from which step-out was initiated (trivial example is a case expression). Similarly to steplocal, we will filter the breakpoints at which the RTS yields to the debugger based on the SrcSpan. When doing step-out, only stop if the breakpoint is /not/ contained in the function from which we initiated it. This is especially relevant in monadic statements such as IO which is compiled to a long chain of case expressions. See Note [Debugger: Filtering step-out stops] - - - - - 7677adcc by Cheng Shao at 2025-07-08T07:40:29-04:00 compiler: make ModBreaks serializable - - - - - 14f67c6d by Rodrigo Mesquita at 2025-07-08T07:40:29-04:00 refactor: "Inspecting the session" moved from GHC Moved utilities for inspecting the session from the GHC module to GHC.Driver.Session.Inspect Purely a clean up - - - - - 9d3f484a by Rodrigo Mesquita at 2025-07-08T07:40:30-04:00 cleanup: Pass the HUG to readModBreaks, not HscEnv A minor cleanup. The associated history and setupBreakpoint functions are changed accordingly. - - - - - b595f713 by Rodrigo Mesquita at 2025-07-08T07:40:30-04:00 cleanup: Move readModBreaks to GHC.Runtime.Interpreter With some small docs changes - - - - - d223227a by Rodrigo Mesquita at 2025-07-08T07:40:30-04:00 cleanup: Move interpreterProfiled to Interp.Types Moves interpreterProfiled and interpreterDynamic to GHC.Runtime.Interpreter.Types from GHC.Runtime.Interpreter. - - - - - 7fdd0a3d by Rodrigo Mesquita at 2025-07-08T07:40:30-04:00 cleanup: Don't import GHC in Debugger.Breakpoints Remove the top-level import GHC from GHC.Runtime.Debugger.Breakpoints This makes the module dependencies more granular and cleans up the qualified imports from the code. - - - - - 5e4da31b by Rodrigo Mesquita at 2025-07-08T07:40:30-04:00 refactor: Use BreakpointId in Core and Ifaces - - - - - 741ac3a8 by Rodrigo Mesquita at 2025-07-08T07:40:30-04:00 stg2bc: Derive BcM via ReaderT StateT A small refactor that simplifies GHC.StgToByteCode by deriving-via the Monad instances for BcM. This is done along the lines of previous similar refactors like 72b54c0760bbf85be1f73c1a364d4701e5720465. - - - - - 0414fcc9 by Rodrigo Mesquita at 2025-07-08T07:40:30-04:00 refact: Split InternalModBreaks out of ModBreaks There are currently two competing ways of referring to a Breakpoint: 1. Using the Tick module + Tick index 2. Using the Info module + Info index 1. The Tick index is allocated during desugaring in `mkModBreaks`. It is used to refer to a breakpoint associated to a Core Tick. For a given Tick module, there are N Ticks indexed by Tick index. 2. The Info index is allocated during code generation (in StgToByteCode) and uniquely identifies the breakpoints at runtime (and is indeed used to determine which breakpoint was hit at runtime). Why we need both is described by Note [Breakpoint identifiers]. For every info index we used to keep a `CgBreakInfo`, a datatype containing information relevant to ByteCode Generation, in `ModBreaks`. This commit splits out the `IntMap CgBreakInfo` out of `ModBreaks` into a new datatype `InternalModBreaks`. - The purpose is to separate the `ModBreaks` datatype, which stores data associated from tick-level information which is fixed after desugaring, from the unrelated `IntMap CgBreakInfo` information accumulated during bytecode generation. - We move `ModBreaks` to GHC.HsToCore.Breakpoints The new `InternalModBreaks` simply combines the `IntMap CgBreakInfo` with `ModBreaks`. After code generation we construct an `InternalModBreaks` with the `CgBreakInfo`s we accumulated and the existing `ModBreaks` and store that in the compiled BCO in `bc_breaks`. - Note that we previously only updated the `modBreaks_breakInfo` field of `ModBreaks` at this exact location, and then stored the updated `ModBreaks` in the same `bc_breaks`. - We put this new datatype in GHC.ByteCode.Breakpoints The rest of the pipeline for which CgBreakInfo is relevant is accordingly updated to also use `InternalModBreaks` - - - - - 2a097955 by Rodrigo Mesquita at 2025-07-08T07:40:30-04:00 cleanup: Use BreakpointIds in bytecode gen Small clean up to use BreakpointId and InternalBreakpointId more uniformly in bytecode generation rather than using Module + Ix pairs - - - - - 0515cc2f by Rodrigo Mesquita at 2025-07-08T07:40:30-04:00 ghci: Allocate BreakArrays at link time only Previously, a BreakArray would be allocated with a slot for every tick in a module at `mkModBreaks`, in HsToCore. However, this approach has a few downsides: - It interleaves interpreter behaviour (allocating arrays for breakpoints) within the desugarer - It is inflexible in the sense it is impossible for the bytecode generator to add "internal" breakpoints that can be triggered at runtime, because those wouldn't have a source tick. (This is relevant for our intended implementation plan of step-out in #26042) - It ties the BreakArray indices to the *tick* indexes, while at runtime we would rather just have the *info* indexes (currently we have both because BreakArrays are indexed by the *tick* one). Paving the way for #26042 and #26064, this commit moves the allocation of BreakArrays to bytecode-loading time -- akin to what is done for CCS arrays. Since a BreakArray is allocated only when bytecode is linked, if a breakpoint is set (e.g. `:break 10`) before the bytecode is linked, there will exist no BreakArray to trigger the breakpoint in. Therefore, the function to allocate break arrays (`allocateBreakArrays`) is exposed and also used in GHC.Runtime.Eval to allocate a break array when a breakpoint is set, if it doesn't exist yet (in the linker env). - - - - - 8016561f by Simon Peyton Jones at 2025-07-08T07:41:13-04:00 Add a test for T26176 - - - - - 454cd682 by Simon Peyton Jones at 2025-07-08T07:41:13-04:00 Add test for #14010 This test started to work in GHC 9.6 and has worked since. This MR just adds a regression test - - - - - ea2c6673 by Teo Camarasu at 2025-07-08T13:24:43-04:00 Implement user-defined allocation limit handlers Allocation Limits allow killing a thread if they allocate more than a user-specified limit. We extend this feature to allow more versatile behaviour. - We allow not killing the thread if the limit is exceeded. - We allow setting a custom handler to be called when the limit is exceeded. User-specified allocation limit handlers run in a fresh thread and are passed the ThreadId of the thread that exceeded its limit. We introduce utility functions for getting and setting the allocation limits of other threads, so that users can reset the limit of a thread from a handler. Both of these are somewhat coarse-grained as we are unaware of the allocations in the current nursery chunk. We provide several examples of usages in testsuite/tests/rts/T22859.hs Resolves #22859 - - - - - 03e047f9 by Simon Hengel at 2025-07-08T13:25:25-04:00 Fix typo in using.rst - - - - - 67957854 by Ben Gamari at 2025-07-09T09:44:44-04:00 compiler: Import AnnotationWrapper from ghc-internal Since `GHC.Desugar` exported from `base` has been deprecated. - - - - - 813d99d6 by Ben Gamari at 2025-07-09T09:44:44-04:00 ghc-compact: Eliminate dependency on ghc-prim - - - - - 0ec952a1 by Ben Gamari at 2025-07-09T09:44:44-04:00 ghc-heap: Eliminate dependency on ghc-prim - - - - - 480074c3 by Ben Gamari at 2025-07-09T09:44:44-04:00 ghc-heap: Drop redundant import - - - - - 03455829 by Ben Gamari at 2025-07-09T09:44:45-04:00 ghc-prim: Bump version to 0.13.1 There are no interface changes from 0.13.0 but the implementation now lives in `ghc-internal`. - - - - - d315345a by Ben Gamari at 2025-07-09T09:44:45-04:00 template-haskell: Bump version number to 2.24.0.0 Bumps exceptions submodule. - - - - - 004c800e by Ben Gamari at 2025-07-09T09:44:45-04:00 Bump GHC version number to 9.14 - - - - - eb1a3816 by Ben Gamari at 2025-07-09T09:44:45-04:00 Bump parsec to 3.1.18.0 Bumps parsec submodule. - - - - - 86f83296 by Ben Gamari at 2025-07-09T09:44:45-04:00 unix: Bump to 2.8.7.0 Bumps unix submodule. - - - - - 89e13998 by Ben Gamari at 2025-07-09T09:44:45-04:00 binary: Bump to 0.8.9.3 Bumps binary submodule. - - - - - 55fff191 by Ben Gamari at 2025-07-09T09:44:45-04:00 Win32: Bump to 2.14.2.0 Bumps Win32 submodule. - - - - - 7dafa40c by Ben Gamari at 2025-07-09T09:44:45-04:00 base: Bump version to 4.22.0 Bumps various submodules. - - - - - ef03d8b8 by Rodrigo Mesquita at 2025-07-09T09:45:28-04:00 base: Export displayExceptionWithInfo This function should be exposed from base following CLC#285 Approved change in CLC#344 Fixes #26058 - - - - - 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 - - - - - 2b4db9ba by Pi Delport at 2025-07-11T16:40:52-04:00 (Applicative docs typo: missing "one") - - - - - f707bab4 by Andreas Klebinger at 2025-07-12T14:56:16+01:00 Specialise: Improve specialisation by refactoring interestingDict This MR addresses #26051, which concerns missed type-class specialisation. The main payload of the MR is to completely refactor the key function `interestingDict` in GHC.Core.Opt.Specialise The main change is that we now also look at the structure of the dictionary we consider specializing on, rather than only the type. See the big `Note [Interesting dictionary arguments]` - - - - - ca7a9d42 by Simon Peyton Jones at 2025-07-12T14:56:16+01:00 Treat tuple dictionaries uniformly; don't unbox them See `Note [Do not unbox class dictionaries]` in DmdAnal.hs, sep (DNB1). This MR reverses the plan in #23398, which suggested a special case to unbox tuple dictionaries in worker/wrapper. But: - This was the cause of a pile of complexity in the specialiser (#26158) - Even with that complexity, specialision was still bad, very bad See https://gitlab.haskell.org/ghc/ghc/-/issues/19747#note_626297 And it's entirely unnecessary! Specialision works fine without unboxing tuple dictionaries. - - - - - be7296c9 by Andreas Klebinger at 2025-07-12T14:56:16+01:00 Remove complex special case from the type-class specialiser There was a pretty tricky special case in Specialise which is no longer necessary. * Historical Note [Floating dictionaries out of cases] * #26158 * #19747 https://gitlab.haskell.org/ghc/ghc/-/issues/19747#note_626297 This MR removes it. Hooray. - - - - - 4acf3a86 by Ben Gamari at 2025-07-15T05:46:32-04:00 configure: bump version to 9.15 - - - - - 45efaf71 by Teo Camarasu at 2025-07-15T05:47:13-04:00 rts/nonmovingGC: remove n_free We remove the nonmovingHeap.n_free variable. We wanted this to track the length of nonmovingHeap.free. But this isn't possible to do atomically. When this isn't accurate we can get a segfault by going past the end of the list. Instead, we just count the length of the list when we grab it in nonmovingPruneFreeSegment. Resolves #26186 - - - - - c635f164 by Ben Gamari at 2025-07-15T14:05:54-04:00 configure: Drop probing of ld.gold As noted in #25716, `gold` has been dropped from binutils-2.44. Fixes #25716. Metric Increase: size_hello_artifact_gzip size_hello_unicode_gzip ghc_prim_so - - - - - 637bb538 by Ben Gamari at 2025-07-15T14:05:55-04:00 testsuite/recomp015: Ignore stderr This is necessary since ld.bfd complains that we don't have a .note.GNU-stack section, potentially resulting in an executable stack. - - - - - d3cd4ec8 by Wen Kokke at 2025-07-15T14:06:39-04:00 Fix documentation for heap profile ID - - - - - 73082769 by Ben Gamari at 2025-07-15T16:56:38-04:00 Bump win32-tarballs to v0.9 - - - - - 3b63b254 by Ben Gamari at 2025-07-15T16:56:39-04:00 rts/LoadArchive: Handle null terminated string tables As of `llvm-ar` now emits filename tables terminated with null characters instead of the usual POSIX `/\n` sequence. Fixes #26150. - - - - - 195f6527 by Tamar Christina at 2025-07-15T16:56:39-04:00 rts: rename label so name doesn't conflict with param - - - - - 63373b95 by Tamar Christina at 2025-07-15T16:56:39-04:00 rts: Handle API set symbol versioning conflicts - - - - - 48e9aa3e by Tamar Christina at 2025-07-15T16:56:39-04:00 rts: Mark API set symbols as HIDDEN and correct symbol type - - - - - 959e827a by Tamar Christina at 2025-07-15T16:56:39-04:00 rts: Implement WEAK EXTERNAL undef redirection by target symbol name - - - - - 65f19293 by Ben Gamari at 2025-07-15T16:56:39-04:00 rts/LoadArchive: Handle string table entries terminated with / llvm-ar appears to terminate string table entries with `/\n` [1]. This matters in the case of thin archives, since the filename is used. In the past this worked since `llvm-ar` would produce archives with "small" filenames when possible. However, now it appears to always use the string table. [1] https://github.com/llvm/llvm-project/blob/bfb686bb5ba503e9386dc899e1ebbe248… - - - - - 9cbb3ef5 by Ben Gamari at 2025-07-15T16:56:39-04:00 testsuite: Mark T12497 as fixed Thanks to the LLVM toolchain update. Closes #22694. - - - - - 2854407e by Ben Gamari at 2025-07-15T16:56:39-04:00 testsuite: Accept new output of T11223_link_order_a_b_2_fail on Windows The archive member number changed due to the fact that llvm-ar now uses a string table. - - - - - 28439593 by Ben Gamari at 2025-07-15T16:56:39-04:00 rts/linker/PEi386: Implement IMAGE_REL_AMD64_SECREL This appears to now be used by libc++ as distributed by msys2. - - - - - 2b053755 by Tamar Christina at 2025-07-15T16:56:39-04:00 rts: Cleanup merge resolution residue in lookupSymbolInDLL_PEi386 and make safe without dependent - - - - - e8acd2e7 by Wen Kokke at 2025-07-16T08:37:04-04:00 Remove the `profile_id` parameter from various RTS functions. Various RTS functions took a `profile_id` parameter, intended to be used to distinguish parallel heap profile breakdowns (e.g., `-hT` and `-hi`). However, this feature was never implemented and the `profile_id` parameter was set to 0 throughout the RTS. This commit removes the parameter but leaves the hardcoded profile ID in the functions that emit the encoded eventlog events as to not change the protocol. The affected functions are `traceHeapProfBegin`, `postHeapProfBegin`, `traceHeapProfSampleString`, `postHeapProfSampleString`, `traceHeapProfSampleCostCentre`, and `postHeapProfSampleCostCentre`. - - - - - 76d392a2 by Wen Kokke at 2025-07-16T08:37:04-04:00 Make `traceHeapProfBegin` an init event. - - - - - bbaa44a7 by Peng Fan at 2025-07-16T16:50:42-04:00 NCG/LA64: Support finer-grained DBAR hints For LA664 and newer uarchs, they have made finer granularity hints available: Bit4: ordering or completion (0: completion, 1: ordering) Bit3: barrier for previous read (0: true, 1: false) Bit2: barrier for previous write (0: true, 1: false) Bit1: barrier for succeeding read (0: true, 1: false) Bit0: barrier for succeeding write (0: true, 1: false) And not affect the existing models because other hints are treated as 'dbar 0' there. - - - - - 7da86e16 by Andreas Klebinger at 2025-07-16T16:51:25-04:00 Disable -fprof-late-overloaded-calls for join points. Currently GHC considers cost centres as destructive to join contexts. Or in other words this is not considered valid: join f x = ... in ... -> scc<tick> jmp This makes the functionality of `-fprof-late-overloaded-calls` not feasible for join points in general. We used to try to work around this by putting the ticks on the rhs of the join point rather than around the jump. However beyond the loss of accuracy this was broken for recursive join points as we ended up with something like: rec-join f x = scc<tick> ... jmp f x Which similarly is not valid as the tick once again destroys the tail call. One might think we could limit ourselves to non-recursive tail calls and do something clever like: join f x = scc<tick> ... in ... jmp f x And sometimes this works! But sometimes the full rhs would look something like: join g x = .... join f x = scc<tick> ... -> jmp g x Which, would again no longer be valid. I believe in the long run we can make cost centre ticks non-destructive to join points. Or we could keep track of where we are/are not allowed to insert a cost centre. But in the short term I will simply disable the annotation of join calls under this flag. - - - - - 7ee22fd5 by ARATA Mizuki at 2025-07-17T06:05:30-04:00 x86 NCG: Better lowering for shuffleFloatX4# and shuffleDoubleX2# The new implementation * make use of specialized instructions like (V)UNPCK{L,H}{PS,PD}, and * do not require -mavx. Close #26096 Co-authored-by: sheaf <sam.derbyshire(a)gmail.com> - - - - - c6cd2da1 by Jappie Klooster at 2025-07-17T06:06:20-04:00 Update interact docs to explain about buffering We need to tell the user to set to the appropriate buffer format. Otherwise, this function may get randomly stuck, or just behave confusingly. issue: https://gitlab.haskell.org/ghc/ghc/-/issues/26131 NB, I'm running this with cabal *NOT* ghci. ghci messes with buffering anyway. ```haskell interaction :: String -> String interaction "jappie" = "hi" interaction "jakob" = "hello" interaction x = "unkown input: " <> x main :: IO () main = interact interaction ``` so in my input (prefixed by `>`) I get: ``` > jappie unkown input: jappie ``` we confirmed later this was due to lack of \n matching. Anyway movnig on to more unexpected stuff: ```haskell main :: IO () main = do interact (concatMap interaction . lines) ``` get's stuck forever. actually `^D` (ctrl+d) unstucks it and runs all input as expected. for example you can get: ``` > sdfkds > fakdsf unkown input: sdfkdsunkown input: fakdsf ``` This program works! ```haskell interaction :: String -> String interaction "jappie" = "hi \n" interaction "jakob" = "hello \n" interaction x = "unkown input: " <> x <> "\n" main :: IO () main = do interact (concatMap interaction . lines) ``` the reason is that linebuffering is set for both in and output by default. so lines eats the input lines, and all the \n postfixes make sure the buffer is put out. - - - - - 9fa590a6 by Zubin Duggal at 2025-07-17T06:07:03-04:00 fetch_gitlab: Ensure we copy users_guide.pdf and Haddock.pdf to the release docs directory Fixes #24093 - - - - - 387c86c7 by Matthew Pickering at 2025-07-17T12:28:45+01:00 ipe: Place strings and metadata into specific .ipe section By placing the .ipe metadata into a specific section it can be stripped from the final binary if desired. ``` objcopy --remove-section .ipe <binary> upx <binary> ``` Towards #21766 - - - - - e43eaa03 by Matthew Pickering at 2025-07-17T12:28:45+01:00 ipe: Place magic word at the start of entries in the .ipe section The magic word "IPE\nIPE\n" is placed at the start of .ipe sections, then if the section is stripped, we can check whether the section starts with the magic word or not to determine whether there is metadata present or not. Towards #21766 - - - - - 4799fd4d by Matthew Pickering at 2025-07-17T12:30:31+01:00 ipe: Use stable IDs for IPE entries IPEs have historically been indexed and reported by their address. This makes it impossible to compare profiles between runs, since the addresses may change (due to ASLR) and also makes it tricky to separate out the IPE map from the binary. This small patch adds a stable identifier for each IPE entry. The stable identifier is a single 64 bit word. The high-bits are a per-module identifier and the low bits identify which entry in each module. 1. When a node is added into the IPE buffer it is assigned a unique identifier from an incrementing global counter. 2. Each entry already has an index by it's position in the `IpeBufferListNode`. The two are combined together by the `IPE_ENTRY_KEY` macro. Info table profiling uses the stable identifier rather than the address of the info table. The benefits of this change are: * Profiles from different runs can be easily compared * The metadata can be extracted from the binary (via the eventlog for example) and then stripped from the executable. Fixes #21766 - - - - - 249 changed files: - .gitlab/rel_eng/fetch-gitlab-artifacts/fetch_gitlab.py - compiler/GHC.hs - compiler/GHC/Builtin/primops.txt.pp - compiler/GHC/ByteCode/Asm.hs - + compiler/GHC/ByteCode/Breakpoints.hs - compiler/GHC/ByteCode/Instr.hs - compiler/GHC/ByteCode/Linker.hs - compiler/GHC/ByteCode/Types.hs - compiler/GHC/Cmm.hs - compiler/GHC/CmmToAsm/LA64/CodeGen.hs - compiler/GHC/CmmToAsm/LA64/Instr.hs - compiler/GHC/CmmToAsm/LA64/Ppr.hs - compiler/GHC/CmmToAsm/PPC/Ppr.hs - compiler/GHC/CmmToAsm/Ppr.hs - compiler/GHC/CmmToAsm/X86/CodeGen.hs - compiler/GHC/CmmToAsm/X86/Instr.hs - compiler/GHC/CmmToAsm/X86/Ppr.hs - compiler/GHC/CmmToLlvm/Data.hs - compiler/GHC/Core/FVs.hs - compiler/GHC/Core/LateCC/OverloadedCalls.hs - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/Map/Expr.hs - compiler/GHC/Core/Opt/DmdAnal.hs - compiler/GHC/Core/Opt/OccurAnal.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Opt/Specialise.hs - compiler/GHC/Core/Ppr.hs - compiler/GHC/Core/Predicate.hs - compiler/GHC/Core/Subst.hs - compiler/GHC/Core/Tidy.hs - compiler/GHC/Core/TyCon.hs - compiler/GHC/Core/Utils.hs - compiler/GHC/CoreToIface.hs - compiler/GHC/CoreToStg.hs - compiler/GHC/CoreToStg/Prep.hs - compiler/GHC/Driver/Config.hs - + compiler/GHC/Driver/Session/Inspect.hs - compiler/GHC/HsToCore.hs - compiler/GHC/HsToCore/Breakpoints.hs - compiler/GHC/HsToCore/Ticks.hs - compiler/GHC/Iface/Syntax.hs - compiler/GHC/Iface/Tidy.hs - compiler/GHC/IfaceToCore.hs - compiler/GHC/Linker/Loader.hs - compiler/GHC/Linker/Types.hs - compiler/GHC/Runtime/Debugger/Breakpoints.hs - compiler/GHC/Runtime/Eval.hs - compiler/GHC/Runtime/Eval/Types.hs - compiler/GHC/Runtime/Interpreter.hs - compiler/GHC/Runtime/Interpreter/Types.hs - compiler/GHC/Stg/BcPrep.hs - compiler/GHC/Stg/FVs.hs - compiler/GHC/StgToByteCode.hs - compiler/GHC/StgToCmm/InfoTableProv.hs - compiler/GHC/StgToCmm/Prim.hs - compiler/GHC/StgToJS/Prim.hs - compiler/GHC/Tc/Gen/Splice.hs - compiler/GHC/Tc/Solver.hs - compiler/GHC/Tc/Solver/Dict.hs - compiler/GHC/Tc/Solver/InertSet.hs - compiler/GHC/Tc/Solver/Monad.hs - compiler/GHC/Tc/Utils/TcType.hs - − compiler/GHC/Types/Breakpoint.hs - compiler/GHC/Types/Tickish.hs - compiler/GHC/Unit/Module/ModGuts.hs - compiler/ghc.cabal.in - configure.ac - docs/users_guide/9.14.1-notes.rst - docs/users_guide/eventlog-formats.rst - docs/users_guide/exts/doandifthenelse.rst - docs/users_guide/exts/ffi.rst - docs/users_guide/ghci.rst - docs/users_guide/profiling.rst - docs/users_guide/using.rst - ghc/GHCi/UI.hs - hadrian/src/Oracles/Flag.hs - hadrian/src/Rules/Generate.hs - hadrian/src/Settings/Builders/Cabal.hs - hadrian/src/Settings/Packages.hs - hadrian/src/Settings/Program.hs - libraries/Win32 - libraries/array - libraries/base/base.cabal.in - libraries/base/changelog.md - libraries/base/src/Control/Exception.hs - libraries/binary - libraries/deepseq - libraries/directory - libraries/exceptions - libraries/filepath - libraries/ghc-boot-th/ghc-boot-th.cabal.in - libraries/ghc-boot/ghc-boot.cabal.in - libraries/ghc-compact/GHC/Compact.hs - libraries/ghc-compact/GHC/Compact/Serialized.hs - libraries/ghc-compact/ghc-compact.cabal - libraries/ghc-experimental/ghc-experimental.cabal.in - + libraries/ghc-experimental/src/System/Mem/Experimental.hs - libraries/ghc-heap/GHC/Exts/Heap/Closures.hs - libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingDisabled.hsc - libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingEnabled.hsc - libraries/ghc-heap/GHC/Exts/Heap/Utils.hsc - libraries/ghc-heap/ghc-heap.cabal.in - libraries/ghc-heap/tests/parse_tso_flags.hs - libraries/ghc-internal/ghc-internal.cabal.in - + libraries/ghc-internal/src/GHC/Internal/AllocationLimitHandler.hs - libraries/ghc-internal/src/GHC/Internal/Base.hs - libraries/ghc-internal/src/GHC/Internal/Exception/Type.hs - libraries/ghc-internal/src/GHC/Internal/List.hs - libraries/ghc-internal/src/GHC/Internal/System/IO.hs - libraries/ghc-prim/changelog.md - libraries/ghc-prim/ghc-prim.cabal - + libraries/ghci/GHCi/Debugger.hs - libraries/ghci/GHCi/Message.hs - libraries/ghci/GHCi/Run.hs - libraries/ghci/ghci.cabal.in - libraries/haskeline - libraries/hpc - libraries/os-string - libraries/parsec - libraries/process - libraries/semaphore-compat - libraries/stm - libraries/template-haskell/template-haskell.cabal.in - libraries/terminfo - libraries/text - libraries/unix - m4/find_ld.m4 - mk/get-win32-tarballs.py - + rts/AllocArray.c - + rts/AllocArray.h - rts/Disassembler.c - rts/Heap.c - rts/IPE.c - rts/Interpreter.c - rts/Interpreter.h - rts/Prelude.h - rts/PrimOps.cmm - rts/ProfHeap.c - rts/RetainerSet.c - rts/RtsStartup.c - rts/RtsSymbols.c - rts/RtsUtils.c - rts/Schedule.c - rts/StgMiscClosures.cmm - rts/ThreadLabels.c - rts/Threads.c - rts/Trace.c - rts/Trace.h - rts/Weak.c - rts/eventlog/EventLog.c - rts/eventlog/EventLog.h - rts/external-symbols.list.in - rts/include/Rts.h - rts/include/rts/Bytecodes.h - rts/include/rts/Constants.h - rts/include/rts/IPE.h - rts/include/rts/prof/CCS.h - rts/include/rts/storage/Closures.h - rts/include/rts/storage/GC.h - rts/include/rts/storage/Heap.h - rts/include/rts/storage/TSO.h - rts/include/stg/MiscClosures.h - rts/linker/LoadArchive.c - rts/linker/PEi386.c - rts/rts.cabal - rts/sm/NonMoving.c - rts/sm/NonMoving.h - rts/sm/NonMovingAllocate.c - rts/sm/Sanity.c - rts/sm/Storage.c - testsuite/tests/backpack/cabal/bkpcabal08/bkpcabal08.stdout - testsuite/tests/count-deps/CountDepsAst.stdout - testsuite/tests/count-deps/CountDepsParser.stdout - testsuite/tests/dmdanal/should_compile/T23398.hs - testsuite/tests/dmdanal/should_compile/T23398.stderr - testsuite/tests/driver/recomp015/all.T - + testsuite/tests/ghci.debugger/scripts/T26042b.hs - + testsuite/tests/ghci.debugger/scripts/T26042b.script - + testsuite/tests/ghci.debugger/scripts/T26042b.stdout - + testsuite/tests/ghci.debugger/scripts/T26042c.hs - + testsuite/tests/ghci.debugger/scripts/T26042c.script - + testsuite/tests/ghci.debugger/scripts/T26042c.stdout - + testsuite/tests/ghci.debugger/scripts/T26042d.hs - + testsuite/tests/ghci.debugger/scripts/T26042d.script - + testsuite/tests/ghci.debugger/scripts/T26042d.stdout - + testsuite/tests/ghci.debugger/scripts/T26042e.hs - + testsuite/tests/ghci.debugger/scripts/T26042e.script - + testsuite/tests/ghci.debugger/scripts/T26042e.stdout - + testsuite/tests/ghci.debugger/scripts/T26042f.hs - + testsuite/tests/ghci.debugger/scripts/T26042f.script - + testsuite/tests/ghci.debugger/scripts/T26042f1.stderr - + testsuite/tests/ghci.debugger/scripts/T26042f1.stdout - + testsuite/tests/ghci.debugger/scripts/T26042f2.stdout - + testsuite/tests/ghci.debugger/scripts/T26042g.hs - + testsuite/tests/ghci.debugger/scripts/T26042g.script - + testsuite/tests/ghci.debugger/scripts/T26042g.stdout - testsuite/tests/ghci.debugger/scripts/all.T - + testsuite/tests/indexed-types/should_fail/T26176.hs - + testsuite/tests/indexed-types/should_fail/T26176.stderr - testsuite/tests/indexed-types/should_fail/all.T - testsuite/tests/interface-stability/base-exports.stdout - testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs - testsuite/tests/interface-stability/base-exports.stdout-mingw32 - testsuite/tests/interface-stability/base-exports.stdout-ws-32 - testsuite/tests/interface-stability/ghc-experimental-exports.stdout - testsuite/tests/interface-stability/ghc-experimental-exports.stdout-mingw32 - testsuite/tests/interface-stability/ghc-prim-exports.stdout - testsuite/tests/interface-stability/ghc-prim-exports.stdout-mingw32 - + testsuite/tests/perf/should_run/SpecTyFamRun.hs - + testsuite/tests/perf/should_run/SpecTyFamRun.stdout - + testsuite/tests/perf/should_run/SpecTyFam_Import.hs - testsuite/tests/perf/should_run/all.T - + testsuite/tests/rts/T22859.hs - + testsuite/tests/rts/T22859.stderr - testsuite/tests/rts/all.T - testsuite/tests/rts/ipe/ipeMap.c - testsuite/tests/rts/ipe/ipe_lib.c - testsuite/tests/rts/linker/T11223/T11223_link_order_a_b_2_fail.stderr-ws-32-mingw32 - testsuite/tests/rts/linker/T11223/T11223_link_order_a_b_2_fail.stderr-ws-64-mingw32 - testsuite/tests/simd/should_run/all.T - + testsuite/tests/simd/should_run/doublex2_shuffle.hs - + testsuite/tests/simd/should_run/doublex2_shuffle.stdout - + testsuite/tests/simd/should_run/doublex2_shuffle_baseline.hs - + testsuite/tests/simd/should_run/doublex2_shuffle_baseline.stdout - + testsuite/tests/simd/should_run/floatx4_shuffle.hs - + testsuite/tests/simd/should_run/floatx4_shuffle.stdout - + testsuite/tests/simd/should_run/floatx4_shuffle_baseline.hs - + testsuite/tests/simd/should_run/floatx4_shuffle_baseline.stdout - + testsuite/tests/simplCore/should_compile/T26051.hs - + testsuite/tests/simplCore/should_compile/T26051.stderr - + testsuite/tests/simplCore/should_compile/T26051_Import.hs - testsuite/tests/simplCore/should_compile/all.T - + testsuite/tests/typecheck/should_compile/T14010.hs - testsuite/tests/typecheck/should_compile/all.T - utils/ghc-toolchain/src/GHC/Toolchain/Tools/Link.hs - utils/haddock/CHANGES.md - utils/haddock/haddock-api/haddock-api.cabal - utils/haddock/haddock-api/src/Haddock/Interface/AttachInstances.hs - utils/haddock/haddock-api/src/Haddock/Interface/Create.hs - utils/haddock/haddock-api/src/Haddock/InterfaceFile.hs - utils/haddock/haddock-api/src/Haddock/Types.hs - utils/haddock/haddock-library/haddock-library.cabal - utils/haddock/haddock-test/haddock-test.cabal - utils/haddock/haddock-test/src/Test/Haddock/Config.hs - utils/haddock/haddock.cabal - utils/haddock/html-test/ref/Bug1004.html - + utils/haddock/html-test/ref/Bug25739.html - + utils/haddock/html-test/src/Bug25739.hs - utils/hsc2hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/59f62065392ec54603b879b8800b0d… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/59f62065392ec54603b879b8800b0d… You're receiving this email because of your account on gitlab.haskell.org.

1 0