Generate DWARF info section

This is where we actually make GHC emit DWARF code. The info section
contains all the general meta information bits as well as an entry for
every block of native code.

Notes:

* We need quite a few new labels in order to properly address starts
  and ends of blocks.

* Thanks to Nathan Howell for taking the iniative to get our own Haskell
  language ID for DWARF!

(From Phabricator D396)

7 files changed, 519 insertions, 40 deletions

diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs
index 37b8ada75b..603f2130e0 100644
--- a/compiler/cmm/CLabel.hs
+++ b/compiler/cmm/CLabel.hs
@@ -44,6 +44,8 @@ module CLabel (
         mkStringLitLabel,
 
         mkAsmTempLabel,
+        mkAsmTempDerivedLabel,
+        mkAsmTempEndLabel,
 
         mkPlainModuleInitLabel,
 
@@ -99,7 +101,7 @@ module CLabel (
         mkHpcTicksLabel,
 
         hasCAF,
-        needsCDecl, isAsmTemp, maybeAsmTemp, externallyVisibleCLabel,
+        needsCDecl, maybeAsmTemp, externallyVisibleCLabel,
         isMathFun,
         isCFunctionLabel, isGcPtrLabel, labelDynamic,
 
@@ -123,6 +125,7 @@ import FastString
 import DynFlags
 import Platform
 import UniqSet
+import PprCore ( {- instances -} )
 
 -- -----------------------------------------------------------------------------
 -- The CLabel type
@@ -190,6 +193,10 @@ data CLabel
   | AsmTempLabel
         {-# UNPACK #-} !Unique
 
+  | AsmTempDerivedLabel
+        CLabel
+        FastString              -- suffix
+
   | StringLitLabel
         {-# UNPACK #-} !Unique
 
@@ -547,6 +554,11 @@ mkStringLitLabel                = StringLitLabel
 mkAsmTempLabel :: Uniquable a => a -> CLabel
 mkAsmTempLabel a                = AsmTempLabel (getUnique a)
 
+mkAsmTempDerivedLabel :: CLabel -> FastString -> CLabel
+mkAsmTempDerivedLabel = AsmTempDerivedLabel
+
+mkAsmTempEndLabel :: CLabel -> CLabel
+mkAsmTempEndLabel l = mkAsmTempDerivedLabel l (fsLit "_end")
 mkPlainModuleInitLabel :: Module -> CLabel
 mkPlainModuleInitLabel mod      = PlainModuleInitLabel mod
 
@@ -634,6 +646,7 @@ needsCDecl (PlainModuleInitLabel _)     = True
 
 needsCDecl (StringLitLabel _)           = False
 needsCDecl (AsmTempLabel _)             = False
+needsCDecl (AsmTempDerivedLabel _ _)    = False
 needsCDecl (RtsLabel _)                 = False
 
 needsCDecl (CmmLabel pkgId _ _)
@@ -652,12 +665,6 @@ needsCDecl (DynamicLinkerLabel {})      = panic "needsCDecl DynamicLinkerLabel"
 needsCDecl PicBaseLabel                 = panic "needsCDecl PicBaseLabel"
 needsCDecl (DeadStripPreventer {})      = panic "needsCDecl DeadStripPreventer"
 
--- | Check whether a label is a local temporary for native code generation
-isAsmTemp  :: CLabel -> Bool
-isAsmTemp (AsmTempLabel _)              = True
-isAsmTemp _                             = False
-
-
 -- | If a label is a local temporary used for native code generation
 --      then return just its unique, otherwise nothing.
 maybeAsmTemp :: CLabel -> Maybe Unique
@@ -763,6 +770,7 @@ externallyVisibleCLabel :: CLabel -> Bool -- not C "static"
 externallyVisibleCLabel (CaseLabel _ _)         = False
 externallyVisibleCLabel (StringLitLabel _)      = False
 externallyVisibleCLabel (AsmTempLabel _)        = False
+externallyVisibleCLabel (AsmTempDerivedLabel _ _)= False
 externallyVisibleCLabel (PlainModuleInitLabel _)= True
 externallyVisibleCLabel (RtsLabel _)            = True
 externallyVisibleCLabel (CmmLabel _ _ _)        = True
@@ -982,6 +990,13 @@ pprCLabel platform (AsmTempLabel u)
      else
         char '_' <> pprUnique u
 
+pprCLabel platform (AsmTempDerivedLabel l suf)
+ | cGhcWithNativeCodeGen == "YES"
+   = ptext (asmTempLabelPrefix platform)
+     <> case l of AsmTempLabel u -> pprUnique u
+                  _other         -> pprCLabel platform l
+     <> ftext suf
+
 pprCLabel platform (DynamicLinkerLabel info lbl)
  | cGhcWithNativeCodeGen == "YES"
    = pprDynamicLinkerAsmLabel platform info lbl
@@ -1107,6 +1122,7 @@ pprCLbl (HpcTicksLabel mod)
   = ptext (sLit "_hpc_tickboxes_")  <> ppr mod <> ptext (sLit "_hpc")
 
 pprCLbl (AsmTempLabel {})       = panic "pprCLbl AsmTempLabel"
+pprCLbl (AsmTempDerivedLabel {})= panic "pprCLbl AsmTempDerivedLabel"
 pprCLbl (DynamicLinkerLabel {}) = panic "pprCLbl DynamicLinkerLabel"
 pprCLbl (PicBaseLabel {})       = panic "pprCLbl PicBaseLabel"
 pprCLbl (DeadStripPreventer {}) = panic "pprCLbl DeadStripPreventer"
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index a6a49e547e..a6624ff25f 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -558,6 +558,9 @@ Library
             RegAlloc.Linear.X86_64.FreeRegs
             RegAlloc.Linear.PPC.FreeRegs
             RegAlloc.Linear.SPARC.FreeRegs
+            Dwarf
+            Dwarf.Types
+            Dwarf.Constants
 
     if flag(ghci)
         Exposed-Modules:
diff --git a/compiler/nativeGen/AsmCodeGen.hs b/compiler/nativeGen/AsmCodeGen.hs
index daaeaa217c..4080398e1f 100644
--- a/compiler/nativeGen/AsmCodeGen.hs
+++ b/compiler/nativeGen/AsmCodeGen.hs
@@ -47,6 +47,7 @@ import Instruction
 import PIC
 import Reg
 import NCGMonad
+import Dwarf
 import Debug
 
 import BlockId
@@ -286,41 +287,46 @@ nativeCodeGen' dflags this_mod modLoc ncgImpl h us cmms
         let ngs0 = NGS [] [] [] [] [] [] emptyUFM
         (ngs, us') <- cmmNativeGenStream dflags this_mod modLoc ncgImpl bufh us
                                          cmms ngs0
-        finishNativeGen dflags bufh ngs
-
-        return us'
+        finishNativeGen dflags modLoc bufh us' ngs
 
 finishNativeGen :: Instruction instr
                 => DynFlags
+                -> ModLocation
                 -> BufHandle
+                -> UniqSupply
                 -> NativeGenAcc statics instr
-                -> IO ()
-finishNativeGen dflags bufh@(BufHandle _ _ h) ngs
+                -> IO UniqSupply
+finishNativeGen dflags modLoc bufh@(BufHandle _ _ h) us ngs
  = do
+        -- Write debug data and finish
+        let emitDw = gopt Opt_Debug dflags && not (gopt Opt_SplitObjs dflags)
+        us' <- if not emitDw then return us else do
+          (dwarf, us') <- dwarfGen dflags modLoc us (ngs_debug ngs)
+          emitNativeCode dflags bufh dwarf
+          return us'
         bFlush bufh
 
-        let platform = targetPlatform dflags
-
         -- dump global NCG stats for graph coloring allocator
         let stats = concat (ngs_colorStats ngs)
         when (not (null stats)) $ do
 
-                -- build the global register conflict graph
-                let graphGlobal
-                        = foldl Color.union Color.initGraph
-                        $ [ Color.raGraph stat
-                                | stat@Color.RegAllocStatsStart{} <- stats]
+          -- build the global register conflict graph
+          let graphGlobal
+                  = foldl Color.union Color.initGraph
+                  $ [ Color.raGraph stat
+                          | stat@Color.RegAllocStatsStart{} <- stats]
 
-                dump_stats (Color.pprStats stats graphGlobal)
+          dump_stats (Color.pprStats stats graphGlobal)
 
-                dumpIfSet_dyn dflags
-                        Opt_D_dump_asm_conflicts "Register conflict graph"
-                        $ Color.dotGraph
-                                (targetRegDotColor platform)
-                                (Color.trivColorable platform
-                                        (targetVirtualRegSqueeze platform)
-                                        (targetRealRegSqueeze platform))
-                        $ graphGlobal
+          let platform = targetPlatform dflags
+          dumpIfSet_dyn dflags
+                  Opt_D_dump_asm_conflicts "Register conflict graph"
+                  $ Color.dotGraph
+                          (targetRegDotColor platform)
+                          (Color.trivColorable platform
+                                  (targetVirtualRegSqueeze platform)
+                                  (targetRealRegSqueeze platform))
+                  $ graphGlobal
 
 
         -- dump global NCG stats for linear allocator
@@ -332,6 +338,7 @@ finishNativeGen dflags bufh@(BufHandle _ _ h) ngs
         Pretty.printDoc Pretty.LeftMode (pprCols dflags) h
                 $ withPprStyleDoc dflags (mkCodeStyle AsmStyle)
                 $ makeImportsDoc dflags (concat (ngs_imports ngs))
+        return us'
   where
     dump_stats = dumpSDoc dflags alwaysQualify Opt_D_dump_asm_stats "NCG stats"
 
@@ -377,15 +384,21 @@ cmmNativeGenStream dflags this_mod modLoc ncgImpl h us cmm_stream ngs
           dumpIfSet_dyn dflags Opt_D_dump_debug "Debug Infos"
             (vcat $ map ppr ldbgs)
 
-          -- Clear DWARF info when generating split object files
-          let ngs'' | debugFlag && splitFlag
-                    = ngs' { ngs_debug = []
-                           , ngs_dwarfFiles = emptyUFM
-                           , ngs_labels = [] }
-                    | otherwise
-                    = ngs' { ngs_debug  = ngs_debug ngs' ++ ldbgs
-                           , ngs_labels = [] }
-          cmmNativeGenStream dflags this_mod modLoc ncgImpl h us'
+          -- Emit & clear DWARF information when generating split
+          -- object files, as we need it to land in the same object file
+          (ngs'', us'') <-
+            if debugFlag && splitFlag
+            then do (dwarf, us'') <- dwarfGen dflags modLoc us ldbgs
+                    emitNativeCode dflags h dwarf
+                    return (ngs' { ngs_debug = []
+                                 , ngs_dwarfFiles = emptyUFM
+                                 , ngs_labels = [] },
+                            us'')
+            else return (ngs' { ngs_debug  = ngs_debug ngs' ++ ldbgs
+                              , ngs_labels = [] },
+                         us')
+
+          cmmNativeGenStream dflags this_mod modLoc ncgImpl h us''
               cmm_stream' ngs''
 
 -- | Do native code generation on all these cmms.
diff --git a/compiler/nativeGen/Dwarf.hs b/compiler/nativeGen/Dwarf.hs
new file mode 100644
index 0000000000..9420424080
--- /dev/null
+++ b/compiler/nativeGen/Dwarf.hs
@@ -0,0 +1,120 @@
+module Dwarf (
+  dwarfGen
+  ) where
+
+import CLabel
+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 System.FilePath
+import System.Directory ( getCurrentDirectory )
+
+import qualified Compiler.Hoopl as H
+
+-- | Generate DWARF/debug information
+dwarfGen :: DynFlags -> ModLocation -> UniqSupply -> [DebugBlock]
+            -> IO (SDoc, UniqSupply)
+dwarfGen df modLoc us blocks = do
+
+  -- Convert debug data structures to DWARF info records
+  let procs = debugSplitProcs blocks
+  compPath <- getCurrentDirectory
+  let dwarfUnit = DwarfCompileUnit
+        { dwChildren = map (procToDwarf df) procs
+        , dwName = fromMaybe "" (ml_hs_file modLoc)
+        , dwCompDir = addTrailingPathSeparator compPath
+        , dwProducer = cProjectName ++ " " ++ cProjectVersion
+        , 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).
+  let haveSrcIn blk = isJust (dblSourceTick blk) && isJust (dblPosition blk)
+                      || any haveSrcIn (dblBlocks blk)
+      haveSrc = any haveSrcIn procs
+
+  -- .debug_abbrev section: Declare the format we're using
+  let abbrevSct = pprAbbrevDecls haveSrc
+
+  -- .debug_info section: Information records on procedures and blocks
+  let (unitU, us') = takeUniqFromSupply us
+      infoSct = vcat [ dwarfInfoSection
+                     , compileUnitHeader unitU
+                     , pprDwarfInfo haveSrc dwarfUnit
+                     , compileUnitFooter unitU
+                     ]
+
+  -- .debug_line section: Generated mainly by the assembler, but we
+  -- need to label it
+  let lineSct = dwarfLineSection $$
+                ptext dwarfLineLabel <> colon
+
+  return (infoSct $$ abbrevSct $$ lineSct, us')
+
+-- | Header for a compilation unit, establishing global format
+-- parameters
+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  -- compilation unit size
+          , ppr cuLabel <> colon
+          , ptext (sLit "\t.word 3")           -- DWARF version
+          , pprDwWord (ptext dwarfAbbrevLabel <> char '-' <>
+                       ptext dwarfAbbrevLabel) -- pointer to our abbrevs
+          , ptext (sLit "\t.byte ") <> ppr (platformWordSize plat) -- word size
+          ]
+
+-- | Compilation unit footer, mainly establishing size of debug sections
+compileUnitFooter :: Unique -> SDoc
+compileUnitFooter unitU =
+  let cuEndLabel = mkAsmTempEndLabel $ mkAsmTempLabel 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.
+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
+        -- 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.
+
+-- | Generate DWARF info for a procedure debug block
+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
+                    }
+
+-- | 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)
+                        }
diff --git a/compiler/nativeGen/Dwarf/Constants.hs b/compiler/nativeGen/Dwarf/Constants.hs
new file mode 100644
index 0000000000..b6a688d657
--- /dev/null
+++ b/compiler/nativeGen/Dwarf/Constants.hs
@@ -0,0 +1,132 @@
+-- | Constants describing the DWARF format. Most of this simply
+-- mirrors /usr/include/dwarf.h.
+
+module Dwarf.Constants where
+
+import FastString
+import Platform
+import Outputable
+
+import Data.Word
+
+-- | Language ID used for Haskell.
+dW_LANG_Haskell :: Word
+dW_LANG_Haskell = 0x18
+  -- Thanks to Nathan Howell for getting us our very own language ID!
+
+-- | Dwarf tags
+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_array_type      = 1
+dW_TAG_lexical_block   = 11
+dW_TAG_pointer_type    = 15
+dW_TAG_compile_unit    = 17
+dW_TAG_structure_type  = 19
+dW_TAG_typedef         = 22
+dW_TAG_subroutine_type = 32
+dW_TAG_subrange_type   = 33
+dW_TAG_base_type       = 36
+dW_TAG_file_type       = 41
+dW_TAG_subprogram      = 46
+dW_TAG_variable        = 52
+dW_TAG_auto_variable   = 256
+dW_TAG_arg_variable    = 257
+
+-- | 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,
+  dW_AT_MIPS_linkage_name :: Word
+dW_AT_name              = 0x03
+dW_AT_stmt_list         = 0x10
+dW_AT_low_pc            = 0x11
+dW_AT_high_pc           = 0x12
+dW_AT_language          = 0x13
+dW_AT_comp_dir          = 0x1b
+dW_AT_producer          = 0x25
+dW_AT_external          = 0x3f
+dW_AT_frame_base        = 0x40
+dW_AT_MIPS_linkage_name = 0x2007
+
+-- | Abbrev declaration
+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 :: Word
+dW_FORM_addr   = 0x01
+dW_FORM_data4  = 0x06
+dW_FORM_string = 0x08
+dW_FORM_flag   = 0x0c
+dW_FORM_block1 = 0x0a
+dW_FORM_ref4   = 0x13
+
+-- | Dwarf native types
+dW_ATE_address, dW_ATE_boolean, dW_ATE_float, dW_ATE_signed,
+  dW_ATE_signed_char, dW_ATE_unsigned, dW_ATE_unsigned_char :: Word
+dW_ATE_address       = 1
+dW_ATE_boolean       = 2
+dW_ATE_float         = 4
+dW_ATE_signed        = 5
+dW_ATE_signed_char   = 6
+dW_ATE_unsigned      = 7
+dW_ATE_unsigned_char = 8
+
+-- | Call frame information
+dW_CFA_set_loc, dW_CFA_undefined, dW_CFA_same_value,
+  dW_CFA_def_cfa, dW_CFA_def_cfa_offset, dW_CFA_def_cfa_expression,
+  dW_CFA_expression, dW_CFA_offset_extended_sf, dW_CFA_def_cfa_offset_sf,
+  dW_CFA_def_cfa_sf, dW_CFA_val_offset, dW_CFA_val_expression,
+  dW_CFA_offset :: Word8
+dW_CFA_set_loc            = 0x01
+dW_CFA_undefined          = 0x07
+dW_CFA_same_value         = 0x08
+dW_CFA_def_cfa            = 0x0c
+dW_CFA_def_cfa_offset     = 0x0e
+dW_CFA_def_cfa_expression = 0x0f
+dW_CFA_expression         = 0x10
+dW_CFA_offset_extended_sf = 0x11
+dW_CFA_def_cfa_sf         = 0x12
+dW_CFA_def_cfa_offset_sf  = 0x13
+dW_CFA_val_offset         = 0x14
+dW_CFA_val_expression     = 0x16
+dW_CFA_offset             = 0x80
+
+-- | Operations
+dW_OP_deref, dW_OP_consts,
+  dW_OP_minus, dW_OP_mul, dW_OP_plus,
+  dW_OP_lit0, dW_OP_breg0, dW_OP_call_frame_cfa :: Word8
+dW_OP_deref          = 0x06
+dW_OP_consts         = 0x11
+dW_OP_minus          = 0x1c
+dW_OP_mul            = 0x1e
+dW_OP_plus           = 0x22
+dW_OP_lit0           = 0x30
+dW_OP_breg0          = 0x70
+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"
+
+dwarfSection :: String -> SDoc
+dwarfSection name = sdocWithPlatform $ \plat ->
+  case platformOS plat of
+    OSDarwin -> ftext $ mkFastString $
+                  ".section __DWARF,__debug_" ++ name ++ ",regular,debug"
+    _other   -> ftext $ mkFastString $
+                  ".section .debug_" ++ name ++ ",\"\",@progbits"
+
+-- | Dwarf section labels
+dwarfInfoLabel, dwarfAbbrevLabel, dwarfLineLabel :: LitString
+dwarfInfoLabel   = sLit ".Lsection_info"
+dwarfAbbrevLabel = sLit ".Lsection_abbrev"
+dwarfLineLabel   = sLit ".Lsection_line"
diff --git a/compiler/nativeGen/Dwarf/Types.hs b/compiler/nativeGen/Dwarf/Types.hs
new file mode 100644
index 0000000000..1d564f30c0
--- /dev/null
+++ b/compiler/nativeGen/Dwarf/Types.hs
@@ -0,0 +1,186 @@
+module Dwarf.Types
+  ( DwarfInfo(..)
+  , pprDwarfInfo
+  , pprAbbrevDecls
+  , pprByte
+  , pprWord
+  , pprDwWord
+  , pprLEBWord
+  , pprLEBInt
+  )
+  where
+
+import CLabel
+import FastString
+import Outputable
+import Platform
+
+import Dwarf.Constants
+
+import Data.Bits
+import Data.Word
+import Data.Char
+
+-- | Individual dwarf records. Each one will be encoded as an entry in
+-- the .debug_info section.
+data DwarfInfo
+  = DwarfCompileUnit { dwChildren :: [DwarfInfo]
+                     , dwName :: String
+                     , dwProducer :: String
+                     , dwCompDir :: String
+                     , dwLineLabel :: LitString }
+  | DwarfSubprogram { dwChildren :: [DwarfInfo]
+                    , dwName :: String
+                    , dwLabel :: CLabel }
+  | DwarfBlock { dwChildren :: [DwarfInfo]
+               , dwLabel :: CLabel
+               , dwMarker :: CLabel }
+
+-- | Abbreviation codes used for encoding above records in the
+-- .debug_info section.
+data DwarfAbbrev
+  = DwAbbrNull          -- ^ Pseudo, used for marking the end of lists
+  | DwAbbrCompileUnit
+  | DwAbbrSubprogram
+  | DwAbbrBlock
+  deriving (Eq, Enum)
+
+-- | Generate assembly for the given abbreviation code
+pprAbbrev :: DwarfAbbrev -> SDoc
+pprAbbrev = pprLEBWord . fromIntegral . fromEnum
+
+-- | Abbreviation declaration. This explains the binary encoding we
+-- use for representing @DwarfInfo@.
+pprAbbrevDecls :: Bool -> SDoc
+pprAbbrevDecls haveDebugLine =
+  let mkAbbrev abbr tag chld flds =
+        let fld (tag, form) = pprLEBWord tag $$ pprLEBWord form
+        in pprAbbrev abbr $$ pprLEBWord tag $$ pprByte chld $$
+           vcat (map fld flds) $$ pprByte 0 $$ pprByte 0
+  in dwarfAbbrevSection $$
+     ptext dwarfAbbrevLabel <> colon $$
+     mkAbbrev DwAbbrCompileUnit dW_TAG_compile_unit dW_CHILDREN_yes
+       ([ (dW_AT_name, dW_FORM_string)
+       , (dW_AT_producer, dW_FORM_string)
+       , (dW_AT_language, dW_FORM_data4)
+       , (dW_AT_comp_dir, dW_FORM_string)
+       ] ++
+       (if haveDebugLine
+        then [ (dW_AT_stmt_list, dW_FORM_data4) ]
+        else [])) $$
+     mkAbbrev DwAbbrSubprogram dW_TAG_subprogram 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)
+       ] $$
+     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)
+       ]
+-- | Generate assembly for DWARF data
+pprDwarfInfo :: Bool -> DwarfInfo -> SDoc
+pprDwarfInfo haveSrc d
+  = pprDwarfInfoOpen haveSrc d $$
+    vcat (map (pprDwarfInfo haveSrc) (dwChildren d)) $$
+    pprDwarfInfoClose
+
+-- | Prints assembler data corresponding to DWARF info records. Note
+-- that the binary format of this is paramterized in @abbrevDecls@ and
+-- has to be kept in synch.
+pprDwarfInfoOpen :: Bool -> DwarfInfo -> SDoc
+pprDwarfInfoOpen haveSrc (DwarfCompileUnit _ name producer compDir lineLbl) =
+  pprAbbrev DwAbbrCompileUnit
+  $$ pprString name
+  $$ pprString producer
+  $$ pprData4 dW_LANG_Haskell
+  $$ pprString compDir
+  $$ if haveSrc
+     then pprData4' (ptext lineLbl <> char '-' <> ptext dwarfLineLabel)
+     else empty
+pprDwarfInfoOpen _ (DwarfSubprogram _ name label) = sdocWithDynFlags $ \df ->
+  pprAbbrev DwAbbrSubprogram
+  $$ pprString name
+  $$ pprString (renderWithStyle df (ppr label) (mkCodeStyle CStyle))
+  $$ pprFlag (externallyVisibleCLabel label)
+  $$ pprWord (ppr label)
+  $$ pprWord (ppr $ mkAsmTempEndLabel label)
+pprDwarfInfoOpen _ (DwarfBlock _ label marker) = sdocWithDynFlags $ \df ->
+  pprAbbrev DwAbbrBlock
+  $$ pprString (renderWithStyle df (ppr label) (mkCodeStyle CStyle))
+  $$ pprWord (ppr marker)
+  $$ pprWord (ppr $ mkAsmTempEndLabel marker)
+
+-- | Close a DWARF info record with children
+pprDwarfInfoClose :: SDoc
+pprDwarfInfoClose = pprAbbrev DwAbbrNull
+
+-- | Assembly for a single byte of constant DWARF data
+pprByte :: Word8 -> SDoc
+pprByte x = ptext (sLit "\t.byte ") <> ppr (fromIntegral x :: Word)
+
+-- | Assembly for a constant DWARF flag
+pprFlag :: Bool -> SDoc
+pprFlag f = pprByte (if f then 0xff else 0x00)
+
+-- | Assembly for 4 bytes of dynamic DWARF data
+pprData4' :: SDoc -> SDoc
+pprData4' x = ptext (sLit "\t.long ") <> x
+
+-- | Assembly for 4 bytes of constant DWARF data
+pprData4 :: Word -> SDoc
+pprData4 = pprData4' . ppr
+
+-- | Assembly for a DWARF word of dynamic data. This means 32 bit, as
+-- we are generating 32 bit DWARF.
+pprDwWord :: SDoc -> SDoc
+pprDwWord = pprData4'
+
+-- | Assembly for a machine word of dynamic data. Depends on the
+-- architecture we are currently generating code for.
+pprWord :: SDoc -> SDoc
+pprWord s = (<> s) . sdocWithPlatform $ \plat ->
+  case platformWordSize plat of
+    4 -> ptext (sLit "\t.long ")
+    8 -> ptext (sLit "\t.quad ")
+    n -> panic $ "pprWord: Unsupported target platform word length " ++
+                 show n ++ "!"
+
+-- | Prints a number in "little endian base 128" format. The idea is
+-- to optimize for small numbers by stopping once all further bytes
+-- would be 0. The highest bit in every byte signals whether there
+-- are further bytes to read.
+pprLEBWord :: Word -> SDoc
+pprLEBWord x | x < 128   = pprByte (fromIntegral x)
+             | otherwise = pprByte (fromIntegral $ 128 .|. (x .&. 127)) $$
+                           pprLEBWord (x `shiftR` 7)
+
+-- | Same as @pprLEBWord@, but for a signed number
+pprLEBInt :: Int -> SDoc
+pprLEBInt x | x >= -64 && x < 64
+                        = pprByte (fromIntegral (x .&. 127))
+            | otherwise = pprByte (fromIntegral $ 128 .|. (x .&. 127)) $$
+                          pprLEBInt (x `shiftR` 7)
+
+-- | Generates a dynamic null-terminated string. If required the
+-- caller needs to make sure that the string is escaped properly.
+pprString' :: SDoc -> SDoc
+pprString' str = ptext (sLit "\t.asciz \"") <> str <> char '"'
+
+-- | Generate a string constant. We take care to escape the string.
+pprString :: String -> SDoc
+pprString = pprString' . hcat . map escape
+  where escape '\\' = ptext (sLit "\\\\")
+        escape '\"' = ptext (sLit "\\\"")
+        escape '\n' = ptext (sLit "\\n")
+        escape c    | isAscii c && isPrint c && c /= '?'
+                      -- escaping '?' prevents trigraph warnings
+                    = char c
+                    | otherwise
+                    = let ch = ord c
+                      in char '\\' <>
+                         char (intToDigit (ch `div` 64)) <>
+                         char (intToDigit ((ch `div` 8) `mod` 8)) <>
+                         char (intToDigit (ch `mod` 8))
diff --git a/compiler/nativeGen/X86/Ppr.hs b/compiler/nativeGen/X86/Ppr.hs
index 5b4eccd845..982f79a561 100644
--- a/compiler/nativeGen/X86/Ppr.hs
+++ b/compiler/nativeGen/X86/Ppr.hs
@@ -56,6 +56,7 @@ pprNatCmmDecl (CmmData section dats) =
   pprSectionHeader section $$ pprDatas dats
 
 pprNatCmmDecl proc@(CmmProc top_info lbl _ (ListGraph blocks)) =
