module Dwarf (
  dwarfGen
  ) where

import GhcPrelude

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

import Dwarf.Constants
import Dwarf.Types

import Control.Arrow    ( first )
import Control.Monad    ( mfilter )
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 Hoopl.Label as H
import qualified Hoopl.Collections as H

-- | Generate DWARF/debug information
dwarfGen :: DynFlags -> ModLocation -> UniqSupply -> [DebugBlock]
            -> IO (SDoc, UniqSupply)
dwarfGen :: DynFlags
-> ModLocation
-> UniqSupply
-> [DebugBlock]
-> IO (SDoc, UniqSupply)
dwarfGen _  _      us :: UniqSupply
us [] = (SDoc, UniqSupply) -> IO (SDoc, UniqSupply)
forall (m :: * -> *) a. Monad m => a -> m a
return (SDoc
empty, UniqSupply
us)
dwarfGen df :: DynFlags
df modLoc :: ModLocation
modLoc us :: UniqSupply
us blocks :: [DebugBlock]
blocks = do

  -- Convert debug data structures to DWARF info records
  -- We strip out block information when running with -g0 or -g1.
  let procs :: [DebugBlock]
procs = [DebugBlock] -> [DebugBlock]
debugSplitProcs [DebugBlock]
blocks
      stripBlocks :: DebugBlock -> DebugBlock
stripBlocks dbg :: DebugBlock
dbg
        | DynFlags -> Int
debugLevel DynFlags
df Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 2 = DebugBlock
dbg { dblBlocks :: [DebugBlock]
dblBlocks = [] }
        | Bool
otherwise         = DebugBlock
dbg
  FilePath
compPath <- IO FilePath
getCurrentDirectory
  let lowLabel :: CLabel
lowLabel = DebugBlock -> CLabel
dblCLabel (DebugBlock -> CLabel) -> DebugBlock -> CLabel
forall a b. (a -> b) -> a -> b
$ [DebugBlock] -> DebugBlock
forall a. [a] -> a
head [DebugBlock]
procs
      highLabel :: CLabel
highLabel = CLabel -> CLabel
mkAsmTempEndLabel (CLabel -> CLabel) -> CLabel -> CLabel
forall a b. (a -> b) -> a -> b
$ DebugBlock -> CLabel
dblCLabel (DebugBlock -> CLabel) -> DebugBlock -> CLabel
forall a b. (a -> b) -> a -> b
$ [DebugBlock] -> DebugBlock
forall a. [a] -> a
last [DebugBlock]
procs
      dwarfUnit :: DwarfInfo
