summaryrefslogtreecommitdiff
path: root/compiler/nativeGen
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/nativeGen')
-rw-r--r--compiler/nativeGen/AsmCodeGen.hs129
-rw-r--r--compiler/nativeGen/NCGMonad.hs37
-rw-r--r--compiler/nativeGen/RegAlloc/Linear/Main.hs4
-rw-r--r--compiler/nativeGen/X86/CodeGen.hs13
-rw-r--r--compiler/nativeGen/X86/Instr.hs6
-rw-r--r--compiler/nativeGen/X86/Ppr.hs5
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)))
View Lorry Controller Status