Output source notes in extended DWARF DIEs

In order to accomplish this we need to ensure that emit DIEs for all
DebugBlocks, even those that have been optimized out, lest we end up
with undefined symbols of parents at link time.

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

3 files changed, 119 insertions, 29 deletions

diff --git a/compiler/nativeGen/Dwarf.hs b/compiler/nativeGen/Dwarf.hs
index b19f534bbd..54422ec299 100644
--- a/compiler/nativeGen/Dwarf.hs
+++ b/compiler/nativeGen/Dwarf.hs
@@ -18,6 +18,7 @@ import UniqSupply
 import Dwarf.Constants
 import Dwarf.Types
 
+import Control.Monad    ( mfilter )
 import Data.Maybe
 import Data.List        ( sortBy )
 import Data.Ord         ( comparing )
@@ -172,23 +173,33 @@ parent, B.
 -- | Generate DWARF info for a procedure debug block
 procToDwarf :: DynFlags -> DebugBlock -> DwarfInfo
 procToDwarf df prc
-  = DwarfSubprogram { dwChildren = foldr blockToDwarf [] $ dblBlocks 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 (/= dblCLabel prc)
+                                   $ fmap dblCLabel (dblParent prc)
+                      -- Omit parent if it would be self-referential
                     }
 
 -- | Generate DWARF info for a block
-blockToDwarf :: DebugBlock -> [DwarfInfo] -> [DwarfInfo]
-blockToDwarf blk dws
-  | isJust (dblPosition blk) = dw : dws
-  | otherwise                = nested ++ dws -- block was optimized out, flatten
-  where nested = foldr blockToDwarf [] $ dblBlocks blk
-        dw = DwarfBlock { dwChildren = nested
-                        , dwLabel    = dblCLabel blk
-                        , dwMarker   = mkAsmTempLabel (dblLabel blk)
-                        }
+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   -- block was optimized out
+
+tickToDwarf :: DynFlags -> Tickish () -> [DwarfInfo]
+tickToDwarf _  (SourceNote ss _) = [DwarfSrcNote ss]
+tickToDwarf _ _ = []
 
 -- | Generates the data for the debug frame section, which encodes the
 -- desired stack unwind behaviour for the debugger
diff --git a/compiler/nativeGen/Dwarf/Constants.hs b/compiler/nativeGen/Dwarf/Constants.hs
index a46d113393..40e4e7d9a8 100644
--- a/compiler/nativeGen/Dwarf/Constants.hs
+++ b/compiler/nativeGen/Dwarf/Constants.hs
@@ -22,7 +22,8 @@ dW_TAG_compile_unit, dW_TAG_subroutine_type,
   dW_TAG_file_type, dW_TAG_subprogram, dW_TAG_lexical_block,
   dW_TAG_base_type, dW_TAG_structure_type, dW_TAG_pointer_type,
   dW_TAG_array_type, dW_TAG_subrange_type, dW_TAG_typedef,
-  dW_TAG_variable, dW_TAG_arg_variable, dW_TAG_auto_variable :: Word
+  dW_TAG_variable, dW_TAG_arg_variable, dW_TAG_auto_variable,
+  dW_TAG_ghc_src_note :: Word
 dW_TAG_array_type      = 1
 dW_TAG_lexical_block   = 11
 dW_TAG_pointer_type    = 15
@@ -38,6 +39,8 @@ dW_TAG_variable        = 52
 dW_TAG_auto_variable   = 256
 dW_TAG_arg_variable    = 257
 
+dW_TAG_ghc_src_note    = 0x5b00
+
 -- * Dwarf attributes
 dW_AT_name, dW_AT_stmt_list, dW_AT_low_pc, dW_AT_high_pc, dW_AT_language,
   dW_AT_comp_dir, dW_AT_producer, dW_AT_external, dW_AT_frame_base,
@@ -54,19 +57,41 @@ dW_AT_frame_base        = 0x40
 dW_AT_use_UTF8          = 0x53
 dW_AT_MIPS_linkage_name = 0x2007
 
--- * Abbrev declaration
+-- * Custom DWARF attributes
+-- Chosen a more or less random section of the vendor-extensible region
+
+-- ** Describing C-- blocks
+-- These appear in DW_TAG_lexical_scope DIEs corresponding to C-- blocks
+dW_AT_ghc_tick_parent :: Word
+dW_AT_ghc_tick_parent     = 0x2b20
+
+-- ** Describing source notes
+-- These appear in DW_TAG_ghc_src_note DIEs
+dW_AT_ghc_span_file, dW_AT_ghc_span_start_line,
+  dW_AT_ghc_span_start_col, dW_AT_ghc_span_end_line,
+  dW_AT_ghc_span_end_col :: Word
+dW_AT_ghc_span_file       = 0x2b00
+dW_AT_ghc_span_start_line = 0x2b01
+dW_AT_ghc_span_start_col  = 0x2b02
+dW_AT_ghc_span_end_line   = 0x2b03
+dW_AT_ghc_span_end_col    = 0x2b04
+
+
+-- * Abbrev declarations
 dW_CHILDREN_no, dW_CHILDREN_yes :: Word8
 dW_CHILDREN_no  = 0
 dW_CHILDREN_yes = 1
 