dwarfUnit = DwarfCompileUnit :: [DwarfInfo]
-> FilePath
-> FilePath
-> FilePath
-> CLabel
-> CLabel
-> PtrString
-> DwarfInfo
DwarfCompileUnit
        { dwChildren :: [DwarfInfo]
dwChildren = (DebugBlock -> DwarfInfo) -> [DebugBlock] -> [DwarfInfo]
forall a b. (a -> b) -> [a] -> [b]
map (DynFlags -> DebugBlock -> DwarfInfo
procToDwarf DynFlags
df) ((DebugBlock -> DebugBlock) -> [DebugBlock] -> [DebugBlock]
forall a b. (a -> b) -> [a] -> [b]
map DebugBlock -> DebugBlock
stripBlocks [DebugBlock]
procs)
        , dwName :: FilePath
dwName = FilePath -> Maybe FilePath -> FilePath
forall a. a -> Maybe a -> a
fromMaybe "" (ModLocation -> Maybe FilePath
ml_hs_file ModLocation
modLoc)
        , dwCompDir :: FilePath
dwCompDir = FilePath -> FilePath
addTrailingPathSeparator FilePath
compPath
        , dwProducer :: FilePath
dwProducer = FilePath
cProjectName FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ " " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
cProjectVersion
        , dwLowLabel :: CLabel
dwLowLabel = CLabel
lowLabel
        , dwHighLabel :: CLabel
dwHighLabel = CLabel
highLabel
        , dwLineLabel :: PtrString
dwLineLabel = PtrString
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 :: DebugBlock -> Bool
haveSrcIn blk :: DebugBlock
blk = Maybe CmmTickish -> Bool
forall a. Maybe a -> Bool
isJust (DebugBlock -> Maybe CmmTickish
dblSourceTick DebugBlock
blk) Bool -> Bool -> Bool
&& Maybe Int -> Bool
forall a. Maybe a -> Bool
isJust (DebugBlock -> Maybe Int
dblPosition DebugBlock
blk)
                      Bool -> Bool -> Bool
|| (DebugBlock -> Bool) -> [DebugBlock] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any DebugBlock -> Bool
haveSrcIn (DebugBlock -> [DebugBlock]
dblBlocks DebugBlock
blk)
      haveSrc :: Bool
haveSrc = (DebugBlock -> Bool) -> [DebugBlock] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any DebugBlock -> Bool
haveSrcIn [DebugBlock]
procs

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

  -- .debug_info section: Information records on procedures and blocks
  let -- unique to identify start and end compilation unit .debug_inf
      (unitU :: Unique
unitU, us' :: UniqSupply
us') = UniqSupply -> (Unique, UniqSupply)
takeUniqFromSupply UniqSupply
us
      infoSct :: SDoc
infoSct = [SDoc] -> SDoc
vcat [ PtrString -> SDoc
ptext PtrString
dwarfInfoLabel SDoc -> SDoc -> SDoc
<> SDoc
colon
                     , SDoc
dwarfInfoSection
                     , Unique -> SDoc
compileUnitHeader Unique
unitU
                     , Bool -> DwarfInfo -> SDoc
pprDwarfInfo Bool
haveSrc DwarfInfo
dwarfUnit
                     , Unique -> SDoc
compileUnitFooter Unique
unitU
                     ]

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

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

  -- .aranges section: Information about the bounds of compilation units
  let aranges' :: [DwarfARange]
aranges' | GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_SplitSections DynFlags
df = (DebugBlock -> DwarfARange) -> [DebugBlock] -> [DwarfARange]
forall a b. (a -> b) -> [a] -> [b]
map DebugBlock -> DwarfARange
mkDwarfARange [DebugBlock]
procs
               | Bool
otherwise                 = [CLabel -> CLabel -> DwarfARange
DwarfARange CLabel
lowLabel CLabel
highLabel]
  let aranges :: SDoc
aranges = SDoc
dwarfARangesSection SDoc -> SDoc -> SDoc
$$ [DwarfARange] -> Unique -> SDoc
pprDwarfARanges [DwarfARange]
aranges' Unique
unitU

  (SDoc, UniqSupply) -> IO (SDoc, UniqSupply)
forall (m :: * -> *) a. Monad m => a -> m a
return (SDoc
infoSct SDoc -> SDoc -> SDoc
$$ SDoc
abbrevSct SDoc -> SDoc -> SDoc
$$ SDoc
lineSct SDoc -> SDoc -> SDoc
$$ SDoc
frameSct SDoc -> SDoc -> SDoc
$$ SDoc
aranges, UniqSupply
us'')

-- | Build an address range entry for one proc.
-- With split sections, each proc needs its own entry, since they may get
-- scattered in the final binary. Without split sections, we could make a
-- single arange based on the first/last proc.
mkDwarfARange :: DebugBlock -> DwarfARange
mkDwarfARange :: DebugBlock -> DwarfARange
mkDwarfARange proc :: DebugBlock
proc = CLabel -> CLabel -> DwarfARange
DwarfARange CLabel
start CLabel
end
  where
    start :: CLabel
start = DebugBlock -> CLabel
dblCLabel DebugBlock
proc
    end :: CLabel
end = CLabel -> CLabel
mkAsmTempEndLabel CLabel
start

-- | Header for a compilation unit, establishing global format
-- parameters
compileUnitHeader :: Unique -> SDoc
compileUnitHeader :: Unique -> SDoc
compileUnitHeader unitU :: Unique
unitU = (Platform -> SDoc) -> SDoc
sdocWithPlatform ((Platform -> SDoc) -> SDoc) -> (Platform -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$ \plat :: Platform
plat ->
  let cuLabel :: CLabel
cuLabel = Unique -> CLabel
forall a. Uniquable a => a -> CLabel
mkAsmTempLabel Unique
unitU  -- sits right before initialLength field
      length :: SDoc
length = CLabel -> SDoc
forall a. Outputable a => a -> SDoc
ppr (CLabel -> CLabel
mkAsmTempEndLabel CLabel
cuLabel) SDoc -> SDoc -> SDoc
<> Char -> SDoc
char '-' SDoc -> SDoc -> SDoc
<> CLabel -> SDoc
forall a. Outputable a => a -> SDoc
ppr CLabel
cuLabel
               SDoc -> SDoc -> SDoc
<> FilePath -> SDoc
text "-4"       -- length of initialLength field
  in [SDoc] -> SDoc
vcat [ CLabel -> SDoc
forall a. Outputable a => a -> SDoc
ppr CLabel
cuLabel SDoc -> SDoc -> SDoc
<> SDoc
colon
          , FilePath -> SDoc
text "\t.long " SDoc -> SDoc -> SDoc
<> SDoc
length  -- compilation unit size
          , Word16 -> SDoc
pprHalf 3                          -- DWARF version
          , SDoc -> SDoc -> SDoc
sectionOffset (PtrString -> SDoc
ptext PtrString
dwarfAbbrevLabel) (PtrString -> SDoc
ptext PtrString
dwarfAbbrevLabel)
                                               -- abbrevs offset
          , FilePath -> SDoc
text "\t.byte " SDoc -> SDoc -> SDoc
<> Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Platform -> Int
platformWordSize Platform
plat) -- word size
          ]

-- | Compilation unit footer, mainly establishing size of debug sections
compileUnitFooter :: Unique -> SDoc
compileUnitFooter :: Unique -> SDoc
compileUnitFooter unitU :: Unique
unitU =
  let cuEndLabel :: CLabel
cuEndLabel = CLabel -> CLabel
mkAsmTempEndLabel (CLabel -> CLabel) -> CLabel -> CLabel
forall a b. (a -> b) -> a -> b
$ Unique -> CLabel
forall a. Uniquable a => a -> CLabel
mkAsmTempLabel Unique
unitU
  in CLabel -> SDoc
forall a. Outputable a => a -> SDoc
ppr CLabel
cuEndLabel SDoc -> SDoc -> SDoc
<> SDoc
colon

-- | Splits the blocks by procedures. In the result all nested blocks
-- will come from the same procedure as the top-level block. See
-- Note [Splitting DebugBlocks] for details.
debugSplitProcs :: [DebugBlock] -> [DebugBlock]
debugSplitProcs :: [DebugBlock] -> [DebugBlock]
debugSplitProcs b :: [DebugBlock]
b = [[DebugBlock]] -> [DebugBlock]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[DebugBlock]] -> [DebugBlock]) -> [[DebugBlock]] -> [DebugBlock]
forall a b. (a -> b) -> a -> b
$ LabelMap [DebugBlock] -> [[DebugBlock]]
forall (map :: * -> *) a. IsMap map => map a -> [a]
H.mapElems (LabelMap [DebugBlock] -> [[DebugBlock]])
-> LabelMap [DebugBlock] -> [[DebugBlock]]
forall a b. (a -> b) -> a -> b
$ [LabelMap [DebugBlock]] -> LabelMap [DebugBlock]
forall a. [LabelMap [a]] -> LabelMap [a]
mergeMaps ([LabelMap [DebugBlock]] -> LabelMap [DebugBlock])
-> [LabelMap [DebugBlock]] -> LabelMap [DebugBlock]
forall a b. (a -> b) -> a -> b
$ (DebugBlock -> LabelMap [DebugBlock])
-> [DebugBlock] -> [LabelMap [DebugBlock]]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe DebugBlock -> DebugBlock -> LabelMap [DebugBlock]
split Maybe DebugBlock
forall a. Maybe a
Nothing) [DebugBlock]
b
  where mergeMaps :: [LabelMap [a]] -> LabelMap [a]
