[Git][ghc/ghc][wip/jeltsch/textual-bytecode-output] Until finishing breakpoint output

5 Jun 2026


      Wolfgang Jeltsch pushed to branch wip/jeltsch/textual-bytecode-output at Glasgow Haskell Compiler / GHC


Commits:
22e83285 by Wolfgang Jeltsch at 2026-06-05T16:49:08+03:00
Until finishing breakpoint output

- - - - -


1 changed file:

- compiler/GHC/ByteCode/Show.hs


Changes:

=====================================
compiler/GHC/ByteCode/Show.hs
=====================================
@@ -6,20 +6,25 @@
 module GHC.ByteCode.Show (showByteCode) where
 
 import Prelude ((+), (-), Integral, div)
+import Control.Applicative ((<$>), (<*>))
 import Control.Arrow ((>>>))
 import Control.Exception (assert)
 import Data.Eq ((==))
 import Data.Bits (FiniteBits, finiteBitSize)
-import Data.Function (($), (.))
-import Data.Tuple (uncurry)
-import Data.Bool (Bool, otherwise, not)
+import Data.Function (($), id, (.))
+import Data.Tuple (fst, snd, uncurry)
+import Data.Bool (Bool, otherwise, not, (&&))
 import Data.Int (Int)
 import Data.Word (Word, Word16)
 import Data.Maybe (Maybe, maybe)
+import Data.Either (Either, either)
 import Data.List (length, (++), map, zipWith, take, drop, replicate)
 import Data.String (String)
 import Data.ByteString (ByteString, unpack)
-import Data.Array.IArray (IArray, elems)
+import Data.ByteString.Short (ShortByteString)
+import Data.IntMap (IntMap)
+import Data.IntMap qualified as IntMap (toList)
+import Data.Array.IArray (IArray, bounds, indices, elems)
 import Data.Array.Unboxed (UArray)
 import Numeric (showHex)
 import Text.Show (show)
@@ -30,9 +35,13 @@ import GHC.Data.FlatBag (FlatBag, elemsFlatBag)
 import GHC.Fingerprint (Fingerprint)
 import GHC.Types.SrcLoc (noSrcSpan)
 import GHC.Types.Name (Name)
+import GHC.Types.Name.Occurrence (OccName)
+import GHC.Types.Tickish (BreakTickIndex, BreakpointId (..))
 import GHC.Types.SptEntry (SptEntry)
 import GHC.Types.Error (MessageClass (MCDump))
 import GHC.Utils.Logger (Logger, logMsg)
+import GHC.Utils.Binary (BinSrcSpan (..))
+import GHC.Utils.Encoding.UTF8 (utf8DecodeShortByteString)
 import GHC.Utils.Outputable
        (
            defaultDumpStyle,
@@ -47,6 +56,8 @@ import GHC.Utils.Outputable
            ppr
        )
 import GHC.Unit.Types (Module)
+import GHC.Iface.Type (IfaceType, IfaceTvBndr, IfaceIdBndr)
+import GHC.HsToCore.Breakpoints (ModBreaks (..))
 import GHC.ByteCode.Types
        (
            FFIInfo (..),
@@ -56,7 +67,13 @@ import GHC.ByteCode.Types
            ByteCodeHpcInfo,
            CompiledByteCode (..)
        )
-import GHC.ByteCode.Breakpoints (InternalBreakpointId (..), InternalModBreaks)
+import GHC.ByteCode.Breakpoints
+       (
+           InternalBreakpointId (..),
+           InternalBreakLoc (..),
+           CgBreakInfo (..),
+           InternalModBreaks (..)
+       )
 import GHC.ByteCode.Binary (OnDiskModuleByteCode (..))
 import GHC.ByteCode.Serialize (readOnDiskModuleByteCode)
 import GHC.Driver.Env.Types (HscEnv)
@@ -95,7 +112,7 @@ pprCompiledByteCode currentModule CompiledByteCode {..}
                pprByteCodeObjects currentModule $ bc_bcos,
                pprDataConstructorInfoTables     $ bc_itbls,
                pprTopLevelStrings               $ bc_strs,
-               pprBreakpoints                   $ bc_breaks,
+               pprBreakpoints currentModule     $ bc_breaks,
                pprStaticPointerTableEntries     $ bc_spt_entries,
                pprHPCInfo                       $ bc_hpc_info
            ]