-dW_FORM_addr, dW_FORM_data4, dW_FORM_string, dW_FORM_flag,
-  dW_FORM_block1, dW_FORM_ref4, dW_FORM_flag_present :: Word
+dW_FORM_addr, dW_FORM_data2, dW_FORM_data4, dW_FORM_string, dW_FORM_flag,
+  dW_FORM_block1, dW_FORM_ref4, dW_FORM_ref_addr, dW_FORM_flag_present :: Word
 dW_FORM_addr   = 0x01
+dW_FORM_data2  = 0x05
 dW_FORM_data4  = 0x06
 dW_FORM_string = 0x08
 dW_FORM_flag   = 0x0c
 dW_FORM_block1 = 0x0a
-dW_FORM_ref4   = 0x13
+dW_FORM_ref_addr     = 0x10
+dW_FORM_ref4         = 0x13
 dW_FORM_flag_present = 0x19
 
 -- * Dwarf native types
diff --git a/compiler/nativeGen/Dwarf/Types.hs b/compiler/nativeGen/Dwarf/Types.hs
index 8647253c26..91a5e4189c 100644
--- a/compiler/nativeGen/Dwarf/Types.hs
+++ b/compiler/nativeGen/Dwarf/Types.hs
@@ -31,6 +31,7 @@ import Outputable
 import Platform
 import Unique
 import Reg
+import SrcLoc
 
 import Dwarf.Constants
 
@@ -54,10 +55,16 @@ data DwarfInfo
                      , dwLineLabel :: LitString }
   | DwarfSubprogram { dwChildren :: [DwarfInfo]
                     , dwName :: String
-                    , dwLabel :: CLabel }
+                    , dwLabel :: CLabel
+                    , dwParent :: Maybe CLabel
+                      -- ^ label of DIE belonging to the parent tick
+                    }
   | DwarfBlock { dwChildren :: [DwarfInfo]
                , dwLabel :: CLabel
-               , dwMarker :: CLabel }
+               , dwMarker :: Maybe CLabel
+               }
+  | DwarfSrcNote { dwSrcSpan :: RealSrcSpan
+                 }
 
 -- | Abbreviation codes used for encoding above records in the
 -- @.debug_info@ section.
@@ -65,7 +72,10 @@ data DwarfAbbrev
   = DwAbbrNull          -- ^ Pseudo, used for marking the end of lists
   | DwAbbrCompileUnit
   | DwAbbrSubprogram
+  | DwAbbrSubprogramWithParent
+  | DwAbbrBlockWithoutCode
   | DwAbbrBlock
+  | DwAbbrGhcSrcNote
   deriving (Eq, Enum)
 
 -- | Generate assembly for the given abbreviation code
@@ -81,6 +91,16 @@ pprAbbrevDecls haveDebugLine =
         let fld (tag, form) = pprLEBWord tag $$ pprLEBWord form
         in pprAbbrev abbr $$ pprLEBWord tag $$ pprByte chld $$
            vcat (map fld flds) $$ pprByte 0 $$ pprByte 0
+      -- These are shared between DwAbbrSubprogram and
+      -- DwAbbrSubprogramWithParent
+      subprogramAttrs =
+           [ (dW_AT_name, dW_FORM_string)
+           , (dW_AT_MIPS_linkage_name, dW_FORM_string)
+           , (dW_AT_external, dW_FORM_flag)
+           , (dW_AT_low_pc, dW_FORM_addr)
+           , (dW_AT_high_pc, dW_FORM_addr)
+           , (dW_AT_frame_base, dW_FORM_block1)
+           ]
   in dwarfAbbrevSection $$
      ptext dwarfAbbrevLabel <> colon $$
      mkAbbrev DwAbbrCompileUnit dW_TAG_compile_unit dW_CHILDREN_yes
@@ -96,26 +116,40 @@ pprAbbrevDecls haveDebugLine =
         then [ (dW_AT_stmt_list, dW_FORM_data4) ]
         else [])) $$
      mkAbbrev DwAbbrSubprogram dW_TAG_subprogram dW_CHILDREN_yes
+       subprogramAttrs $$
+     mkAbbrev DwAbbrSubprogramWithParent dW_TAG_subprogram dW_CHILDREN_yes
+       (subprogramAttrs ++ [(dW_AT_ghc_tick_parent, dW_FORM_ref_addr)]) $$
+     mkAbbrev DwAbbrBlockWithoutCode dW_TAG_lexical_block dW_CHILDREN_yes
        [ (dW_AT_name, dW_FORM_string)
-       , (dW_AT_MIPS_linkage_name, dW_FORM_string)
-       , (dW_AT_external, dW_FORM_flag)
-       , (dW_AT_low_pc, dW_FORM_addr)
-       , (dW_AT_high_pc, dW_FORM_addr)
-       , (dW_AT_frame_base, dW_FORM_block1)
        ] $$
      mkAbbrev DwAbbrBlock dW_TAG_lexical_block dW_CHILDREN_yes
        [ (dW_AT_name, dW_FORM_string)
        , (dW_AT_low_pc, dW_FORM_addr)
        , (dW_AT_high_pc, dW_FORM_addr)
        ] $$
