[Git][ghc/ghc][wip/jeltsch/textual-bytecode-output] Wobbly Manoeuvres in the Light (WML)

3 Jun 2026


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


Commits:
ca5bf454 by Wolfgang Jeltsch at 2026-06-03T19:58:25+03:00
Wobbly Manoeuvres in the Light (WML)

- - - - -


2 changed files:

- compiler/GHC/ByteCode/Show.hs
- libraries/ghci/GHCi/ResolvedBCO.hs


Changes:

=====================================
compiler/GHC/ByteCode/Show.hs
=====================================
@@ -11,12 +11,15 @@ import Control.Exception (assert)
 import Data.Eq ((==))
 import Data.Bits (FiniteBits, finiteBitSize)
 import Data.Function (($), (.))
+import Data.Bool (otherwise)
 import Data.Int (Int)
 import Data.Word (Word, Word16)
 import Data.Maybe (Maybe, maybe)
 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.Array.Unboxed (UArray)
 import Numeric (showHex)
 import Text.Show (show)
 import System.IO (IO, FilePath)
@@ -36,17 +39,17 @@ import GHC.Utils.Outputable
            text,
            (<+>),
            hsep,
-           nest,
-           ($$),
            vcat,
+           hang,
            withPprStyle,
            ppr
        )
+import GHC.Unit.Types (Module)
 import GHC.ByteCode.Types
        (
            FFIInfo (..),
            BCONPtr (..),
-           BCOPtr,
+           BCOPtr (..),
            UnlinkedBCO (..),
            ByteCodeHpcInfo,
            CompiledByteCode (..)
@@ -55,7 +58,7 @@ import GHC.ByteCode.Breakpoints (InternalBreakpointId (..), InternalModBreaks)
 import GHC.ByteCode.Binary (OnDiskModuleByteCode (..))
 import GHC.ByteCode.Serialize (readOnDiskModuleByteCode)
 import GHC.Driver.Env.Types (HscEnv)
-import GHCi.ResolvedBCO (BCOByteArray)
+import GHCi.ResolvedBCO (BCOByteArray, fromBCOByteArray)
 import GHCi.FFI (FFIType)
 import GHCi.Message (ConInfoTable)
 
@@ -73,9 +76,9 @@ pprOnDiskModuleByteCode :: OnDiskModuleByteCode -> SDoc
 pprOnDiskModuleByteCode OnDiskModuleByteCode {..}
     = entry (text "module" <+> ppr odgbc_module) $
       vcat [
-               pprHash               odgbc_hash,
-               pprCompiledByteCode   odgbc_compiled_byte_code,
-               pprObjectFileContents odgbc_foreign
+               pprHash                          $ odgbc_hash,
+               pprCompiledByteCode odgbc_module $ odgbc_compiled_byte_code,
+               pprObjectFileContents            $ odgbc_foreign
            ]
 
 -- | […]
@@ -83,52 +86,53 @@ pprHash :: Fingerprint -> SDoc
 pprHash = entry (text "hash:") . ppr
 
 -- | […]
-pprCompiledByteCode :: CompiledByteCode -> SDoc
-pprCompiledByteCode CompiledByteCode {..}
+pprCompiledByteCode :: Module -> CompiledByteCode -> SDoc
+pprCompiledByteCode currentModule CompiledByteCode {..}
     = entry (text "compiled bytecode:") $
       vcat [
-               pprByteCodeObjects           bc_bcos,
-               pprDataConstructorInfoTables bc_itbls,
-               pprTopLevelStrings           bc_strs,
-               pprBreakpoints               bc_breaks,
-               pprStaticPointerTableEntries bc_spt_entries,
-               pprHPCInfo                   bc_hpc_info
+               pprByteCodeObjects currentModule $ bc_bcos,
+               pprDataConstructorInfoTables     $ bc_itbls,
+               pprTopLevelStrings               $ bc_strs,
+               pprBreakpoints                   $ bc_breaks,
+               pprStaticPointerTableEntries     $ bc_spt_entries,
+               pprHPCInfo                       $ bc_hpc_info
            ]
 
 -- | […]
-pprByteCodeObjects :: FlatBag UnlinkedBCO -> SDoc
-pprByteCodeObjects = entry (text "bytecode objects:") .
-                     vcatOrNone                       .
-                     map pprByteCodeObject            .
-                     elemsFlatBag
+pprByteCodeObjects :: Module -> FlatBag UnlinkedBCO -> SDoc
+pprByteCodeObjects currentModule = entry (text "bytecode objects:")      .
+                                   vcatOrNone                            .
+                                   map (pprByteCodeObject currentModule) .
+                                   elemsFlatBag
 
 -- | […]
-pprByteCodeObject :: UnlinkedBCO -> SDoc
-pprByteCodeObject UnlinkedBCO {..}
-    = entry (text "ordinary bytecode object" <+> ppr unlinkedBCOName) $
-      vcat [
-               pprArity        unlinkedBCOArity,
-               pprInstructions unlinkedBCOInstrs,
-               pprBitmap       unlinkedBCOBitmap,
-               pprLiterals     unlinkedBCOLits,
-               pprPointers     unlinkedBCOPtrs
-           ]
-pprByteCodeObject UnlinkedStaticCon {{-..-}}
-    = entry (text "static constructor object:") $
-      vcat [
-               {-
-                   unlinkedStaticConName :: !Name,
-                   -- ^ The name to which this static constructor is bound, not to be
-                   -- confused with the name of the static constructor itself
-                   -- ('unlinkedStaticConDataConName')
-                   unlinkedStaticConDataConName :: !Name,
-                   unlinkedStaticConLits :: !(FlatBag BCONPtr),
-                   -- ^ non-ptrs full words, where sub-word literals have already been
-                   -- packed into full words as needed
-                   unlinkedStaticConPtrs :: !(FlatBag BCOPtr),  -- ptrs
-                   unlinkedStaticConIsUnlifted :: !Bool
-               -}
-           ]
+pprByteCodeObject :: Module -> UnlinkedBCO -> SDoc
+pprByteCodeObject currentModule byteCodeObject = case byteCodeObject of
+    UnlinkedBCO {..}
+        -> entry (text "ordinary bytecode object" <+> ppr unlinkedBCOName) $
+           vcat [
+                    pprArity                  $ unlinkedBCOArity,
+                    pprInstructions           $ unlinkedBCOInstrs,
+                    pprBitmap                 $ unlinkedBCOBitmap,
+                    pprLiterals currentModule $ unlinkedBCOLits,
+                    pprPointers currentModule $ unlinkedBCOPtrs
+                ]
+    UnlinkedStaticCon {{-..-}}
+        -> entry (text "static constructor object:") $ --FIXME: Remove colon and add name.
+           vcat [
+                    {-
+                        unlinkedStaticConName :: !Name,
+                        -- ^ The name to which this static constructor is bound, not to be
+                        -- confused with the name of the static constructor itself
+                        -- ('unlinkedStaticConDataConName')
+                        unlinkedStaticConDataConName :: !Name,
+                        unlinkedStaticConLits :: !(FlatBag BCONPtr),
+                        -- ^ non-ptrs full words, where sub-word literals have already been
+                        -- packed into full words as needed
+                        unlinkedStaticConPtrs :: !(FlatBag BCOPtr),  -- ptrs
+                        unlinkedStaticConIsUnlifted :: !Bool
+                    -}
+                ]
 
 -- | […]
 pprArity :: Int -> SDoc
@@ -143,30 +147,31 @@ pprBitmap :: BCOByteArray Word -> SDoc
 pprBitmap = entry (text "bitmap:") . pprBCOByteArray
 
 -- | […]
-pprLiterals :: FlatBag BCONPtr -> SDoc
-pprLiterals = entry (text "literals:") .
-              vcatOrNone               .
-              map pprLiteral           .
-              elemsFlatBag
+pprLiterals :: Module -> FlatBag BCONPtr -> SDoc
+pprLiterals currentModule = entry (text "literals:")       .
+                            vcatOrNone                     .
+                            map (pprLiteral currentModule) .
+                            elemsFlatBag
 
 -- | […]
-pprLiteral :: BCONPtr -> SDoc
-pprLiteral (BCONPtrWord word)
-    = text "word" <+> pprFixedSizeNatural word
-pprLiteral (BCONPtrLbl label)
-    = text "label" <+> ppr label
-pprLiteral (BCONPtrItbl infoTableName)
-    = text "info table" <+> ppr infoTableName
-pprLiteral (BCONPtrAddr addrName)
-    = text "address" <+> ppr addrName
-pprLiteral (BCONPtrStr encodedString)
-    = text "top-level string" <+> pprByteString encodedString
-pprLiteral (BCONPtrFS string)
-    = text "top-level string" <+> ppr string
-pprLiteral (BCONPtrFFIInfo ffiInfo)
-    = text "foreign function" <+> pprFFIInfo ffiInfo
-pprLiteral (BCONPtrCostCentre breakpointID)
-    = text "cost center" <+> pprBreakpointID breakpointID
+pprLiteral :: Module -> BCONPtr -> SDoc
+pprLiteral currentModule literal = case literal of
+    BCONPtrWord word
+        -> text "word" <+> pprFixedSizeNatural word
+    BCONPtrLbl label
+        -> text "label" <+> ppr label
+    BCONPtrItbl infoTableName
+        -> text "info table" <+> ppr infoTableName
+    BCONPtrAddr addrName
+        -> text "address" <+> ppr addrName
+    BCONPtrStr encodedString
+        -> text "top-level string" <+> pprByteString encodedString
+    BCONPtrFS string
+        -> text "top-level string" <+> ppr string
+    BCONPtrFFIInfo ffiInfo
+        -> text "foreign function" <+> pprFFIInfo ffiInfo
+    BCONPtrCostCentre breakpointID
+        -> text "cost center" <+> pprBreakpointID currentModule breakpointID
 
 -- | […]
 pprFFIInfo :: FFIInfo -> SDoc
@@ -182,13 +187,35 @@ pprFFIType ffiType = assert (take 3 ident == "FFI") $ text (drop 3 ident) where
     ident = show ffiType
 
 -- | […]
-pprBreakpointID :: InternalBreakpointId -> SDoc
-pprBreakpointID InternalBreakpointId {..} = ppr ibi_info_index
---FIXME: Either render the module also, or document why this is not necessary.
+pprBreakpointID :: Module -> InternalBreakpointId -> SDoc
+pprBreakpointID currentModule InternalBreakpointId {..}
+    | ibi_info_mod == currentModule = indexDoc
+    | otherwise                     = indexDoc         <+>
+                                      text "in"        <+>
+                                      ppr ibi_info_mod
+    where
+
+    indexDoc :: SDoc
+    indexDoc = ppr ibi_info_index
+
+-- | […]
+pprPointers :: Module -> FlatBag BCOPtr -> SDoc
+pprPointers currentModule = entry (text "pointers:")       .
+                            vcatOrNone                     .
+                            map (pprPointer currentModule) .
+                            elemsFlatBag
 
 -- | […]
-pprPointers :: FlatBag BCOPtr -> SDoc
-pprPointers = pprPointers
+pprPointer :: Module -> BCOPtr -> SDoc
+pprPointer currentModule pointer = case pointer of
+    BCOPtrName name
+        -> text "name" <+> ppr name
+    BCOPtrPrimOp primOp
+        -> text "primitive operation" <+> ppr primOp
+    BCOPtrBCO byteCodeObject
+        -> pprByteCodeObject currentModule byteCodeObject
+    BCOPtrBreakArray breakArrayModule
+        -> text "break array of module" <+> ppr breakArrayModule
 
 -- | […]
 pprDataConstructorInfoTables :: [(Name, ConInfoTable)] -> SDoc
@@ -242,7 +269,7 @@ pprByteString :: ByteString -> SDoc
 pprByteString = pprFixedSizeNaturalList . unpack
 
 -- | […]
-pprBCOByteArray :: (Storable a, Integral a, FiniteBits a) =>
+pprBCOByteArray :: (Integral a, FiniteBits a, Storable a, IArray UArray a) =>
                    BCOByteArray a -> SDoc
 pprBCOByteArray = pprFixedSizeNaturalList . elems . fromBCOByteArray
 
@@ -265,7 +292,7 @@ pprFixedSizeNatural num
 
 -- | […]
 entry :: SDoc -> SDoc -> SDoc
-entry title content = title $$ nest 2 content
+entry title content = hang title 2 content
 
 -- | […]
 vcatOrNone :: [SDoc] -> SDoc


=====================================
libraries/ghci/GHCi/ResolvedBCO.hs
=====================================
@@ -7,6 +7,7 @@ module GHCi.ResolvedBCO
   , isLittleEndian
   , BCOByteArray(..)
   , mkBCOByteArray
+  , fromBCOByteArray
   ) where
 
 #include "MachDeps.h"
