[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 2 commits: rts: Annotate BCOs with their Name
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Wed Dec 11 06:08:19 UTC 2024
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
3ad97f19 by Ben Gamari at 2024-12-11T01:08:03-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.
- - - - -
10673bf0 by Ben Gamari at 2024-12-11T01:08:04-05:00
configure: Implement ld override whitelist
Bring `configure` into alignment with `ghc-toolchain`, ensuring that the
ld-override logic will only take effect on Linux and Windows.
Fixes #25501.
- - - - -
16 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/Unit/Info.hs
- compiler/ghc.cabal.in
- docs/users_guide/debugging.rst
- hadrian/src/Rules/Rts.hs
- m4/find_ld.m4
- rts/Disassembler.c
- rts/Interpreter.c
- rts/include/rts/Bytecodes.h
- rts/rts.cabal
- testsuite/tests/th/T10279.hs
- testsuite/tests/th/T10279.stderr
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,10 @@ import GHC.Runtime.Heap.Layout ( StgWord )
import Data.Int
import Data.Word
+#if MIN_VERSION_rts(1,0,3)
+import Data.ByteString (ByteString)
+#endif
+
import GHC.Stack.CCS (CostCentre)
import GHC.Stg.Syntax
@@ -229,6 +233,22 @@ 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
+
+
+{- Note [BCO_NAME]
+ ~~~~~~~~~~~~~~~
+ The BCO_NAME instruction is a debugging-aid enabled with the -fadd-bco-name flag.
+ When enabled the bytecode assembler will prepend a BCO_NAME instruction to every
+ generated bytecode object capturing the STG name of the binding the BCO implements.
+ This is then printed by the bytecode disassembler, allowing bytecode objects to be
+ readily correlated with their STG and Core source.
+ -}
+
-- -----------------------------------------------------------------------------
-- Printing bytecode instructions
@@ -383,6 +403,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 +510,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
=====================================
@@ -581,6 +581,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
=====================================
@@ -2540,6 +2540,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,9 @@ import GHC.Unit.Home.ModInfo (lookupHpt)
import Data.Array
import Data.Coerce (coerce)
import Data.ByteString (ByteString)
+#if MIN_VERSION_rts(1,0,3)
+import qualified Data.ByteString.Char8 as BS
+#endif
import Data.Map (Map)
import Data.IntMap (IntMap)
import qualified Data.Map as Map
@@ -236,7 +239,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 +253,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 +264,14 @@ mkProtoBCO platform nm instrs_ordlist origin arity bitmap_size bitmap is_ret ffi
protoBCOFFIs = ffis
}
where
+#if MIN_VERSION_rts(1,0,3)
+ maybe_add_bco_name instrs
+ | _add_bco_name = BCO_NAME str : instrs
+ where
+ str = BS.pack $ showSDocOneLine defaultSDocContext (ppr nm)
+#endif
+ maybe_add_bco_name instrs = instrs
+
-- 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 +279,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 +322,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 +331,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 +374,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 +396,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 +1086,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 +1397,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 +1416,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 +2355,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/Unit/Info.hs
=====================================
@@ -236,7 +236,7 @@ unitHsLibs namever ways0 p = map (mkDynName . addSuffix . ST.unpack) (unitLibrar
-- This change elevates the need to add custom hooks
-- and handling specifically for the `rts` package.
addSuffix rts@"HSrts" = rts ++ (expandTag rts_tag)
- addSuffix rts@"HSrts-1.0.2" = rts ++ (expandTag rts_tag)
+ addSuffix rts@"HSrts-1.0.3" = rts ++ (expandTag rts_tag)
addSuffix other_lib = other_lib ++ (expandTag tag)
expandTag t | null t = ""
=====================================
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.
+
=====================================
hadrian/src/Rules/Rts.hs
=====================================
@@ -165,7 +165,7 @@ needRtsSymLinks stage rtsWays
prefix, versionlessPrefix :: String
versionlessPrefix = "libHSrts"
-prefix = versionlessPrefix ++ "-1.0.2"
+prefix = versionlessPrefix ++ "-1.0.3"
-- removeRtsDummyVersion "a/libHSrts-1.0-ghc1.2.3.4.so"
-- == "a/libHSrts-ghc1.2.3.4.so"
=====================================
m4/find_ld.m4
=====================================
@@ -79,13 +79,16 @@ AC_DEFUN([FIND_LD],[
dnl See #21712.
AC_CHECK_TARGET_TOOL([LD], [ld])
;;
- *)
+ *-linux*|*-mingw32)
if test "x$enable_ld_override" = "xyes"; then
find_ld
else
AC_CHECK_TARGET_TOOL([LD], [ld])
fi
;;
+ *)
+ AC_CHECK_TARGET_TOOL([LD], [ld])
+ ;;
esac
CHECK_LD_COPY_BUG([$1])
])
=====================================
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
=====================================
@@ -2085,6 +2085,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.
=====================================
testsuite/tests/th/T10279.hs
=====================================
@@ -7,4 +7,4 @@ import Language.Haskell.TH.Syntax
-- error message doesn't recognize it as a source package ID,
-- (This is OK, since it will look obviously wrong when they
-- try to find the package in their package database.)
-blah = $(conE (Name (mkOccName "Foo") (NameG VarName (mkPkgName "rts-1.0.2") (mkModName "A"))))
+blah = $(conE (Name (mkOccName "Foo") (NameG VarName (mkPkgName "rts-1.0.3") (mkModName "A"))))
=====================================
testsuite/tests/th/T10279.stderr
=====================================
@@ -1,11 +1,11 @@
T10279.hs:10:9: error: [GHC-51294]
• Failed to load interface for ‘A’.
- no unit id matching ‘rts-1.0.2’ was found
+ no unit id matching ‘rts-1.0.3’ was found
(This unit ID looks like the source package ID;
the real unit ID is ‘rts’)
• In the untyped splice:
$(conE
(Name
(mkOccName "Foo")
- (NameG VarName (mkPkgName "rts-1.0.2") (mkModName "A"))))
+ (NameG VarName (mkPkgName "rts-1.0.3") (mkModName "A"))))
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e129a40bd4c4c391040fb16d53bddd00ff280a11...10673bf03b67b241e0c58c4c524a58fb76fb78bb
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e129a40bd4c4c391040fb16d53bddd00ff280a11...10673bf03b67b241e0c58c4c524a58fb76fb78bb
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/20241211/51ee8c22/attachment-0001.html>
More information about the ghc-commits
mailing list