Generate .loc/.file directives from source ticks

This generates DWARF, albeit indirectly using the assembler. This is
the easiest (and, apparently, quite standard) method of generating the
.debug_line DWARF section.

Notes:

* Note we have to make sure that .file directives appear correctly
  before the respective .loc. Right now we ppr them manually, which makes
  them absent from dumps. Fixing this would require .file to become a
  native instruction.

* We have to pass a lot of things around the native code generator. I
  know Ian did quite a bit of refactoring already, but having one common
  monad could *really* simplify things here...

* To support SplitObjcs, we need to emit/reset all DWARF data at every
  split. We use the occassion to move split marker generation to
  cmmNativeGenStream as well, so debug data extraction doesn't have to
  choke on it.

(From Phabricator D396)

6 files changed, 137 insertions, 57 deletions

diff --git a/compiler/nativeGen/AsmCodeGen.hs b/compiler/nativeGen/AsmCodeGen.hs
index 55d1247952..daaeaa217c 100644
--- a/compiler/nativeGen/AsmCodeGen.hs
+++ b/compiler/nativeGen/AsmCodeGen.hs
@@ -266,6 +266,7 @@ data NativeGenAcc statics instr
         , ngs_linearStats :: ![[Linear.RegAllocStats]]
         , ngs_labels      :: ![Label]
         , ngs_debug       :: ![DebugBlock]
+        , ngs_dwarfFiles  :: !DwarfFiles
         }
 
 nativeCodeGen' :: (Outputable statics, Outputable instr, Instruction instr)
@@ -278,25 +279,17 @@ nativeCodeGen' :: (Outputable statics, Outputable instr, Instruction instr)
                -> IO UniqSupply
 nativeCodeGen' dflags this_mod modLoc ncgImpl h us cmms
  = do
-        let split_cmms  = Stream.map add_split cmms
         -- BufHandle is a performance hack.  We could hide it inside
         -- Pretty if it weren't for the fact that we do lots of little
         -- printDocs here (in order to do codegen in constant space).
         bufh <- newBufHandle h