mergeMaps = (LabelMap [a] -> LabelMap [a] -> LabelMap [a])
-> LabelMap [a] -> [LabelMap [a]] -> LabelMap [a]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((KeyOf LabelMap -> [a] -> [a] -> [a])
-> LabelMap [a] -> LabelMap [a] -> LabelMap [a]
forall (map :: * -> *) a.
IsMap map =>
(KeyOf map -> a -> a -> a) -> map a -> map a -> map a
H.mapUnionWithKey (([a] -> [a] -> [a]) -> KeyOf LabelMap -> [a] -> [a] -> [a]
forall a b. a -> b -> a
const [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
(++))) LabelMap [a]
forall (map :: * -> *) a. IsMap map => map a
H.mapEmpty
        split :: Maybe DebugBlock -> DebugBlock -> H.LabelMap [DebugBlock]
        split :: Maybe DebugBlock -> DebugBlock -> LabelMap [DebugBlock]
split parent :: Maybe DebugBlock
parent blk :: DebugBlock
blk = KeyOf LabelMap
-> [DebugBlock] -> LabelMap [DebugBlock] -> LabelMap [DebugBlock]
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> a -> map a -> map a
H.mapInsert KeyOf LabelMap
Label
prc [DebugBlock
blk'] LabelMap [DebugBlock]
nested
          where prc :: Label
prc = DebugBlock -> Label
dblProcedure DebugBlock
blk
                blk' :: DebugBlock
blk' = DebugBlock
blk { dblBlocks :: [DebugBlock]
dblBlocks = [DebugBlock]
own_blks
                           , dblParent :: Maybe DebugBlock
dblParent = Maybe DebugBlock
parent
                           }
                own_blks :: [DebugBlock]
own_blks = [DebugBlock] -> Maybe [DebugBlock] -> [DebugBlock]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [DebugBlock] -> [DebugBlock])
-> Maybe [DebugBlock] -> [DebugBlock]
forall a b. (a -> b) -> a -> b
$ KeyOf LabelMap -> LabelMap [DebugBlock] -> Maybe [DebugBlock]
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
H.mapLookup KeyOf LabelMap
Label
prc LabelMap [DebugBlock]
nested
                nested :: LabelMap [DebugBlock]
nested = [LabelMap [DebugBlock]] -> LabelMap [DebugBlock]
forall a. [LabelMap [a]] -> LabelMap [a]
mergeMaps ([LabelMap [DebugBlock]] -> LabelMap [DebugBlock])
-> [LabelMap [DebugBlock]] -> LabelMap [DebugBlock]
forall a b. (a -> b) -> a -> b
$ (DebugBlock -> LabelMap [DebugBlock])
-> [DebugBlock] -> [LabelMap [DebugBlock]]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe DebugBlock -> DebugBlock -> LabelMap [DebugBlock]
split Maybe DebugBlock
parent') ([DebugBlock] -> [LabelMap [DebugBlock]])
-> [DebugBlock] -> [LabelMap [DebugBlock]]
forall a b. (a -> b) -> a -> b
$ DebugBlock -> [DebugBlock]
dblBlocks DebugBlock
blk
                -- Figure out who should be the parent of nested blocks.
                -- If @blk@ is optimized out then it isn't a good choice
                -- and we just use its parent.
                parent' :: Maybe DebugBlock
parent'
                  | Maybe Int
Nothing <- DebugBlock -> Maybe Int
dblPosition DebugBlock
blk = Maybe DebugBlock
parent
                  | Bool
otherwise                  = DebugBlock -> Maybe DebugBlock
forall a. a -> Maybe a
Just DebugBlock
blk

{-
Note [Splitting DebugBlocks]

DWARF requires that we break up the nested DebugBlocks produced from
the C-- AST. For instance, we begin with tick trees containing nested procs.
For example,

    proc A [tick1, tick2]
      block B [tick3]
        proc C [tick4]

when producing DWARF we need to procs (which are represented in DWARF as
TAG_subprogram DIEs) to be top-level DIEs. debugSplitProcs is responsible for
this transform, pulling out the nested procs into top-level procs.

However, in doing this we need to be careful to preserve the parentage of the
nested procs. This is the reason DebugBlocks carry the dblParent field, allowing
us to reorganize the above tree as,

    proc A [tick1, tick2]
      block B [tick3]
    proc C [tick4] parent=B

Here we have annotated the new proc C with an attribute giving its original
parent, B.
-}

-- | Generate DWARF info for a procedure debug block
procToDwarf :: DynFlags -> DebugBlock -> DwarfInfo
procToDwarf :: DynFlags -> DebugBlock -> DwarfInfo
procToDwarf df :: DynFlags
df prc :: DebugBlock
prc
  = DwarfSubprogram :: [DwarfInfo] -> FilePath -> CLabel -> Maybe CLabel -> DwarfInfo
DwarfSubprogram { dwChildren :: [DwarfInfo]
dwChildren = (DebugBlock -> DwarfInfo) -> [DebugBlock] -> [DwarfInfo]
forall a b. (a -> b) -> [a] -> [b]
map (DynFlags -> DebugBlock -> DwarfInfo
blockToDwarf DynFlags
df) (DebugBlock -> [DebugBlock]
dblBlocks DebugBlock
prc)
                    , dwName :: FilePath
dwName     = case DebugBlock -> Maybe CmmTickish
dblSourceTick DebugBlock
prc of
                         Just s :: CmmTickish
s@SourceNote{} -> CmmTickish -> FilePath
forall id. Tickish id -> FilePath
sourceName CmmTickish
s
                         _otherwise :: Maybe CmmTickish
_otherwise -> DynFlags -> SDoc -> FilePath
showSDocDump DynFlags
df (SDoc -> FilePath) -> SDoc -> FilePath
forall a b. (a -> b) -> a -> b
$ Label -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Label -> SDoc) -> Label -> SDoc
forall a b. (a -> b) -> a -> b
$ DebugBlock -> Label
dblLabel DebugBlock
prc
                    , dwLabel :: CLabel
dwLabel    = DebugBlock -> CLabel
dblCLabel DebugBlock
prc
                    , dwParent :: Maybe CLabel
dwParent   = (CLabel -> CLabel) -> Maybe CLabel -> Maybe CLabel
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CLabel -> CLabel
mkAsmTempDieLabel
                                   (Maybe CLabel -> Maybe CLabel) -> Maybe CLabel -> Maybe CLabel
forall a b. (a -> b) -> a -> b
$ (CLabel -> Bool) -> Maybe CLabel -> Maybe CLabel
forall (m :: * -> *) a. MonadPlus m => (a -> Bool) -> m a -> m a
mfilter CLabel -> Bool
goodParent
                                   (Maybe CLabel -> Maybe CLabel) -> Maybe CLabel -> Maybe CLabel
forall a b. (a -> b) -> a -> b
$ (DebugBlock -> CLabel) -> Maybe DebugBlock -> Maybe CLabel
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DebugBlock -> CLabel
dblCLabel (DebugBlock -> Maybe DebugBlock
dblParent DebugBlock
prc)
                    }
  where
  goodParent :: CLabel -> Bool
