moduleDwarf(dwarfGen )whereimportGhcPreludeimportCLabel importCmmExpr (GlobalReg (..))importConfig(cProjectName,cProjectVersion)importCoreSyn(Tickish(..))importDebug importDynFlagsimportModuleimportOutputableimportPlatformimportUniqueimportUniqSupplyimportDwarf.Constants importDwarf.Types importControl.Arrow(first)importControl.Monad(mfilter)importData.MaybeimportData.List(sortBy)importData.Ord(comparing)importqualifiedData.MapasMapimportSystem.FilePathimportSystem.Directory(getCurrentDirectory)importqualifiedHoopl.Label asHimportqualifiedHoopl.Collections asH-- | Generate DWARF/debug informationdwarfGen::DynFlags->ModLocation->UniqSupply->[DebugBlock ]->IO(SDoc,UniqSupply)dwarfGen __us []=return(empty,us )dwarfGendf modLoc us blocks =do-- Convert debug data structures to DWARF info records-- We strip out block information when running with -g0 or -g1.letprocs =debugSplitProcs blocks stripBlocks dbg |debugLeveldf <2=dbg {dblBlocks=[]}|otherwise=dbg compPath <-getCurrentDirectoryletlowLabel =dblCLabel$headprocs highLabel =mkAsmTempEndLabel $dblCLabel$lastprocs dwarfUnit =DwarfCompileUnit {dwChildren=map(procToDwarf df )(mapstripBlocks procs ),dwName=fromMaybe""(ml_hs_filemodLoc ),dwCompDir=addTrailingPathSeparatorcompPath ,dwProducer=cProjectName++" "++cProjectVersion,dwLowLabel=lowLabel ,dwHighLabel=highLabel ,dwLineLabel=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).lethaveSrcIn blk =isJust(dblSourceTickblk )&&isJust(dblPositionblk )||anyhaveSrcIn (dblBlocksblk )haveSrc =anyhaveSrcIn procs -- .debug_abbrev section: Declare the format we're usingletabbrevSct =pprAbbrevDecls haveSrc -- .debug_info section: Information records on procedures and blockslet-- unique to identify start and end compilation unit .debug_inf(unitU ,us' )=takeUniqFromSupplyus infoSct =vcat[ptextdwarfInfoLabel <>colon,dwarfInfoSection ,compileUnitHeader unitU ,pprDwarfInfo haveSrc dwarfUnit ,compileUnitFooter unitU ]-- .debug_line section: Generated mainly by the assembler, but we-- need to label itletlineSct =dwarfLineSection $$ptextdwarfLineLabel <>colon-- .debug_frame section: Information about the layout of the GHC stacklet(framesU ,us'' )=takeUniqFromSupplyus' frameSct =dwarfFrameSection $$ptextdwarfFrameLabel <>colon$$pprDwarfFrame (debugFrame framesU procs )-- .aranges section: Information about the bounds of compilation unitsletaranges' |goptOpt_SplitSectionsdf =mapmkDwarfARange procs |otherwise=[DwarfARange lowLabel highLabel ]letaranges =dwarfARangesSection $$pprDwarfARanges aranges' unitU return(infoSct $$abbrevSct $$lineSct $$frameSct $$aranges ,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 proc =DwarfARange start end wherestart =dblCLabelproc end =mkAsmTempEndLabel start -- | Header for a compilation unit, establishing global format-- parameterscompileUnitHeader::Unique->SDoccompileUnitHeader unitU =sdocWithPlatform$\plat ->letcuLabel =mkAsmTempLabel unitU -- sits right before initialLength fieldlength =ppr(mkAsmTempEndLabel cuLabel )<>char'-'<>pprcuLabel <>text"-4"-- length of initialLength fieldinvcat[pprcuLabel <>colon,text"\t.long "<>length -- compilation unit size,pprHalf 3-- DWARF version,sectionOffset (ptextdwarfAbbrevLabel )(ptextdwarfAbbrevLabel )-- abbrevs offset,text"\t.byte "<>ppr(platformWordSizeplat )-- word size]-- | Compilation unit footer, mainly establishing size of debug sectionscompileUnitFooter::Unique->SDoccompileUnitFooter unitU =letcuEndLabel =mkAsmTempEndLabel $mkAsmTempLabel unitU inpprcuEndLabel <>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 b =concat$H.mapElems $mergeMaps $map(split Nothing)b wheremergeMaps =foldr(H.mapUnionWithKey (const(++)))H.mapEmpty split::MaybeDebugBlock ->DebugBlock ->H.LabelMap [DebugBlock ]split parent blk =H.mapInsert prc [blk' ]nested whereprc =dblProcedureblk blk' =blk {dblBlocks=own_blks ,dblParent=parent }own_blks =fromMaybe[]$H.mapLookup prc nested nested =mergeMaps $map(split parent' )$dblBlocksblk -- 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' |Nothing<-dblPositionblk =parent |otherwise=Justblk {-
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 blockprocToDwarf::DynFlags->DebugBlock ->DwarfInfo procToDwarf df prc =DwarfSubprogram {dwChildren=map(blockToDwarf df )(dblBlocksprc ),dwName=casedblSourceTickprc ofJusts @SourceNote{}->sourceNames _otherwise ->showSDocDumpdf $ppr$dblLabelprc ,dwLabel=dblCLabelprc ,dwParent=fmapmkAsmTempDieLabel $mfiltergoodParent $fmapdblCLabel(dblParentprc )}wheregoodParent a |a ==dblCLabelprc =False-- Omit parent if it would be self-referentialgoodParenta |not(externallyVisibleCLabel a ),debugLeveldf <2=False-- We strip block information when running -g0 or -g1, don't-- refer to blocks in that case. Fixes #14894.goodParent_=True-- | Generate DWARF info for a blockblockToDwarf::DynFlags->DebugBlock ->DwarfInfo blockToDwarf df blk =DwarfBlock {dwChildren=concatMap(tickToDwarf df )(dblTicksblk )++map(blockToDwarf df )(dblBlocksblk ),dwLabel=dblCLabelblk ,dwMarker=marker }wheremarker |Just_<-dblPositionblk =Just$mkAsmTempLabel $dblLabelblk |otherwise=Nothing-- block was optimized outtickToDwarf::DynFlags->Tickish()->[DwarfInfo ]tickToDwarf _(SourceNotess _)=[DwarfSrcNote ss ]tickToDwarf__=[]-- | Generates the data for the debug frame section, which encodes the-- desired stack unwind behaviour for the debuggerdebugFrame::Unique->[DebugBlock ]->DwarfFrame debugFrame u procs =DwarfFrame {dwCieLabel=mkAsmTempLabel u ,dwCieInit=initUws ,dwCieProcs=map(procToFrame initUws )procs }whereinitUws::UnwindTable initUws =Map.fromList[(Sp ,Just(UwReg Sp 0))]-- | Generates unwind information for a procedure debug blockprocToFrame::UnwindTable ->DebugBlock ->DwarfFrameProc procToFrame initUws blk =DwarfFrameProc {dwFdeProc=dblCLabelblk ,dwFdeHasInfo=dblHasInfoTblblk ,dwFdeBlocks=map(uncurryblockToFrame )(setHasInfo blockUws )}whereblockUws::[(DebugBlock ,[UnwindPoint ])]blockUws =mapsnd$sortBy(comparingfst)$flatten blk flatten::DebugBlock ->[(Int,(DebugBlock ,[UnwindPoint ]))]flatten b @DebugBlock {dblPosition=pos ,dblUnwind=uws ,dblBlocks=blocks }|Justp <-pos =(p ,(b ,uws' )):nested |otherwise=nested -- block was optimized outwhereuws' =addDefaultUnwindings initUws uws nested =concatMapflatten 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 Dwarf.Types.setHasInfo::[(DebugBlock ,[UnwindPoint ])]->[(DebugBlock ,[UnwindPoint ])]setHasInfo []=[]setHasInfo(c0 :cs )=firstsetIt c0 :cs wheresetIt child =child {dblHasInfoTbl=dblHasInfoTblchild ||dblHasInfoTblblk }blockToFrame::DebugBlock ->[UnwindPoint ]->DwarfFrameBlock blockToFrame blk uws =DwarfFrameBlock {dwFdeBlkHasInfo=dblHasInfoTblblk ,dwFdeUnwind=uws }addDefaultUnwindings::UnwindTable ->[UnwindPoint ]->[UnwindPoint ]addDefaultUnwindings tbl pts =[UnwindPoint lbl (tbl' `mappend`tbl )-- mappend is left-biased|UnwindPoint lbl tbl' <-pts ]