module GHC.CmmToAsm.Dwarf (
  dwarfGen
  ) where

import GHC.Prelude

import GHC.Cmm.CLabel
import GHC.Cmm.Expr
import GHC.Data.FastString
import GHC.Settings.Config ( cProjectName, cProjectVersion )
import GHC.Types.Tickish   ( CmmTickish, GenTickish(..) )
import GHC.Cmm.DebugBlock
import GHC.Unit.Module
import GHC.Utils.Outputable
import GHC.Platform
import GHC.Types.Unique
import GHC.Types.Unique.DSM

import GHC.CmmToAsm.Dwarf.Constants
import GHC.CmmToAsm.Dwarf.Types
import GHC.CmmToAsm.Config

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 qualified GHC.Cmm.Dataflow.Label as H

-- | Generate DWARF/debug information
dwarfGen :: IsDoc doc => String -> NCGConfig -> ModLocation -> DUniqSupply -> [DebugBlock] -> (doc, DUniqSupply)
dwarfGen :: forall doc.
IsDoc doc =>
String
-> NCGConfig
-> ModLocation
-> DUniqSupply
-> [DebugBlock]
-> (doc, DUniqSupply)
dwarfGen String
_        NCGConfig
_      ModLocation
_      DUniqSupply
us []     = (doc
forall doc. IsOutput doc => doc
empty, DUniqSupply
us)
dwarfGen String
compPath NCGConfig
config ModLocation
modLoc DUniqSupply
us [DebugBlock]
blocks =
  let platform :: Platform
platform = NCGConfig -> Platform
ncgPlatform NCGConfig
config

      -- Convert debug data structures to DWARF info records
      procs :: [DebugBlock]
procs = [DebugBlock] -> [DebugBlock]
debugSplitProcs [DebugBlock]
blocks
      stripBlocks :: DebugBlock -> DebugBlock
stripBlocks DebugBlock
dbg
        | NCGConfig -> Bool
ncgDwarfStripBlockInfo NCGConfig
config = DebugBlock
dbg { dblBlocks = [] }
        | Bool
otherwise                     = DebugBlock
dbg
      lowLabel :: CLabel
lowLabel = DebugBlock -> CLabel
dblCLabel (DebugBlock -> CLabel) -> DebugBlock -> CLabel
forall a b. (a -> b) -> a -> b
$ [DebugBlock] -> DebugBlock
forall a. HasCallStack => [a] -> a
head [DebugBlock]
procs
      highLabel :: CLabel
highLabel = CLabel -> CLabel
mkAsmTempProcEndLabel (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. HasCallStack => [a] -> a
last [DebugBlock]
procs
      dwarfUnit :: DwarfInfo
dwarfUnit = DwarfCompileUnit
        { dwChildren :: [DwarfInfo]
dwChildren = (DebugBlock -> DwarfInfo) -> [DebugBlock] -> [DwarfInfo]
forall a b. (a -> b) -> [a] -> [b]
map (NCGConfig -> DebugBlock -> DwarfInfo
procToDwarf NCGConfig
config) ((DebugBlock -> DebugBlock) -> [DebugBlock] -> [DebugBlock]
forall a b. (a -> b) -> [a] -> [b]
map DebugBlock -> DebugBlock
stripBlocks [DebugBlock]
procs)
        , dwName :: String
dwName = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" (ModLocation -> Maybe String
ml_hs_file ModLocation
modLoc)
        , dwCompDir :: String
dwCompDir = String -> String
addTrailingPathSeparator String
compPath
        , dwProducer :: String
dwProducer = String
cProjectName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cProjectVersion
        , dwLowLabel :: CLabel
dwLowLabel = CLabel
lowLabel
        , dwHighLabel :: CLabel
dwHighLabel = CLabel
highLabel
        }

      -- 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).
      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
      abbrevSct :: doc
