never executed always true always false
    1 module GHC.CmmToAsm.Dwarf (
    2   dwarfGen
    3   ) where
    4 
    5 import GHC.Prelude
    6 
    7 import GHC.Cmm.CLabel
    8 import GHC.Cmm.Expr        ( GlobalReg(..) )
    9 import GHC.Settings.Config ( cProjectName, cProjectVersion )
   10 import GHC.Types.Tickish   ( CmmTickish, GenTickish(..) )
   11 import GHC.Cmm.DebugBlock
   12 import GHC.Unit.Module
   13 import GHC.Utils.Outputable
   14 import GHC.Platform
   15 import GHC.Types.Unique
   16 import GHC.Types.Unique.Supply
   17 
   18 import GHC.CmmToAsm.Dwarf.Constants
   19 import GHC.CmmToAsm.Dwarf.Types
   20 import GHC.CmmToAsm.Config
   21 
   22 import Control.Arrow    ( first )
   23 import Control.Monad    ( mfilter )
   24 import Data.Maybe
   25 import Data.List        ( sortBy )
   26 import Data.Ord         ( comparing )
   27 import qualified Data.Map as Map
   28 import System.FilePath
   29 import System.Directory ( getCurrentDirectory )
   30 
   31 import qualified GHC.Cmm.Dataflow.Label as H
   32 import qualified GHC.Cmm.Dataflow.Collections as H
   33 
   34 -- | Generate DWARF/debug information
   35 dwarfGen :: NCGConfig -> ModLocation -> UniqSupply -> [DebugBlock]
   36             -> IO (SDoc, UniqSupply)
   37 dwarfGen _      _      us []     = return (empty, us)
   38 dwarfGen config modLoc us blocks = do
   39   let platform = ncgPlatform config
   40 
   41   -- Convert debug data structures to DWARF info records
   42   let procs = debugSplitProcs blocks
   43       stripBlocks dbg
   44         | ncgDwarfStripBlockInfo config = dbg { dblBlocks = [] }
   45         | otherwise                     = dbg
   46   compPath <- getCurrentDirectory
   47   let lowLabel = dblCLabel $ head procs
   48       highLabel = mkAsmTempProcEndLabel $ dblCLabel $ last procs
   49       dwarfUnit = DwarfCompileUnit
   50         { dwChildren = map (procToDwarf config) (map stripBlocks procs)
   51         , dwName = fromMaybe "" (ml_hs_file modLoc)
   52         , dwCompDir = addTrailingPathSeparator compPath
   53         , dwProducer = cProjectName ++ " " ++ cProjectVersion
   54         , dwLowLabel = pdoc platform lowLabel
   55         , dwHighLabel = pdoc platform highLabel
   56         , dwLineLabel = dwarfLineLabel
   57         }
   58 
   59   -- Check whether we have any source code information, so we do not
   60   -- end up writing a pointer to an empty .debug_line section
   61   -- (dsymutil on Mac Os gets confused by this).
   62   let haveSrcIn blk = isJust (dblSourceTick blk) && isJust (dblPosition blk)
   63                       || any haveSrcIn (dblBlocks blk)
   64       haveSrc = any haveSrcIn procs
   65 
   66   -- .debug_abbrev section: Declare the format we're using
   67   let abbrevSct = pprAbbrevDecls platform haveSrc
   68 
   69   -- .debug_info section: Information records on procedures and blocks
   70   let -- unique to identify start and end compilation unit .debug_inf
   71       (unitU, us') = takeUniqFromSupply us
   72       infoSct = vcat [ dwarfInfoLabel <> colon
   73                      , dwarfInfoSection platform
   74                      , compileUnitHeader platform unitU
   75                      , pprDwarfInfo platform haveSrc dwarfUnit
   76                      , compileUnitFooter platform unitU
   77                      ]
   78 
   79   -- .debug_line section: Generated mainly by the assembler, but we
   80   -- need to label it
   81   let lineSct = dwarfLineSection platform $$
   82                 dwarfLineLabel <> colon
   83 
   84   -- .debug_frame section: Information about the layout of the GHC stack
   85   let (framesU, us'') = takeUniqFromSupply us'
   86       frameSct = dwarfFrameSection platform $$
   87                  dwarfFrameLabel <> colon $$
   88                  pprDwarfFrame platform (debugFrame framesU procs)
   89 
   90   -- .aranges section: Information about the bounds of compilation units
   91   let aranges' | ncgSplitSections config = map mkDwarfARange procs
   92                | otherwise               = [DwarfARange lowLabel highLabel]
   93   let aranges = dwarfARangesSection platform $$ pprDwarfARanges platform aranges' unitU
   94 
   95   return (infoSct $$ abbrevSct $$ lineSct $$ frameSct $$ aranges, us'')
   96 
   97 -- | Build an address range entry for one proc.
   98 -- With split sections, each proc needs its own entry, since they may get
   99 -- scattered in the final binary. Without split sections, we could make a
  100 -- single arange based on the first/last proc.
  101 mkDwarfARange :: DebugBlock -> DwarfARange
  102 mkDwarfARange proc = DwarfARange lbl end
  103   where
  104     lbl = dblCLabel proc
  105     end = mkAsmTempProcEndLabel lbl
  106 
  107 -- | Header for a compilation unit, establishing global format
  108 -- parameters
  109 compileUnitHeader :: Platform -> Unique -> SDoc
  110 compileUnitHeader platform unitU =
  111   let cuLabel = mkAsmTempLabel unitU  -- sits right before initialLength field
  112       length = pdoc platform (mkAsmTempEndLabel cuLabel) <> char '-' <> pdoc platform cuLabel
  113                <> text "-4"       -- length of initialLength field
  114   in vcat [ pdoc platform cuLabel <> colon
  115           , text "\t.long " <> length  -- compilation unit size
  116           , pprHalf 3                          -- DWARF version
  117           , sectionOffset platform dwarfAbbrevLabel dwarfAbbrevLabel
  118                                                -- abbrevs offset
  119           , text "\t.byte " <> ppr (platformWordSizeInBytes platform) -- word size
  120           ]
  121 
  122 -- | Compilation unit footer, mainly establishing size of debug sections
  123 compileUnitFooter :: Platform -> Unique -> SDoc
  124 compileUnitFooter platform unitU =
  125   let cuEndLabel = mkAsmTempEndLabel $ mkAsmTempLabel unitU
  126   in pdoc platform cuEndLabel <> colon
  127 
  128 -- | Splits the blocks by procedures. In the result all nested blocks
  129 -- will come from the same procedure as the top-level block. See
  130 -- Note [Splitting DebugBlocks] for details.
  131 debugSplitProcs :: [DebugBlock] -> [DebugBlock]
  132 debugSplitProcs b = concat $ H.mapElems $ mergeMaps $ map (split Nothing) b
  133   where mergeMaps = foldr (H.mapUnionWithKey (const (++))) H.mapEmpty
  134         split :: Maybe DebugBlock -> DebugBlock -> H.LabelMap [DebugBlock]
  135         split parent blk = H.mapInsert prc [blk'] nested
  136           where prc = dblProcedure blk
  137                 blk' = blk { dblBlocks = own_blks
  138                            , dblParent = parent
  139                            }
  140                 own_blks = fromMaybe [] $ H.mapLookup prc nested
  141                 nested = mergeMaps $ map (split parent') $ dblBlocks blk
  142                 -- Figure out who should be the parent of nested blocks.
  143                 -- If @blk@ is optimized out then it isn't a good choice
  144                 -- and we just use its parent.
  145                 parent'
  146                   | Nothing <- dblPosition blk = parent
  147                   | otherwise                  = Just blk
  148 
  149 {-
  150 Note [Splitting DebugBlocks]
  151 
  152 DWARF requires that we break up the nested DebugBlocks produced from
  153 the C-- AST. For instance, we begin with tick trees containing nested procs.
  154 For example,
  155 
  156     proc A [tick1, tick2]
  157       block B [tick3]
  158         proc C [tick4]
  159 
  160 when producing DWARF we need to procs (which are represented in DWARF as
  161 TAG_subprogram DIEs) to be top-level DIEs. debugSplitProcs is responsible for
  162 this transform, pulling out the nested procs into top-level procs.
  163 
  164 However, in doing this we need to be careful to preserve the parentage of the
  165 nested procs. This is the reason DebugBlocks carry the dblParent field, allowing
  166 us to reorganize the above tree as,
  167 
  168     proc A [tick1, tick2]
  169       block B [tick3]
  170     proc C [tick4] parent=B
  171 
  172 Here we have annotated the new proc C with an attribute giving its original
  173 parent, B.
  174 -}
  175 
  176 -- | Generate DWARF info for a procedure debug block
  177 procToDwarf :: NCGConfig -> DebugBlock -> DwarfInfo
  178 procToDwarf config prc
  179   = DwarfSubprogram { dwChildren = map (blockToDwarf config) (dblBlocks prc)
  180                     , dwName     = case dblSourceTick prc of
  181                          Just s@SourceNote{} -> sourceName s
  182                          _otherwise -> show (dblLabel prc)
  183                     , dwLabel    = dblCLabel prc
  184                     , dwParent   = fmap mkAsmTempDieLabel
  185                                    $ mfilter goodParent
  186                                    $ fmap dblCLabel (dblParent prc)
  187                     }
  188   where
  189   goodParent a | a == dblCLabel prc = False
  190                -- Omit parent if it would be self-referential
  191   goodParent a | not (externallyVisibleCLabel a)
  192                , ncgDwarfStripBlockInfo config = False
  193                -- If we strip block information, don't refer to blocks.
  194                -- Fixes #14894.
  195   goodParent _ = True
  196 
  197 -- | Generate DWARF info for a block
  198 blockToDwarf :: NCGConfig -> DebugBlock -> DwarfInfo
  199 blockToDwarf config blk
  200   = DwarfBlock { dwChildren = map (blockToDwarf config) (dblBlocks blk) ++ srcNotes
  201                , dwLabel    = dblCLabel blk
  202                , dwMarker   = marker
  203                }
  204   where
  205     srcNotes
  206       | ncgDwarfSourceNotes config = concatMap tickToDwarf (dblTicks blk)
  207       | otherwise                  = []
  208 
  209     marker
  210       | Just _ <- dblPosition blk = Just $ mkAsmTempLabel $ dblLabel blk
  211       | otherwise                 = Nothing   -- block was optimized out
  212 
  213 tickToDwarf :: CmmTickish -> [DwarfInfo]
  214 tickToDwarf  (SourceNote ss _) = [DwarfSrcNote ss]
  215 tickToDwarf _ = []
  216 
  217 -- | Generates the data for the debug frame section, which encodes the
  218 -- desired stack unwind behaviour for the debugger
  219 debugFrame :: Unique -> [DebugBlock] -> DwarfFrame
  220 debugFrame u procs
  221   = DwarfFrame { dwCieLabel = mkAsmTempLabel u
  222                , dwCieInit  = initUws
  223                , dwCieProcs = map (procToFrame initUws) procs
  224                }
  225   where
  226     initUws :: UnwindTable
  227     initUws = Map.fromList [(Sp, Just (UwReg Sp 0))]
  228 
  229 -- | Generates unwind information for a procedure debug block
  230 procToFrame :: UnwindTable -> DebugBlock -> DwarfFrameProc
  231 procToFrame initUws blk
  232   = DwarfFrameProc { dwFdeProc    = dblCLabel blk
  233                    , dwFdeHasInfo = dblHasInfoTbl blk
  234                    , dwFdeBlocks  = map (uncurry blockToFrame)
  235                                         (setHasInfo blockUws)
  236                    }
  237   where blockUws :: [(DebugBlock, [UnwindPoint])]
  238         blockUws = map snd $ sortBy (comparing fst) $ flatten blk
  239 
  240         flatten :: DebugBlock
  241                 -> [(Int, (DebugBlock, [UnwindPoint]))]
  242         flatten b@DebugBlock{ dblPosition=pos, dblUnwind=uws, dblBlocks=blocks }
  243           | Just p <- pos  = (p, (b, uws')):nested
  244           | otherwise      = nested -- block was optimized out
  245           where uws'   = addDefaultUnwindings initUws uws
  246                 nested = concatMap flatten blocks
  247 
  248         -- | If the current procedure has an info table, then we also say that
  249         -- its first block has one to ensure that it gets the necessary -1
  250         -- offset applied to its start address.
  251         -- See Note [Info Offset] in "GHC.CmmToAsm.Dwarf.Types".
  252         setHasInfo :: [(DebugBlock, [UnwindPoint])]
  253                    -> [(DebugBlock, [UnwindPoint])]
  254         setHasInfo [] = []
  255         setHasInfo (c0:cs) = first setIt c0 : cs
  256           where
  257             setIt child =
  258               child { dblHasInfoTbl = dblHasInfoTbl child
  259                                       || dblHasInfoTbl blk }
  260 
  261 blockToFrame :: DebugBlock -> [UnwindPoint] -> DwarfFrameBlock
  262 blockToFrame blk uws
  263   = DwarfFrameBlock { dwFdeBlkHasInfo = dblHasInfoTbl blk
  264                     , dwFdeUnwind     = uws
  265                     }
  266 
  267 addDefaultUnwindings :: UnwindTable -> [UnwindPoint] -> [UnwindPoint]
  268 addDefaultUnwindings tbl pts =
  269     [ UnwindPoint lbl (tbl' `mappend` tbl)
  270       -- mappend is left-biased
  271     | UnwindPoint lbl tbl' <- pts
  272     ]