summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/GHC/CmmToAsm.hs63
-rw-r--r--compiler/GHC/CmmToAsm/Config.hs6
-rw-r--r--compiler/GHC/CmmToAsm/Dwarf.hs37
-rw-r--r--compiler/GHC/CmmToAsm/PPC/Ppr.hs4
-rw-r--r--compiler/GHC/CmmToAsm/X86/CodeGen.hs2
-rw-r--r--compiler/GHC/CmmToAsm/X86/Ppr.hs6
-rw-r--r--compiler/GHC/CmmToLlvm/Base.hs2
-rw-r--r--compiler/GHC/CmmToLlvm/CodeGen.hs2
-rw-r--r--compiler/GHC/Driver/Backpack.hs4
-rw-r--r--compiler/GHC/Driver/Ppr.hs8
-rw-r--r--compiler/GHC/Unit/State.hs6
-rw-r--r--compiler/GHC/Utils/Outputable.hs48
-rw-r--r--testsuite/tests/hiefile/should_run/HieQueries.hs4
13 files changed, 120 insertions, 72 deletions
diff --git a/compiler/GHC/CmmToAsm.hs b/compiler/GHC/CmmToAsm.hs
index 677c7bdcbf..4f19085ac9 100644
--- a/compiler/GHC/CmmToAsm.hs
+++ b/compiler/GHC/CmmToAsm.hs
@@ -152,7 +152,7 @@ nativeCodeGen dflags this_mod modLoc h us cmms
platform = ncgPlatform config
nCG' :: ( Outputable statics, Outputable jumpDest, Instruction instr)
=> NcgImpl statics instr jumpDest -> IO a
- nCG' ncgImpl = nativeCodeGen' dflags this_mod modLoc ncgImpl h us cmms
+ nCG' ncgImpl = nativeCodeGen' dflags config this_mod modLoc ncgImpl h us cmms
in case platformArch platform of
ArchX86 -> nCG' (X86.ncgX86 config)
ArchX86_64 -> nCG' (X86.ncgX86_64 config)
@@ -216,39 +216,42 @@ See also Note [What is this unwinding business?] in "GHC.Cmm.DebugBlock".
nativeCodeGen' :: (Outputable statics, Outputable jumpDest, Instruction instr)
=> DynFlags
+ -> NCGConfig
-> Module -> ModLocation
-> NcgImpl statics instr jumpDest
-> Handle
-> UniqSupply
-> Stream IO RawCmmGroup a
-> IO a
-nativeCodeGen' dflags this_mod modLoc ncgImpl h us cmms
+nativeCodeGen' dflags config this_mod modLoc ncgImpl h us cmms
= do
-- 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 mapEmpty
- (ngs, us', a) <- cmmNativeGenStream dflags this_mod modLoc ncgImpl bufh us
+ (ngs, us', a) <- cmmNativeGenStream dflags config this_mod modLoc ncgImpl bufh us
cmms ngs0
- _ <- finishNativeGen dflags modLoc bufh us' ngs
+ _ <- finishNativeGen dflags config modLoc bufh us' ngs
return a
finishNativeGen :: Instruction instr
=> DynFlags
+ -> NCGConfig
-> ModLocation
-> BufHandle
-> UniqSupply
-> NativeGenAcc statics instr
-> IO UniqSupply
-finishNativeGen dflags modLoc bufh@(BufHandle _ _ h) us ngs
+finishNativeGen dflags config modLoc bufh@(BufHandle _ _ h) us ngs
= withTimingSilent dflags (text "NCG") (`seq` ()) $ do
-- Write debug data and finish
- let emitDw = debugLevel dflags > 0
- us' <- if not emitDw then return us else do
- (dwarf, us') <- dwarfGen dflags modLoc us (ngs_debug ngs)
- emitNativeCode dflags bufh dwarf
- return us'
+ us' <- if not (ncgDwarfEnabled config)
+ then return us
+ else do
+ (dwarf, us') <- dwarfGen config modLoc us (ngs_debug ngs)
+ emitNativeCode dflags config bufh dwarf
+ return us'
bFlush bufh
-- dump global NCG stats for graph coloring allocator
@@ -263,7 +266,7 @@ finishNativeGen dflags modLoc bufh@(BufHandle _ _ h) us ngs
dump_stats (Color.pprStats stats graphGlobal)
- let platform = targetPlatform dflags
+ let platform = ncgPlatform config
dumpIfSet_dyn dflags
Opt_D_dump_asm_conflicts "Register conflict graph"
FormatText
@@ -281,7 +284,7 @@ finishNativeGen dflags modLoc bufh@(BufHandle _ _ h) us ngs
dump_stats (Linear.pprStats (concat (ngs_natives ngs)) linearStats)
-- write out the imports
- let ctx = initSDocContext dflags (mkCodeStyle AsmStyle)
+ let ctx = ncgAsmContext config
printSDocLn ctx Pretty.LeftMode h
$ makeImportsDoc dflags (concat (ngs_imports ngs))
return us'
@@ -292,6 +295,7 @@ finishNativeGen dflags modLoc bufh@(BufHandle _ _ h) us ngs
cmmNativeGenStream :: (Outputable statics, Outputable jumpDest, Instruction instr)
=> DynFlags
+ -> NCGConfig
-> Module -> ModLocation
-> NcgImpl statics instr jumpDest
-> BufHandle
@@ -300,7 +304,7 @@ cmmNativeGenStream :: (Outputable statics, Outputable jumpDest, Instruction inst
-> NativeGenAcc statics instr
-> IO (NativeGenAcc statics instr, UniqSupply, a)
-cmmNativeGenStream dflags this_mod modLoc ncgImpl h us cmm_stream ngs
+cmmNativeGenStream dflags config this_mod modLoc ncgImpl h us cmm_stream ngs
= do r <- Stream.runStream cmm_stream
case r of
Left a ->
@@ -317,13 +321,12 @@ cmmNativeGenStream dflags this_mod modLoc ncgImpl h us cmm_stream ngs
dflags
ncglabel (\(a, b) -> a `seq` b `seq` ()) $ do
-- Generate debug information
- let debugFlag = debugLevel dflags > 0
- !ndbgs | debugFlag = cmmDebugGen modLoc cmms
- | otherwise = []
+ let !ndbgs | ncgDwarfEnabled config = cmmDebugGen modLoc cmms
+ | otherwise = []
dbgMap = debugToMap ndbgs
-- Generate native code
- (ngs',us') <- cmmNativeGens dflags this_mod modLoc ncgImpl h
+ (ngs',us') <- cmmNativeGens dflags config this_mod modLoc ncgImpl h
dbgMap us cmms ngs 0
-- Link native code information into debug blocks
@@ -337,7 +340,7 @@ cmmNativeGenStream dflags this_mod modLoc ncgImpl h us cmm_stream ngs
let ngs'' = ngs' { ngs_debug = ngs_debug ngs' ++ ldbgs, ngs_labels = [] }
return (us', ngs'')
- cmmNativeGenStream dflags this_mod modLoc ncgImpl h us'
+ cmmNativeGenStream dflags config this_mod modLoc ncgImpl h us'
cmm_stream' ngs''
where ncglabel = text "NCG"
@@ -347,6 +350,7 @@ cmmNativeGenStream dflags this_mod modLoc ncgImpl h us cmm_stream ngs
cmmNativeGens :: forall statics instr jumpDest.
(Outputable statics, Outputable jumpDest, Instruction instr)
=> DynFlags
+ -> NCGConfig
-> Module -> ModLocation
-> NcgImpl statics instr jumpDest
-> BufHandle
@@ -357,7 +361,7 @@ cmmNativeGens :: forall statics instr jumpDest.
-> Int
-> IO (NativeGenAcc statics instr, UniqSupply)
-cmmNativeGens dflags this_mod modLoc ncgImpl h dbgMap = go
+cmmNativeGens dflags config this_mod modLoc ncgImpl h dbgMap = go
where
go :: UniqSupply -> [RawCmmDecl]
-> NativeGenAcc statics instr -> Int
@@ -382,14 +386,14 @@ cmmNativeGens dflags this_mod modLoc ncgImpl h dbgMap = go
pprDecl (f,n) = text "\t.file " <> ppr n <+>
pprFilePathString (unpackFS f)
- emitNativeCode dflags h $ vcat $
+ emitNativeCode dflags config h $ vcat $
map pprDecl newFileIds ++
map (pprNatCmmDecl ncgImpl) native
-- force evaluation all this stuff to avoid space leaks
{-# SCC "seqString" #-} evaluate $ seqList (showSDoc dflags $ vcat $ map ppr imports) ()
- let !labels' = if debugLevel dflags > 0
+ let !labels' = if ncgDwarfEnabled config
then cmmDebugLabels isMetaInstr native else []
!natives' = if dopt Opt_D_dump_asm_stats dflags
then native : ngs_natives ngs else []
@@ -406,10 +410,10 @@ cmmNativeGens dflags this_mod modLoc ncgImpl h dbgMap = go
go us' cmms ngs' (count + 1)
-emitNativeCode :: DynFlags -> BufHandle -> SDoc -> IO ()
-emitNativeCode dflags h sdoc = do
+emitNativeCode :: DynFlags -> NCGConfig -> BufHandle -> SDoc -> IO ()
+emitNativeCode dflags config h sdoc = do
- let ctx = initSDocContext dflags (mkCodeStyle AsmStyle)
+ let ctx = ncgAsmContext config
{-# SCC "pprNativeCode" #-} bufLeftRenderSDoc ctx h sdoc
-- dump native code
@@ -791,10 +795,9 @@ makeImportsDoc dflags imports
| otherwise
= Outputable.empty
- doPpr lbl = (lbl, renderWithStyle
- (initSDocContext dflags astyle)
+ doPpr lbl = (lbl, renderWithContext
+ (ncgAsmContext config)
(pprCLabel_NCG platform lbl))
- astyle = mkCodeStyle AsmStyle
-- -----------------------------------------------------------------------------
-- Generate jump tables
@@ -1140,8 +1143,8 @@ cmmExprNative referenceKind expr = do
initNCGConfig :: DynFlags -> NCGConfig
initNCGConfig dflags = NCGConfig
{ ncgPlatform = targetPlatform dflags
+ , ncgAsmContext = initSDocContext dflags (mkCodeStyle AsmStyle)
, ncgProcAlignment = cmmProcAlignment dflags
- , ncgDebugLevel = debugLevel dflags
, ncgExternalDynamicRefs = gopt Opt_ExternalDynamicRefs dflags
, ncgPIC = positionIndependent dflags
, ncgInlineThresholdMemcpy = fromIntegral $ maxInlineMemcpyInsns dflags
@@ -1180,5 +1183,9 @@ initNCGConfig dflags = NCGConfig
ArchX86_64 -> v
ArchX86 -> v
_ -> Nothing
+
+ , ncgDwarfEnabled = debugLevel dflags > 0
+ , ncgDwarfUnwindings = debugLevel dflags >= 1
+ , ncgDwarfStripBlockInfo = debugLevel dflags < 2 -- We strip out block information when running with -g0 or -g1.
}
diff --git a/compiler/GHC/CmmToAsm/Config.hs b/compiler/GHC/CmmToAsm/Config.hs
index 29d8bcad15..d4abafd402 100644
--- a/compiler/GHC/CmmToAsm/Config.hs
+++ b/compiler/GHC/CmmToAsm/Config.hs
@@ -11,12 +11,13 @@ import GHC.Prelude
import GHC.Platform
import GHC.Cmm.Type (Width(..))
import GHC.CmmToAsm.CFG.Weight
+import GHC.Utils.Outputable
-- | Native code generator configuration
data NCGConfig = NCGConfig
{ ncgPlatform :: !Platform -- ^ Target platform
+ , ncgAsmContext :: !SDocContext -- ^ Context for ASM code generation
, ncgProcAlignment :: !(Maybe Int) -- ^ Mandatory proc alignment
- , ncgDebugLevel :: !Int -- ^ Debug level
, ncgExternalDynamicRefs :: !Bool -- ^ Generate code to link against dynamic libraries
, ncgPIC :: !Bool -- ^ Enable Position-Independent Code
, ncgInlineThresholdMemcpy :: !Word -- ^ If inlining `memcpy` produces less than this threshold (in pseudo-instruction unit), do it
@@ -33,6 +34,9 @@ data NCGConfig = NCGConfig
, ncgCfgWeights :: !Weights -- ^ CFG edge weights
, ncgCfgBlockLayout :: !Bool -- ^ Use CFG based block layout algorithm
, ncgCfgWeightlessLayout :: !Bool -- ^ Layout based on last instruction per block.
+ , ncgDwarfEnabled :: !Bool -- ^ Enable Dwarf generation
+ , ncgDwarfUnwindings :: !Bool -- ^ Enable unwindings
+ , ncgDwarfStripBlockInfo :: !Bool -- ^ Strip out block information from generated Dwarf
}
-- | Return Word size
diff --git a/compiler/GHC/CmmToAsm/Dwarf.hs b/compiler/GHC/CmmToAsm/Dwarf.hs
index ccf2cf8758..d09588841b 100644
--- a/compiler/GHC/CmmToAsm/Dwarf.hs
+++ b/compiler/GHC/CmmToAsm/Dwarf.hs
@@ -4,9 +4,6 @@ module GHC.CmmToAsm.Dwarf (
import GHC.Prelude
-import GHC.Driver.Session
-import GHC.Driver.Ppr
-
import GHC.Cmm.CLabel
import GHC.Cmm.Expr ( GlobalReg(..) )
import GHC.Settings.Config ( cProjectName, cProjectVersion )
@@ -20,6 +17,7 @@ import GHC.Types.Unique.Supply
import GHC.CmmToAsm.Dwarf.Constants
import GHC.CmmToAsm.Dwarf.Types
+import GHC.CmmToAsm.Config
import Control.Arrow ( first )
import Control.Monad ( mfilter )
@@ -34,23 +32,22 @@ import qualified GHC.Cmm.Dataflow.Label as H
import qualified GHC.Cmm.Dataflow.Collections as H
-- | Generate DWARF/debug information
-dwarfGen :: DynFlags -> ModLocation -> UniqSupply -> [DebugBlock]
+dwarfGen :: NCGConfig -> ModLocation -> UniqSupply -> [DebugBlock]
-> IO (SDoc, UniqSupply)
-dwarfGen _ _ us [] = return (empty, us)
-dwarfGen df modLoc us blocks = do
- let platform = targetPlatform df
+dwarfGen _ _ us [] = return (empty, us)
+dwarfGen config modLoc us blocks = do
+ let platform = ncgPlatform config
-- Convert debug data structures to DWARF info records
- -- We strip out block information when running with -g0 or -g1.
let procs = debugSplitProcs blocks
stripBlocks dbg
- | debugLevel df < 2 = dbg { dblBlocks = [] }
- | otherwise = dbg
+ | ncgDwarfStripBlockInfo config = dbg { dblBlocks = [] }
+ | otherwise = dbg
compPath <- getCurrentDirectory
let lowLabel = dblCLabel $ head procs
highLabel = mkAsmTempEndLabel $ dblCLabel $ last procs
dwarfUnit = DwarfCompileUnit
- { dwChildren = map (procToDwarf df) (map stripBlocks procs)
+ { dwChildren = map (procToDwarf config) (map stripBlocks procs)
, dwName = fromMaybe "" (ml_hs_file modLoc)
, dwCompDir = addTrailingPathSeparator compPath
, dwProducer = cProjectName ++ " " ++ cProjectVersion
@@ -91,8 +88,8 @@ dwarfGen df modLoc us blocks = do
pprDwarfFrame platform (debugFrame framesU procs)
-- .aranges section: Information about the bounds of compilation units
- let aranges' | gopt Opt_SplitSections df = map mkDwarfARange procs
- | otherwise = [DwarfARange lowLabel highLabel]
+ let aranges' | ncgSplitSections config = map mkDwarfARange procs
+ | otherwise = [DwarfARange lowLabel highLabel]
let aranges = dwarfARangesSection platform $$ pprDwarfARanges platform aranges' unitU
return (infoSct $$ abbrevSct $$ lineSct $$ frameSct $$ aranges, us'')
@@ -177,12 +174,14 @@ parent, B.
-}
-- | Generate DWARF info for a procedure debug block
-procToDwarf :: DynFlags -> DebugBlock -> DwarfInfo
-procToDwarf df prc
+procToDwarf :: NCGConfig -> DebugBlock -> DwarfInfo
+procToDwarf config prc
= DwarfSubprogram { dwChildren = map blockToDwarf (dblBlocks prc)
, dwName = case dblSourceTick prc of
Just s@SourceNote{} -> sourceName s
- _otherwise -> showSDocDump df $ ppr $ dblLabel prc
+ _otherwise -> renderWithContext defaultSDocContext
+ $ withPprStyle defaultDumpStyle
+ $ ppr (dblLabel prc)
, dwLabel = dblCLabel prc
, dwParent = fmap mkAsmTempDieLabel
$ mfilter goodParent
@@ -192,9 +191,9 @@ procToDwarf df prc
goodParent a | a == dblCLabel prc = False
-- Omit parent if it would be self-referential
goodParent a | not (externallyVisibleCLabel a)
- , debugLevel df < 2 = False
- -- We strip block information when running -g0 or -g1, don't
- -- refer to blocks in that case. Fixes #14894.
+ , ncgDwarfStripBlockInfo config = False
+ -- If we strip block information, don't refer to blocks.
+ -- Fixes #14894.
goodParent _ = True
-- | Generate DWARF info for a block
diff --git a/compiler/GHC/CmmToAsm/PPC/Ppr.hs b/compiler/GHC/CmmToAsm/PPC/Ppr.hs
index 3622121e6c..259159aa44 100644
--- a/compiler/GHC/CmmToAsm/PPC/Ppr.hs
+++ b/compiler/GHC/CmmToAsm/PPC/Ppr.hs
@@ -64,7 +64,7 @@ pprNatCmmDecl config proc@(CmmProc top_info lbl _ (ListGraph blocks)) =
_ -> pprLabel platform lbl) $$ -- blocks guaranteed not null,
-- so label needed
vcat (map (pprBasicBlock config top_info) blocks) $$
- (if ncgDebugLevel config > 0
+ (if ncgDwarfEnabled config
then ppr (mkAsmTempEndLabel lbl) <> char ':' else empty) $$
pprSizeDecl platform lbl
@@ -131,7 +131,7 @@ pprBasicBlock config info_env (BasicBlock blockid instrs)
= maybe_infotable $$
pprLabel platform asmLbl $$
vcat (map (pprInstr platform) instrs) $$
- (if ncgDebugLevel config > 0
+ (if ncgDwarfEnabled config
then ppr (mkAsmTempEndLabel asmLbl) <> char ':'
else empty
)
diff --git a/compiler/GHC/CmmToAsm/X86/CodeGen.hs b/compiler/GHC/CmmToAsm/X86/CodeGen.hs
index cbf3da9925..31b111eab6 100644
--- a/compiler/GHC/CmmToAsm/X86/CodeGen.hs
+++ b/compiler/GHC/CmmToAsm/X86/CodeGen.hs
@@ -229,7 +229,7 @@ basicBlockCodeGen block = do
addSpUnwindings :: Instr -> NatM (OrdList Instr)
addSpUnwindings instr@(DELTA d) = do
config <- getConfig
- if ncgDebugLevel config >= 1
+ if ncgDwarfUnwindings config
then do lbl <- mkAsmTempLabel <$> getUniqueM
let unwind = M.singleton MachSp (Just $ UwReg MachSp $ negate d)
return $ toOL [ instr, UNWIND lbl unwind ]
diff --git a/compiler/GHC/CmmToAsm/X86/Ppr.hs b/compiler/GHC/CmmToAsm/X86/Ppr.hs
index 410eddbf85..b5fb852512 100644
--- a/compiler/GHC/CmmToAsm/X86/Ppr.hs
+++ b/compiler/GHC/CmmToAsm/X86/Ppr.hs
@@ -91,7 +91,7 @@ pprNatCmmDecl config proc@(CmmProc top_info lbl _ (ListGraph blocks)) =
pprProcAlignment config $$
pprLabel platform lbl $$ -- blocks guaranteed not null, so label needed
vcat (map (pprBasicBlock config top_info) blocks) $$
- (if ncgDebugLevel config > 0
+ (if ncgDwarfEnabled config
then ppr (mkAsmTempEndLabel lbl) <> char ':' else empty) $$
pprSizeDecl platform lbl
@@ -125,7 +125,7 @@ pprBasicBlock config info_env (BasicBlock blockid instrs)
= maybe_infotable $
pprLabel platform asmLbl $$
vcat (map (pprInstr platform) instrs) $$
- (if ncgDebugLevel config > 0
+ (if ncgDwarfEnabled config
then ppr (mkAsmTempEndLabel asmLbl) <> char ':'
else empty
)
@@ -140,7 +140,7 @@ pprBasicBlock config info_env (BasicBlock blockid instrs)
vcat (map (pprData config) info) $$
pprLabel platform infoLbl $$
c $$
- (if ncgDebugLevel config > 0
+ (if ncgDwarfEnabled config
then ppr (mkAsmTempEndLabel infoLbl) <> char ':'
else empty
)
diff --git a/compiler/GHC/CmmToLlvm/Base.hs b/compiler/GHC/CmmToLlvm/Base.hs
index bdadaf49de..d7667bb073 100644
--- a/compiler/GHC/CmmToLlvm/Base.hs
+++ b/compiler/GHC/CmmToLlvm/Base.hs
@@ -498,7 +498,7 @@ strCLabel_llvm lbl = do
dflags <- getDynFlags
platform <- getPlatform
let sdoc = pprCLabel_LLVM platform lbl
- str = Outp.renderWithStyle
+ str = Outp.renderWithContext
(initSDocContext dflags (Outp.mkCodeStyle Outp.CStyle))
sdoc
return (fsLit str)
diff --git a/compiler/GHC/CmmToLlvm/CodeGen.hs b/compiler/GHC/CmmToLlvm/CodeGen.hs
index 916931eefa..34d0353681 100644
--- a/compiler/GHC/CmmToLlvm/CodeGen.hs
+++ b/compiler/GHC/CmmToLlvm/CodeGen.hs
@@ -1566,7 +1566,7 @@ genMachOp_slow opt op [x, y] = case op of
-- Error. Continue anyway so we can debug the generated ll file.
dflags <- getDynFlags
let style = mkCodeStyle CStyle
- toString doc = renderWithStyle (initSDocContext dflags style) doc
+ toString doc = renderWithContext (initSDocContext dflags style) doc
cmmToStr = (lines . toString . PprCmm.pprExpr platform)
statement $ Comment $ map fsLit $ cmmToStr x
statement $ Comment $ map fsLit $ cmmToStr y
diff --git a/compiler/GHC/Driver/Backpack.hs b/compiler/GHC/Driver/Backpack.hs
index 2523fb55d5..1ae745ffe3 100644
--- a/compiler/GHC/Driver/Backpack.hs
+++ b/compiler/GHC/Driver/Backpack.hs
@@ -539,7 +539,7 @@ msgUnitId pk = do
dflags <- getDynFlags
level <- getBkpLevel
liftIO . backpackProgressMsg level dflags
- $ "Instantiating " ++ renderWithStyle
+ $ "Instantiating " ++ renderWithContext
(initSDocContext dflags backpackStyle)
(ppr pk)
@@ -550,7 +550,7 @@ msgInclude (i,n) uid = do
level <- getBkpLevel
liftIO . backpackProgressMsg level dflags
$ showModuleIndex (i, n) ++ "Including " ++
- renderWithStyle (initSDocContext dflags backpackStyle)
+ renderWithContext (initSDocContext dflags backpackStyle)
(ppr uid)
-- ----------------------------------------------------------------------------
diff --git a/compiler/GHC/Driver/Ppr.hs b/compiler/GHC/Driver/Ppr.hs
index fe95b56860..6fe4ea91cc 100644
--- a/compiler/GHC/Driver/Ppr.hs
+++ b/compiler/GHC/Driver/Ppr.hs
@@ -36,7 +36,7 @@ import Control.Monad.IO.Class
-- | Show a SDoc as a String with the default user style
showSDoc :: DynFlags -> SDoc -> String
-showSDoc dflags sdoc = renderWithStyle (initSDocContext dflags defaultUserStyle) sdoc
+showSDoc dflags sdoc = renderWithContext (initSDocContext dflags defaultUserStyle) sdoc
showPpr :: Outputable a => DynFlags -> a -> String
showPpr dflags thing = showSDoc dflags (ppr thing)
@@ -46,13 +46,13 @@ showPprUnsafe a = showPpr unsafeGlobalDynFlags a
-- | Allows caller to specify the PrintUnqualified to use
showSDocForUser :: DynFlags -> PrintUnqualified -> SDoc -> String
-showSDocForUser dflags unqual doc = renderWithStyle (initSDocContext dflags (mkUserStyle unqual AllTheWay)) doc
+showSDocForUser dflags unqual doc = renderWithContext (initSDocContext dflags (mkUserStyle unqual AllTheWay)) doc
showSDocDump :: DynFlags -> SDoc -> String
-showSDocDump dflags d = renderWithStyle (initSDocContext dflags defaultDumpStyle) d
+showSDocDump dflags d = renderWithContext (initSDocContext dflags defaultDumpStyle) d
showSDocDebug :: DynFlags -> SDoc -> String
-showSDocDebug dflags d = renderWithStyle ctx d
+showSDocDebug dflags d = renderWithContext ctx d
where
ctx = (initSDocContext dflags defaultDumpStyle)
{ sdocPprDebug = True
diff --git a/compiler/GHC/Unit/State.hs b/compiler/GHC/Unit/State.hs
index 727b37fa32..f35437be11 100644
--- a/compiler/GHC/Unit/State.hs
+++ b/compiler/GHC/Unit/State.hs
@@ -980,7 +980,7 @@ packageFlagErr' :: SDocContext
-> [(UnitInfo, UnusableUnitReason)]
-> IO a
packageFlagErr' ctx flag_doc reasons
- = throwGhcExceptionIO (CmdLineError (renderWithStyle ctx $ err))
+ = throwGhcExceptionIO (CmdLineError (renderWithContext ctx $ err))
where err = text "cannot satisfy " <> flag_doc <>
(if null reasons then Outputable.empty else text ": ") $$
nest 4 (ppr_reasons $$
@@ -1712,7 +1712,7 @@ mkModuleNameProvidersMap ctx cfg pkg_map closure vis_map =
rnBinding (orig, new) = (new, setOrigins origEntry fromFlag)
where origEntry = case lookupUFM esmap orig of
Just r -> r
- Nothing -> throwGhcException (CmdLineError (renderWithStyle ctx
+ Nothing -> throwGhcException (CmdLineError (renderWithContext ctx
(text "package flag: could not find module name" <+>
ppr orig <+> text "in package" <+> ppr pk)))
@@ -2058,7 +2058,7 @@ getPreloadUnitsAnd ctx unit_state home_unit ids0 =
throwErr :: SDocContext -> MaybeErr MsgDoc a -> IO a
throwErr ctx m = case m of
- Failed e -> throwGhcExceptionIO (CmdLineError (renderWithStyle ctx e))
+ Failed e -> throwGhcExceptionIO (CmdLineError (renderWithContext ctx e))
Succeeded r -> return r
-- | Takes a list of UnitIds (and their "parent" dependency, used for error
diff --git a/compiler/GHC/Utils/Outputable.hs b/compiler/GHC/Utils/Outputable.hs
index e83f0af927..1875d8faf9 100644
--- a/compiler/GHC/Utils/Outputable.hs
+++ b/compiler/GHC/Utils/Outputable.hs
@@ -47,7 +47,7 @@ module GHC.Utils.Outputable (
bufLeftRenderSDoc,
pprCode, mkCodeStyle,
showSDocOneLine,
- renderWithStyle,
+ renderWithContext,
pprInfixVar, pprPrefixVar,
pprHsChar, pprHsString, pprHsBytes,
@@ -71,7 +71,7 @@ module GHC.Utils.Outputable (
QualifyName(..), queryQual,
sdocWithDynFlags, sdocOption,
updSDocContext,
- SDocContext (..), sdocWithContext,
+ SDocContext (..), sdocWithContext, defaultSDocContext,
getPprStyle, withPprStyle, setStyleColoured,
pprDeeper, pprDeeperList, pprSetDepth,
codeStyle, userStyle, dumpStyle, asmStyle,
@@ -302,7 +302,7 @@ code (either C or assembly), or generating interface files.
-- | Represents a pretty-printable document.
--
-- To display an 'SDoc', use 'printSDoc', 'printSDocLn', 'bufLeftRenderSDoc',
--- or 'renderWithStyle'. Avoid calling 'runSDoc' directly as it breaks the
+-- or 'renderWithContext'. Avoid calling 'runSDoc' directly as it breaks the
-- abstraction layer.
newtype SDoc = SDoc { runSDoc :: SDocContext -> Doc }
@@ -354,6 +354,44 @@ instance IsString SDoc where
instance Outputable SDoc where
ppr = id
+-- | Default pretty-printing options
+defaultSDocContext :: SDocContext
+defaultSDocContext = SDC
+ { sdocStyle = defaultDumpStyle
+ , sdocColScheme = Col.defaultScheme
+ , sdocLastColour = Col.colReset
+ , sdocShouldUseColor = False
+ , sdocDefaultDepth = 5
+ , sdocLineLength = 100
+ , sdocCanUseUnicode = False
+ , sdocHexWordLiterals = False
+ , sdocPprDebug = False
+ , sdocPrintUnicodeSyntax = False
+ , sdocPrintCaseAsLet = False
+ , sdocPrintTypecheckerElaboration = False
+ , sdocPrintAxiomIncomps = False
+ , sdocPrintExplicitKinds = False
+ , sdocPrintExplicitCoercions = False
+ , sdocPrintExplicitRuntimeReps = False
+ , sdocPrintExplicitForalls = False
+ , sdocPrintPotentialInstances = False
+ , sdocPrintEqualityRelations = False
+ , sdocSuppressTicks = False
+ , sdocSuppressTypeSignatures = False
+ , sdocSuppressTypeApplications = False
+ , sdocSuppressIdInfo = False
+ , sdocSuppressCoercions = False
+ , sdocSuppressUnfoldings = False
+ , sdocSuppressVarKinds = False
+ , sdocSuppressUniques = False
+ , sdocSuppressModulePrefixes = False
+ , sdocSuppressStgExts = False
+ , sdocErrorSpans = False
+ , sdocStarIsType = False
+ , sdocImpredicativeTypes = False
+ , sdocLinearTypes = False
+ , sdocDynFlags = error "defaultSDocContext: DynFlags not available"
+ }
withPprStyle :: PprStyle -> SDoc -> SDoc
withPprStyle sty d = SDoc $ \ctxt -> runSDoc d ctxt{sdocStyle=sty}
@@ -490,8 +528,8 @@ pprCode cs d = withPprStyle (PprCode cs) d
mkCodeStyle :: CodeStyle -> PprStyle
mkCodeStyle = PprCode
-renderWithStyle :: SDocContext -> SDoc -> String
-renderWithStyle ctx sdoc
+renderWithContext :: SDocContext -> SDoc -> String
+renderWithContext ctx sdoc
= let s = Pretty.style{ Pretty.mode = PageMode,
Pretty.lineLength = sdocLineLength ctx }
in Pretty.renderStyle s $ runSDoc sdoc ctx
diff --git a/testsuite/tests/hiefile/should_run/HieQueries.hs b/testsuite/tests/hiefile/should_run/HieQueries.hs
index f0b3ee5ba2..2446be5963 100644
--- a/testsuite/tests/hiefile/should_run/HieQueries.hs
+++ b/testsuite/tests/hiefile/should_run/HieQueries.hs
@@ -14,7 +14,7 @@ import GHC.Iface.Ext.Utils
import Data.Maybe (fromJust)
import GHC.Driver.Session
import GHC.SysTools
-import GHC.Utils.Outputable ( Outputable, renderWithStyle, ppr, defaultUserStyle, text)
+import GHC.Utils.Outputable ( Outputable, renderWithContext, ppr, defaultUserStyle, text)
import qualified Data.Map as M
import Data.Foldable
@@ -78,5 +78,5 @@ explainEv df hf refmap point = do
pretty = unlines . (++["└"]) . ("┌":) . map ("│ "++) . lines
- pprint = pretty . renderWithStyle (initSDocContext df sty) . ppr
+ pprint = pretty . renderWithContext (initSDocContext df sty) . ppr
sty = defaultUserStyle
View Lorry Controller Status