Hannes Siebenhandl pushed to branch wip/fendor/backtraces-decoders at Glasgow Haskell Compiler / GHC

Commits:

2 changed files:

Changes:

  • libraries/base/src/Control/Exception/Backtrace.hs
    ... ... @@ -50,6 +50,10 @@ module Control.Exception.Backtrace
    50 50 
           BacktraceMechanism(..)
    51 51 
         , getBacktraceMechanismState
    52 52 
         , setBacktraceMechanismState
    53 
    +      -- * Display Backtrace mechanisms
    54 
    +    , DisplayBacktraceMechanisms(..)
    55 
    +    , getDisplayBacktraceMechanisms
    56 
    +    , setDisplayBacktraceMechanismsState
    53 57 
           -- * Collecting backtraces
    54 58 
         , Backtraces(..)
    55 59 
         , displayBacktraces

  • libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs
    ... ... @@ -11,9 +11,9 @@ import GHC.Internal.IORef
    11 11 
     import GHC.Internal.IO.Unsafe (unsafePerformIO)
    12 12 
     import GHC.Internal.Exception.Context
    13 13 
     import GHC.Internal.Ptr
    14 
    +import GHC.Internal.Data.Maybe (fromMaybe)
    14 15 
     import GHC.Internal.Stack.Types as GHC.Stack (CallStack)
    15 16 
     import qualified GHC.Internal.Stack as HCS
    16 
    -import qualified GHC.Internal.ExecutionStack as ExecStack
    17 17 
     import qualified GHC.Internal.ExecutionStack.Internal as ExecStack
    18 18 
     import qualified GHC.Internal.Stack.CloneStack as CloneStack
    19 19 
     import qualified GHC.Internal.Stack.CCS as CCS
    ... ... @@ -86,37 +86,69 @@ setBacktraceMechanismState bm enabled = do
    86 86 
         _ <- atomicModifyIORef'_ enabledBacktraceMechanismsRef (setBacktraceMechanismEnabled bm enabled)
    87 87 
         return ()
    88 88
    89 
    --- | A collection of backtraces.
    89 
    +-- | How to display a backtrace when an exception is thrown.
    90 
    +data DisplayBacktraceMechanisms =
    91 
    +    DisplayBacktraceMechanisms
    92 
    +      { displayCostCentreBacktrace   :: Ptr CCS.CostCentreStack -> String
    93 
    +      , displayHasCallStackBacktrace :: HCS.CallStack -> String
    94 
    +      , displayExecutionBacktrace    :: ExecStack.StackTrace -> String
    95 
    +      , displayIpeBacktrace          :: CloneStack.StackSnapshot -> String
    96 
    +      }
    97 
    +
    98 
    +defaultDisplayBacktraceMechanisms :: DisplayBacktraceMechanisms
    99 
    +defaultDisplayBacktraceMechanisms = DisplayBacktraceMechanisms
    100 
    +  { displayCostCentreBacktrace   = unlines . map (indent 2) . unsafePerformIO . CCS.ccsToStrings
    101 
    +  , displayHasCallStackBacktrace = unlines . map (indent 2 . prettyCallSite) . HCS.getCallStack
    102 
    +  , displayExecutionBacktrace    = unlines . map (indent 2 . flip ExecStack.showLocation "") . fromMaybe [] . ExecStack.stackFrames
    103 
    +  , displayIpeBacktrace          = unlines . map (indent 2 . CloneStack.prettyStackEntry) . unsafePerformIO . CloneStack.decode
    104 
    +  }
    105 
    +  where
    106 
    +    indent :: Int -> String -> String
    107 
    +    indent n s  = replicate n ' ' ++ s
    108 
    +
    109 
    +    prettyCallSite (f, loc) = f ++ ", called at " ++ HCS.prettySrcLoc loc
    110 
    +
    111 
    +
    112 
    +displayBacktraceMechanismsRef :: IORef DisplayBacktraceMechanisms
    113 
    +displayBacktraceMechanismsRef =
    114 
    +    unsafePerformIO $ newIORef defaultDisplayBacktraceMechanisms
    115 
    +{-# NOINLINE displayBacktraceMechanismsRef #-}
    116 
    +
    117 
    +-- | How are the 'Backtraces' going to be displayed?
    118 
    +getDisplayBacktraceMechanisms :: IO DisplayBacktraceMechanisms
    119 
    +getDisplayBacktraceMechanisms = readIORef displayBacktraceMechanismsRef
    120 
    +
    121 
    +-- | Specify how the 'Backtraces' are displayed.
    122 
    +setDisplayBacktraceMechanismsState :: DisplayBacktraceMechanisms -> IO ()
    123 
    +setDisplayBacktraceMechanismsState dbm = do
    124 
    +    _ <- atomicModifyIORef'_ displayBacktraceMechanismsRef (const dbm)
    125 
    +    return ()
    126 
    +
    127 
    +-- | A collection of backtraces, paired with a way to display each respective backtrace.
    90 128 
     data Backtraces =
    91 129 
         Backtraces {
    92 130 
             btrCostCentre :: Maybe (Ptr CCS.CostCentreStack),
    131 
    +        btrDisplayCostCentre :: Ptr CCS.CostCentreStack -> String,
    93 132 
             btrHasCallStack :: Maybe HCS.CallStack,
    94 
    -        btrExecutionStack :: Maybe [ExecStack.Location],
    95 
    -        btrIpe :: Maybe [CloneStack.StackEntry]
    133 
    +        btrDisplayHasCallStack :: HCS.CallStack -> String,
    134 
    +        btrExecutionStack :: Maybe ExecStack.StackTrace,
    135 
    +        btrDisplayExecutionStack :: ExecStack.StackTrace -> String,
    136 
    +        btrIpe :: Maybe CloneStack.StackSnapshot,
    137 
    +        btrDisplayIpe :: CloneStack.StackSnapshot -> String
    96 138 
         }
    97 139
    98 140 
     -- | Render a set of backtraces to a human-readable string.
    99 141 
     displayBacktraces :: Backtraces -> String
    100 142 
     displayBacktraces bts = concat
    101 
    -    [ displayOne "Cost-centre stack backtrace" btrCostCentre displayCc
    102 
    -    , displayOne "Native stack backtrace" btrExecutionStack displayExec
    103 
    -    , displayOne "IPE backtrace" btrIpe displayIpe
    104 
    -    , displayOne "HasCallStack backtrace" btrHasCallStack displayHsc
    143 
    +    [ displayOne "Cost-centre stack backtrace" btrCostCentre btrDisplayCostCentre
    144 
    +    , displayOne "Native stack backtrace" btrExecutionStack btrDisplayExecutionStack
    145 
    +    , displayOne "IPE backtrace" btrIpe btrDisplayIpe
    146 
    +    , displayOne "HasCallStack backtrace" btrHasCallStack btrDisplayHasCallStack
    105 147 
         ]
    106 148 
       where
    107 
    -    indent :: Int -> String -> String
    108 
    -    indent n s  = replicate n ' ' ++ s
    109 
    -
    110 
    -    -- The unsafePerformIO here is safe as we don't currently unload cost-centres.
    111 
    -    displayCc   = unlines . map (indent 2) . unsafePerformIO . CCS.ccsToStrings
    112 
    -    displayExec = unlines . map (indent 2 . flip ExecStack.showLocation "")
    113 
    -    displayIpe  = unlines . map (indent 2 . CloneStack.prettyStackEntry)
    114 
    -    displayHsc  = unlines . map (indent 2 . prettyCallSite) . HCS.getCallStack
    115 
    -      where prettyCallSite (f, loc) = f ++ ", called at " ++ HCS.prettySrcLoc loc
    116 
    -
    117 
    -    displayOne :: String -> (Backtraces -> Maybe rep) -> (rep -> String) -> String
    149 
    +    displayOne :: String -> (Backtraces -> Maybe rep) -> (Backtraces -> rep -> String) -> String
    118 150 
         displayOne label getBt displ
    119 
    -      | Just bt <- getBt bts = concat [label, ":\n", displ bt]
    151 
    +      | Just bt <- getBt bts = concat [label, ":\n", displ bts bt]
    120 152 
           | otherwise            = ""
    121 153
    122 154 
     instance ExceptionAnnotation Backtraces where
    ... ... @@ -125,12 +157,14 @@ instance ExceptionAnnotation Backtraces where
    125 157 
     -- | Collect a set of 'Backtraces'.
    126 158 
     collectBacktraces :: (?callStack :: CallStack) => IO Backtraces
    127 159 
     collectBacktraces = HCS.withFrozenCallStack $ do
    128 
    -    getEnabledBacktraceMechanisms >>= collectBacktraces'
    160 
    +    bm <- getEnabledBacktraceMechanisms
    161 
    +    dpm <- getDisplayBacktraceMechanisms
    162 
    +    collectBacktraces' bm dpm
    129 163
    130 164 
     collectBacktraces'
    131 165 
         :: (?callStack :: CallStack)
    132 
    -    => EnabledBacktraceMechanisms -> IO Backtraces
    133 
    -collectBacktraces' enabled = HCS.withFrozenCallStack $ do
    166 
    +    => EnabledBacktraceMechanisms -> DisplayBacktraceMechanisms -> IO Backtraces
    167 
    +collectBacktraces' enabled renderers = HCS.withFrozenCallStack $ do
    134 168 
         let collect :: BacktraceMechanism -> IO (Maybe a) -> IO (Maybe a)
    135 169 
             collect mech f
    136 170 
               | backtraceMechanismEnabled mech enabled = f
    ... ... @@ -140,18 +174,21 @@ collectBacktraces' enabled = HCS.withFrozenCallStack $ do
    140 174 
             Just `fmap` CCS.getCurrentCCS ()
    141 175
    142 176 
         exec <- collect ExecutionBacktrace $ do
    143 
    -        ExecStack.getStackTrace
    177 
    +        ExecStack.collectStackTrace
    144 178
    145 179 
         ipe <- collect IPEBacktrace $ do
    146 180 
             stack <- CloneStack.cloneMyStack
    147 
    -        stackEntries <- CloneStack.decode stack
    148 
    -        return (Just stackEntries)
    181 
    +        return (Just stack)
    149 182
    150 183 
         hcs <- collect HasCallStackBacktrace $ do
    151 184 
             return (Just ?callStack)
    152 185
    153 186 
         return (Backtraces { btrCostCentre = ccs
    187 
    +                       , btrDisplayCostCentre = displayCostCentreBacktrace renderers
    154 188 
                            , btrHasCallStack = hcs
    189 
    +                       , btrDisplayHasCallStack = displayHasCallStackBacktrace renderers
    155 190 
                            , btrExecutionStack = exec
    191 
    +                       , btrDisplayExecutionStack = displayExecutionBacktrace renderers
    156 192 
                            , btrIpe = ipe
    193 
    +                       , btrDisplayIpe = displayIpeBacktrace renderers
    157 194 
                            })

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