+        let ngs0 = NGS [] [] [] [] [] [] emptyUFM
         (ngs, us') <- cmmNativeGenStream dflags this_mod modLoc ncgImpl bufh us
-                                         split_cmms (NGS [] [] [] [] [] [])
+                                         cmms ngs0
         finishNativeGen dflags bufh ngs
 
         return us'
 
- where  add_split tops
-                | gopt Opt_SplitObjs dflags = split_marker : tops
-                | otherwise                 = tops
-
-        split_marker = CmmProc mapEmpty mkSplitMarkerLabel []
-                               (ofBlockList (panic "split_marker_entry") [])
-
-
 finishNativeGen :: Instruction instr
                 => DynFlags
                 -> BufHandle
@@ -355,56 +348,78 @@ cmmNativeGenStream :: (Outputable statics, Outputable instr, Instruction instr)
 cmmNativeGenStream dflags this_mod modLoc ncgImpl h us cmm_stream ngs
  = do r <- Stream.runStream cmm_stream
       case r of
-          Left () ->
-              return (ngs { ngs_imports = reverse $ ngs_imports ngs
-                          , ngs_natives = reverse $ ngs_natives ngs
-                          , ngs_colorStats = reverse $ ngs_colorStats ngs
-                          , ngs_linearStats = reverse $ ngs_linearStats ngs
-                          },
-                      us)
-          Right (cmms, cmm_stream') -> do
-
-              -- Generate debug information
-              let debugFlag = gopt Opt_Debug dflags
-                  !ndbgs | debugFlag = cmmDebugGen modLoc cmms
-                         | otherwise = []
-
-              -- Generate native code
-              (ngs',us') <- cmmNativeGens dflags this_mod ncgImpl h us cmms ngs 0
-
-              -- Link native code information into debug blocks
-              let !ldbgs = cmmDebugLink (ngs_labels ngs') ndbgs
-              dumpIfSet_dyn dflags Opt_D_dump_debug "Debug Infos"
-                (vcat $ map ppr ldbgs)
-
-              -- Strip references to native code unless we want to dump it later
-              let ngs'' = ngs' { ngs_debug  = ngs_debug ngs' ++ ldbgs
-                               , ngs_labels = [] }
-              cmmNativeGenStream dflags this_mod modLoc ncgImpl h us'
-                  cmm_stream' ngs''
+        Left () ->
+          return (ngs { ngs_imports = reverse $ ngs_imports ngs
+                      , ngs_natives = reverse $ ngs_natives ngs
+                      , ngs_colorStats = reverse $ ngs_colorStats ngs
+                      , ngs_linearStats = reverse $ ngs_linearStats ngs
+                      },
+                  us)
+        Right (cmms, cmm_stream') -> do
+
+          -- Generate debug information
+          let debugFlag = gopt Opt_Debug dflags
+              !ndbgs | debugFlag = cmmDebugGen modLoc cmms
+                     | otherwise = []
+              dbgMap = debugToMap ndbgs
+
+          -- Insert split marker, generate native code
+          let splitFlag = gopt Opt_SplitObjs dflags
+              split_marker = CmmProc mapEmpty mkSplitMarkerLabel [] $
+                             ofBlockList (panic "split_marker_entry") []
+              cmms' | splitFlag  = split_marker : cmms
+                    | otherwise  = cmms
+          (ngs',us') <- cmmNativeGens dflags this_mod modLoc ncgImpl h dbgMap us
+                                      cmms' ngs 0
+
+          -- Link native code information into debug blocks
+          let !ldbgs = cmmDebugLink (ngs_labels ngs') ndbgs
+          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'
+              cmm_stream' ngs''
 
 -- | Do native code generation on all these cmms.
 --
 cmmNativeGens :: (Outputable statics, Outputable instr, Instruction instr)
               => DynFlags
-              -> Module
+              -> Module -> ModLocation
               -> NcgImpl statics instr jumpDest
               -> BufHandle
+              -> LabelMap DebugBlock
               -> UniqSupply
               -> [RawCmmDecl]
               -> NativeGenAcc statics instr
               -> Int
               -> IO (NativeGenAcc statics instr, UniqSupply)
 
-cmmNativeGens _ _ _ _ us [] ngs !_
+cmmNativeGens _ _ _ _ _ _ us [] ngs !_
         = return (ngs, us)
 
-cmmNativeGens dflags this_mod ncgImpl h us (cmm : cmms) ngs count
+cmmNativeGens dflags this_mod modLoc ncgImpl h dbgMap us
+              (cmm : cmms) ngs count
  = do
-        (us', native, imports, colorStats, linearStats)
-                <- {-# SCC "cmmNativeGen" #-} cmmNativeGen dflags this_mod ncgImpl us cmm count
+        let fileIds = ngs_dwarfFiles ngs
+        (us', fileIds', native, imports, colorStats, linearStats)
+          <- {-# SCC "cmmNativeGen" #-}
+             cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap
+                          cmm count
+
+        let newFileIds = fileIds' `minusUFM` fileIds
+            pprDecl (f,n) = ptext (sLit "\t.file ") <> ppr n <+>
+                            doubleQuotes (ftext f)
 
         emitNativeCode dflags h $ vcat $
+          map pprDecl (eltsUFM newFileIds) ++
           map (pprNatCmmDecl ncgImpl) native
 
         -- force evaluation all this stuff to avoid space leaks
@@ -420,8 +435,10 @@ cmmNativeGens dflags this_mod ncgImpl h us (cmm : cmms) ngs count
                       , ngs_colorStats  = colorStats `mCon` ngs_colorStats ngs
                       , ngs_linearStats = linearStats `mCon` ngs_linearStats ngs
                       , ngs_labels      = ngs_labels ngs ++ labels'
+                      , ngs_dwarfFiles  = fileIds'
                       }
-        cmmNativeGens dflags this_mod ncgImpl h us' cmms ngs' (count + 1)
+        cmmNativeGens dflags this_mod modLoc ncgImpl h dbgMap us'
+                      cmms ngs' (count + 1)
 
  where  seqString []            = ()
         seqString (x:xs)        = x `seq` seqString xs
@@ -444,18 +461,21 @@ emitNativeCode dflags h sdoc = do
 cmmNativeGen
         :: (Outputable statics, Outputable instr, Instruction instr)
     => DynFlags
-    -> Module
+    -> Module -> ModLocation
     -> NcgImpl statics instr jumpDest
         -> UniqSupply
+        -> DwarfFiles
+        -> LabelMap DebugBlock
         -> RawCmmDecl                                   -- ^ the cmm to generate code for
         -> Int                                          -- ^ sequence number of this top thing
         -> IO   ( UniqSupply
+                , DwarfFiles
                 , [NatCmmDecl statics instr]                -- native code
                 , [CLabel]                                  -- things imported by this cmm
                 , Maybe [Color.RegAllocStats statics instr] -- stats for the coloring register allocator
                 , Maybe [Linear.RegAllocStats])             -- stats for the linear register allocators
 
-cmmNativeGen dflags this_mod ncgImpl us cmm count
+cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count
  = do
         let platform = targetPlatform dflags
 
@@ -474,9 +494,11 @@ cmmNativeGen dflags this_mod ncgImpl us cmm count
                 (pprCmmGroup [opt_cmm])
 
         -- generate native code from cmm
-        let ((native, lastMinuteImports), usGen) =
+        let ((native, lastMinuteImports, fileIds'), usGen) =
                 {-# SCC "genMachCode" #-}
-                initUs us $ genMachCode dflags this_mod (cmmTopCodeGen ncgImpl) opt_cmm
+                initUs us $ genMachCode dflags this_mod modLoc
+                                        (cmmTopCodeGen ncgImpl)
+                                        fileIds dbgMap opt_cmm
 
         dumpIfSet_dyn dflags
                 Opt_D_dump_asm_native "Native code"
@@ -607,6 +629,7 @@ cmmNativeGen dflags this_mod ncgImpl us cmm count
                 (vcat $ map (pprNatCmmDecl ncgImpl) expanded)
 
         return  ( usAlloc
+                , fileIds'
                 , expanded
                 , lastMinuteImports ++ imports
                 , ppr_raStatsColor
@@ -862,21 +885,25 @@ apply_mapping ncgImpl ufm (CmmProc info lbl live (ListGraph blocks))
 
 genMachCode
         :: DynFlags
-        -> Module
+        -> Module -> ModLocation
         -> (RawCmmDecl -> NatM [NatCmmDecl statics instr])
+        -> DwarfFiles
+        -> LabelMap DebugBlock
         -> RawCmmDecl
         -> UniqSM
                 ( [NatCmmDecl statics instr]
-                , [CLabel])
+                , [CLabel]
+                , DwarfFiles)
 
-genMachCode dflags this_mod cmmTopCodeGen cmm_top
+genMachCode dflags this_mod modLoc cmmTopCodeGen fileIds dbgMap cmm_top
   = do  { initial_us <- getUniqueSupplyM
         ; let initial_st           = mkNatM_State initial_us 0 dflags this_mod
+                                                  modLoc fileIds dbgMap
               (new_tops, final_st) = initNat initial_st (cmmTopCodeGen cmm_top)
               final_delta          = natm_delta final_st
               final_imports        = natm_imports final_st
         ; if   final_delta == 0
-          then return (new_tops, final_imports)
+          then return (new_tops, final_imports, natm_fileid final_st)
           else pprPanic "genMachCode: nonzero final delta" (int final_delta)
     }
 
diff --git a/compiler/nativeGen/NCGMonad.hs b/compiler/nativeGen/NCGMonad.hs
index f47a1ab434..e312d274db 100644
--- a/compiler/nativeGen/NCGMonad.hs
+++ b/compiler/nativeGen/NCGMonad.hs
@@ -25,7 +25,12 @@ module NCGMonad (
         getNewRegPairNat,
         getPicBaseMaybeNat,
         getPicBaseNat,
-        getDynFlags
+        getDynFlags,
+        getModLoc,
+        getFileId,
+        getDebugBlock,
+
+        DwarfFiles
 )
 
 where
@@ -38,6 +43,9 @@ import TargetReg
 
 import BlockId
 import CLabel           ( CLabel, mkAsmTempLabel )
+import Debug
+import FastString       ( FastString )
+import UniqFM
 import UniqSupply
 import Unique           ( Unique )
 import DynFlags
@@ -48,6 +56,8 @@ import Control.Monad    ( liftM, ap )
 import Control.Applicative ( Applicative(..) )
 #endif
 
+import Compiler.Hoopl   ( LabelMap, Label )
+
 data NatM_State
         = NatM_State {
                 natm_us          :: UniqSupply,
@@ -55,15 +65,21 @@ data NatM_State
                 natm_imports     :: [(CLabel)],
                 natm_pic         :: Maybe Reg,
                 natm_dflags      :: DynFlags,
-                natm_this_module :: Module
+                natm_this_module :: Module,
+                natm_modloc      :: ModLocation,
+                natm_fileid      :: DwarfFiles,
+                natm_debug_map   :: LabelMap DebugBlock
         }
 
+type DwarfFiles = UniqFM (FastString, Int)
+
 newtype NatM result = NatM (NatM_State -> (result, NatM_State))
 
 unNat :: NatM a -> NatM_State -> (a, NatM_State)
 unNat (NatM a) = a
 
-mkNatM_State :: UniqSupply -> Int -> DynFlags -> Module -> NatM_State
+mkNatM_State :: UniqSupply -> Int -> DynFlags -> Module -> ModLocation ->
+                DwarfFiles -> LabelMap DebugBlock -> NatM_State
 mkNatM_State us delta dflags this_mod
         = NatM_State us delta [] Nothing dflags this_mod
 
@@ -174,3 +190,18 @@ getPicBaseNat rep
                  -> do
                         reg <- getNewRegNat rep
                         NatM (\state -> (reg, state { natm_pic = Just reg }))
+
+getModLoc :: NatM ModLocation
+getModLoc
+        = NatM $ \ st -> (natm_modloc st, st)
+
+getFileId :: FastString -> NatM Int
+getFileId f = NatM $ \st ->
+  case lookupUFM (natm_fileid st) f of
+    Just (_,n) -> (n, st)
+    Nothing    -> let n = 1 + sizeUFM (natm_fileid st)
+                      fids = addToUFM (natm_fileid st) f (f,n)
+                  in n `seq` fids `seq` (n, st { natm_fileid = fids  })
+
+getDebugBlock :: Label -> NatM (Maybe DebugBlock)
+getDebugBlock l = NatM $ \st -> (mapLookup l (natm_debug_map st), st)
diff --git a/compiler/nativeGen/RegAlloc/Linear/Main.hs b/compiler/nativeGen/RegAlloc/Linear/Main.hs
index 12dc8f0f31..d602d60d10 100644
--- a/compiler/nativeGen/RegAlloc/Linear/Main.hs
+++ b/compiler/nativeGen/RegAlloc/Linear/Main.hs
@@ -401,9 +401,9 @@ raInsn _     new_instrs _ (LiveInstr ii Nothing)
         = do    setDeltaR n
                 return (new_instrs, [])
 
-raInsn _     new_instrs _ (LiveInstr ii Nothing)
+raInsn _     new_instrs _ (LiveInstr ii@(Instr i) Nothing)
         | isMetaInstr ii
-        = return (new_instrs, [])
+        = return (i : new_instrs, [])
 
 
 raInsn block_live new_instrs id (LiveInstr (Instr instr) (Just live))
diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs
index 86d4b17abe..531213dc7f 100644
--- a/compiler/nativeGen/X86/CodeGen.hs
+++ b/compiler/nativeGen/X86/CodeGen.hs
@@ -31,6 +31,7 @@ import X86.Regs
 import X86.RegInfo
 import CodeGen.Platform
 import CPrim
+import Debug            ( DebugBlock(..) )
 import Instruction
 import PIC
 import NCGMonad
@@ -47,6 +48,8 @@ import CmmUtils
 import Cmm
 import Hoopl
 import CLabel
+import CoreSyn          ( Tickish(..) )
+import SrcLoc           ( srcSpanFile, srcSpanStartLine, srcSpanStartCol )
 
 -- The rest:
 import ForeignCall      ( CCallConv(..) )
@@ -114,9 +117,17 @@ basicBlockCodeGen block = do
   let (_, nodes, tail)  = blockSplit block
       id = entryLabel block
       stmts = blockToList nodes
+  -- Generate location directive
+  dbg <- getDebugBlock (entryLabel block)
+  loc_instrs <- case dblSourceTick =<< dbg of
+    Just (SourceNote span name)
+      -> do fileId <- getFileId (srcSpanFile span)
+            let line = srcSpanStartLine span; col = srcSpanStartCol span
+            return $ unitOL $ LOCATION fileId line col name
+    _ -> return nilOL
   mid_instrs <- stmtsToInstrs stmts
   tail_instrs <- stmtToInstrs tail
-  let instrs = mid_instrs `appOL` tail_instrs
+  let instrs = loc_instrs `appOL` mid_instrs `appOL` tail_instrs
   -- code generation may introduce new basic block boundaries, which
   -- are indicated by the NEWBLOCK instruction.  We must split up the
   -- instruction stream into basic blocks again.  Also, we extract
diff --git a/compiler/nativeGen/X86/Instr.hs b/compiler/nativeGen/X86/Instr.hs
index 0d85376868..8677badb02 100644
--- a/compiler/nativeGen/X86/Instr.hs
+++ b/compiler/nativeGen/X86/Instr.hs
@@ -165,6 +165,9 @@ data Instr
         -- comment pseudo-op
         = COMMENT FastString
 
+        -- location pseudo-op (file, line, col, name)
+        | LOCATION Int Int Int String
+
         -- some static data spat out during code
         -- generation.  Will be extracted before
         -- pretty-printing.
@@ -444,6 +447,7 @@ x86_regUsageOfInstr platform instr
     FETCHPC  reg        -> mkRU [] [reg]
 
     COMMENT _           -> noUsage
+    LOCATION{}          -> noUsage
     DELTA   _           -> noUsage
 
     POPCNT _ src dst -> mkRU (use_R src []) [dst]
@@ -616,6 +620,7 @@ x86_patchRegsOfInstr instr env
 
     NOP                 -> instr
     COMMENT _           -> instr
+    LOCATION {}         -> instr
     DELTA _             -> instr
 
     JXX _ _             -> instr
@@ -776,6 +781,7 @@ x86_isMetaInstr
 x86_isMetaInstr instr
  = case instr of
         COMMENT{}       -> True
+        LOCATION{}      -> True
         LDATA{}         -> True
         NEWBLOCK{}      -> True
         DELTA{}         -> True
diff --git a/compiler/nativeGen/X86/Ppr.hs b/compiler/nativeGen/X86/Ppr.hs
index ddd75c83f6..5b4eccd845 100644
--- a/compiler/nativeGen/X86/Ppr.hs
+++ b/compiler/nativeGen/X86/Ppr.hs
@@ -490,6 +490,11 @@ pprInstr (COMMENT _) = empty -- nuke 'em
 {-
 pprInstr (COMMENT s) = ptext (sLit "# ") <> ftext s
 -}
+
+pprInstr (LOCATION file line col name)
+   = ptext (sLit "\t.loc ") <> ppr file <+> ppr line <+> ppr col <>
+     ptext (sLit " /* ") <> text name <> ptext (sLit " */")
+
 pprInstr (DELTA d)
    = pprInstr (COMMENT (mkFastString ("\tdelta = " ++ show d)))