+  sdocWithDynFlags $ \dflags ->
   case topInfoTable proc of
     Nothing ->
        case blocks of
@@ -65,6 +66,8 @@ pprNatCmmDecl proc@(CmmProc top_info lbl _ (ListGraph blocks)) =
            pprSectionHeader Text $$
            pprLabel lbl $$ -- blocks guaranteed not null, so label needed
            vcat (map (pprBasicBlock top_info) blocks) $$
+           (if gopt Opt_Debug dflags
+            then ppr (mkAsmTempEndLabel lbl) <> char ':' else empty) $$
            pprSizeDecl lbl
 
     Just (Statics info_lbl _) ->
@@ -84,6 +87,8 @@ pprNatCmmDecl proc@(CmmProc top_info lbl _ (ListGraph blocks)) =
                   <+> char '-'
                   <+> ppr (mkDeadStripPreventer info_lbl)
              else empty) $$
+      (if gopt Opt_Debug dflags
+       then ppr (mkAsmTempEndLabel info_lbl) <> char ':' else empty) $$
       pprSizeDecl info_lbl
 
 -- | Output the ELF .size directive.
@@ -97,10 +102,14 @@ pprSizeDecl lbl
 
 pprBasicBlock :: BlockEnv CmmStatics -> NatBasicBlock Instr -> SDoc
 pprBasicBlock info_env (BasicBlock blockid instrs)
-  = maybe_infotable $$
-    pprLabel (mkAsmTempLabel (getUnique blockid)) $$
-    vcat (map pprInstr instrs)
+  = sdocWithDynFlags $ \dflags ->
+    maybe_infotable $$
+    pprLabel asmLbl $$
+    vcat (map pprInstr instrs) $$
+    (if gopt Opt_Debug dflags
+     then ppr (mkAsmTempEndLabel asmLbl) <> char ':' else empty)
   where
+    asmLbl = mkAsmTempLabel (getUnique blockid)
     maybe_infotable = case mapLookup blockid info_env of
        Nothing   -> empty
        Just (Statics info_lbl info) ->