nativeGen/Dwarf.hs

    module Dwarf (
      dwarfGen
      ) where

    import CLabel
    import CmmExpr         ( GlobalReg(..) )
    import Config          ( cProjectName, cProjectVersion )
    import CoreSyn         ( Tickish(..) )
    import Debug
    import DynFlags
    import FastString
    import Module
    import Outputable
    import Platform
    import Unique
    import UniqSupply

    import Dwarf.Constants
    import Dwarf.Types

    import Data.Maybe
    import Data.List        ( sortBy )
    import Data.Ord         ( comparing )
    import qualified Data.Map as Map
    import System.FilePath
    import System.Directory ( getCurrentDirectory )

    import qualified Compiler.Hoopl as H

    -- | Generate DWARF/debug information
    dwarfGen :: DynFlags -> ModLocation -> UniqSupply -> [DebugBlock]
                -> IO (SDoc, UniqSupply)
    dwarfGen df modLoc us blocks = do

      -- Convert debug data structures to DWARF info records
      -- We strip out block information, as it is not currently useful for
      -- anything. In future we might want to only do this for -g1.
      let procs = debugSplitProcs blocks
          stripBlocks dbg = dbg { dblBlocks = [] }
      compPath <- getCurrentDirectory
      let dwarfUnit = DwarfCompileUnit
            { dwChildren = map (procToDwarf df) (map stripBlocks procs)
            , dwName = fromMaybe "" (ml_hs_file modLoc)
            , dwCompDir = addTrailingPathSeparator compPath
            , dwProducer = cProjectName ++ " " ++ cProjectVersion
            , dwLineLabel = dwarfLineLabel
            }

      -- Check whether we have any source code information, so we do not
      -- end up writing a pointer to an empty .debug_line section
      -- (dsymutil on Mac Os gets confused by this).
      let haveSrcIn blk = isJust (dblSourceTick blk) && isJust (dblPosition blk)
                          || any haveSrcIn (dblBlocks blk)
          haveSrc = any haveSrcIn procs

      -- .debug_abbrev section: Declare the format we're using
      let abbrevSct = pprAbbrevDecls haveSrc

      -- .debug_info section: Information records on procedures and blocks
      let (unitU, us') = takeUniqFromSupply us
          infoSct = vcat [ dwarfInfoSection
                         , compileUnitHeader unitU
                         , pprDwarfInfo haveSrc dwarfUnit
                         , compileUnitFooter unitU
                         ]

      -- .debug_line section: Generated mainly by the assembler, but we
      -- need to label it
      let lineSct = dwarfLineSection $$
                    ptext dwarfLineLabel <> colon

      -- .debug_frame section: Information about the layout of the GHC stack
      let (framesU, us'') = takeUniqFromSupply us'
          frameSct = dwarfFrameSection $$
                     ptext dwarfFrameLabel <> colon $$
                     pprDwarfFrame (debugFrame framesU procs)

      return (infoSct $$ abbrevSct $$ lineSct $$ frameSct, us'')

    -- | Header for a compilation unit, establishing global format
    -- parameters
    compileUnitHeader :: Unique -> SDoc
    compileUnitHeader unitU = sdocWithPlatform $ \plat ->
      let cuLabel = mkAsmTempLabel unitU
          length = ppr (mkAsmTempEndLabel cuLabel) <> char '-' <> ppr cuLabel
      in vcat [ ptext (sLit "\t.long ") <> length  -- compilation unit size
              , ppr cuLabel <> colon
              , ptext (sLit "\t.word 3")           -- DWARF version
              , sectionOffset dwarfAbbrevLabel dwarfAbbrevLabel
                                                   -- abbrevs offset
              , ptext (sLit "\t.byte ") <> ppr (platformWordSize plat) -- word size
              ]

    -- | Compilation unit footer, mainly establishing size of debug sections
    compileUnitFooter :: Unique -> SDoc
    compileUnitFooter unitU =
      let cuEndLabel = mkAsmTempEndLabel $ mkAsmTempLabel unitU
      in ppr cuEndLabel <> colon

    -- | Splits the blocks by procedures. In the result all nested blocks
    -- will come from the same procedure as the top-level block.
    debugSplitProcs :: [DebugBlock] -> [DebugBlock]
    debugSplitProcs b = concat $ H.mapElems $ mergeMaps $ map split b
      where mergeMaps = foldr (H.mapUnionWithKey (const (++))) H.mapEmpty
            split :: DebugBlock -> H.LabelMap [DebugBlock]
            split blk = H.mapInsert prc [blk {dblBlocks = own_blks}] nested
              where prc = dblProcedure blk
                    own_blks = fromMaybe [] $ H.mapLookup prc nested
                    nested = mergeMaps $ map split $ dblBlocks blk
            -- Note that we are rebuilding the tree here, so tick scopes
            -- might change. We could fix that - but we actually only care
            -- about dblSourceTick in the result, so this is okay.

    -- | Generate DWARF info for a procedure debug block
    procToDwarf :: DynFlags -> DebugBlock -> DwarfInfo
    procToDwarf df prc
      = DwarfSubprogram { dwChildren = foldr blockToDwarf [] $ dblBlocks prc
                        , dwName     = case dblSourceTick prc of
                             Just s@SourceNote{} -> sourceName s
                             _otherwise -> showSDocDump df $ ppr $ dblLabel prc
                        , dwLabel    = dblCLabel prc
                        }

    -- | Generate DWARF info for a block
    blockToDwarf :: DebugBlock -> [DwarfInfo] -> [DwarfInfo]
    blockToDwarf blk dws
      | isJust (dblPosition blk) = dw : dws
      | otherwise                = nested ++ dws -- block was optimized out, flatten
      where nested = foldr blockToDwarf [] $ dblBlocks blk
            dw = DwarfBlock { dwChildren = nested
                            , dwLabel    = dblCLabel blk
                            , dwMarker   = mkAsmTempLabel (dblLabel blk)
                            }

    -- | Generates the data for the debug frame section, which encodes the
    -- desired stack unwind behaviour for the debugger
    debugFrame :: Unique -> [DebugBlock] -> DwarfFrame
    debugFrame u procs
      = DwarfFrame { dwCieLabel = mkAsmTempLabel u
                   , dwCieInit  = initUws
                   , dwCieProcs = map (procToFrame initUws) procs
                   }
      where initUws = Map.fromList [(Sp, UwReg Sp 0)]

    -- | Generates unwind information for a procedure debug block
    procToFrame :: UnwindTable -> DebugBlock -> DwarfFrameProc
    procToFrame initUws blk
      = DwarfFrameProc { dwFdeProc    = dblCLabel blk
                       , dwFdeHasInfo = dblHasInfoTbl blk
                       , dwFdeBlocks  = map (uncurry blockToFrame) blockUws
                       }
      where blockUws :: [(DebugBlock, UnwindTable)]
            blockUws = map snd $ sortBy (comparing fst) $ flatten initUws blk
            flatten uws0 b@DebugBlock{ dblPosition=pos, dblUnwind=uws,
                                       dblBlocks=blocks }
              | Just p <- pos  = (p, (b, uws')):nested
              | otherwise      = nested -- block was optimized out
              where uws'   = uws `Map.union` uws0
                    nested = concatMap (flatten uws') blocks

    blockToFrame :: DebugBlock -> UnwindTable -> DwarfFrameBlock
    blockToFrame blk uws
      = DwarfFrameBlock { dwFdeBlock      = mkAsmTempLabel $ dblLabel blk
                        , dwFdeBlkHasInfo = dblHasInfoTbl blk
                        , dwFdeUnwind     = uws
                        }