goodParent a :: CLabel
a | CLabel
a CLabel -> CLabel -> Bool
forall a. Eq a => a -> a -> Bool
== DebugBlock -> CLabel
dblCLabel DebugBlock
prc = Bool
False
               -- Omit parent if it would be self-referential
  goodParent a :: CLabel
a | Bool -> Bool
not (CLabel -> Bool
externallyVisibleCLabel CLabel
a)
               , DynFlags -> Int
debugLevel DynFlags
df Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 2 = Bool
False
               -- We strip block information when running -g0 or -g1, don't
               -- refer to blocks in that case. Fixes #14894.
  goodParent _ = Bool
True

-- | Generate DWARF info for a block
blockToDwarf :: DynFlags -> DebugBlock -> DwarfInfo
blockToDwarf :: DynFlags -> DebugBlock -> DwarfInfo
blockToDwarf df :: DynFlags
df blk :: DebugBlock
blk
  = DwarfBlock :: [DwarfInfo] -> CLabel -> Maybe CLabel -> DwarfInfo
DwarfBlock { dwChildren :: [DwarfInfo]
dwChildren = (CmmTickish -> [DwarfInfo]) -> [CmmTickish] -> [DwarfInfo]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (DynFlags -> CmmTickish -> [DwarfInfo]
tickToDwarf DynFlags
df) (DebugBlock -> [CmmTickish]
dblTicks DebugBlock
blk)
                              [DwarfInfo] -> [DwarfInfo] -> [DwarfInfo]
forall a. [a] -> [a] -> [a]
++ (DebugBlock -> DwarfInfo) -> [DebugBlock] -> [DwarfInfo]
forall a b. (a -> b) -> [a] -> [b]
map (DynFlags -> DebugBlock -> DwarfInfo
blockToDwarf DynFlags
df) (DebugBlock -> [DebugBlock]
dblBlocks DebugBlock
blk)
               , dwLabel :: CLabel
dwLabel    = DebugBlock -> CLabel
dblCLabel DebugBlock
blk
               , dwMarker :: Maybe CLabel
dwMarker   = Maybe CLabel
marker
               }
  where
    marker :: Maybe CLabel
