module Dwarf (
dwarfGen
) where
import CLabel
import CmmExpr ( GlobalReg(..) )
import Config ( cProjectName, cProjectVersion )
import CoreSyn ( Tickish(..) )
import Debug
import DynFlags
import FastString
import Module
import Outputable
import Platform
import Unique
import UniqSupply
import Dwarf.Constants
import Dwarf.Types
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 Compiler.Hoopl as H
dwarfGen :: DynFlags -> ModLocation -> UniqSupply -> [DebugBlock]
-> IO (SDoc, UniqSupply)
dwarfGen df modLoc us blocks = do
let procs = map stripBlocks $ debugSplitProcs blocks
stripBlocks dbg = dbg { dblBlocks = [] }
compPath <- getCurrentDirectory
let dwarfUnit = DwarfCompileUnit
{ dwChildren = map (procToDwarf df) procs
, dwName = fromMaybe "" (ml_hs_file modLoc)
, dwCompDir = addTrailingPathSeparator compPath
, dwProducer = cProjectName ++ " " ++ cProjectVersion
, 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 [ 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)
return (infoSct $$ abbrevSct $$ lineSct $$ frameSct, us'')
compileUnitHeader :: Unique -> SDoc
compileUnitHeader unitU = sdocWithPlatform $ \plat ->
let cuLabel = mkAsmTempLabel unitU
length = ppr (mkAsmTempEndLabel cuLabel) <> char '-' <> ppr cuLabel
in vcat [ ptext (sLit "\t.long ") <> length
, ppr cuLabel <> colon
, ptext (sLit "\t.word 3")
, pprDwWord (sectionOffset dwarfAbbrevLabel dwarfAbbrevLabel)
, ptext (sLit "\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 b
where mergeMaps = foldr (H.mapUnionWithKey (const (++))) H.mapEmpty
split :: DebugBlock -> H.LabelMap [DebugBlock]
split blk = H.mapInsert prc [blk {dblBlocks = own_blks}] nested
where prc = dblProcedure blk
own_blks = fromMaybe [] $ H.mapLookup prc nested
nested = mergeMaps $ map split $ dblBlocks blk
procToDwarf :: DynFlags -> DebugBlock -> DwarfInfo
procToDwarf df prc
= DwarfSubprogram { dwChildren = foldr blockToDwarf [] $ dblBlocks prc
, dwName = case dblSourceTick prc of
Just s@SourceNote{} -> sourceName s
_otherwise -> showSDocDump df $ ppr $ dblLabel prc
, dwLabel = dblCLabel prc
}
blockToDwarf :: DebugBlock -> [DwarfInfo] -> [DwarfInfo]
blockToDwarf blk dws
| isJust (dblPosition blk) = dw : dws
| otherwise = nested ++ dws
where nested = foldr blockToDwarf [] $ dblBlocks blk
dw = DwarfBlock { dwChildren = nested
, dwLabel = dblCLabel blk
, dwMarker = mkAsmTempLabel (dblLabel blk)
}
debugFrame :: Unique -> [DebugBlock] -> DwarfFrame
debugFrame u procs
= DwarfFrame { dwCieLabel = mkAsmTempLabel u
, dwCieInit = initUws
, dwCieProcs = map (procToFrame initUws) procs
}
where initUws = Map.fromList [(Sp, UwReg Sp 0)]
procToFrame :: UnwindTable -> DebugBlock -> DwarfFrameProc
procToFrame initUws blk
= DwarfFrameProc { dwFdeProc = dblCLabel blk
, dwFdeHasInfo = dblHasInfoTbl blk
, dwFdeBlocks = map (uncurry blockToFrame) blockUws
}
where blockUws :: [(DebugBlock, UnwindTable)]
blockUws = map snd $ sortBy (comparing fst) $ flatten initUws blk
flatten uws0 b@DebugBlock{ dblPosition=pos, dblUnwind=uws,
dblBlocks=blocks }
| Just p <- pos = (p, (b, uws')):nested
| otherwise = nested
where uws' = uws `Map.union` uws0
nested = concatMap (flatten uws') blocks
blockToFrame :: DebugBlock -> UnwindTable -> DwarfFrameBlock
blockToFrame blk uws
= DwarfFrameBlock { dwFdeBlock = mkAsmTempLabel $ dblLabel blk
, dwFdeBlkHasInfo = dblHasInfoTbl blk
, dwFdeUnwind = uws
}