Commit 64678e9e authored by Peter Wortmann's avatar Peter Wortmann Committed by Austin Seipp
Browse files

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)
parent ea788f0f
...@@ -266,6 +266,7 @@ data NativeGenAcc statics instr ...@@ -266,6 +266,7 @@ data NativeGenAcc statics instr
, ngs_linearStats :: ![[Linear.RegAllocStats]] , ngs_linearStats :: ![[Linear.RegAllocStats]]
, ngs_labels :: ![Label] , ngs_labels :: ![Label]
, ngs_debug :: ![DebugBlock] , ngs_debug :: ![DebugBlock]
, ngs_dwarfFiles :: !DwarfFiles
} }
nativeCodeGen' :: (Outputable statics, Outputable instr, Instruction instr) nativeCodeGen' :: (Outputable statics, Outputable instr, Instruction instr)
...@@ -278,25 +279,17 @@ nativeCodeGen' :: (Outputable statics, Outputable instr, Instruction instr) ...@@ -278,25 +279,17 @@ nativeCodeGen' :: (Outputable statics, Outputable instr, Instruction instr)
-> IO UniqSupply -> IO UniqSupply
nativeCodeGen' dflags this_mod modLoc ncgImpl h us cmms nativeCodeGen' dflags this_mod modLoc ncgImpl h us cmms
= do = do
let split_cmms = Stream.map add_split cmms
-- BufHandle is a performance hack. We could hide it inside -- BufHandle is a performance hack. We could hide it inside
-- Pretty if it weren't for the fact that we do lots of little -- Pretty if it weren't for the fact that we do lots of little
-- printDocs here (in order to do codegen in constant space). -- printDocs here (in order to do codegen in constant space).
bufh <- newBufHandle h bufh <- newBufHandle h
let ngs0 = NGS [] [] [] [] [] [] emptyUFM
(ngs, us') <- cmmNativeGenStream dflags this_mod modLoc ncgImpl bufh us (ngs, us') <- cmmNativeGenStream dflags this_mod modLoc ncgImpl bufh us
split_cmms (NGS [] [] [] [] [] []) cmms ngs0
finishNativeGen dflags bufh ngs finishNativeGen dflags bufh ngs
return us' 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 finishNativeGen :: Instruction instr
=> DynFlags => DynFlags
-> BufHandle -> BufHandle
...@@ -368,17 +361,29 @@ cmmNativeGenStream dflags this_mod modLoc ncgImpl h us cmm_stream ngs ...@@ -368,17 +361,29 @@ cmmNativeGenStream dflags this_mod modLoc ncgImpl h us cmm_stream ngs
let debugFlag = gopt Opt_Debug dflags let debugFlag = gopt Opt_Debug dflags
!ndbgs | debugFlag = cmmDebugGen modLoc cmms !ndbgs | debugFlag = cmmDebugGen modLoc cmms
| otherwise = [] | otherwise = []
dbgMap = debugToMap ndbgs
-- Generate native code -- Insert split marker, generate native code
(ngs',us') <- cmmNativeGens dflags this_mod ncgImpl h us cmms ngs 0 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 -- Link native code information into debug blocks
let !ldbgs = cmmDebugLink (ngs_labels ngs') ndbgs let !ldbgs = cmmDebugLink (ngs_labels ngs') ndbgs
dumpIfSet_dyn dflags Opt_D_dump_debug "Debug Infos" dumpIfSet_dyn dflags Opt_D_dump_debug "Debug Infos"
(vcat $ map ppr ldbgs) (vcat $ map ppr ldbgs)
-- Strip references to native code unless we want to dump it later -- Clear DWARF info when generating split object files
let ngs'' = ngs' { ngs_debug = ngs_debug ngs' ++ ldbgs let ngs'' | debugFlag && splitFlag
= ngs' { ngs_debug = []
, ngs_dwarfFiles = emptyUFM
, ngs_labels = [] }
| otherwise
= ngs' { ngs_debug = ngs_debug ngs' ++ ldbgs
, ngs_labels = [] } , ngs_labels = [] }
cmmNativeGenStream dflags this_mod modLoc ncgImpl h us' cmmNativeGenStream dflags this_mod modLoc ncgImpl h us'
cmm_stream' ngs'' cmm_stream' ngs''
...@@ -387,24 +392,34 @@ cmmNativeGenStream dflags this_mod modLoc ncgImpl h us cmm_stream ngs ...@@ -387,24 +392,34 @@ cmmNativeGenStream dflags this_mod modLoc ncgImpl h us cmm_stream ngs
-- --
cmmNativeGens :: (Outputable statics, Outputable instr, Instruction instr) cmmNativeGens :: (Outputable statics, Outputable instr, Instruction instr)
=> DynFlags => DynFlags
-> Module -> Module -> ModLocation
-> NcgImpl statics instr jumpDest -> NcgImpl statics instr jumpDest
-> BufHandle -> BufHandle
-> LabelMap DebugBlock
-> UniqSupply -> UniqSupply
-> [RawCmmDecl] -> [RawCmmDecl]
-> NativeGenAcc statics instr -> NativeGenAcc statics instr
-> Int -> Int
-> IO (NativeGenAcc statics instr, UniqSupply) -> IO (NativeGenAcc statics instr, UniqSupply)
cmmNativeGens _ _ _ _ us [] ngs !_ cmmNativeGens _ _ _ _ _ _ us [] ngs !_
= return (ngs, us) = 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 = do
(us', native, imports, colorStats, linearStats) let fileIds = ngs_dwarfFiles ngs
<- {-# SCC "cmmNativeGen" #-} cmmNativeGen dflags this_mod ncgImpl us cmm count (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 $ emitNativeCode dflags h $ vcat $
map pprDecl (eltsUFM newFileIds) ++
map (pprNatCmmDecl ncgImpl) native map (pprNatCmmDecl ncgImpl) native
-- force evaluation all this stuff to avoid space leaks -- force evaluation all this stuff to avoid space leaks
...@@ -420,8 +435,10 @@ cmmNativeGens dflags this_mod ncgImpl h us (cmm : cmms) ngs count ...@@ -420,8 +435,10 @@ cmmNativeGens dflags this_mod ncgImpl h us (cmm : cmms) ngs count
, ngs_colorStats = colorStats `mCon` ngs_colorStats ngs , ngs_colorStats = colorStats `mCon` ngs_colorStats ngs
, ngs_linearStats = linearStats `mCon` ngs_linearStats ngs , ngs_linearStats = linearStats `mCon` ngs_linearStats ngs
, ngs_labels = ngs_labels ngs ++ labels' , 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 [] = () where seqString [] = ()
seqString (x:xs) = x `seq` seqString xs seqString (x:xs) = x `seq` seqString xs
...@@ -444,18 +461,21 @@ emitNativeCode dflags h sdoc = do ...@@ -444,18 +461,21 @@ emitNativeCode dflags h sdoc = do
cmmNativeGen cmmNativeGen
:: (Outputable statics, Outputable instr, Instruction instr) :: (Outputable statics, Outputable instr, Instruction instr)
=> DynFlags => DynFlags
-> Module -> Module -> ModLocation
-> NcgImpl statics instr jumpDest -> NcgImpl statics instr jumpDest
-> UniqSupply -> UniqSupply
-> DwarfFiles
-> LabelMap DebugBlock
-> RawCmmDecl -- ^ the cmm to generate code for -> RawCmmDecl -- ^ the cmm to generate code for
-> Int -- ^ sequence number of this top thing -> Int -- ^ sequence number of this top thing
-> IO ( UniqSupply -> IO ( UniqSupply
, DwarfFiles
, [NatCmmDecl statics instr] -- native code , [NatCmmDecl statics instr] -- native code
, [CLabel] -- things imported by this cmm , [CLabel] -- things imported by this cmm
, Maybe [Color.RegAllocStats statics instr] -- stats for the coloring register allocator , Maybe [Color.RegAllocStats statics instr] -- stats for the coloring register allocator
, Maybe [Linear.RegAllocStats]) -- stats for the linear register allocators , 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 = do
let platform = targetPlatform dflags let platform = targetPlatform dflags
...@@ -474,9 +494,11 @@ cmmNativeGen dflags this_mod ncgImpl us cmm count ...@@ -474,9 +494,11 @@ cmmNativeGen dflags this_mod ncgImpl us cmm count
(pprCmmGroup [opt_cmm]) (pprCmmGroup [opt_cmm])
-- generate native code from cmm -- generate native code from cmm
let ((native, lastMinuteImports), usGen) = let ((native, lastMinuteImports, fileIds'), usGen) =
{-# SCC "genMachCode" #-} {-# 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 dumpIfSet_dyn dflags
Opt_D_dump_asm_native "Native code" Opt_D_dump_asm_native "Native code"
...@@ -607,6 +629,7 @@ cmmNativeGen dflags this_mod ncgImpl us cmm count ...@@ -607,6 +629,7 @@ cmmNativeGen dflags this_mod ncgImpl us cmm count
(vcat $ map (pprNatCmmDecl ncgImpl) expanded) (vcat $ map (pprNatCmmDecl ncgImpl) expanded)
return ( usAlloc return ( usAlloc
, fileIds'
, expanded , expanded
, lastMinuteImports ++ imports , lastMinuteImports ++ imports
, ppr_raStatsColor , ppr_raStatsColor
...@@ -862,21 +885,25 @@ apply_mapping ncgImpl ufm (CmmProc info lbl live (ListGraph blocks)) ...@@ -862,21 +885,25 @@ apply_mapping ncgImpl ufm (CmmProc info lbl live (ListGraph blocks))
genMachCode genMachCode
:: DynFlags :: DynFlags
-> Module -> Module -> ModLocation
-> (RawCmmDecl -> NatM [NatCmmDecl statics instr]) -> (RawCmmDecl -> NatM [NatCmmDecl statics instr])
-> DwarfFiles
-> LabelMap DebugBlock
-> RawCmmDecl -> RawCmmDecl
-> UniqSM -> UniqSM
( [NatCmmDecl statics instr] ( [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 = do { initial_us <- getUniqueSupplyM
; let initial_st = mkNatM_State initial_us 0 dflags this_mod ; let initial_st = mkNatM_State initial_us 0 dflags this_mod
modLoc fileIds dbgMap
(new_tops, final_st) = initNat initial_st (cmmTopCodeGen cmm_top) (new_tops, final_st) = initNat initial_st (cmmTopCodeGen cmm_top)
final_delta = natm_delta final_st final_delta = natm_delta final_st
final_imports = natm_imports final_st final_imports = natm_imports final_st
; if final_delta == 0 ; 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) else pprPanic "genMachCode: nonzero final delta" (int final_delta)
} }
......
...@@ -25,7 +25,12 @@ module NCGMonad ( ...@@ -25,7 +25,12 @@ module NCGMonad (
getNewRegPairNat, getNewRegPairNat,
getPicBaseMaybeNat, getPicBaseMaybeNat,
getPicBaseNat, getPicBaseNat,
getDynFlags getDynFlags,
getModLoc,
getFileId,
getDebugBlock,
DwarfFiles
) )
where where
...@@ -38,6 +43,9 @@ import TargetReg ...@@ -38,6 +43,9 @@ import TargetReg
import BlockId import BlockId
import CLabel ( CLabel, mkAsmTempLabel ) import CLabel ( CLabel, mkAsmTempLabel )
import Debug
import FastString ( FastString )
import UniqFM
import UniqSupply import UniqSupply
import Unique ( Unique ) import Unique ( Unique )
import DynFlags import DynFlags
...@@ -48,6 +56,8 @@ import Control.Monad ( liftM, ap ) ...@@ -48,6 +56,8 @@ import Control.Monad ( liftM, ap )
import Control.Applicative ( Applicative(..) ) import Control.Applicative ( Applicative(..) )
#endif #endif
import Compiler.Hoopl ( LabelMap, Label )
data NatM_State data NatM_State
= NatM_State { = NatM_State {
natm_us :: UniqSupply, natm_us :: UniqSupply,
...@@ -55,15 +65,21 @@ data NatM_State ...@@ -55,15 +65,21 @@ data NatM_State
natm_imports :: [(CLabel)], natm_imports :: [(CLabel)],
natm_pic :: Maybe Reg, natm_pic :: Maybe Reg,
natm_dflags :: DynFlags, 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)) newtype NatM result = NatM (NatM_State -> (result, NatM_State))
unNat :: NatM a -> NatM_State -> (a, NatM_State) unNat :: NatM a -> NatM_State -> (a, NatM_State)
unNat (NatM a) = a 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 mkNatM_State us delta dflags this_mod
= NatM_State us delta [] Nothing dflags this_mod = NatM_State us delta [] Nothing dflags this_mod
...@@ -174,3 +190,18 @@ getPicBaseNat rep ...@@ -174,3 +190,18 @@ getPicBaseNat rep
-> do -> do
reg <- getNewRegNat rep reg <- getNewRegNat rep
NatM (\state -> (reg, state { natm_pic = Just reg })) 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)
...@@ -401,9 +401,9 @@ raInsn _ new_instrs _ (LiveInstr ii Nothing) ...@@ -401,9 +401,9 @@ raInsn _ new_instrs _ (LiveInstr ii Nothing)
= do setDeltaR n = do setDeltaR n
return (new_instrs, []) return (new_instrs, [])
raInsn _ new_instrs _ (LiveInstr ii Nothing) raInsn _ new_instrs _ (LiveInstr ii@(Instr i) Nothing)
| isMetaInstr ii | isMetaInstr ii
= return (new_instrs, []) = return (i : new_instrs, [])
raInsn block_live new_instrs id (LiveInstr (Instr instr) (Just live)) raInsn block_live new_instrs id (LiveInstr (Instr instr) (Just live))
......
...@@ -31,6 +31,7 @@ import X86.Regs ...@@ -31,6 +31,7 @@ import X86.Regs
import X86.RegInfo import X86.RegInfo
import CodeGen.Platform import CodeGen.Platform
import CPrim import CPrim
import Debug ( DebugBlock(..) )
import Instruction import Instruction
import PIC import PIC
import NCGMonad import NCGMonad
...@@ -47,6 +48,8 @@ import CmmUtils ...@@ -47,6 +48,8 @@ import CmmUtils
import Cmm import Cmm
import Hoopl import Hoopl
import CLabel import CLabel
import CoreSyn ( Tickish(..) )
import SrcLoc ( srcSpanFile, srcSpanStartLine, srcSpanStartCol )
-- The rest: -- The rest:
import ForeignCall ( CCallConv(..) ) import ForeignCall ( CCallConv(..) )
...@@ -114,9 +117,17 @@ basicBlockCodeGen block = do ...@@ -114,9 +117,17 @@ basicBlockCodeGen block = do
let (_, nodes, tail) = blockSplit block let (_, nodes, tail) = blockSplit block
id = entryLabel block id = entryLabel block
stmts = blockToList nodes 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 mid_instrs <- stmtsToInstrs stmts
tail_instrs <- stmtToInstrs tail 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 -- code generation may introduce new basic block boundaries, which
-- are indicated by the NEWBLOCK instruction. We must split up the -- are indicated by the NEWBLOCK instruction. We must split up the
-- instruction stream into basic blocks again. Also, we extract -- instruction stream into basic blocks again. Also, we extract
......
...@@ -165,6 +165,9 @@ data Instr ...@@ -165,6 +165,9 @@ data Instr
-- comment pseudo-op -- comment pseudo-op
= COMMENT FastString = COMMENT FastString
-- location pseudo-op (file, line, col, name)
| LOCATION Int Int Int String
-- some static data spat out during code -- some static data spat out during code
-- generation. Will be extracted before -- generation. Will be extracted before
-- pretty-printing. -- pretty-printing.
...@@ -444,6 +447,7 @@ x86_regUsageOfInstr platform instr ...@@ -444,6 +447,7 @@ x86_regUsageOfInstr platform instr
FETCHPC reg -> mkRU [] [reg] FETCHPC reg -> mkRU [] [reg]
COMMENT _ -> noUsage COMMENT _ -> noUsage
LOCATION{} -> noUsage
DELTA _ -> noUsage DELTA _ -> noUsage
POPCNT _ src dst -> mkRU (use_R src []) [dst] POPCNT _ src dst -> mkRU (use_R src []) [dst]
...@@ -616,6 +620,7 @@ x86_patchRegsOfInstr instr env ...@@ -616,6 +620,7 @@ x86_patchRegsOfInstr instr env
NOP -> instr NOP -> instr
COMMENT _ -> instr COMMENT _ -> instr
LOCATION {} -> instr
DELTA _ -> instr DELTA _ -> instr
JXX _ _ -> instr JXX _ _ -> instr
...@@ -776,6 +781,7 @@ x86_isMetaInstr ...@@ -776,6 +781,7 @@ x86_isMetaInstr
x86_isMetaInstr instr x86_isMetaInstr instr
= case instr of = case instr of
COMMENT{} -> True COMMENT{} -> True
LOCATION{} -> True
LDATA{} -> True LDATA{} -> True
NEWBLOCK{} -> True NEWBLOCK{} -> True
DELTA{} -> True DELTA{} -> True
......
...@@ -490,6 +490,11 @@ pprInstr (COMMENT _) = empty -- nuke 'em ...@@ -490,6 +490,11 @@ pprInstr (COMMENT _) = empty -- nuke 'em
{- {-
pprInstr (COMMENT s) = ptext (sLit "# ") <> ftext s 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 (DELTA d)
= pprInstr (COMMENT (mkFastString ("\tdelta = " ++ show d))) = pprInstr (COMMENT (mkFastString ("\tdelta = " ++ show d)))
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment