Cheng Shao pushed to branch wip/symbolizer at Glasgow Haskell Compiler / GHC Commits: 1c5f14f2 by Cheng Shao at 2025-08-15T06:18:01+02:00 compiler/rts: add debug symbolizer - - - - - 10 changed files: - + compiler/GHC/Cmm/GenerateDebugSymbolStub.hs - compiler/GHC/Driver/CodeOutput.hs - compiler/GHC/Driver/Main.hs - compiler/ghc.cabal.in - rts/Printer.c - rts/Printer.h - rts/RtsStartup.c - rts/include/Rts.h - + rts/include/rts/Debug.h - rts/rts.cabal Changes: ===================================== compiler/GHC/Cmm/GenerateDebugSymbolStub.hs ===================================== @@ -0,0 +1,124 @@ +{-# LANGUAGE MultiWayIf #-} + +module GHC.Cmm.GenerateDebugSymbolStub + ( generateDebugSymbolStub, + ) +where + +import Control.Monad +import Control.Monad.IO.Class +import Data.Foldable +import Data.Functor +import Data.IORef +import Data.List (isSuffixOf) +import Data.Map.Strict qualified as Map +import Data.Maybe +import GHC.Cmm +import GHC.Cmm.CLabel +import GHC.Cmm.Dataflow.Label qualified as H +import GHC.Data.FastString +import GHC.Data.Stream (Stream) +import GHC.Data.Stream qualified as Stream +import GHC.Platform +import GHC.Prelude +import GHC.Types.ForeignStubs +import GHC.Unit.Types +import GHC.Utils.Outputable + +generateDebugSymbolStub :: + (MonadIO m) => + Platform -> + Module -> + Stream m RawCmmGroup r -> + Stream m RawCmmGroup (r, CStub) +generateDebugSymbolStub platform this_mod rawcmms0 = do + (lbls_ref, per_group) <- liftIO $ do + lbls_ref <- newIORef Map.empty + let per_group decls = for_ decls per_decl $> decls + per_decl (CmmData _ (CmmStaticsRaw lbl _)) = + liftIO + $ when (externallyVisibleCLabel lbl) + $ modifyIORef' lbls_ref + $ Map.insert lbl (data_label_type lbl) + per_decl (CmmProc h lbl _ _) = case H.mapToList h of + [] -> + liftIO + $ when (externallyVisibleCLabel lbl) + $ modifyIORef' lbls_ref + $ Map.insert lbl (proc_label_type lbl) + hs -> for_ hs $ \(_, CmmStaticsRaw lbl _) -> + liftIO + $ when (externallyVisibleCLabel lbl) + $ modifyIORef' lbls_ref + $ Map.insert lbl (data_label_type lbl) + data_label_type lbl + | "_closure" + `isSuffixOf` str + && not + (str `elem` ["stg_CHARLIKE_closure", "stg_INTLIKE_closure"]) = + Just ("extern StgClosure ", "") + | "_str" `isSuffixOf` str = + Just ("EB_(", ")") + | str + `elem` [ "stg_arg_bitmaps", + "stg_ap_stack_entries", + "stg_stack_save_entries" + ] = + Just ("ERO_(", ")") + | str + `elem` [ "no_break_on_exception", + "stg_scheduler_loop_epoch", + "stg_scheduler_loop_tid" + ] = + Just ("ERW_(", ")") + | str + `elem` [ "stg_gc_prim_p_ll_info", + "stg_gc_prim_pp_ll_info", + "stg_JSVAL_info", + "stg_scheduler_loop_info" + ] = + Just ("extern const StgInfoTable ", "") + | not $ needsCDecl lbl = + Nothing + | "_cc" `isSuffixOf` str = + Just ("extern CostCentre ", "[]") + | "_ccs" `isSuffixOf` str = + Just ("extern CostCentreStack ", "[]") + | otherwise = + Just ("ERW_(", ")") + where + str = + showSDocOneLine defaultSDocContext {sdocStyle = PprCode} + $ pprCLabel platform lbl + proc_label_type _ = Just ("EF_(", ")") + pure (lbls_ref, per_group) + r <- Stream.mapM per_group rawcmms0 + liftIO $ do + lbls <- Map.toList <$> readIORef lbls_ref + let ctor_lbl = mkInitializerStubLabel this_mod $ fsLit "symbolizer" + ctor_decls = + vcat + $ [ text + "extern void registerDebugSymbol( void *addr, const char *sym );" + ] + ++ [ text lbl_type_l + <> pprCLabel platform lbl + <> text lbl_type_r + <> semi + | (lbl, maybe_lbl_type) <- lbls, + (lbl_type_l, lbl_type_r) <- maybeToList maybe_lbl_type + ] + ctor_body = + vcat + $ [ text "registerDebugSymbol" + <> parens + ( text "(void*)&" + <> pprCLabel platform lbl + <> comma + <> doubleQuotes (pprCLabel platform lbl) + ) + <> semi + | (lbl, _) <- lbls + ] + cstub = initializerCStub platform ctor_lbl ctor_decls ctor_body + pure (r, cstub) ===================================== compiler/GHC/Driver/CodeOutput.hs ===================================== @@ -26,6 +26,7 @@ import GHC.CmmToC ( cmmToC ) import GHC.Cmm.Lint ( cmmLint ) import GHC.Cmm import GHC.Cmm.CLabel +import GHC.Cmm.GenerateDebugSymbolStub import GHC.StgToCmm.CgUtils (CgStream) @@ -76,7 +77,8 @@ import qualified Data.Set as Set codeOutput :: forall a. - Logger + Platform + -> Logger -> TmpFs -> LlvmConfigCache -> DynFlags @@ -95,7 +97,7 @@ codeOutput (Bool{-stub_h_exists-}, Maybe FilePath{-stub_c_exists-}), [(ForeignSrcLang, FilePath)]{-foreign_fps-}, a) -codeOutput logger tmpfs llvm_config dflags unit_state this_mod filenm location genForeignStubs foreign_fps pkg_deps dus0 +codeOutput platform logger tmpfs llvm_config dflags unit_state this_mod filenm location genForeignStubs foreign_fps pkg_deps dus0 cmm_stream = do { @@ -119,10 +121,12 @@ codeOutput logger tmpfs llvm_config dflags unit_state this_mod filenm location g ; return cmm } + debug_cmm_stream = generateDebugSymbolStub platform this_mod linted_cmm_stream + ; let final_stream :: CgStream RawCmmGroup (ForeignStubs, a) final_stream = do - { a <- linted_cmm_stream - ; let stubs = genForeignStubs a + { (a, debug_cstub) <- debug_cmm_stream + ; let stubs = genForeignStubs a `appendStubC` debug_cstub ; emitInitializerDecls this_mod stubs ; return (stubs, a) } ===================================== compiler/GHC/Driver/Main.hs ===================================== @@ -2094,7 +2094,7 @@ hscGenHardCode hsc_env cgguts mod_loc output_filename = do (output_filename, (_stub_h_exists, stub_c_exists), foreign_fps, cmm_cg_infos) <- {-# SCC "codeOutput" #-} - codeOutput logger tmpfs llvm_config dflags (hsc_units hsc_env) this_mod output_filename mod_loc + codeOutput platform logger tmpfs llvm_config dflags (hsc_units hsc_env) this_mod output_filename mod_loc foreign_stubs foreign_files dependencies (initDUniqSupply 'n' 0) rawcmms1 return ( output_filename, stub_c_exists, foreign_fps , Just stg_cg_infos, Just cmm_cg_infos) @@ -2248,7 +2248,7 @@ hscCompileCmmFile hsc_env original_filename filename output_filename = runHsc hs in NoStubs `appendStubC` ip_init | otherwise = NoStubs (_output_filename, (_stub_h_exists, stub_c_exists), _foreign_fps, _caf_infos) - <- codeOutput logger tmpfs llvm_config dflags (hsc_units hsc_env) cmm_mod output_filename no_loc foreign_stubs [] S.empty + <- codeOutput platform logger tmpfs llvm_config dflags (hsc_units hsc_env) cmm_mod output_filename no_loc foreign_stubs [] S.empty dus1 rawCmms return stub_c_exists where ===================================== compiler/ghc.cabal.in ===================================== @@ -242,6 +242,7 @@ Library GHC.Cmm.Dataflow.Label GHC.Cmm.DebugBlock GHC.Cmm.Expr + GHC.Cmm.GenerateDebugSymbolStub GHC.Cmm.GenericOpt GHC.Cmm.Graph GHC.Cmm.Info ===================================== rts/Printer.c ===================================== @@ -43,7 +43,7 @@ static void printStdObjPayload( const StgClosure *obj ); void printPtr( StgPtr p ) { const char *raw; - raw = lookupGHCName(p); + raw = lookupDebugSymbol(p); if (raw != NULL) { debugBelch("<%s>", raw); debugBelch("[%p]", p); @@ -853,30 +853,6 @@ void printLargeAndPinnedObjects(void) * Uses symbol table in (unstripped executable) * ------------------------------------------------------------------------*/ -/* -------------------------------------------------------------------------- - * Simple lookup table - * address -> function name - * ------------------------------------------------------------------------*/ - -static HashTable * add_to_fname_table = NULL; - -const char *lookupGHCName( void *addr ) -{ - if (add_to_fname_table == NULL) - return NULL; - - return lookupHashTable(add_to_fname_table, (StgWord)addr); -} - -/* -------------------------------------------------------------------------- - * Symbol table loading - * ------------------------------------------------------------------------*/ - -extern void DEBUG_LoadSymbols( const char *name STG_UNUSED ) -{ - /* nothing, yet */ -} - void findPtr(P_ p, int); /* keep gcc -Wall happy */ int searched = 0; @@ -981,6 +957,29 @@ void printObj( StgClosure *obj ) #endif /* DEBUG */ +/* -------------------------------------------------------------------------- + * Simple lookup table + * address -> function name + * ------------------------------------------------------------------------*/ + +static HashTable * add_to_fname_table = NULL; + +void registerDebugSymbol( void *addr, const char *sym ) { + if (add_to_fname_table == NULL) { + add_to_fname_table = allocHashTable(); + } + + insertHashTable(add_to_fname_table, (StgWord)addr, sym); +} + +const char *lookupDebugSymbol( void *addr ) +{ + if (add_to_fname_table == NULL) + return NULL; + + return lookupHashTable(add_to_fname_table, (StgWord)addr); +} + /* ----------------------------------------------------------------------------- Closure types ===================================== rts/Printer.h ===================================== @@ -30,11 +30,9 @@ extern void printStaticObjects ( StgClosure *obj ); extern void printWeakLists ( void ); extern void printLargeAndPinnedObjects ( void ); -extern void DEBUG_LoadSymbols( const char *name ); - -extern const char *lookupGHCName( void *addr ); - extern const char *what_next_strs[]; #endif +extern const char *lookupDebugSymbol( void *addr ); + #include "EndPrivate.h" ===================================== rts/RtsStartup.c ===================================== @@ -15,7 +15,6 @@ #include "RtsFlags.h" #include "RtsUtils.h" #include "Prelude.h" -#include "Printer.h" /* DEBUG_LoadSymbols */ #include "Schedule.h" /* initScheduler */ #include "Stats.h" /* initStats */ #include "STM.h" /* initSTM */ @@ -326,11 +325,6 @@ hs_init_ghc(int *argc, char **argv[], RtsConfig rts_config) } else { setFullProgArgv(*argc,*argv); setupRtsFlags(argc, *argv, rts_config); - -#if defined(DEBUG) - /* load debugging symbols for current binary */ - DEBUG_LoadSymbols((*argv)[0]); -#endif /* DEBUG */ } /* Based on the RTS flags, decide which I/O manager to use. */ ===================================== rts/include/Rts.h ===================================== @@ -283,6 +283,7 @@ void _warnFail(const char *filename, unsigned int linenum); #include "rts/StaticPtrTable.h" #include "rts/Libdw.h" #include "rts/LibdwPool.h" +#include "rts/Debug.h" /* Misc stuff without a home */ DLL_IMPORT_RTS extern char **prog_argv; /* so we can get at these from Haskell */ ===================================== rts/include/rts/Debug.h ===================================== @@ -0,0 +1,16 @@ +/* ----------------------------------------------------------------------------- + * + * (c) The GHC Team, 2017-2025 + * + * Debug API + * + * Do not #include this file directly: #include "Rts.h" instead. + * + * To understand the structure of the RTS headers, see the wiki: + * https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes + * + * -------------------------------------------------------------------------- */ + +#pragma once + +void registerDebugSymbol( void *addr, const char *sym ); ===================================== rts/rts.cabal ===================================== @@ -280,6 +280,7 @@ library rts/Bytecodes.h rts/Config.h rts/Constants.h + rts/Debug.h rts/EventLogFormat.h rts/EventLogWriter.h rts/FileLock.h View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1c5f14f2bab4f6fa9e84fa911bc34ccf... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1c5f14f2bab4f6fa9e84fa911bc34ccf... You're receiving this email because of your account on gitlab.haskell.org.