Cheng Shao pushed to branch wip/symbolizer at Glasgow Haskell Compiler / GHC

Commits:

10 changed files:

Changes:

  • compiler/GHC/Cmm/GenerateDebugSymbolStub.hs
    1 
    +{-# LANGUAGE MultiWayIf #-}
    2 
    +
    3 
    +module GHC.Cmm.GenerateDebugSymbolStub
    4 
    +  ( generateDebugSymbolStub,
    5 
    +  )
    6 
    +where
    7 
    +
    8 
    +import Control.Monad
    9 
    +import Control.Monad.IO.Class
    10 
    +import Data.Foldable
    11 
    +import Data.Functor
    12 
    +import Data.IORef
    13 
    +import Data.List (isSuffixOf)
    14 
    +import Data.Map.Strict qualified as Map
    15 
    +import Data.Maybe
    16 
    +import GHC.Cmm
    17 
    +import GHC.Cmm.CLabel
    18 
    +import GHC.Cmm.Dataflow.Label qualified as H
    19 
    +import GHC.Data.FastString
    20 
    +import GHC.Data.Stream (Stream)
    21 
    +import GHC.Data.Stream qualified as Stream
    22 
    +import GHC.Platform
    23 
    +import GHC.Prelude
    24 
    +import GHC.Types.ForeignStubs
    25 
    +import GHC.Unit.Types
    26 
    +import GHC.Utils.Outputable
    27 
    +
    28 
    +generateDebugSymbolStub ::
    29 
    +  (MonadIO m) =>
    30 
    +  Platform ->
    31 
    +  Module ->
    32 
    +  Stream m RawCmmGroup r ->
    33 
    +  Stream m RawCmmGroup (r, CStub)
    34 
    +generateDebugSymbolStub platform this_mod rawcmms0 = do
    35 
    +  (lbls_ref, per_group) <- liftIO $ do
    36 
    +    lbls_ref <- newIORef Map.empty
    37 
    +    let per_group decls = for_ decls per_decl $> decls
    38 
    +        per_decl (CmmData _ (CmmStaticsRaw lbl _)) =
    39 
    +          liftIO
    40 
    +            $ when (externallyVisibleCLabel lbl)
    41 
    +            $ modifyIORef' lbls_ref
    42 
    +            $ Map.insert lbl (data_label_type lbl)
    43 
    +        per_decl (CmmProc h lbl _ _) = case H.mapToList h of
    44 
    +          [] ->
    45 
    +            liftIO
    46 
    +              $ when (externallyVisibleCLabel lbl)
    47 
    +              $ modifyIORef' lbls_ref
    48 
    +              $ Map.insert lbl (proc_label_type lbl)
    49 
    +          hs -> for_ hs $ \(_, CmmStaticsRaw lbl _) ->
    50 
    +            liftIO
    51 
    +              $ when (externallyVisibleCLabel lbl)
    52 
    +              $ modifyIORef' lbls_ref
    53 
    +              $ Map.insert lbl (data_label_type lbl)
    54 
    +        data_label_type lbl
    55 
    +          | "_closure"
    56 
    +              `isSuffixOf` str
    57 
    +              && not
    58 
    +                (str `elem` ["stg_CHARLIKE_closure", "stg_INTLIKE_closure"]) =
    59 
    +              Just ("extern StgClosure ", "")
    60 
    +          | "_str" `isSuffixOf` str =
    61 
    +              Just ("EB_(", ")")
    62 
    +          | str
    63 
    +              `elem` [ "stg_arg_bitmaps",
    64 
    +                       "stg_ap_stack_entries",
    65 
    +                       "stg_stack_save_entries"
    66 
    +                     ] =
    67 
    +              Just ("ERO_(", ")")
    68 
    +          | str
    69 
    +              `elem` [ "no_break_on_exception",
    70 
    +                       "stg_scheduler_loop_epoch",
    71 
    +                       "stg_scheduler_loop_tid"
    72 
    +                     ] =
    73 
    +              Just ("ERW_(", ")")
    74 
    +          | str
    75 
    +              `elem` [ "stg_gc_prim_p_ll_info",
    76 
    +                       "stg_gc_prim_pp_ll_info",
    77 
    +                       "stg_JSVAL_info",
    78 
    +                       "stg_scheduler_loop_info"
    79 
    +                     ] =
    80 
    +              Just ("extern const StgInfoTable ", "")
    81 
    +          | not $ needsCDecl lbl =
    82 
    +              Nothing
    83 
    +          | "_cc" `isSuffixOf` str =
    84 
    +              Just ("extern CostCentre ", "[]")
    85 
    +          | "_ccs" `isSuffixOf` str =
    86 
    +              Just ("extern CostCentreStack ", "[]")
    87 
    +          | otherwise =
    88 
    +              Just ("ERW_(", ")")
    89 
    +          where
    90 
    +            str =
    91 
    +              showSDocOneLine defaultSDocContext {sdocStyle = PprCode}
    92 
    +                $ pprCLabel platform lbl
    93 
    +        proc_label_type _ = Just ("EF_(", ")")
    94 
    +    pure (lbls_ref, per_group)
    95 
    +  r <- Stream.mapM per_group rawcmms0
    96 
    +  liftIO $ do
    97 
    +    lbls <- Map.toList <$> readIORef lbls_ref
    98 
    +    let ctor_lbl = mkInitializerStubLabel this_mod $ fsLit "symbolizer"
    99 
    +        ctor_decls =
    100 
    +          vcat
    101 
    +            $ [ text
    102 
    +                  "extern void registerDebugSymbol( void *addr, const char *sym );"
    103 
    +              ]
    104 
    +            ++ [ text lbl_type_l
    105 
    +                   <> pprCLabel platform lbl
    106 
    +                   <> text lbl_type_r
    107 
    +                   <> semi
    108 
    +               | (lbl, maybe_lbl_type) <- lbls,
    109 
    +                 (lbl_type_l, lbl_type_r) <- maybeToList maybe_lbl_type
    110 
    +               ]
    111 
    +        ctor_body =
    112 
    +          vcat
    113 
    +            $ [ text "registerDebugSymbol"
    114 
    +                  <> parens
    115 
    +                    ( text "(void*)&"
    116 
    +                        <> pprCLabel platform lbl
    117 
    +                        <> comma
    118 
    +                        <> doubleQuotes (pprCLabel platform lbl)
    119 
    +                    )
    120 
    +                  <> semi
    121 
    +              | (lbl, _) <- lbls
    122 
    +              ]
    123 
    +        cstub = initializerCStub platform ctor_lbl ctor_decls ctor_body
    124 
    +    pure (r, cstub)

  • compiler/GHC/Driver/CodeOutput.hs
    ... ... @@ -26,6 +26,7 @@ import GHC.CmmToC ( cmmToC )
    26 26 
     import GHC.Cmm.Lint         ( cmmLint )
    27 27 
     import GHC.Cmm
    28 28 
     import GHC.Cmm.CLabel
    29 
    +import GHC.Cmm.GenerateDebugSymbolStub
    29 30
    30 31 
     import GHC.StgToCmm.CgUtils (CgStream)
    31 32
    ... ... @@ -76,7 +77,8 @@ import qualified Data.Set as Set
    76 77
    77 78 
     codeOutput
    78 79 
         :: forall a.
    79 
    -       Logger
    80 
    +       Platform
    81 
    +    -> Logger
    80 82 
         -> TmpFs
    81 83 
         -> LlvmConfigCache
    82 84 
         -> DynFlags
    ... ... @@ -95,7 +97,7 @@ codeOutput
    95 97 
                (Bool{-stub_h_exists-}, Maybe FilePath{-stub_c_exists-}),
    96 98 
                [(ForeignSrcLang, FilePath)]{-foreign_fps-},
    97 99 
                a)
    98 
    -codeOutput logger tmpfs llvm_config dflags unit_state this_mod filenm location genForeignStubs foreign_fps pkg_deps dus0
    100 
    +codeOutput platform logger tmpfs llvm_config dflags unit_state this_mod filenm location genForeignStubs foreign_fps pkg_deps dus0
    99 101 
       cmm_stream
    100 102 
       =
    101 103 
         do  {
    ... ... @@ -119,10 +121,12 @@ codeOutput logger tmpfs llvm_config dflags unit_state this_mod filenm location g
    119 121 
                     ; return cmm
    120 122 
                     }
    121 123
    124 
    +              debug_cmm_stream = generateDebugSymbolStub platform this_mod linted_cmm_stream
    125 
    +
    122 126 
             ; let final_stream :: CgStream RawCmmGroup (ForeignStubs, a)
    123 127 
                   final_stream = do
    124 
    -                  { a <- linted_cmm_stream
    125 
    -                  ; let stubs = genForeignStubs a
    128 
    +                  { (a, debug_cstub) <- debug_cmm_stream
    129 
    +                  ; let stubs = genForeignStubs a `appendStubC` debug_cstub
    126 130 
                       ; emitInitializerDecls this_mod stubs
    127 131 
                       ; return (stubs, a) }
    128 132

  • compiler/GHC/Driver/Main.hs
    ... ... @@ -2094,7 +2094,7 @@ hscGenHardCode hsc_env cgguts mod_loc output_filename = do
    2094 2094
    2095 2095 
                   (output_filename, (_stub_h_exists, stub_c_exists), foreign_fps, cmm_cg_infos)
    2096 2096 
                       <- {-# SCC "codeOutput" #-}
    2097 
    -                    codeOutput logger tmpfs llvm_config dflags (hsc_units hsc_env) this_mod output_filename mod_loc
    2097 
    +                    codeOutput platform logger tmpfs llvm_config dflags (hsc_units hsc_env) this_mod output_filename mod_loc
    2098 2098 
                         foreign_stubs foreign_files dependencies (initDUniqSupply 'n' 0) rawcmms1
    2099 2099 
                   return  ( output_filename, stub_c_exists, foreign_fps
    2100 2100 
                           , Just stg_cg_infos, Just cmm_cg_infos)
    ... ... @@ -2248,7 +2248,7 @@ hscCompileCmmFile hsc_env original_filename filename output_filename = runHsc hs
    2248 2248 
                       in NoStubs `appendStubC` ip_init
    2249 2249 
                   | otherwise     = NoStubs
    2250 2250 
             (_output_filename, (_stub_h_exists, stub_c_exists), _foreign_fps, _caf_infos)
    2251 
    -          <- codeOutput logger tmpfs llvm_config dflags (hsc_units hsc_env) cmm_mod output_filename no_loc foreign_stubs [] S.empty
    2251 
    +          <- codeOutput platform logger tmpfs llvm_config dflags (hsc_units hsc_env) cmm_mod output_filename no_loc foreign_stubs [] S.empty
    2252 2252 
                  dus1 rawCmms
    2253 2253 
             return stub_c_exists
    2254 2254 
       where

  • compiler/ghc.cabal.in
    ... ... @@ -242,6 +242,7 @@ Library
    242 242 
             GHC.Cmm.Dataflow.Label
    243 243 
             GHC.Cmm.DebugBlock
    244 244 
             GHC.Cmm.Expr
    245 
    +        GHC.Cmm.GenerateDebugSymbolStub
    245 246 
             GHC.Cmm.GenericOpt
    246 247 
             GHC.Cmm.Graph
    247 248 
             GHC.Cmm.Info

  • rts/Printer.c
    ... ... @@ -43,7 +43,7 @@ static void printStdObjPayload( const StgClosure *obj );
    43 43 
     void printPtr( StgPtr p )
    44 44 
     {
    45 45 
         const char *raw;
    46 
    -    raw = lookupGHCName(p);
    46 
    +    raw = lookupDebugSymbol(p);
    47 47 
         if (raw != NULL) {
    48 48 
             debugBelch("<%s>", raw);
    49 49 
             debugBelch("[%p]", p);
    ... ... @@ -853,30 +853,6 @@ void printLargeAndPinnedObjects(void)
    853 853 
      * Uses symbol table in (unstripped executable)
    854 854 
      * ------------------------------------------------------------------------*/
    855 855
    856 
    -/* --------------------------------------------------------------------------
    857 
    - * Simple lookup table
    858 
    - * address -> function name
    859 
    - * ------------------------------------------------------------------------*/
    860 
    -
    861 
    -static HashTable * add_to_fname_table = NULL;
    862 
    -
    863 
    -const char *lookupGHCName( void *addr )
    864 
    -{
    865 
    -    if (add_to_fname_table == NULL)
    866 
    -        return NULL;
    867 
    -
    868 
    -    return lookupHashTable(add_to_fname_table, (StgWord)addr);
    869 
    -}
    870 
    -
    871 
    -/* --------------------------------------------------------------------------
    872 
    - * Symbol table loading
    873 
    - * ------------------------------------------------------------------------*/
    874 
    -
    875 
    -extern void DEBUG_LoadSymbols( const char *name STG_UNUSED )
    876 
    -{
    877 
    -  /* nothing, yet */
    878 
    -}
    879 
    -
    880 856 
     void findPtr(P_ p, int);                /* keep gcc -Wall happy */
    881 857
    882 858 
     int searched = 0;
    ... ... @@ -981,6 +957,29 @@ void printObj( StgClosure *obj )
    981 957
    982 958 
     #endif /* DEBUG */
    983 959
    960 
    +/* --------------------------------------------------------------------------
    961 
    + * Simple lookup table
    962 
    + * address -> function name
    963 
    + * ------------------------------------------------------------------------*/
    964 
    +
    965 
    +static HashTable * add_to_fname_table = NULL;
    966 
    +
    967 
    +void registerDebugSymbol( void *addr, const char *sym ) {
    968 
    +    if (add_to_fname_table == NULL) {
    969 
    +        add_to_fname_table = allocHashTable();
    970 
    +    }
    971 
    +
    972 
    +    insertHashTable(add_to_fname_table, (StgWord)addr, sym);
    973 
    +}
    974 
    +
    975 
    +const char *lookupDebugSymbol( void *addr )
    976 
    +{
    977 
    +    if (add_to_fname_table == NULL)
    978 
    +        return NULL;
    979 
    +
    980 
    +    return lookupHashTable(add_to_fname_table, (StgWord)addr);
    981 
    +}
    982 
    +
    984 983 
     /* -----------------------------------------------------------------------------
    985 984 
        Closure types
    986 985

  • rts/Printer.h
    ... ... @@ -30,11 +30,9 @@ extern void printStaticObjects ( StgClosure *obj );
    30 30 
     extern void        printWeakLists ( void );
    31 31 
     extern void        printLargeAndPinnedObjects ( void );
    32 32
    33 
    -extern void DEBUG_LoadSymbols( const char *name );
    34 
    -
    35 
    -extern const char *lookupGHCName( void *addr );
    36 
    -
    37 33 
     extern const char *what_next_strs[];
    38 34 
     #endif
    39 35
    36 
    +extern const char *lookupDebugSymbol( void *addr );
    37 
    +
    40 38 
     #include "EndPrivate.h"

  • rts/RtsStartup.c
    ... ... @@ -15,7 +15,6 @@
    15 15 
     #include "RtsFlags.h"
    16 16 
     #include "RtsUtils.h"
    17 17 
     #include "Prelude.h"
    18 
    -#include "Printer.h"    /* DEBUG_LoadSymbols */
    19 18 
     #include "Schedule.h"   /* initScheduler */
    20 19 
     #include "Stats.h"      /* initStats */
    21 20 
     #include "STM.h"        /* initSTM */
    ... ... @@ -326,11 +325,6 @@ hs_init_ghc(int *argc, char **argv[], RtsConfig rts_config)
    326 325 
         } else {
    327 326 
             setFullProgArgv(*argc,*argv);
    328 327 
             setupRtsFlags(argc, *argv, rts_config);
    329 
    -
    330 
    -#if defined(DEBUG)
    331 
    -        /* load debugging symbols for current binary */
    332 
    -        DEBUG_LoadSymbols((*argv)[0]);
    333 
    -#endif /* DEBUG */
    334 328 
         }
    335 329
    336 330 
         /* 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);
    283 283 
     #include "rts/StaticPtrTable.h"
    284 284 
     #include "rts/Libdw.h"
    285 285 
     #include "rts/LibdwPool.h"
    286 
    +#include "rts/Debug.h"
    286 287
    287 288 
     /* Misc stuff without a home */
    288 289 
     DLL_IMPORT_RTS extern char **prog_argv; /* so we can get at these from Haskell */

  • rts/include/rts/Debug.h
    1 
    +/* -----------------------------------------------------------------------------
    2 
    + *
    3 
    + * (c) The GHC Team, 2017-2025
    4 
    + *
    5 
    + * Debug API
    6 
    + *
    7 
    + * Do not #include this file directly: #include "Rts.h" instead.
    8 
    + *
    9 
    + * To understand the structure of the RTS headers, see the wiki:
    10 
    + *   https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes
    11 
    + *
    12 
    + * -------------------------------------------------------------------------- */
    13 
    +
    14 
    +#pragma once
    15 
    +
    16 
    +void registerDebugSymbol( void *addr, const char *sym );

  • rts/rts.cabal
    ... ... @@ -280,6 +280,7 @@ library
    280 280 
                             rts/Bytecodes.h
    281 281 
                             rts/Config.h
    282 282 
                             rts/Constants.h
    283 
    +                        rts/Debug.h
    283 284 
                             rts/EventLogFormat.h
    284 285 
                             rts/EventLogWriter.h
    285 286 
                             rts/FileLock.h

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help