marker
      | Just _ <- DebugBlock -> Maybe Int
dblPosition DebugBlock
blk = CLabel -> Maybe CLabel
forall a. a -> Maybe a
Just (CLabel -> Maybe CLabel) -> CLabel -> Maybe CLabel
forall a b. (a -> b) -> a -> b
$ Label -> CLabel
forall a. Uniquable a => a -> CLabel
mkAsmTempLabel (Label -> CLabel) -> Label -> CLabel
forall a b. (a -> b) -> a -> b
$ DebugBlock -> Label
dblLabel DebugBlock
blk
      | Bool
otherwise                 = Maybe CLabel
forall a. Maybe a
Nothing   -- block was optimized out

tickToDwarf :: DynFlags -> Tickish () -> [DwarfInfo]
tickToDwarf :: DynFlags -> CmmTickish -> [DwarfInfo]
tickToDwarf _  (SourceNote ss :: RealSrcSpan
ss _) = [RealSrcSpan -> DwarfInfo
DwarfSrcNote RealSrcSpan
ss]
tickToDwarf _ _ = []

-- | Generates the data for the debug frame section, which encodes the
-- desired stack unwind behaviour for the debugger
debugFrame :: Unique -> [DebugBlock] -> DwarfFrame
debugFrame :: Unique -> [DebugBlock] -> DwarfFrame
debugFrame u :: Unique
u procs :: [DebugBlock]
procs
  = DwarfFrame :: CLabel -> UnwindTable -> [DwarfFrameProc] -> DwarfFrame
