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
dwarfGen :: DynFlags -> ModLocation -> UniqSupply -> [DebugBlock]
-> IO (SDoc, UniqSupply)
dwarfGen _ _ us [] = return (empty, us)
dwarfGen df modLoc us blocks = do
let procs = debugSplitProcs blocks
stripBlocks dbg
| debugLevel df < 2 = dbg { dblBlocks = [] }
| otherwise = dbg
compPath <- getCurrentDirectory
let lowLabel = dblCLabel $ head procs
highLabel = mkAsmTempEndLabel $ dblCLabel $ last procs
dwarfUnit = DwarfCompileUnit
{ dwChildren = map (procToDwarf df) (map stripBlocks procs)
, dwName = fromMaybe "" (ml_hs_file modLoc)
, dwCompDir = addTrailingPathSeparator compPath
, dwProducer = cProjectName ++ " " ++ cProjectVersion
, dwLowLabel = lowLabel
, dwHighLabel = highLabel
, dwLineLabel = dwarfLineLabel
}
let haveSrcIn blk = isJust (dblSourceTick blk) && isJust (dblPosition blk)
|| any haveSrcIn (dblBlocks blk)
haveSrc = any haveSrcIn procs
let abbrevSct = pprAbbrevDecls haveSrc
let
(unitU, us') = takeUniqFromSupply us
infoSct = vcat [ ptext dwarfInfoLabel <> colon
, dwarfInfoSection
, compileUnitHeader unitU
, pprDwarfInfo haveSrc dwarfUnit
, compileUnitFooter unitU
]
let lineSct = dwarfLineSection $$
ptext dwarfLineLabel <> colon
let (framesU, us'') = takeUniqFromSupply us'
frameSct = dwarfFrameSection $$
ptext dwarfFrameLabel <> colon $$
pprDwarfFrame (debugFrame framesU procs)
let aranges' | gopt Opt_SplitSections df = map mkDwarfARange procs
| otherwise = [DwarfARange lowLabel highLabel]
let aranges = dwarfARangesSection $$ pprDwarfARanges aranges' unitU
return (infoSct $$ abbrevSct $$ lineSct $$ frameSct $$ aranges, us'')
mkDwarfARange :: DebugBlock -> DwarfARange
mkDwarfARange proc = DwarfARange start end
where
start = dblCLabel proc
end = mkAsmTempEndLabel start
compileUnitHeader :: Unique -> SDoc
compileUnitHeader unitU = sdocWithPlatform $ \plat ->
let cuLabel = mkAsmTempLabel unitU
length = ppr (mkAsmTempEndLabel cuLabel) <> char '-' <> ppr cuLabel
<> text "-4"
in vcat [ ppr cuLabel <> colon
, text "\t.long " <> length
, pprHalf 3
, sectionOffset (ptext dwarfAbbrevLabel) (ptext dwarfAbbrevLabel)
, text "\t.byte " <> ppr (platformWordSize plat)
]
compileUnitFooter :: Unique -> SDoc
compileUnitFooter unitU =
let cuEndLabel = mkAsmTempEndLabel $ mkAsmTempLabel unitU
in ppr cuEndLabel <> colon
debugSplitProcs :: [DebugBlock] -> [DebugBlock]
debugSplitProcs b = concat $ H.mapElems $ mergeMaps $ map (split Nothing) b
where mergeMaps = foldr (H.mapUnionWithKey (const (++))) H.mapEmpty
split :: Maybe DebugBlock -> DebugBlock -> H.LabelMap [DebugBlock]
split parent blk = H.mapInsert prc [blk'] nested
where prc = dblProcedure blk
blk' = blk { dblBlocks = own_blks
, dblParent = parent
}
own_blks = fromMaybe [] $ H.mapLookup prc nested
nested = mergeMaps $ map (split parent') $ dblBlocks blk
parent'
| Nothing <- dblPosition blk = parent
| otherwise = Just blk
procToDwarf :: DynFlags -> DebugBlock -> DwarfInfo
procToDwarf df prc
= DwarfSubprogram { dwChildren = map (blockToDwarf df) (dblBlocks prc)
, dwName = case dblSourceTick prc of
Just s@SourceNote{} -> sourceName s
_otherwise -> showSDocDump df $ ppr $ dblLabel prc
, dwLabel = dblCLabel prc
, dwParent = fmap mkAsmTempDieLabel
$ mfilter goodParent
$ fmap dblCLabel (dblParent prc)
}
where
goodParent a | a == dblCLabel prc = False
goodParent a | not (externallyVisibleCLabel a)
, debugLevel df < 2 = False
goodParent _ = True
blockToDwarf :: DynFlags -> DebugBlock -> DwarfInfo
blockToDwarf df blk
= DwarfBlock { dwChildren = concatMap (tickToDwarf df) (dblTicks blk)
++ map (blockToDwarf df) (dblBlocks blk)
, dwLabel = dblCLabel blk
, dwMarker = marker
}
where
marker
| Just _ <- dblPosition blk = Just $ mkAsmTempLabel $ dblLabel blk
| otherwise = Nothing
tickToDwarf :: DynFlags -> Tickish () -> [DwarfInfo]
tickToDwarf _ (SourceNote ss _) = [DwarfSrcNote ss]
tickToDwarf _ _ = []
debugFrame :: Unique -> [DebugBlock] -> DwarfFrame
debugFrame u procs
= DwarfFrame { dwCieLabel = mkAsmTempLabel u
, dwCieInit = initUws
, dwCieProcs = map (procToFrame initUws) procs
}
where
initUws :: UnwindTable
initUws = Map.fromList [(Sp, Just (UwReg Sp 0))]
procToFrame :: UnwindTable -> DebugBlock -> DwarfFrameProc
procToFrame initUws blk
= DwarfFrameProc { dwFdeProc = dblCLabel blk
, dwFdeHasInfo = dblHasInfoTbl blk
, dwFdeBlocks = map (uncurry blockToFrame)
(setHasInfo blockUws)
}
where blockUws :: [(DebugBlock, [UnwindPoint])]
blockUws = map snd $ sortBy (comparing fst) $ flatten blk
flatten :: DebugBlock
-> [(Int, (DebugBlock, [UnwindPoint]))]
flatten b@DebugBlock{ dblPosition=pos, dblUnwind=uws, dblBlocks=blocks }
| Just p <- pos = (p, (b, uws')):nested
| otherwise = nested
where uws' = addDefaultUnwindings initUws uws
nested = concatMap flatten blocks
setHasInfo :: [(DebugBlock, [UnwindPoint])]
-> [(DebugBlock, [UnwindPoint])]
setHasInfo [] = []
setHasInfo (c0:cs) = first setIt c0 : cs
where
setIt child =
child { dblHasInfoTbl = dblHasInfoTbl child
|| dblHasInfoTbl blk }
blockToFrame :: DebugBlock -> [UnwindPoint] -> DwarfFrameBlock
blockToFrame blk uws
= DwarfFrameBlock { dwFdeBlkHasInfo = dblHasInfoTbl blk
, dwFdeUnwind = uws
}
addDefaultUnwindings :: UnwindTable -> [UnwindPoint] -> [UnwindPoint]
addDefaultUnwindings tbl pts =
[ UnwindPoint lbl (tbl' `mappend` tbl)
| UnwindPoint lbl tbl' <- pts
]