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.