@@ -20,7 +21,6 @@ import GHCi.BreakArray
 import Control.Monad
 import Data.Array.Base (foldrArray, listArray)
 import Data.ByteString.Builder.Extra
-import Foreign.Storable
 #endif
 
 import Data.Binary (Binary(..))
@@ -32,6 +32,7 @@ import GHC.Generics
 
 import GHC.Exts
 import Data.Array.Base (UArray(..))
+import Foreign.Storable
 import qualified GHC.Exts.Heap as Heap
 
 #include "MachDeps.h"
@@ -91,13 +92,11 @@ data BCOByteArray a
         getBCOByteArray :: !ByteArray#
   }
 
-#if SIZEOF_HSWORD == 4
 fromBCOByteArray :: forall a . Storable a => BCOByteArray a -> UArray Int a
 fromBCOByteArray (BCOByteArray ba#) = UArray 0 (n - 1) n ba#
   where
     len# = sizeofByteArray# ba#
     n = (I# len#) `div` sizeOf (undefined :: a)
-#endif
 
 mkBCOByteArray :: UArray Int a -> BCOByteArray a
 mkBCOByteArray (UArray _ _ _ arr) = BCOByteArray arr



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

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

    

Wolfgang Jeltsch (＠jeltsch)

tags

participants (1)