module GHC.CmmToAsm.Dwarf (
  dwarfGen
  ) where

import GHC.Prelude

import GHC.Cmm.CLabel
import GHC.Cmm.Expr        ( GlobalReg(..) )
import GHC.Settings.Config ( cProjectName, cProjectVersion )
import GHC.Core            ( Tickish(..) )
import GHC.Cmm.DebugBlock
import GHC.Driver.Session
import GHC.Unit.Module
import GHC.Utils.Outputable
import GHC.Platform
import GHC.Types.Unique
import GHC.Types.Unique.Supply

import GHC.CmmToAsm.Dwarf.Constants
import GHC.CmmToAsm.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 GHC.Cmm.Dataflow.Label as H
import qualified GHC.Cmm.Dataflow.Collections as H

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

  -- 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 DebugBlock
dbg
        | DynFlags -> Int
debugLevel DynFlags
df Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
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 FilePath
"" (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 -> 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 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 = Platform -> Bool -> SDoc
pprAbbrevDecls Platform
platform Bool
haveSrc

  -- .debug_info section: Information records on procedures and blocks
  let -- unique to identify start and end compilation unit .debug_inf
      (Unique
unitU, UniqSupply
us') = UniqSupply -> (Unique, UniqSupply)
takeUniqFromSupply UniqSupply
us
      infoSct :: SDoc
infoSct = [SDoc] -> SDoc
vcat [ PtrString -> SDoc
ptext PtrString
dwarfInfoLabel SDoc -> SDoc -> SDoc
<> SDoc
colon
                     , Platform -> SDoc
dwarfInfoSection Platform
platform
                     , Platform -> Unique -> SDoc
compileUnitHeader Platform
platform Unique
unitU
                     , Platform -> Bool -> DwarfInfo -> SDoc
pprDwarfInfo Platform
platform 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 = Platform -> SDoc
dwarfLineSection Platform
platform 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 (Unique
framesU, UniqSupply
us'') = UniqSupply -> (Unique, UniqSupply)
takeUniqFromSupply UniqSupply
us'
      frameSct :: SDoc
frameSct = Platform -> SDoc
dwarfFrameSection Platform
platform SDoc -> SDoc -> SDoc
$$
                 PtrString -> SDoc
ptext PtrString
dwarfFrameLabel SDoc -> SDoc -> SDoc
<> SDoc
colon SDoc -> SDoc -> SDoc
$$
                 Platform -> DwarfFrame -> SDoc
pprDwarfFrame Platform
platform (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 = Platform -> SDoc
dwarfARangesSection Platform
platform SDoc -> SDoc -> SDoc
$$ Platform -> [DwarfARange] -> Unique -> SDoc
pprDwarfARanges Platform
platform [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 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 :: Platform -> Unique -> SDoc
compileUnitHeader :: Platform -> Unique -> SDoc
compileUnitHeader Platform
platform Unique
unitU =
  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 Char
'-' SDoc -> SDoc -> SDoc
<> CLabel -> SDoc
forall a. Outputable a => a -> SDoc
ppr CLabel
cuLabel
               SDoc -> SDoc -> SDoc
<> FilePath -> SDoc
text FilePath
"-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 FilePath
"\t.long " SDoc -> SDoc -> SDoc
<> SDoc
length  -- compilation unit size
          , Word16 -> SDoc
pprHalf Word16
3                          -- DWARF version
          , Platform -> SDoc -> SDoc -> SDoc
sectionOffset Platform
platform (PtrString -> SDoc
ptext PtrString
dwarfAbbrevLabel) (PtrString -> SDoc
ptext PtrString
dwarfAbbrevLabel)
                                               -- abbrevs offset
          , FilePath -> SDoc
text FilePath
"\t.byte " SDoc -> SDoc -> SDoc
<> Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Platform -> Int
platformWordSizeInBytes Platform
platform) -- word size
          ]

-- | Compilation unit footer, mainly establishing size of debug sections
compileUnitFooter :: Unique -> SDoc
compileUnitFooter :: Unique -> SDoc
compileUnitFooter 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 [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 Maybe DebugBlock
parent 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 DynFlags
df 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 DebugBlock -> DwarfInfo
blockToDwarf (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
                         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 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 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
< Int
2 = Bool
False
               -- We strip block information when running -g0 or -g1, don't
               -- refer to blocks in that case. Fixes #14894.
  goodParent CLabel
_ = Bool
True

-- | Generate DWARF info for a block
blockToDwarf :: DebugBlock -> DwarfInfo
blockToDwarf :: DebugBlock -> DwarfInfo
blockToDwarf 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 CmmTickish -> [DwarfInfo]
tickToDwarf (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 DebugBlock -> DwarfInfo
blockToDwarf (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 Int
_ <- 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 :: Tickish () -> [DwarfInfo]
tickToDwarf :: CmmTickish -> [DwarfInfo]
tickToDwarf  (SourceNote RealSrcSpan
ss FilePath
_) = [RealSrcSpan -> DwarfInfo
DwarfSrcNote RealSrcSpan
ss]
tickToDwarf CmmTickish
_ = []

-- | 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 Unique
u [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 Int
0))]

-- | Generates unwind information for a procedure debug block
procToFrame :: UnwindTable -> DebugBlock -> DwarfFrameProc
procToFrame :: UnwindTable -> DebugBlock -> DwarfFrameProc
procToFrame UnwindTable
initUws 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 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 "GHC.CmmToAsm.Dwarf.Types".
        setHasInfo :: [(DebugBlock, [UnwindPoint])]
                   -> [(DebugBlock, [UnwindPoint])]
        setHasInfo :: [(DebugBlock, [UnwindPoint])] -> [(DebugBlock, [UnwindPoint])]
setHasInfo [] = []
        setHasInfo ((DebugBlock, [UnwindPoint])
c0:[(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 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 DebugBlock
blk [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 UnwindTable
tbl [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 CLabel
lbl UnwindTable
tbl' <- [UnwindPoint]
pts
    ]