abbrevSct = Platform -> Bool -> doc
forall doc. IsDoc doc => Platform -> Bool -> doc
pprAbbrevDecls Platform
platform Bool
haveSrc

  -- .debug_info section: Information records on procedures and blocks
      -- unique to identify start and end compilation unit .debug_inf
      (Unique
unitU, DUniqSupply
us') = DUniqSupply -> (Unique, DUniqSupply)
takeUniqueFromDSupply DUniqSupply
us
      infoSct :: doc
infoSct = [doc] -> doc
forall doc. IsDoc doc => [doc] -> doc
vcat [ Line doc -> doc
forall doc. IsDoc doc => Line doc -> doc
line (Line doc
forall doc. IsLine doc => doc
dwarfInfoLabel Line doc -> Line doc -> Line doc
forall doc. IsLine doc => doc -> doc -> doc
<> Line doc
forall doc. IsLine doc => doc
colon)
                     , Platform -> doc
forall doc. IsDoc doc => Platform -> doc
dwarfInfoSection Platform
platform
                     , Platform -> Unique -> doc
forall doc. IsDoc doc => Platform -> Unique -> doc
compileUnitHeader Platform
platform Unique
unitU
                     , Platform -> Bool -> DwarfInfo -> doc
forall doc. IsDoc doc => Platform -> Bool -> DwarfInfo -> doc
pprDwarfInfo Platform
platform Bool
haveSrc DwarfInfo
dwarfUnit
                     , Platform -> Unique -> doc
forall doc. IsDoc doc => Platform -> Unique -> doc
compileUnitFooter Platform
platform Unique
unitU
                     ]

  -- .debug_line section: Generated mainly by the assembler, but we
  -- need to label it
      lineSct :: doc
lineSct = Platform -> doc
forall doc. IsDoc doc => Platform -> doc
dwarfLineSection Platform
platform doc -> doc -> doc
forall doc. IsDoc doc => doc -> doc -> doc
$$
                Line doc -> doc
forall doc. IsDoc doc => Line doc -> doc
line (Line doc
forall doc. IsLine doc => doc
dwarfLineLabel Line doc -> Line doc -> Line doc
forall doc. IsLine doc => doc -> doc -> doc
<> Line doc
forall doc. IsLine doc => doc
colon)

  -- .debug_frame section: Information about the layout of the GHC stack
      (Unique
framesU, DUniqSupply
us'') = DUniqSupply -> (Unique, DUniqSupply)
takeUniqueFromDSupply DUniqSupply
us'
      frameSct :: doc
frameSct = Platform -> doc
forall doc. IsDoc doc => Platform -> doc
dwarfFrameSection Platform
platform doc -> doc -> doc
forall doc. IsDoc doc => doc -> doc -> doc
$$
                 Line doc -> doc
forall doc. IsDoc doc => Line doc -> doc
line (Line doc
forall doc. IsLine doc => doc
dwarfFrameLabel Line doc -> Line doc -> Line doc
forall doc. IsLine doc => doc -> doc -> doc
<> Line doc
forall doc. IsLine doc => doc
colon) doc -> doc -> doc
forall doc. IsDoc doc => doc -> doc -> doc
$$
                 Platform -> DwarfFrame -> doc
forall doc. IsDoc doc => Platform -> DwarfFrame -> doc
pprDwarfFrame Platform
platform (Platform -> Unique -> [DebugBlock] -> DwarfFrame
debugFrame Platform
platform Unique
framesU [DebugBlock]
procs)

  -- .aranges section: Information about the bounds of compilation units
      aranges' :: [DwarfARange]
aranges' | NCGConfig -> Bool
ncgSplitSections NCGConfig
config = (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]
      aranges :: doc
aranges = Platform -> doc
forall doc. IsDoc doc => Platform -> doc
dwarfARangesSection Platform
platform doc -> doc -> doc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Platform -> [DwarfARange] -> Unique -> doc
forall doc. IsDoc doc => Platform -> [DwarfARange] -> Unique -> doc
pprDwarfARanges Platform
platform [DwarfARange]
aranges' Unique
unitU

  in (doc
infoSct doc -> doc -> doc
forall doc. IsDoc doc => doc -> doc -> doc
$$ doc
abbrevSct doc -> doc -> doc
forall doc. IsDoc doc => doc -> doc -> doc
$$ doc
lineSct doc -> doc -> doc
forall doc. IsDoc doc => doc -> doc -> doc
$$ doc
frameSct doc -> doc -> doc
forall doc. IsDoc doc => doc -> doc -> doc
$$ doc
aranges, DUniqSupply
us'')
{-# SPECIALIZE dwarfGen :: String -> NCGConfig -> ModLocation -> DUniqSupply -> [DebugBlock] -> (SDoc, DUniqSupply) #-}
{-# SPECIALIZE dwarfGen :: String -> NCGConfig -> ModLocation -> DUniqSupply -> [DebugBlock] -> (HDoc, DUniqSupply) #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable

-- | 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
lbl CLabel
end
  where
    lbl :: CLabel
lbl = DebugBlock -> CLabel
dblCLabel DebugBlock
proc
    end :: CLabel
end = CLabel -> CLabel
mkAsmTempProcEndLabel CLabel
lbl

-- | Header for a compilation unit, establishing global format
-- parameters
compileUnitHeader :: IsDoc doc => Platform -> Unique -> doc
compileUnitHeader :: forall doc. IsDoc doc => Platform -> Unique -> doc
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 :: Line doc
length = Platform -> CLabel -> Line doc
forall doc. IsLine doc => Platform -> CLabel -> doc
pprAsmLabel Platform
platform (CLabel -> CLabel
mkAsmTempEndLabel CLabel
cuLabel) Line doc -> Line doc -> Line doc
forall doc. IsLine doc => doc -> doc -> doc
<> Char -> Line doc
forall doc. IsLine doc => Char -> doc
char Char
'-' Line doc -> Line doc -> Line doc
forall doc. IsLine doc => doc -> doc -> doc
<> Platform -> CLabel -> Line doc
forall doc. IsLine doc => Platform -> CLabel -> doc
pprAsmLabel Platform
platform CLabel
cuLabel
               Line doc -> Line doc -> Line doc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> Line doc
forall doc. IsLine doc => String -> doc
text String
"-4"       -- length of initialLength field
  in [doc] -> doc
forall doc. IsDoc doc => [doc] -> doc
vcat [ Line doc -> doc
forall doc. IsDoc doc => Line doc -> doc
line (Platform -> CLabel -> Line doc
forall doc. IsLine doc => Platform -> CLabel -> doc
pprAsmLabel Platform
platform CLabel
cuLabel Line doc -> Line doc -> Line doc
forall doc. IsLine doc => doc -> doc -> doc
<> Line doc
forall doc. IsLine doc => doc
colon)
          , Line doc -> doc
forall doc. IsDoc doc => Line doc -> doc
line (String -> Line doc
forall doc. IsLine doc => String -> doc
text String
"\t.long " Line doc -> Line doc -> Line doc
forall doc. IsLine doc => doc -> doc -> doc
<> Line doc
length)  -- compilation unit size
          , Word16 -> doc
forall doc. IsDoc doc => Word16 -> doc
pprHalf Word16
3                          -- DWARF version
          , Platform -> Line doc -> Line doc -> doc
forall doc. IsDoc doc => Platform -> Line doc -> Line doc -> doc
sectionOffset Platform
platform Line doc
forall doc. IsLine doc => doc
dwarfAbbrevLabel Line doc
forall doc. IsLine doc => doc
dwarfAbbrevLabel
                                               -- abbrevs offset
          , Line doc -> doc
forall doc. IsDoc doc => Line doc -> doc
line (String -> Line doc
forall doc. IsLine doc => String -> doc
text String
"\t.byte " Line doc -> Line doc -> Line doc
forall doc. IsLine doc => doc -> doc -> doc
<> Int -> Line doc
forall doc. IsLine doc => Int -> doc
int (Platform -> Int
platformWordSizeInBytes Platform
platform)) -- word size
          ]

-- | Compilation unit footer, mainly establishing size of debug sections
compileUnitFooter :: IsDoc doc => Platform -> Unique -> doc
compileUnitFooter :: forall doc. IsDoc doc => Platform -> Unique -> doc
compileUnitFooter Platform
platform 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 Line doc -> doc
forall doc. IsDoc doc => Line doc -> doc
line (Platform -> CLabel -> Line doc
forall doc. IsLine doc => Platform -> CLabel -> doc
pprAsmLabel Platform
platform CLabel
cuEndLabel Line doc -> Line doc -> Line doc
forall doc. IsLine doc => doc -> doc -> doc
<> Line doc
forall doc. IsLine doc => doc
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 a. LabelMap 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 a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((Label -> [a] -> [a] -> [a])
-> LabelMap [a] -> LabelMap [a] -> LabelMap [a]
forall v.
(Label -> v -> v -> v) -> LabelMap v -> LabelMap v -> LabelMap v
H.mapUnionWithKey (([a] -> [a] -> [a]) -> Label -> [a] -> [a] -> [a]
forall a b. a -> b -> a
const [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
(++))) LabelMap [a]
forall v. LabelMap v
H.mapEmpty
        split :: Maybe DebugBlock -> DebugBlock -> H.LabelMap [DebugBlock]
        split :: Maybe DebugBlock -> DebugBlock -> LabelMap [DebugBlock]
split Maybe DebugBlock
parent DebugBlock
blk = Label
-> [DebugBlock] -> LabelMap [DebugBlock] -> LabelMap [DebugBlock]
forall v. Label -> v -> LabelMap v -> LabelMap v
H.mapInsert Label
prc [DebugBlock
blk'] LabelMap [DebugBlock]
nested
          where prc :: Label
prc = DebugBlock -> Label
dblProcedure DebugBlock
blk
                blk' :: DebugBlock
blk' = DebugBlock
blk { dblBlocks = own_blks
                           , dblParent = 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
$ Label -> LabelMap [DebugBlock] -> Maybe [DebugBlock]
forall a. Label -> LabelMap a -> Maybe a
H.mapLookup 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 :: NCGConfig -> DebugBlock -> DwarfInfo
procToDwarf :: NCGConfig -> DebugBlock -> DwarfInfo
procToDwarf NCGConfig
config DebugBlock
prc
  = DwarfSubprogram { dwChildren :: [DwarfInfo]
dwChildren = (DebugBlock -> DwarfInfo) -> [DebugBlock] -> [DwarfInfo]
forall a b. (a -> b) -> [a] -> [b]
map (NCGConfig -> DebugBlock -> DwarfInfo
blockToDwarf NCGConfig
config) (DebugBlock -> [DebugBlock]
dblBlocks DebugBlock
prc)
                    , dwName :: String
dwName     = case DebugBlock -> Maybe CmmTickish
dblSourceTick DebugBlock
prc of
                         Just s :: CmmTickish
s@SourceNote{} -> case CmmTickish -> LexicalFastString
forall (pass :: TickishPass). GenTickish pass -> LexicalFastString
sourceName CmmTickish
s of
                            LexicalFastString FastString
s -> FastString -> String
unpackFS FastString
s
                         Maybe CmmTickish
_otherwise -> Label -> String
forall a. Show a => a -> String
show (DebugBlock -> Label
dblLabel DebugBlock
prc)
                    , dwLabel :: CLabel
dwLabel    = DebugBlock -> CLabel
dblCLabel DebugBlock
prc
                    , dwParent :: Maybe CLabel
dwParent   = (CLabel -> CLabel) -> Maybe CLabel -> Maybe CLabel
forall a b. (a -> b) -> Maybe a -> Maybe b
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 a b. (a -> b) -> Maybe a -> Maybe b
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)
               , NCGConfig -> Bool
ncgDwarfStripBlockInfo NCGConfig
config = Bool
False
               -- If we strip block information, don't refer to blocks.
               -- Fixes #14894.
  goodParent CLabel
_ = Bool
True

-- | Generate DWARF info for a block
blockToDwarf :: NCGConfig -> DebugBlock -> DwarfInfo
blockToDwarf :: NCGConfig -> DebugBlock -> DwarfInfo
blockToDwarf NCGConfig
config DebugBlock
blk
  = DwarfBlock { dwChildren :: [DwarfInfo]
dwChildren = (DebugBlock -> DwarfInfo) -> [DebugBlock] -> [DwarfInfo]
forall a b. (a -> b) -> [a] -> [b]
map (NCGConfig -> DebugBlock -> DwarfInfo
blockToDwarf NCGConfig
config) (DebugBlock -> [DebugBlock]
dblBlocks DebugBlock
blk) [DwarfInfo] -> [DwarfInfo] -> [DwarfInfo]
forall a. [a] -> [a] -> [a]
++ [DwarfInfo]
srcNotes
               , dwLabel :: CLabel
dwLabel    = DebugBlock -> CLabel
dblCLabel DebugBlock
blk
               , dwMarker :: Maybe CLabel
dwMarker   = Maybe CLabel
marker
               }
  where
    srcNotes :: [DwarfInfo]
srcNotes
      | NCGConfig -> Bool
ncgDwarfSourceNotes NCGConfig
config = (CmmTickish -> [DwarfInfo]) -> [CmmTickish] -> [DwarfInfo]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap CmmTickish -> [DwarfInfo]
tickToDwarf (DebugBlock -> [CmmTickish]
dblTicks DebugBlock
blk)
      | Bool
otherwise                  = []

    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 :: CmmTickish -> [DwarfInfo]
tickToDwarf :: CmmTickish -> [DwarfInfo]
tickToDwarf  (SourceNote RealSrcSpan
ss LexicalFastString
_) = [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 :: Platform -> Unique -> [DebugBlock] -> DwarfFrame
debugFrame :: Platform -> Unique -> [DebugBlock] -> DwarfFrame
debugFrame Platform
p Unique
u [DebugBlock]
procs
  = 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 (GlobalRegUse -> Int -> UnwindExpr
UwReg (GlobalReg -> CmmType -> GlobalRegUse
GlobalRegUse GlobalReg
Sp (CmmType -> GlobalRegUse) -> CmmType -> GlobalRegUse
forall a b. (a -> b) -> a -> b
$ Platform -> CmmType
bWord Platform
p) Int
0))]

-- | Generates unwind information for a procedure debug block
procToFrame :: UnwindTable -> DebugBlock -> DwarfFrameProc
procToFrame :: UnwindTable -> DebugBlock -> DwarfFrameProc
procToFrame UnwindTable
initUws DebugBlock
blk
  = 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 b c d. (b -> c) -> (b, d) -> (c, d)
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 = dblHasInfoTbl child
                                      || dblHasInfoTbl blk }

blockToFrame :: DebugBlock -> [UnwindPoint] -> DwarfFrameBlock
blockToFrame :: DebugBlock -> [UnwindPoint] -> DwarfFrameBlock
blockToFrame DebugBlock
blk [UnwindPoint]
uws
  = 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
    ]