Dwarf: Ensure tick parentage is preserved

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

2 files changed, 45 insertions, 8 deletions

diff --git a/compiler/cmm/Debug.hs b/compiler/cmm/Debug.hs
index 83db2a1057..fa4d6458a0 100644
--- a/compiler/cmm/Debug.hs
+++ b/compiler/cmm/Debug.hs
@@ -48,6 +48,8 @@ data DebugBlock =
   , dblLabel      :: !Label        -- ^ Hoopl label
   , dblCLabel     :: !CLabel       -- ^ Output label
   , dblHasInfoTbl :: !Bool         -- ^ Has an info table?
+  , dblParent     :: !(Maybe DebugBlock)
+    -- ^ The parent of this proc. See Note [Splitting DebugBlocks]
   , dblTicks      :: ![CmmTickish] -- ^ Ticks defined in this block
   , dblSourceTick
             :: !(Maybe CmmTickish) -- ^ Best source tick covering block
@@ -158,6 +160,7 @@ cmmDebugGen modLoc decls = map (blocksForScope Nothing) topScopes
                                    | g_entry graph == label -> entryLbl
                                    | otherwise              -> blockLbl label
                              , dblHasInfoTbl   = isJust info
+                             , dblParent       = Nothing
                              , dblTicks        = ticks
                              , dblPosition     = Nothing -- see cmmDebugLink
                              , dblUnwind       = unwind
diff --git a/compiler/nativeGen/Dwarf.hs b/compiler/nativeGen/Dwarf.hs
index 3903dd9580..b19f534bbd 100644
--- a/compiler/nativeGen/Dwarf.hs
+++ b/compiler/nativeGen/Dwarf.hs
@@ -122,18 +122,52 @@ compileUnitFooter unitU =
   in ppr cuEndLabel <> colon
 
 -- | Splits the blocks by procedures. In the result all nested blocks
--- will come from the same procedure as the top-level block.
+-- 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 b
+debugSplitProcs b = concat $ H.mapElems $ mergeMaps $ map (split Nothing) b
   where mergeMaps = foldr (H.mapUnionWithKey (const (++))) H.mapEmpty
-        split :: DebugBlock -> H.LabelMap [DebugBlock]
-        split blk = H.mapInsert prc [blk {dblBlocks = own_blks}] nested
+        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 $ dblBlocks blk
-        -- Note that we are rebuilding the tree here, so tick scopes
-        -- might change. We could fix that - but we actually only care
-        -- about dblSourceTick in the result, so this is okay.
+                nested = mergeMaps $ map (split parent') $ dblBlocks blk
+                -- 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 <- dblPosition blk = parent
+                  | otherwise                  = Just blk
+
+{-
+Note [Splitting DebugBlocks]
+
+DWARF requires that we break up the 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 block
 procToDwarf :: DynFlags -> DebugBlock -> DwarfInfo