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
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
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
}
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
abbrevSct :: doc
abbrevSct = Platform -> Bool -> doc
forall doc. IsDoc doc => Platform -> Bool -> doc
pprAbbrevDecls Platform
platform Bool
haveSrc
(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
]
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)
(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' :: [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) #-}
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
compileUnitHeader :: IsDoc doc => Platform -> Unique -> doc
Platform
platform Unique
unitU =
let cuLabel :: CLabel
cuLabel = Unique -> CLabel
forall a. Uniquable a => a -> CLabel
mkAsmTempLabel Unique
unitU
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"
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)
, Word16 -> doc
forall doc. IsDoc doc => Word16 -> doc
pprHalf Word16
3
, 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
, 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))
]
compileUnitFooter :: IsDoc doc => Platform -> Unique -> doc
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)
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
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
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
goodParent CLabel
a | Bool -> Bool
not (CLabel -> Bool
externallyVisibleCLabel CLabel
a)
, NCGConfig -> Bool
ncgDwarfStripBlockInfo NCGConfig
config = Bool
False
goodParent CLabel
_ = Bool
True
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
tickToDwarf :: CmmTickish -> [DwarfInfo]
tickToDwarf :: CmmTickish -> [DwarfInfo]
tickToDwarf (SourceNote RealSrcSpan
ss LexicalFastString
_) = [RealSrcSpan -> DwarfInfo
DwarfSrcNote RealSrcSpan
ss]
tickToDwarf CmmTickish
_ = []
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))]
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
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
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)
| UnwindPoint CLabel
lbl UnwindTable
tbl' <- [UnwindPoint]
pts
]