@@ -178,7 +195,8 @@ pprLiteral currentModule literal = case literal of
     BCONPtrFFIInfo ffiInfo
         -> text "foreign function" <+> pprFFIInfo ffiInfo
     BCONPtrCostCentre breakpointID
-        -> text "cost center" <+> pprBreakpointID currentModule breakpointID
+        -> text "cost center" <+>
+           pprInternalBreakpointID currentModule breakpointID
 
 -- | […]
 pprFFIInfo :: FFIInfo -> SDoc
@@ -194,8 +212,8 @@ pprFFIType ffiType = assert (take 3 ident == "FFI") $ text (drop 3 ident) where
     ident = show ffiType
 
 -- | […]
-pprBreakpointID :: Module -> InternalBreakpointId -> SDoc
-pprBreakpointID currentModule InternalBreakpointId {..}
+pprInternalBreakpointID :: Module -> InternalBreakpointId -> SDoc
+pprInternalBreakpointID currentModule InternalBreakpointId {..}
     | ibi_info_mod == currentModule = indexDoc
     | otherwise                     = indexDoc         <+>
                                       text "in"        <+>
@@ -228,19 +246,19 @@ pprPointer currentModule pointer = case pointer of
 pprDataConstructorInfoTables :: [(Name, ConInfoTable)] -> SDoc
 pprDataConstructorInfoTables = entry (text "data constructor info tables:") .
                                vcatOrNone                                   .
-                               map (uncurry pprDataConstructorInfoTableOf)
+                               map (uncurry pprDataConstructorInfoTable)
 
 -- | […]
