[Git][ghc/ghc][wip/bco-name] rts: Annotate BCOs with their Name
Ben Gamari (@bgamari)
gitlab at gitlab.haskell.org
Fri Dec 6 22:13:36 UTC 2024
Ben Gamari pushed to branch wip/bco-name at Glasgow Haskell Compiler / GHC
Commits:
9bb9bee0 by Ben Gamari at 2024-12-06T17:13:18-05:00
rts: Annotate BCOs with their Name
This introduces a new bytecode instruction, `BCO_NAME`, to aid in debugging
bytecode execution. This instruction is injected by `mkProtoBCO` and
captures the Haskell name of the BCO. It is then printed by the
disassembler, allowing ready correlation with STG dumps.
- - - - -
11 changed files:
- compiler/GHC/ByteCode/Asm.hs
- compiler/GHC/ByteCode/Instr.hs
- compiler/GHC/Driver/Flags.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/StgToByteCode.hs
- compiler/ghc.cabal.in
- docs/users_guide/debugging.rst
- rts/Disassembler.c
- rts/Interpreter.c
- rts/include/rts/Bytecodes.h
- rts/rts.cabal
Changes:
=====================================
compiler/GHC/ByteCode/Asm.hs
=====================================
@@ -106,7 +106,7 @@ assembleBCOs interp profile proto_bcos tycons top_strs modbreaks spt_entries = d
bcos' <- mallocStrings interp bcos
return CompiledByteCode
{ bc_bcos = bcos'
- , bc_itbls = itblenv
+ , bc_itbls = itblenv
, bc_ffis = concatMap protoBCOFFIs proto_bcos
, bc_strs = top_strs
, bc_breaks = modbreaks
@@ -178,11 +178,12 @@ assembleOneBCO interp profile pbco = do
return ubco'
assembleBCO :: Platform -> ProtoBCO Name -> IO UnlinkedBCO
-assembleBCO platform (ProtoBCO { protoBCOName = nm
- , protoBCOInstrs = instrs
- , protoBCOBitmap = bitmap
- , protoBCOBitmapSize = bsize
- , protoBCOArity = arity }) = do
+assembleBCO platform
+ (ProtoBCO { protoBCOName = nm
+ , protoBCOInstrs = instrs
+ , protoBCOBitmap = bitmap
+ , protoBCOBitmapSize = bsize
+ , protoBCOArity = arity }) = do
-- pass 1: collect up the offsets of the local labels.
let asm = mapM_ (assembleI platform) instrs
@@ -527,6 +528,10 @@ assembleI platform i = case i of
, SmallOp tickx, SmallOp infox
, Op np
]
+#if MIN_VERSION_rts(1,0,3)
+ BCO_NAME name -> do np <- lit [BCONPtrStr name]
+ emit bci_BCO_NAME [Op np]
+#endif
where
literal (LitLabel fs _) = litlabel fs
=====================================
compiler/GHC/ByteCode/Instr.hs
=====================================
@@ -1,4 +1,4 @@
-
+{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# OPTIONS_GHC -funbox-strict-fields #-}
@@ -27,6 +27,8 @@ import GHC.Runtime.Heap.Layout ( StgWord )
import Data.Int
import Data.Word
+import Data.ByteString (ByteString)
+
import GHC.Stack.CCS (CostCentre)
import GHC.Stg.Syntax
@@ -229,6 +231,12 @@ data BCInstr
!Word16 -- breakpoint info index
(RemotePtr CostCentre)
+#if MIN_VERSION_rts(1,0,3)
+ -- | A "meta"-instruction for recording the name of a BCO for debugging purposes.
+ -- These are ignored by the interpreter but helpfully printed by the disassmbler.
+ | BCO_NAME !ByteString
+#endif
+
-- -----------------------------------------------------------------------------
-- Printing bytecode instructions
@@ -383,6 +391,9 @@ instance Outputable BCInstr where
<+> text "<tick_module>" <+> ppr tickx
<+> text "<info_module>" <+> ppr infox
<+> text "<cc>"
+#if MIN_VERSION_rts(1,0,3)
+ ppr (BCO_NAME nm) = text "BCO_NAME" <+> text (show nm)
+#endif
@@ -487,3 +498,6 @@ bciStackUse SLIDE{} = 0
bciStackUse MKAP{} = 0
bciStackUse MKPAP{} = 0
bciStackUse PACK{} = 1 -- worst case is PACK 0 words
+#if MIN_VERSION_rts(1,0,3)
+bciStackUse BCO_NAME{} = 0
+#endif
=====================================
compiler/GHC/Driver/Flags.hs
=====================================
@@ -573,6 +573,7 @@ data GeneralFlag
| Opt_DoAsmLinting
| Opt_DoAnnotationLinting
| Opt_DoBoundsChecking
+ | Opt_AddBcoName
| Opt_NoLlvmMangler -- hidden flag
| Opt_FastLlvm -- hidden flag
| Opt_NoTypeableBinds
=====================================
compiler/GHC/Driver/Session.hs
=====================================
@@ -2532,6 +2532,7 @@ fFlagsDeps = [
flagSpec "catch-nonexhaustive-cases" Opt_CatchNonexhaustiveCases,
flagSpec "alignment-sanitisation" Opt_AlignmentSanitisation,
flagSpec "check-prim-bounds" Opt_DoBoundsChecking,
+ flagSpec "add-bco-name" Opt_AddBcoName,
flagSpec "num-constant-folding" Opt_NumConstantFolding,
flagSpec "core-constant-folding" Opt_CoreConstantFolding,
flagSpec "fast-pap-calls" Opt_FastPAPCalls,
=====================================
compiler/GHC/StgToByteCode.hs
=====================================
@@ -1,4 +1,4 @@
-
+{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RecordWildCards #-}
@@ -81,6 +81,7 @@ import GHC.Unit.Home.ModInfo (lookupHpt)
import Data.Array
import Data.Coerce (coerce)
import Data.ByteString (ByteString)
+import qualified Data.ByteString.Char8 as BS
import Data.Map (Map)
import Data.IntMap (IntMap)
import qualified Data.Map as Map
@@ -236,7 +237,10 @@ ppBCEnv p
-- Create a BCO and do a spot of peephole optimisation on the insns
-- at the same time.
mkProtoBCO
- :: Platform
+ :: (Outputable name)
+ => Platform
+ -> Bool -- ^ True <=> label with @BCO_NAME@ instruction
+ -- see Note [BCO_NAME]
-> name
-> BCInstrList
-> Either [CgStgAlt] (CgStgRhs)
@@ -247,10 +251,10 @@ mkProtoBCO
-> Bool -- ^ True <=> is a return point, rather than a function
-> [FFIInfo]
-> ProtoBCO name
-mkProtoBCO platform nm instrs_ordlist origin arity bitmap_size bitmap is_ret ffis
+mkProtoBCO platform _add_bco_name nm instrs_ordlist origin arity bitmap_size bitmap is_ret ffis
= ProtoBCO {
protoBCOName = nm,
- protoBCOInstrs = maybe_with_stack_check,
+ protoBCOInstrs = maybe_add_bco_name $ maybe_add_stack_check peep_d,
protoBCOBitmap = bitmap,
protoBCOBitmapSize = fromIntegral bitmap_size,
protoBCOArity = arity,
@@ -258,6 +262,14 @@ mkProtoBCO platform nm instrs_ordlist origin arity bitmap_size bitmap is_ret ffi
protoBCOFFIs = ffis
}
where
+ maybe_add_bco_name instrs
+ | not _add_bco_name = instrs
+#if MIN_VERSION_rts(1,0,3)
+ | otherwise = BCO_NAME str : instrs
+ where
+ str = BS.pack $ showSDocOneLine defaultSDocContext (ppr nm)
+#endif
+
-- Overestimate the stack usage (in words) of this BCO,
-- and if >= iNTERP_STACK_CHECK_THRESH, add an explicit
-- stack check. (The interpreter always does a stack check
@@ -265,17 +277,17 @@ mkProtoBCO platform nm instrs_ordlist origin arity bitmap_size bitmap is_ret ffi
-- BCO anyway, so we only need to add an explicit one in the
-- (hopefully rare) cases when the (overestimated) stack use
-- exceeds iNTERP_STACK_CHECK_THRESH.
- maybe_with_stack_check
- | is_ret && stack_usage < fromIntegral (pc_AP_STACK_SPLIM (platformConstants platform)) = peep_d
+ maybe_add_stack_check instrs
+ | is_ret && stack_usage < fromIntegral (pc_AP_STACK_SPLIM (platformConstants platform)) = instrs
-- don't do stack checks at return points,
-- everything is aggregated up to the top BCO
-- (which must be a function).
-- That is, unless the stack usage is >= AP_STACK_SPLIM,
-- see bug #1466.
| stack_usage >= fromIntegral iNTERP_STACK_CHECK_THRESH
- = STKCHECK stack_usage : peep_d
+ = STKCHECK stack_usage : instrs
| otherwise
- = peep_d -- the supposedly common case
+ = instrs -- the supposedly common case
-- We assume that this sum doesn't wrap
stack_usage = sum (map bciStackUse peep_d)
@@ -308,6 +320,7 @@ schemeTopBind (id, rhs)
| Just data_con <- isDataConWorkId_maybe id,
isNullaryRepDataCon data_con = do
platform <- profilePlatform <$> getProfile
+ add_bco_name <- shouldAddBcoName
-- Special case for the worker of a nullary data con.
-- It'll look like this: Nil = /\a -> Nil a
-- If we feed it into schemeR, we'll get
@@ -316,7 +329,8 @@ schemeTopBind (id, rhs)
-- by just re-using the single top-level definition. So
-- for the worker itself, we must allocate it directly.
-- ioToBc (putStrLn $ "top level BCO")
- emitBc (mkProtoBCO platform (getName id) (toOL [PACK data_con 0, RETURN P])
+ emitBc (mkProtoBCO platform add_bco_name
+ (getName id) (toOL [PACK data_con 0, RETURN P])
(Right rhs) 0 0 [{-no bitmap-}] False{-not alts-})
| otherwise
@@ -358,6 +372,7 @@ schemeR_wrk
-> BcM (ProtoBCO Name)
schemeR_wrk fvs nm original_body (args, body)
= do
+ add_bco_name <- shouldAddBcoName
profile <- getProfile
let
platform = profilePlatform profile
@@ -379,7 +394,7 @@ schemeR_wrk fvs nm original_body (args, body)
bitmap = mkBitmap platform bits
body_code <- schemeER_wrk sum_szsb_args p_init body
- emitBc (mkProtoBCO platform nm body_code (Right original_body)
+ emitBc (mkProtoBCO platform add_bco_name nm body_code (Right original_body)
arity bitmap_size bitmap False{-not alts-})
-- | Introduce break instructions for ticked expressions.
@@ -1069,9 +1084,10 @@ doCase d s p scrut bndr alts
| ubx_tuple_frame = SLIDE 0 2 `consOL` alt_final0
| otherwise = alt_final0
+ add_bco_name <- shouldAddBcoName
let
alt_bco_name = getName bndr
- alt_bco = mkProtoBCO platform alt_bco_name alt_final (Left alts)
+ alt_bco = mkProtoBCO platform add_bco_name alt_bco_name alt_final (Left alts)
0{-no arity-} bitmap_size bitmap True{-is alts-}
scrut_code <- schemeE (d + ret_frame_size_b + save_ccs_size_b)
(d + ret_frame_size_b + save_ccs_size_b)
@@ -1379,7 +1395,7 @@ Note [unboxed tuple bytecodes and tuple_BCO]
tupleBCO :: Platform -> NativeCallInfo -> [(PrimRep, ByteOff)] -> [FFIInfo] -> ProtoBCO Name
tupleBCO platform args_info args =
- mkProtoBCO platform invented_name body_code (Left [])
+ mkProtoBCO platform False invented_name body_code (Left [])
0{-no arity-} bitmap_size bitmap False{-is alts-}
where
{-
@@ -1398,9 +1414,9 @@ tupleBCO platform args_info args =
body_code = mkSlideW 0 1 -- pop frame header
`snocOL` RETURN_TUPLE -- and add it again
-primCallBCO :: Platform -> NativeCallInfo -> [(PrimRep, ByteOff)] -> [FFIInfo] -> ProtoBCO Name
+primCallBCO :: Platform -> NativeCallInfo -> [(PrimRep, ByteOff)] -> [FFIInfo] -> ProtoBCO Name
primCallBCO platform args_info args =
- mkProtoBCO platform invented_name body_code (Left [])
+ mkProtoBCO platform False invented_name body_code (Left [])
0{-no arity-} bitmap_size bitmap False{-is alts-}
where
{-
@@ -2337,6 +2353,9 @@ getHscEnv = BcM $ \st -> return (st, bcm_hsc_env st)
getProfile :: BcM Profile
getProfile = targetProfile <$> getDynFlags
+shouldAddBcoName :: BcM Bool
+shouldAddBcoName = gopt Opt_AddBcoName <$> getDynFlags
+
emitBc :: ([FFIInfo] -> ProtoBCO Name) -> BcM (ProtoBCO Name)
emitBc bco
= BcM $ \st -> return (st{ffis=[]}, bco (ffis st))
=====================================
compiler/ghc.cabal.in
=====================================
@@ -130,6 +130,7 @@ Library
exceptions == 0.10.*,
semaphore-compat,
stm,
+ rts,
ghc-boot == @ProjectVersionMunged@,
ghc-heap == @ProjectVersionMunged@,
ghci == @ProjectVersionMunged@
=====================================
docs/users_guide/debugging.rst
=====================================
@@ -1240,8 +1240,7 @@ Other
:type: dynamic
:since: 9.8.1
-
- default: enabled
+ :default: enabled
At the moment, ghci disables optimizations, because not all passes
are compatible with the interpreter.
@@ -1254,3 +1253,16 @@ Other
expressions.
Those cannot be stored in breakpoints, so any free variable that refers to
optimized code will not be inspectable when this flag is enabled.
+
+.. ghc-flag:: -fadd-bco-name
+ :shortdesc: Add ``BCO_NAME`` instructions in generated bytecode.
+ :reverse: -fno-add-bco-name
+ :type: dynamic
+
+ :since: 9.14.1
+
+ Prefix every generated bytecode object with a ``BCO_NAME`` instruction
+ containing the STG name of the binding from which the BCO originated.
+ These are printed by the bytecode disassembler, aiding in correlating
+ bytecode with STG.
+
=====================================
rts/Disassembler.c
=====================================
@@ -452,6 +452,13 @@ disInstr ( StgBCO *bco, int pc )
debugBelch("RETURN_T\n ");
break;
+ case bci_BCO_NAME: {
+ const char *name = (const char*) literals[instrs[pc]];
+ debugBelch("BCO_NAME \"%s\"\n ", name);
+ pc += 1;
+ break;
+ }
+
default:
barf("disInstr: unknown opcode %u", (unsigned int) instr);
}
@@ -464,10 +471,9 @@ void disassemble( StgBCO *bco )
StgWord16* instrs = (StgWord16*)(bco->instrs->payload);
StgMutArrPtrs* ptrs = bco->ptrs;
uint32_t nbcs = (uint32_t)(bco->instrs->bytes / sizeof(StgWord16));
- uint32_t pc = 1;
+ uint32_t pc = 0;
debugBelch("BCO\n" );
- pc = 0;
while (pc < nbcs) {
debugBelch("\t%2d: ", pc );
pc = disInstr ( bco, pc );
=====================================
rts/Interpreter.c
=====================================
@@ -2087,6 +2087,10 @@ run_BCO:
goto do_return_nonpointer;
}
+ case bci_BCO_NAME:
+ bciPtr++;
+ goto nextInsn;
+
case bci_SWIZZLE: {
W_ stkoff = BCO_GET_LARGE_ARG;
StgInt n = BCO_GET_LARGE_ARG;
=====================================
rts/include/rts/Bytecodes.h
=====================================
@@ -112,6 +112,8 @@
#define bci_PRIMCALL 87
+#define bci_BCO_NAME 88
+
/* If you need to go past 255 then you will run into the flags */
/* If you need to go below 0x0100 then you will run into the instructions */
=====================================
rts/rts.cabal
=====================================
@@ -1,6 +1,6 @@
cabal-version: 3.0
name: rts
-version: 1.0.2
+version: 1.0.3
synopsis: The GHC runtime system
description:
The GHC runtime system.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9bb9bee0001541fc62c9effca8312050d9d56bf2
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9bb9bee0001541fc62c9effca8312050d9d56bf2
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20241206/40caa2b3/attachment-0001.html>
More information about the ghc-commits
mailing list