+     mkAbbrev DwAbbrGhcSrcNote dW_TAG_ghc_src_note dW_CHILDREN_no
+       [ (dW_AT_ghc_span_file, dW_FORM_string)
+       , (dW_AT_ghc_span_start_line, dW_FORM_data4)
+       , (dW_AT_ghc_span_start_col, dW_FORM_data2)
+       , (dW_AT_ghc_span_end_line, dW_FORM_data4)
+       , (dW_AT_ghc_span_end_col, dW_FORM_data2)
+       ] $$
      pprByte 0
 
 -- | Generate assembly for DWARF data
 pprDwarfInfo :: Bool -> DwarfInfo -> SDoc
 pprDwarfInfo haveSrc d
-  = pprDwarfInfoOpen haveSrc d $$
-    vcat (map (pprDwarfInfo haveSrc) (dwChildren d)) $$
-    pprDwarfInfoClose
+  = case d of
+      DwarfCompileUnit {}  -> hasChildren
+      DwarfSubprogram {}   -> hasChildren
+      DwarfBlock {}        -> hasChildren
+      DwarfSrcNote {}      -> noChildren
+  where
+    hasChildren =
+        pprDwarfInfoOpen haveSrc d $$
+        vcat (map (pprDwarfInfo haveSrc) (dwChildren d)) $$
+        pprDwarfInfoClose
+    noChildren = pprDwarfInfoOpen haveSrc d
 
 -- | Prints assembler data corresponding to DWARF info records. Note
 -- that the binary format of this is paramterized in @abbrevDecls@ and
@@ -133,8 +167,10 @@ pprDwarfInfoOpen haveSrc (DwarfCompileUnit _ name producer compDir lowLabel
   $$ if haveSrc
      then sectionOffset (ptext lineLbl) (ptext dwarfLineLabel)
      else empty
-pprDwarfInfoOpen _ (DwarfSubprogram _ name label) = sdocWithDynFlags $ \df ->
-  pprAbbrev DwAbbrSubprogram
+pprDwarfInfoOpen _ (DwarfSubprogram _ name label
+                                    parent) = sdocWithDynFlags $ \df ->
+  ppr (mkAsmTempDieLabel label) <> colon
+  $$ pprAbbrev abbrev
   $$ pprString name
   $$ pprString (renderWithStyle df (ppr label) (mkCodeStyle CStyle))
   $$ pprFlag (externallyVisibleCLabel label)
@@ -142,11 +178,29 @@ pprDwarfInfoOpen _ (DwarfSubprogram _ name label) = sdocWithDynFlags $ \df ->
   $$ pprWord (ppr $ mkAsmTempEndLabel label)
   $$ pprByte 1
   $$ pprByte dW_OP_call_frame_cfa
-pprDwarfInfoOpen _ (DwarfBlock _ label marker) = sdocWithDynFlags $ \df ->
-  pprAbbrev DwAbbrBlock
+  $$ parentValue
+  where
+    abbrev = case parent of Nothing -> DwAbbrSubprogram
+                            Just _  -> DwAbbrSubprogramWithParent
+    parentValue = maybe empty pprParentDie parent
+    pprParentDie sym = sectionOffset (ppr sym) (ptext dwarfInfoLabel)
+pprDwarfInfoOpen _ (DwarfBlock _ label Nothing) = sdocWithDynFlags $ \df ->
+  ppr (mkAsmTempDieLabel label) <> colon
+  $$ pprAbbrev DwAbbrBlockWithoutCode
+  $$ pprString (renderWithStyle df (ppr label) (mkCodeStyle CStyle))
+pprDwarfInfoOpen _ (DwarfBlock _ label (Just marker)) = sdocWithDynFlags $ \df ->
+  ppr (mkAsmTempDieLabel label) <> colon
+  $$ pprAbbrev DwAbbrBlock
   $$ pprString (renderWithStyle df (ppr label) (mkCodeStyle CStyle))
   $$ pprWord (ppr marker)
   $$ pprWord (ppr $ mkAsmTempEndLabel marker)
+pprDwarfInfoOpen _ (DwarfSrcNote ss) =
+  pprAbbrev DwAbbrGhcSrcNote
+  $$ pprString' (ftext $ srcSpanFile ss)
+  $$ pprData4 (fromIntegral $ srcSpanStartLine ss)
+  $$ pprHalf (fromIntegral $ srcSpanStartCol ss)
+  $$ pprData4 (fromIntegral $ srcSpanEndLine ss)
+  $$ pprHalf (fromIntegral $ srcSpanEndCol ss)
 
 -- | Close a DWARF info record with children
 pprDwarfInfoClose :: SDoc