Dwarf: Produce .dwarf_aranges section

Test Plan: Check with `readelf --debug-dump=ranges`

Reviewers: scpmw, austin

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D1174

3 files changed, 77 insertions, 21 deletions

diff --git a/compiler/nativeGen/Dwarf.hs b/compiler/nativeGen/Dwarf.hs
index 273949ecfd..35ee9c90ab 100644
--- a/compiler/nativeGen/Dwarf.hs
+++ b/compiler/nativeGen/Dwarf.hs
@@ -39,13 +39,15 @@ dwarfGen df modLoc us blocks = do
   let procs = debugSplitProcs blocks
       stripBlocks dbg = dbg { dblBlocks = [] }
   compPath <- getCurrentDirectory
-  let dwarfUnit = DwarfCompileUnit
+  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 = dblCLabel $ head procs
-        , dwHighLabel = mkAsmTempEndLabel $ dblCLabel $ last procs
+        , dwLowLabel = lowLabel
+        , dwHighLabel = highLabel
         , dwLineLabel = dwarfLineLabel
         }
 
@@ -62,7 +64,8 @@ dwarfGen df modLoc us blocks = do
   -- .debug_info section: Information records on procedures and blocks
   let -- unique to identify start and end compilation unit .debug_inf
       (unitU, us') = takeUniqFromSupply us
-      infoSct = vcat [ dwarfInfoSection
+      infoSct = vcat [ ptext dwarfInfoLabel <> colon
+                     , dwarfInfoSection
                      , compileUnitHeader unitU
                      , pprDwarfInfo haveSrc dwarfUnit
                      , compileUnitFooter unitU
@@ -79,18 +82,23 @@ dwarfGen df modLoc us blocks = do
                  ptext dwarfFrameLabel <> colon $$
                  pprDwarfFrame (debugFrame framesU procs)
 
-  return (infoSct $$ abbrevSct $$ lineSct $$ frameSct, us'')
+  -- .aranges section: Information about the bounds of compilation units
+  let aranges = dwarfARangesSection $$
+                pprDwarfARange (DwarfARange lowLabel highLabel unitU)
+
+  return (infoSct $$ abbrevSct $$ lineSct $$ frameSct $$ aranges, us'')
 
 -- | Header for a compilation unit, establishing global format
 -- parameters
 compileUnitHeader :: Unique -> SDoc
 compileUnitHeader unitU = sdocWithPlatform $ \plat ->
-  let cuLabel = mkAsmTempLabel unitU
+  let cuLabel = mkAsmTempLabel unitU  -- sits right before initialLength field
       length = ppr (mkAsmTempEndLabel cuLabel) <> char '-' <> ppr cuLabel
-  in vcat [ ptext (sLit "\t.long ") <> length  -- compilation unit size
-          , ppr cuLabel <> colon
-          , ptext (sLit "\t.word 3")           -- DWARF version
-          , sectionOffset dwarfAbbrevLabel dwarfAbbrevLabel
+               <> ptext (sLit "-4")       -- length of initialLength field
+  in vcat [ ppr cuLabel <> colon
+          , ptext (sLit "\t.long ") <> length  -- compilation unit size
+          , pprHalf 3                          -- DWARF version
+          , sectionOffset (ptext dwarfAbbrevLabel) (ptext dwarfAbbrevLabel)
                                                -- abbrevs offset
           , ptext (sLit "\t.byte ") <> ppr (platformWordSize plat) -- word size
           ]
diff --git a/compiler/nativeGen/Dwarf/Constants.hs b/compiler/nativeGen/Dwarf/Constants.hs
index 333d670914..9fe1297a5f 100644
--- a/compiler/nativeGen/Dwarf/Constants.hs
+++ b/compiler/nativeGen/Dwarf/Constants.hs
@@ -115,12 +115,13 @@ dW_OP_call_frame_cfa = 0x9c
 
 -- | Dwarf section declarations
 dwarfInfoSection, dwarfAbbrevSection, dwarfLineSection,
-  dwarfFrameSection, dwarfGhcSection :: SDoc
-dwarfInfoSection   = dwarfSection "info"
-dwarfAbbrevSection = dwarfSection "abbrev"
-dwarfLineSection   = dwarfSection "line"
-dwarfFrameSection  = dwarfSection "frame"
-dwarfGhcSection    = dwarfSection "ghc"
+  dwarfFrameSection, dwarfGhcSection, dwarfARangesSection :: SDoc
+dwarfInfoSection    = dwarfSection "info"
+dwarfAbbrevSection  = dwarfSection "abbrev"
+dwarfLineSection    = dwarfSection "line"
+dwarfFrameSection   = dwarfSection "frame"
+dwarfGhcSection     = dwarfSection "ghc"
+dwarfARangesSection = dwarfSection "aranges"
 
 dwarfSection :: String -> SDoc
 dwarfSection name = sdocWithPlatform $ \plat -> ftext $ mkFastString $
diff --git a/compiler/nativeGen/Dwarf/Types.hs b/compiler/nativeGen/Dwarf/Types.hs
index 9a600bd610..17fbf3bb95 100644
--- a/compiler/nativeGen/Dwarf/Types.hs
+++ b/compiler/nativeGen/Dwarf/Types.hs
@@ -3,11 +3,15 @@ module Dwarf.Types
     DwarfInfo(..)
   , pprDwarfInfo
   , pprAbbrevDecls
+    -- * Dwarf address range table
+  , DwarfARange(..)
+  , pprDwarfARange
     -- * Dwarf frame
   , DwarfFrame(..), DwarfFrameProc(..), DwarfFrameBlock(..)
   , pprDwarfFrame
     -- * Utilities
   , pprByte
+  , pprHalf
   , pprData4'
   , pprDwWord
   , pprWord
@@ -25,6 +29,7 @@ import Encoding
 import FastString
 import Outputable
 import Platform
+import Unique
 import Reg
 
 import Dwarf.Constants
@@ -126,7 +131,7 @@ pprDwarfInfoOpen haveSrc (DwarfCompileUnit _ name producer compDir lowLabel
   $$ pprWord (ppr lowLabel)
   $$ pprWord (ppr highLabel)
   $$ if haveSrc
-     then sectionOffset lineLbl dwarfLineLabel
+     then sectionOffset (ptext lineLbl) (ptext dwarfLineLabel)
      else empty
 pprDwarfInfoOpen _ (DwarfSubprogram _ name label) = sdocWithDynFlags $ \df ->
   pprAbbrev DwAbbrSubprogram
@@ -147,6 +152,44 @@ pprDwarfInfoOpen _ (DwarfBlock _ label marker) = sdocWithDynFlags $ \df ->
 pprDwarfInfoClose :: SDoc
 pprDwarfInfoClose = pprAbbrev DwAbbrNull
 
+-- | A DWARF address range. This is used by the debugger to quickly locate
+-- which compilation unit a given address belongs to. This type assumes
+-- a non-segmented address-space.
+data DwarfARange
+  = DwarfARange
+    { dwArngStartLabel :: CLabel
+    , dwArngEndLabel   :: CLabel
+    , dwArngUnitUnique :: Unique
+      -- ^ from which the corresponding label in @.debug_info@ is derived
+    }
+
+-- | Print assembler directives corresponding to a DWARF @.debug_aranges@
+-- address table entry.
+pprDwarfARange :: DwarfARange -> SDoc
+pprDwarfARange arng = sdocWithPlatform $ \plat ->
+  let wordSize = platformWordSize plat
+      paddingSize = 4 :: Int
+      -- header is 12 bytes long.
+      -- entry is 8 bytes (32-bit platform) or 16 bytes (64-bit platform).
+      -- pad such that first entry begins at multiple of entry size.
+      pad n = vcat $ replicate n $ pprByte 0
+      initialLength = 8 + paddingSize + 2*2*wordSize
+      length = ppr (dwArngEndLabel arng)
+               <> char '-' <> ppr (dwArngStartLabel arng)
+  in pprDwWord (ppr initialLength)
+     $$ pprHalf 2
+     $$ sectionOffset (ppr $ mkAsmTempLabel $ dwArngUnitUnique arng)
+                      (ptext dwarfInfoLabel)
+     $$ pprByte (fromIntegral wordSize)
+     $$ pprByte 0
+     $$ pad paddingSize
+     -- beginning of body
+     $$ pprWord (ppr $ dwArngStartLabel arng)
+     $$ pprWord length
+     -- terminus
+     $$ pprWord (char '0')
+     $$ pprWord (char '0')
+
 -- | Information about unwind instructions for a procedure. This
 -- corresponds to a "Common Information Entry" (CIE) in DWARF.
 data DwarfFrame
@@ -366,6 +409,10 @@ wordAlign = sdocWithPlatform $ \plat ->
 pprByte :: Word8 -> SDoc
 pprByte x = ptext (sLit "\t.byte ") <> ppr (fromIntegral x :: Word)
 
+-- | Assembly for a two-byte constant integer
+pprHalf :: Word16 -> SDoc
+pprHalf x = ptext (sLit "\t.hword ") <> ppr (fromIntegral x :: Word)
+
 -- | Assembly for a constant DWARF flag
 pprFlag :: Bool -> SDoc
 pprFlag f = pprByte (if f then 0xff else 0x00)
@@ -442,9 +489,9 @@ escapeChar c
 -- us to just reference the target directly, and will figure out on
 -- their own that we actually need an offset. Finally, Windows has
 -- a special directive to refer to relative offsets. Fun.
-sectionOffset :: LitString -> LitString -> SDoc
+sectionOffset :: SDoc -> SDoc -> SDoc
 sectionOffset target section = sdocWithPlatform $ \plat ->
   case platformOS plat of
-    OSDarwin  -> pprDwWord (ptext target <> char '-' <> ptext section)
-    OSMinGW32 -> text "\t.secrel32 " <> ptext target
-    _other    -> pprDwWord (ptext target)
+    OSDarwin  -> pprDwWord (target <> char '-' <> section)
+    OSMinGW32 -> text "\t.secrel32 " <> target
+    _other    -> pprDwWord target