Commit 659eb31b authored by Sylvain Henry's avatar Sylvain Henry Committed by Marge Bot
Browse files

NCG: Dwarf configuration

* remove references to DynFlags in GHC.CmmToAsm.Dwarf
* add specific Dwarf options in NCGConfig instead of directly querying
  the debug level
parent 50eb4460
......@@ -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.
}
......@@ -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
......
......@@ -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
......
......@@ -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
)
......
......@@ -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 ]
......
......@@ -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
)
......
......@@ -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)
......
......@@ -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
......
......@@ -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)
-- ----------------------------------------------------------------------------
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
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