DwarfFrame { dwCieLabel :: CLabel
dwCieLabel = Unique -> CLabel
forall a. Uniquable a => a -> CLabel
mkAsmTempLabel Unique
u
               , dwCieInit :: UnwindTable
dwCieInit  = UnwindTable
initUws
               , dwCieProcs :: [DwarfFrameProc]
dwCieProcs = (DebugBlock -> DwarfFrameProc) -> [DebugBlock] -> [DwarfFrameProc]
forall a b. (a -> b) -> [a] -> [b]
map (UnwindTable -> DebugBlock -> DwarfFrameProc
procToFrame UnwindTable
initUws) [DebugBlock]
procs
               }
  where
    initUws :: UnwindTable
    initUws :: UnwindTable
initUws = [(GlobalReg, Maybe UnwindExpr)] -> UnwindTable
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(GlobalReg
Sp, UnwindExpr -> Maybe UnwindExpr
forall a. a -> Maybe a
Just (GlobalReg -> Int -> UnwindExpr
UwReg GlobalReg
Sp 0))]

-- | Generates unwind information for a procedure debug block
procToFrame :: UnwindTable -> DebugBlock -> DwarfFrameProc
procToFrame :: UnwindTable -> DebugBlock -> DwarfFrameProc
procToFrame initUws :: UnwindTable
initUws blk :: DebugBlock
blk
  = DwarfFrameProc :: CLabel -> Bool -> [DwarfFrameBlock] -> DwarfFrameProc