-pprDataConstructorInfoTableOf :: Name -> ConInfoTable -> SDoc
-pprDataConstructorInfoTableOf dataConstrName ConInfoTable {..}
+pprDataConstructorInfoTable :: Name -> ConInfoTable -> SDoc
+pprDataConstructorInfoTable dataConstrName ConInfoTable {..}
     = entry (text "info table of" <+> ppr dataConstrName <> text ":") $
       vcat [
-               pprTablePositioning $ conItblTablesNextToCode,
-               pprLiteralCount     $ conItblNPtrs,
-               pprPointerCount     $ conItblPtrs,
-               pprConstructorTag   $ conItblConTag,
-               pprPointerTag       $ conItblPtrTag,
-               pprDescription      $ conItblDescr
+               pprTablePositioning    $ conItblTablesNextToCode,
+               pprPointerWordCount    $ conItblPtrs,
+               pprNonPointerWordCount $ conItblNPtrs,
+               pprConstructorTag      $ conItblConTag,
+               pprPointerTag          $ conItblPtrTag,
+               pprDescription         $ conItblDescr
            ]
 {-FIXME:
     Check based on any answers to my message on 4 June 2026, 13:17 EEST whether
@@ -252,12 +270,12 @@ pprTablePositioning :: Bool -> SDoc
 pprTablePositioning = entry (text "tables next to code:") . noOrYes
 
 -- | […]
-pprLiteralCount :: Int -> SDoc
-pprLiteralCount = entry (text "number of literals:") . ppr
+pprPointerWordCount :: Int -> SDoc
+pprPointerWordCount = entry (text "number of words for pointers:") . ppr
 
 -- | […]
-pprPointerCount :: Int -> SDoc
-pprPointerCount = entry (text "number of pointers:") . ppr
+pprNonPointerWordCount :: Int -> SDoc
+pprNonPointerWordCount = entry (text "number of words for non-pointers:") . ppr
 
 -- | […]
 pprConstructorTag :: Int -> SDoc
@@ -274,17 +292,172 @@ pprDescription = entry (text "description:") . pprByteString
 -- | […]
 pprTopLevelStrings :: [(Name, ByteString)] -> SDoc
 pprTopLevelStrings = entry (text "top-level strings:") .
-                     pprTopLevelStrings
+                     vcatOrNone                        .
+                     map (uncurry pprTopLevelString)
+
+-- | […]
+pprTopLevelString :: Name -> ByteString -> SDoc
+pprTopLevelString stringName encodedString
+    = entry (text "string" <+> ppr stringName <> text ":") $
+      pprByteString encodedString
+
+-- | […]
+pprBreakpoints :: Module -> Maybe InternalModBreaks -> SDoc
+pprBreakpoints currentModule
+    = entry (text "breakpoints:") .
+      maybe (text "<none>") (pprBreakpointsData currentModule)
+
+-- | […]
+pprBreakpointsData :: Module -> InternalModBreaks -> SDoc
+pprBreakpointsData currentModule InternalModBreaks {..}
+    = vcat [
+               pprBreakpointsInSource currentModule   $ imodBreaks_modBreaks,
+               pprBreakpointsInByteCode currentModule $ imodBreaks_breakInfo
+           ]
+
+-- | […]
+pprBreakpointsInSource :: Module -> ModBreaks -> SDoc
+pprBreakpointsInSource currentModule ModBreaks {..}
+    = entry (text "breakpoints in source:")                 $
+      assert (modBreaks_module == currentModule)            $
+      assert boundsAreIdentical                             $
+      vcatOrNone                                            $
+      pprBreakpointInSource <$> indices modBreaks_locs_ <*>
+                                elems modBreaks_locs_   <*>
+                                elems modBreaks_decls   <*>
+                                elems modBreaks_vars    <*>
+                                elems modBreaks_ccs
+    where
+
+    boundsAreIdentical :: Bool
+    boundsAreIdentical = bounds modBreaks_locs_ == bounds modBreaks_decls &&
+                         bounds modBreaks_locs_ == bounds modBreaks_vars  &&
+                         bounds modBreaks_locs_ == bounds modBreaks_ccs
 
 -- | […]
-pprBreakpoints :: Maybe InternalModBreaks -> SDoc
-pprBreakpoints = entry (text "breakpoints:") .
-                 maybe (text "<none>") pprBreakpointsData
+pprBreakpointInSource :: BreakTickIndex
+                      -> BinSrcSpan
+                      -> [String]
+                      -> [OccName]
+                      -> (ShortByteString, ShortByteString)
+                      -> SDoc
+pprBreakpointInSource ix srcSpan declarationPath freeVars costCenterInfo
+    = entry (text "breakpoint" <+> ppr ix <> text ":") $
+      vcat [
+               pprSrcSpan            $ srcSpan,
+               pprDeclarationPath    $ declarationPath,
+               pprFreeVariables      $ freeVars,
+               pprCostCenterPath     $ costCenterPath,
+               pprCostCenterLocation $ costCenterLocation
+           ]
+    where
+
+    costCenterPath :: String
+    costCenterPath = utf8DecodeShortByteString (fst costCenterInfo)
+
+    costCenterLocation :: String
+    costCenterLocation = utf8DecodeShortByteString (snd costCenterInfo)
+
+    -- The structure of the cost center information is apparent from the
+    -- implementation of 'GHC.HsToCore.Breakpoints.mkModBreaks'.
 
 -- | […]
-pprBreakpointsData :: InternalModBreaks -> SDoc
-pprBreakpointsData = pprBreakpointsData
---FIXME: Either render the module also, or document why this is not necessary.
+pprSrcSpan :: BinSrcSpan -> SDoc
+pprSrcSpan = entry (text "source span:") . ppr . unBinSrcSpan
+
+-- | […]
+pprDeclarationPath :: [String] -> SDoc
+pprDeclarationPath = entry (text "declaration path:") . vcat . map text
+
+-- | […]
+pprFreeVariables :: [OccName] -> SDoc
+pprFreeVariables = entry (text "free variables:") . hsep . map ppr
+
+-- | […]
+pprCostCenterPath :: String -> SDoc
+pprCostCenterPath = entry (text "cost center path:") . text
+
+-- | […]
+pprCostCenterLocation :: String -> SDoc
+pprCostCenterLocation = entry (text "cost center location:") . text
+
+-- | […]
+pprBreakpointsInByteCode :: Module -> IntMap CgBreakInfo -> SDoc
+pprBreakpointsInByteCode currentModule
+    = entry (text "breakpoints in bytecode:")               .
+      vcatOrNone                                            .
+      map (uncurry (pprBreakpointInByteCode currentModule)) .
+      IntMap.toList
+
+-- | […]
+pprBreakpointInByteCode :: Module -> Int -> CgBreakInfo -> SDoc
+pprBreakpointInByteCode currentModule ix CgBreakInfo {..}
+    = entry (text "breakpoint" <+> ppr ix <> text ":") $
+      vcat [
+               pprType                 $ cgb_resty,
+               pprTypeVariables        $ cgb_tyvars,
+               pprVariables            $ cgb_vars,
+               pprOrigin currentModule $ cgb_tick_id
+           ]
+    -- That the 'cgb_resty' field holds the type of the breakpoint is apparent
+    -- from the fact that this field is set by
+    -- 'GHC.StgToByteCode.dehydrateCgBreakInfo' using one of its arguments and
+    -- 'dehydrateCgBreakInfo' is always invoked with this argument set to the
+    -- extension field of 'Breakpoint', which in turn holds the type of the
+    -- breakpoint, according to Note [Tickish passes] and the comment on the
+    -- instance declaration of @XBreakpoint 'TickishPassStg@.
+
+pprType :: IfaceType -> SDoc
+pprType = entry (text "type:") . ppr
+
+-- | […]
+pprTypeVariables :: [IfaceTvBndr] -> SDoc
+pprTypeVariables = entry (text "type variables:") .
+                   vcat                           .
+                   map pprTypeVariableBinder
+
+-- | […]
+pprTypeVariableBinder :: IfaceTvBndr -> SDoc
+pprTypeVariableBinder (name, kind) = ppr name <+> text "::" <+> ppr kind
+
+-- | […]
+pprVariables :: [Maybe (IfaceIdBndr, Word)] -> SDoc
+pprVariables = entry (text "variables:") .
+               vcat                           .
+               map pprVariable
+
+-- | […]
+pprVariable :: Maybe (IfaceIdBndr, Word) -> SDoc
+pprVariable = maybe (text "<unknown>") (uncurry pprKnown) where
+
+    pprKnown :: IfaceIdBndr -> Word -> SDoc
+    pprKnown binder offset = pprVariableBinder binder   <+>
+                             text "@"                   <+>
+                             pprFixedSizeNatural offset
+    -- That the second argument is an offset is apparent from the use of the
+    -- identifier @offset@ in the implementation of
+    -- 'GHC.StgToByteCode.dehydrateCgBreakInfo'.
+
+-- | […]
+pprVariableBinder :: IfaceIdBndr -> SDoc
+pprVariableBinder (multiplicity, name, type_)
+    = text "%" <> ppr multiplicity <+>
+      ppr name <+> text "::" <+> ppr type_
+
+pprOrigin :: Module -> Either InternalBreakLoc BreakpointId -> SDoc
+pprOrigin currentModule = entry (text "origin:")        .
+                          pprBreakpointID currentModule .
+                          either internalBreakLoc id
+
+-- | […] [analogous to 'pprInternalBreakpointID' but the meanging of the index is different]
+pprBreakpointID :: Module -> BreakpointId -> SDoc
+pprBreakpointID currentModule BreakpointId {..}
+    | bi_tick_mod == currentModule = indexDoc
+    | otherwise                    = indexDoc <+> text "in" <+> ppr bi_tick_mod
+    where
+
+    indexDoc :: SDoc
+    indexDoc = ppr bi_tick_index
 
 -- | […]
 pprStaticPointerTableEntries :: [SptEntry] -> SDoc
@@ -304,11 +477,12 @@ pprHPCInfoData = pprHPCInfoData
 pprObjectFileContents :: [ByteString] -> SDoc
 pprObjectFileContents = entry (text "contents of object files:") .
                         vcatOrNone                               .
-                        zipWith pprContentOfObjectFile [0 ..]
+                        zipWith pprObjectFileContent [0 ..]
 
-pprContentOfObjectFile :: Int -> ByteString -> SDoc
-pprContentOfObjectFile ix = entry (text "file" <+> ppr ix <> text ":") .
-                            pprByteString
+-- | […]
+pprObjectFileContent :: Int -> ByteString -> SDoc
+pprObjectFileContent ix = entry (text "file" <+> ppr ix <> text ":") .
+                          pprByteString
 
 -- | […]
 pprByteString :: ByteString -> SDoc



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/22e832854630e3d6c65f76f45ac4ace4...

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/22e832854630e3d6c65f76f45ac4ace4...
You're receiving this email because of your account on gitlab.haskell.org.

    

Wolfgang Jeltsch (＠jeltsch)

tags

participants (1)