DwarfFrameProc { dwFdeProc :: CLabel
dwFdeProc    = DebugBlock -> CLabel
dblCLabel DebugBlock
blk
                   , dwFdeHasInfo :: Bool
dwFdeHasInfo = DebugBlock -> Bool
dblHasInfoTbl DebugBlock
blk
                   , dwFdeBlocks :: [DwarfFrameBlock]
dwFdeBlocks  = ((DebugBlock, [UnwindPoint]) -> DwarfFrameBlock)
-> [(DebugBlock, [UnwindPoint])] -> [DwarfFrameBlock]
forall a b. (a -> b) -> [a] -> [b]
map ((DebugBlock -> [UnwindPoint] -> DwarfFrameBlock)
-> (DebugBlock, [UnwindPoint]) -> DwarfFrameBlock
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry DebugBlock -> [UnwindPoint] -> DwarfFrameBlock
blockToFrame)
                                        ([(DebugBlock, [UnwindPoint])] -> [(DebugBlock, [UnwindPoint])]
setHasInfo [(DebugBlock, [UnwindPoint])]
blockUws)
                   }
  where blockUws :: [(DebugBlock, [UnwindPoint])]
        blockUws :: [(DebugBlock, [UnwindPoint])]
blockUws = ((Int, (DebugBlock, [UnwindPoint])) -> (DebugBlock, [UnwindPoint]))
-> [(Int, (DebugBlock, [UnwindPoint]))]
-> [(DebugBlock, [UnwindPoint])]
forall a b. (a -> b) -> [a] -> [b]
map (Int, (DebugBlock, [UnwindPoint])) -> (DebugBlock, [UnwindPoint])
forall a b. (a, b) -> b
snd ([(Int, (DebugBlock, [UnwindPoint]))]
 -> [(DebugBlock, [UnwindPoint])])
-> [(Int, (DebugBlock, [UnwindPoint]))]
-> [(DebugBlock, [UnwindPoint])]
forall a b. (a -> b) -> a -> b
$ ((Int, (DebugBlock, [UnwindPoint]))
 -> (Int, (DebugBlock, [UnwindPoint])) -> Ordering)
-> [(Int, (DebugBlock, [UnwindPoint]))]
-> [(Int, (DebugBlock, [UnwindPoint]))]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((Int, (DebugBlock, [UnwindPoint])) -> Int)
-> (Int, (DebugBlock, [UnwindPoint]))
-> (Int, (DebugBlock, [UnwindPoint]))
-> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (Int, (DebugBlock, [UnwindPoint])) -> Int
forall a b. (a, b) -> a
fst) ([(Int, (DebugBlock, [UnwindPoint]))]
 -> [(Int, (DebugBlock, [UnwindPoint]))])
-> [(Int, (DebugBlock, [UnwindPoint]))]
-> [(Int, (DebugBlock, [UnwindPoint]))]
forall a b. (a -> b) -> a -> b
$ DebugBlock -> [(Int, (DebugBlock, [UnwindPoint]))]
flatten DebugBlock
blk

        flatten :: DebugBlock
                -> [(Int, (DebugBlock, [UnwindPoint]))]
        flatten :: DebugBlock -> [(Int, (DebugBlock, [UnwindPoint]))]
flatten b :: DebugBlock
b@DebugBlock{ dblPosition :: DebugBlock -> Maybe Int
dblPosition=Maybe Int
pos, dblUnwind :: DebugBlock -> [UnwindPoint]
dblUnwind=[UnwindPoint]
uws, dblBlocks :: DebugBlock -> [DebugBlock]
dblBlocks=[DebugBlock]
blocks }
          | Just p :: Int
p <- Maybe Int
pos  = (Int
p, (DebugBlock
b, [UnwindPoint]
uws'))(Int, (DebugBlock, [UnwindPoint]))
-> [(Int, (DebugBlock, [UnwindPoint]))]
-> [(Int, (DebugBlock, [UnwindPoint]))]
forall a. a -> [a] -> [a]
:[(Int, (DebugBlock, [UnwindPoint]))]
nested
          | Bool
otherwise      = [(Int, (DebugBlock, [UnwindPoint]))]
nested -- block was optimized out
          where uws' :: [UnwindPoint]
uws'   = UnwindTable -> [UnwindPoint] -> [UnwindPoint]
addDefaultUnwindings UnwindTable
initUws [UnwindPoint]
uws
                nested :: [(Int, (DebugBlock, [UnwindPoint]))]
nested = (DebugBlock -> [(Int, (DebugBlock, [UnwindPoint]))])
-> [DebugBlock] -> [(Int, (DebugBlock, [UnwindPoint]))]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap DebugBlock -> [(Int, (DebugBlock, [UnwindPoint]))]
flatten [DebugBlock]
blocks

        -- | If the current procedure has an info table, then we also say that
        -- its first block has one to ensure that it gets the necessary -1
        -- offset applied to its start address.
        -- See Note [Info Offset] in Dwarf.Types.
        setHasInfo :: [(DebugBlock, [UnwindPoint])]
                   -> [(DebugBlock, [UnwindPoint])]
        setHasInfo :: [(DebugBlock, [UnwindPoint])] -> [(DebugBlock, [UnwindPoint])]
setHasInfo [] = []
        setHasInfo (c0 :: (DebugBlock, [UnwindPoint])
c0:cs :: [(DebugBlock, [UnwindPoint])]
cs) = (DebugBlock -> DebugBlock)
-> (DebugBlock, [UnwindPoint]) -> (DebugBlock, [UnwindPoint])
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first DebugBlock -> DebugBlock
setIt (DebugBlock, [UnwindPoint])
c0 (DebugBlock, [UnwindPoint])
-> [(DebugBlock, [UnwindPoint])] -> [(DebugBlock, [UnwindPoint])]
forall a. a -> [a] -> [a]
: [(DebugBlock, [UnwindPoint])]
cs
          where
            setIt :: DebugBlock -> DebugBlock
setIt child :: DebugBlock
child =
              DebugBlock
child { dblHasInfoTbl :: Bool
dblHasInfoTbl = DebugBlock -> Bool
dblHasInfoTbl DebugBlock
child
                                      Bool -> Bool -> Bool
|| DebugBlock -> Bool
dblHasInfoTbl DebugBlock
blk }

blockToFrame :: DebugBlock -> [UnwindPoint] -> DwarfFrameBlock
blockToFrame :: DebugBlock -> [UnwindPoint] -> DwarfFrameBlock
blockToFrame blk :: DebugBlock
blk uws :: [UnwindPoint]
uws
  = DwarfFrameBlock :: Bool -> [UnwindPoint] -> DwarfFrameBlock
DwarfFrameBlock { dwFdeBlkHasInfo :: Bool
dwFdeBlkHasInfo = DebugBlock -> Bool
dblHasInfoTbl DebugBlock
blk
                    , dwFdeUnwind :: [UnwindPoint]
dwFdeUnwind     = [UnwindPoint]
uws
                    }

addDefaultUnwindings :: UnwindTable -> [UnwindPoint] -> [UnwindPoint]
addDefaultUnwindings :: UnwindTable -> [UnwindPoint] -> [UnwindPoint]
addDefaultUnwindings tbl :: UnwindTable
tbl pts :: [UnwindPoint]
pts =
    [ CLabel -> UnwindTable -> UnwindPoint
UnwindPoint CLabel
lbl (UnwindTable
tbl' UnwindTable -> UnwindTable -> UnwindTable
forall a. Monoid a => a -> a -> a
`mappend` UnwindTable
tbl)
      -- mappend is left-biased
    | UnwindPoint lbl :: CLabel
lbl tbl' :: UnwindTable
tbl' <- [UnwindPoint]
pts
    ]