Commit 8e2f85f6 authored by Sylvain Henry's avatar Sylvain Henry Committed by Marge Bot

Refactor Logger

Before this patch, the only way to override GHC's default logging
behavior was to set `log_action`, `dump_action` and `trace_action`
fields in DynFlags. This patch introduces a new Logger abstraction and
stores it in HscEnv instead.

This is part of #17957 (avoid storing state in DynFlags). DynFlags are
duplicated and updated per-module (because of OPTIONS_GHC pragma), so
we shouldn't store global state in them.

This patch also fixes a race in parallel "--make" mode which updated
the `generatedDumps` IORef concurrently.

Bump haddock submodule

The increase in MultilayerModules is tracked in #19293.

Metric Increase:
    MultiLayerModules
parent 40983d23
Pipeline #31227 passed with stages
in 394 minutes and 1 second
......@@ -31,10 +31,17 @@ module GHC (
GhcMode(..), GhcLink(..),
parseDynamicFlags, parseTargetFiles,
getSessionDynFlags, setSessionDynFlags,
getProgramDynFlags, setProgramDynFlags, setLogAction,
getProgramDynFlags, setProgramDynFlags,
getInteractiveDynFlags, setInteractiveDynFlags,
interpretPackageEnv,
-- * Logging
Logger, getLogger,
pushLogHook, popLogHook,
pushLogHookM, popLogHookM, modifyLogger,
putMsgM, putLogMsgM,
-- * Targets
Target(..), TargetId(..), Phase,
setTargets,
......@@ -353,6 +360,7 @@ import GHC.Utils.Monad
import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Logger
import GHC.Core.Predicate
import GHC.Core.Type hiding( typeKind )
......@@ -524,9 +532,10 @@ withCleanupSession ghc = ghc `MC.finally` cleanup
cleanup = do
hsc_env <- getSession
let dflags = hsc_dflags hsc_env
let logger = hsc_logger hsc_env
liftIO $ do
cleanTempFiles dflags
cleanTempDirs dflags
cleanTempFiles logger dflags
cleanTempDirs logger dflags
stopInterp hsc_env -- shut down the IServ
-- exceptions will be blocked while we clean the temporary files,
-- so there shouldn't be any difficulty if we receive further
......@@ -551,11 +560,12 @@ initGhcMonad mb_top_dir
; mySettings <- initSysTools top_dir
; myLlvmConfig <- lazyInitLlvmConfig top_dir
; dflags <- initDynFlags (defaultDynFlags mySettings myLlvmConfig)
; checkBrokenTablesNextToCode dflags
; hsc_env <- newHscEnv dflags
; checkBrokenTablesNextToCode (hsc_logger hsc_env) dflags
; setUnsafeGlobalDynFlags dflags
-- c.f. DynFlags.parseDynamicFlagsFull, which
-- creates DynFlags and sets the UnsafeGlobalDynFlags
; newHscEnv dflags }
; return hsc_env }
; setSession env }
-- | The binutils linker on ARM emits unnecessary R_ARM_COPY relocations which
......@@ -564,9 +574,9 @@ initGhcMonad mb_top_dir
-- version where this bug is fixed.
-- See https://sourceware.org/bugzilla/show_bug.cgi?id=16177 and
-- https://gitlab.haskell.org/ghc/ghc/issues/4210#note_78333
checkBrokenTablesNextToCode :: MonadIO m => DynFlags -> m ()
checkBrokenTablesNextToCode dflags
= do { broken <- checkBrokenTablesNextToCode' dflags
checkBrokenTablesNextToCode :: MonadIO m => Logger -> DynFlags -> m ()
checkBrokenTablesNextToCode logger dflags
= do { broken <- checkBrokenTablesNextToCode' logger dflags
; when broken
$ do { _ <- liftIO $ throwIO $ mkApiErr dflags invalidLdErr
; liftIO $ fail "unsupported linker"
......@@ -577,13 +587,13 @@ checkBrokenTablesNextToCode dflags
text "when using binutils ld (please see:" <+>
text "https://sourceware.org/bugzilla/show_bug.cgi?id=16177)"
checkBrokenTablesNextToCode' :: MonadIO m => DynFlags -> m Bool
checkBrokenTablesNextToCode' dflags
checkBrokenTablesNextToCode' :: MonadIO m => Logger -> DynFlags -> m Bool
checkBrokenTablesNextToCode' logger dflags
| not (isARM arch) = return False
| WayDyn `S.notMember` ways dflags = return False
| not tablesNextToCode = return False
| otherwise = do
linkerInfo <- liftIO $ getLinkerInfo dflags
linkerInfo <- liftIO $ getLinkerInfo logger dflags
case linkerInfo of
GnuLD _ -> return True
_ -> return False
......@@ -627,9 +637,10 @@ checkBrokenTablesNextToCode' dflags
-- (packageFlags dflags).
setSessionDynFlags :: GhcMonad m => DynFlags -> m ()
setSessionDynFlags dflags0 = do
dflags <- checkNewDynFlags dflags0
logger <- getLogger
dflags <- checkNewDynFlags logger dflags0
hsc_env <- getSession
(dbs,unit_state,home_unit) <- liftIO $ initUnits dflags (hsc_unit_dbs hsc_env)
(dbs,unit_state,home_unit) <- liftIO $ initUnits logger dflags (hsc_unit_dbs hsc_env)
-- Interpreter
interp <- if gopt Opt_ExternalInterpreter dflags
......@@ -644,7 +655,7 @@ setSessionDynFlags dflags0 = do
| otherwise = ""
msg = text "Starting " <> text prog
tr <- if verbosity dflags >= 3
then return (logInfo dflags $ withPprStyle defaultDumpStyle msg)
then return (logInfo logger dflags $ withPprStyle defaultDumpStyle msg)
else return (pure ())
let
conf = IServConfig
......@@ -689,24 +700,16 @@ setSessionDynFlags dflags0 = do
setProgramDynFlags :: GhcMonad m => DynFlags -> m Bool
setProgramDynFlags dflags = setProgramDynFlags_ True dflags
-- | Set the action taken when the compiler produces a message. This
-- can also be accomplished using 'setProgramDynFlags', but using
-- 'setLogAction' avoids invalidating the cached module graph.
setLogAction :: GhcMonad m => LogAction -> m ()
setLogAction action = do
dflags' <- getProgramDynFlags
void $ setProgramDynFlags_ False $
dflags' { log_action = action }
setProgramDynFlags_ :: GhcMonad m => Bool -> DynFlags -> m Bool
setProgramDynFlags_ invalidate_needed dflags = do
dflags' <- checkNewDynFlags dflags
logger <- getLogger
dflags' <- checkNewDynFlags logger dflags
dflags_prev <- getProgramDynFlags
let changed = packageFlagsChanged dflags_prev dflags'
if changed
then do
hsc_env <- getSession
(dbs,unit_state,home_unit) <- liftIO $ initUnits dflags' (hsc_unit_dbs hsc_env)
(dbs,unit_state,home_unit) <- liftIO $ initUnits logger dflags' (hsc_unit_dbs hsc_env)
let unit_env = UnitEnv
{ ue_platform = targetPlatform dflags'
, ue_namever = ghcNameVersion dflags'
......@@ -759,8 +762,9 @@ getProgramDynFlags = getSessionDynFlags
-- 'unitState' into the interactive @DynFlags@.
setInteractiveDynFlags :: GhcMonad m => DynFlags -> m ()
setInteractiveDynFlags dflags = do
dflags' <- checkNewDynFlags dflags
dflags'' <- checkNewInteractiveDynFlags dflags'
logger <- getLogger
dflags' <- checkNewDynFlags logger dflags
dflags'' <- checkNewInteractiveDynFlags logger dflags'
modifySessionM $ \hsc_env0 -> do
let ic0 = hsc_IC hsc_env0
......@@ -783,12 +787,15 @@ getInteractiveDynFlags :: GhcMonad m => m DynFlags
getInteractiveDynFlags = withSession $ \h -> return (ic_dflags (hsc_IC h))
parseDynamicFlags :: MonadIO m =>
DynFlags -> [Located String]
-> m (DynFlags, [Located String], [Warn])
parseDynamicFlags dflags cmdline = do
parseDynamicFlags
:: MonadIO m
=> Logger
-> DynFlags
-> [Located String]
-> m (DynFlags, [Located String], [Warn])
parseDynamicFlags logger dflags cmdline = do
(dflags1, leftovers, warns) <- parseDynamicFlagsCmdLine dflags cmdline
dflags2 <- liftIO $ interpretPackageEnv dflags1
dflags2 <- liftIO $ interpretPackageEnv logger dflags1
return (dflags2, leftovers, warns)
-- | Parse command line arguments that look like files.
......@@ -877,19 +884,19 @@ normalise_hyp fp
-- | Checks the set of new DynFlags for possibly erroneous option
-- combinations when invoking 'setSessionDynFlags' and friends, and if
-- found, returns a fixed copy (if possible).
checkNewDynFlags :: MonadIO m => DynFlags -> m DynFlags
checkNewDynFlags dflags = do
checkNewDynFlags :: MonadIO m => Logger -> DynFlags -> m DynFlags
checkNewDynFlags logger dflags = do
-- See Note [DynFlags consistency]
let (dflags', warnings) = makeDynFlagsConsistent dflags
liftIO $ handleFlagWarnings dflags (map (Warn NoReason) warnings)
liftIO $ handleFlagWarnings logger dflags (map (Warn NoReason) warnings)
return dflags'
checkNewInteractiveDynFlags :: MonadIO m => DynFlags -> m DynFlags
checkNewInteractiveDynFlags dflags0 = do
checkNewInteractiveDynFlags :: MonadIO m => Logger -> DynFlags -> m DynFlags
checkNewInteractiveDynFlags logger dflags0 = do
-- We currently don't support use of StaticPointers in expressions entered on
-- the REPL. See #12356.
if xopt LangExt.StaticPointers dflags0
then do liftIO $ printOrThrowWarnings dflags0 $ listToBag
then do liftIO $ printOrThrowWarnings logger dflags0 $ listToBag
[mkPlainWarnMsg interactiveSrcSpan
$ text "StaticPointers is not supported in GHCi interactive expressions."]
return $ xopt_unset dflags0 LangExt.StaticPointers
......@@ -1799,8 +1806,8 @@ parser str dflags filename =
-- > id1
-- > id2
--
interpretPackageEnv :: DynFlags -> IO DynFlags
interpretPackageEnv dflags = do
interpretPackageEnv :: Logger -> DynFlags -> IO DynFlags
interpretPackageEnv logger dflags = do
mPkgEnv <- runMaybeT $ msum $ [
getCmdLineArg >>= \env -> msum [
probeNullEnv env
......@@ -1828,7 +1835,7 @@ interpretPackageEnv dflags = do
return dflags
Just envfile -> do
content <- readFile envfile
compilationProgressMsg dflags (text "Loaded package environment from " <> text envfile)
compilationProgressMsg logger dflags (text "Loaded package environment from " <> text envfile)
let (_, dflags') = runCmdLine (runEwM (setFlagsFromEnvFile envfile content)) dflags
return dflags'
......
......@@ -52,6 +52,7 @@ import GHC.Driver.Session
import GHC.Utils.Error (withTimingSilent)
import GHC.Utils.Panic
import GHC.Types.Unique.Supply
import GHC.Utils.Logger
import GHC.Utils.Monad
import GHC.Utils.Misc
import GHC.Utils.Outputable
......@@ -68,14 +69,14 @@ mkEmptyContInfoTable info_lbl
, cit_srt = Nothing
, cit_clo = Nothing }
cmmToRawCmm :: DynFlags -> Stream IO CmmGroupSRTs a
cmmToRawCmm :: Logger -> DynFlags -> Stream IO CmmGroupSRTs a
-> IO (Stream IO RawCmmGroup a)
cmmToRawCmm dflags cmms
cmmToRawCmm logger dflags cmms
= do { uniqs <- mkSplitUniqSupply 'i'
; let do_one :: UniqSupply -> [CmmDeclSRTs] -> IO (UniqSupply, [RawCmmDecl])
do_one uniqs cmm =
-- NB. strictness fixes a space leak. DO NOT REMOVE.
withTimingSilent dflags (text "Cmm -> Raw Cmm")
withTimingSilent logger dflags (text "Cmm -> Raw Cmm")
forceRes $
case initUs uniqs $ concatMapM (mkInfoTable dflags) cmm of
(b,uniqs') -> return (uniqs',b)
......
......@@ -24,6 +24,7 @@ import GHC.Types.Unique.Supply
import GHC.Driver.Session
import GHC.Driver.Backend
import GHC.Utils.Error
import GHC.Utils.Logger
import GHC.Driver.Env
import Control.Monad
import GHC.Utils.Outputable
......@@ -41,26 +42,24 @@ cmmPipeline
-> CmmGroup -- Input C-- with Procedures
-> IO (ModuleSRTInfo, CmmGroupSRTs) -- Output CPS transformed C--
cmmPipeline hsc_env srtInfo prog = withTimingSilent dflags (text "Cmm pipeline") forceRes $
do let dflags = hsc_dflags hsc_env
platform = targetPlatform dflags
tops <- {-# SCC "tops" #-} mapM (cpsTop dflags) prog
cmmPipeline hsc_env srtInfo prog = do
let logger = hsc_logger hsc_env
let dflags = hsc_dflags hsc_env
let forceRes (info, group) = info `seq` foldr (\decl r -> decl `seq` r) () group
withTimingSilent logger dflags (text "Cmm pipeline") forceRes $ do
tops <- {-# SCC "tops" #-} mapM (cpsTop logger dflags) prog
let (procs, data_) = partitionEithers tops
(srtInfo, cmms) <- {-# SCC "doSRTs" #-} doSRTs dflags srtInfo procs data_
dumpWith dflags Opt_D_dump_cmm_cps "Post CPS Cmm" FormatCMM (pdoc platform cmms)
let platform = targetPlatform dflags
dumpWith logger dflags Opt_D_dump_cmm_cps "Post CPS Cmm" FormatCMM (pdoc platform cmms)
return (srtInfo, cmms)
where forceRes (info, group) =
info `seq` foldr (\decl r -> decl `seq` r) () group
dflags = hsc_dflags hsc_env
cpsTop :: DynFlags -> CmmDecl -> IO (Either (CAFEnv, [CmmDecl]) (CAFSet, CmmDecl))
cpsTop dflags p@(CmmData _ statics) = return (Right (cafAnalData (targetPlatform dflags) statics, p))
cpsTop dflags proc =
cpsTop :: Logger -> DynFlags -> CmmDecl -> IO (Either (CAFEnv, [CmmDecl]) (CAFSet, CmmDecl))
cpsTop _logger dflags p@(CmmData _ statics) = return (Right (cafAnalData (targetPlatform dflags) statics, p))
cpsTop logger dflags proc =
do
----------- Control-flow optimisations ----------------------------------
......@@ -97,7 +96,7 @@ cpsTop dflags proc =
then do
pp <- {-# SCC "minimalProcPointSet" #-} runUniqSM $
minimalProcPointSet platform call_pps g
dumpWith dflags Opt_D_dump_cmm_proc "Proc points"
dumpWith logger dflags Opt_D_dump_cmm_proc "Proc points"
FormatCMM (pdoc platform l $$ ppr pp $$ pdoc platform g)
return pp
else
......@@ -118,14 +117,14 @@ cpsTop dflags proc =
------------- CAF analysis ----------------------------------------------
let cafEnv = {-# SCC "cafAnal" #-} cafAnal platform call_pps l g
dumpWith dflags Opt_D_dump_cmm_caf "CAFEnv" FormatText (pdoc platform cafEnv)
dumpWith logger dflags Opt_D_dump_cmm_caf "CAFEnv" FormatText (pdoc platform cafEnv)
g <- if splitting_proc_points
then do
------------- Split into separate procedures -----------------------
let pp_map = {-# SCC "procPointAnalysis" #-}
procPointAnalysis proc_points g
dumpWith dflags Opt_D_dump_cmm_procmap "procpoint map"
dumpWith logger dflags Opt_D_dump_cmm_procmap "procpoint map"
FormatCMM (ppr pp_map)
g <- {-# SCC "splitAtProcPoints" #-} runUniqSM $
splitAtProcPoints platform l call_pps proc_points pp_map
......@@ -153,10 +152,10 @@ cpsTop dflags proc =
return (Left (cafEnv, g))
where platform = targetPlatform dflags
dump = dumpGraph dflags
dump = dumpGraph logger dflags
dumps flag name
= mapM_ (dumpWith dflags flag name FormatCMM . pdoc platform)
= mapM_ (dumpWith logger dflags flag name FormatCMM . pdoc platform)
condPass flag pass g dumpflag dumpname =
if gopt flag dflags
......@@ -349,25 +348,24 @@ runUniqSM m = do
return (initUs_ us m)
dumpGraph :: DynFlags -> DumpFlag -> String -> CmmGraph -> IO ()
dumpGraph dflags flag name g = do
dumpGraph :: Logger -> DynFlags -> DumpFlag -> String -> CmmGraph -> IO ()
dumpGraph logger dflags flag name g = do
when (gopt Opt_DoCmmLinting dflags) $ do_lint g
dumpWith dflags flag name FormatCMM (pdoc platform g)
dumpWith logger dflags flag name FormatCMM (pdoc platform g)
where
platform = targetPlatform dflags
do_lint g = case cmmLintGraph platform g of
Just err -> do { fatalErrorMsg dflags err
; ghcExit dflags 1
Just err -> do { fatalErrorMsg logger dflags err
; ghcExit logger dflags 1
}
Nothing -> return ()
dumpWith :: DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
dumpWith dflags flag txt fmt sdoc = do
dumpIfSet_dyn dflags flag txt fmt sdoc
dumpWith :: Logger -> DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
dumpWith logger dflags flag txt fmt sdoc = do
dumpIfSet_dyn logger dflags flag txt fmt sdoc
when (not (dopt flag dflags)) $
-- If `-ddump-cmm-verbose -ddump-to-file` is specified,
-- dump each Cmm pipeline stage output to a separate file. #16930
when (dopt Opt_D_dump_cmm_verbose dflags)
$ dumpAction dflags (mkDumpStyle alwaysQualify)
(dumpOptionsFromFlag flag) txt fmt sdoc
dumpIfSet_dyn dflags Opt_D_dump_cmm_verbose_by_proc txt fmt sdoc
$ putDumpMsg logger dflags (mkDumpStyle alwaysQualify) flag txt fmt sdoc
dumpIfSet_dyn logger dflags Opt_D_dump_cmm_verbose_by_proc txt fmt sdoc
......@@ -128,6 +128,7 @@ import GHC.Types.Unique.Supply
import GHC.Driver.Session
import GHC.Driver.Ppr
import GHC.Utils.Misc
import GHC.Utils.Logger
import qualified GHC.Utils.Ppr as Pretty
import GHC.Utils.BufHandle
......@@ -148,15 +149,15 @@ import Control.Monad
import System.IO
--------------------
nativeCodeGen :: forall a . DynFlags -> Module -> ModLocation -> Handle -> UniqSupply
nativeCodeGen :: forall a . Logger -> DynFlags -> Module -> ModLocation -> Handle -> UniqSupply
-> Stream IO RawCmmGroup a
-> IO a
nativeCodeGen dflags this_mod modLoc h us cmms
nativeCodeGen logger dflags this_mod modLoc h us cmms
= let config = initNCGConfig dflags this_mod
platform = ncgPlatform config
nCG' :: ( OutputableP Platform statics, Outputable jumpDest, Instruction instr)
=> NcgImpl statics instr jumpDest -> IO a
nCG' ncgImpl = nativeCodeGen' dflags config modLoc ncgImpl h us cmms
nCG' ncgImpl = nativeCodeGen' logger dflags config modLoc ncgImpl h us cmms
in case platformArch platform of
ArchX86 -> nCG' (X86.ncgX86 config)
ArchX86_64 -> nCG' (X86.ncgX86_64 config)
......@@ -219,7 +220,8 @@ See also Note [What is this unwinding business?] in "GHC.Cmm.DebugBlock".
-}
nativeCodeGen' :: (OutputableP Platform statics, Outputable jumpDest, Instruction instr)
=> DynFlags
=> Logger
-> DynFlags
-> NCGConfig
-> ModLocation
-> NcgImpl statics instr jumpDest
......@@ -227,34 +229,35 @@ nativeCodeGen' :: (OutputableP Platform statics, Outputable jumpDest, Instructio
-> UniqSupply
-> Stream IO RawCmmGroup a
-> IO a
nativeCodeGen' dflags config modLoc ncgImpl h us cmms
nativeCodeGen' logger dflags config 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 config modLoc ncgImpl bufh us
(ngs, us', a) <- cmmNativeGenStream logger dflags config modLoc ncgImpl bufh us
cmms ngs0
_ <- finishNativeGen dflags config modLoc bufh us' ngs
_ <- finishNativeGen logger dflags config modLoc bufh us' ngs
return a
finishNativeGen :: Instruction instr
=> DynFlags
=> Logger
-> DynFlags
-> NCGConfig
-> ModLocation
-> BufHandle
-> UniqSupply
-> NativeGenAcc statics instr
-> IO UniqSupply
finishNativeGen dflags config modLoc bufh@(BufHandle _ _ h) us ngs
= withTimingSilent dflags (text "NCG") (`seq` ()) $ do
finishNativeGen logger dflags config modLoc bufh@(BufHandle _ _ h) us ngs
= withTimingSilent logger dflags (text "NCG") (`seq` ()) $ do
-- Write debug data and finish
us' <- if not (ncgDwarfEnabled config)
then return us
else do
(dwarf, us') <- dwarfGen config modLoc us (ngs_debug ngs)
emitNativeCode dflags config bufh dwarf
emitNativeCode logger dflags config bufh dwarf
return us'
bFlush bufh
......@@ -271,7 +274,7 @@ finishNativeGen dflags config modLoc bufh@(BufHandle _ _ h) us ngs
dump_stats (Color.pprStats stats graphGlobal)
let platform = ncgPlatform config
dumpIfSet_dyn dflags
dumpIfSet_dyn logger dflags
Opt_D_dump_asm_conflicts "Register conflict graph"
FormatText
$ Color.dotGraph
......@@ -293,12 +296,13 @@ finishNativeGen dflags config modLoc bufh@(BufHandle _ _ h) us ngs
$ makeImportsDoc config (concat (ngs_imports ngs))
return us'
where
dump_stats = dumpAction dflags (mkDumpStyle alwaysQualify)
(dumpOptionsFromFlag Opt_D_dump_asm_stats) "NCG stats"
dump_stats = putDumpMsg logger dflags (mkDumpStyle alwaysQualify)
Opt_D_dump_asm_stats "NCG stats"
FormatText
cmmNativeGenStream :: (OutputableP Platform statics, Outputable jumpDest, Instruction instr)
=> DynFlags
=> Logger
-> DynFlags
-> NCGConfig
-> ModLocation
-> NcgImpl statics instr jumpDest
......@@ -308,7 +312,7 @@ cmmNativeGenStream :: (OutputableP Platform statics, Outputable jumpDest, Instru
-> NativeGenAcc statics instr
-> IO (NativeGenAcc statics instr, UniqSupply, a)
cmmNativeGenStream dflags config modLoc ncgImpl h us cmm_stream ngs
cmmNativeGenStream logger dflags config modLoc ncgImpl h us cmm_stream ngs
= do r <- Stream.runStream cmm_stream
case r of
Left a ->
......@@ -321,7 +325,7 @@ cmmNativeGenStream dflags config modLoc ncgImpl h us cmm_stream ngs
a)
Right (cmms, cmm_stream') -> do
(us', ngs'') <-
withTimingSilent
withTimingSilent logger
dflags
ncglabel (\(a, b) -> a `seq` b `seq` ()) $ do
-- Generate debug information
......@@ -330,22 +334,22 @@ cmmNativeGenStream dflags config modLoc ncgImpl h us cmm_stream ngs
dbgMap = debugToMap ndbgs
-- Generate native code
(ngs',us') <- cmmNativeGens dflags config modLoc ncgImpl h
dbgMap us cmms ngs 0
(ngs',us') <- cmmNativeGens logger dflags config modLoc ncgImpl h
dbgMap us cmms ngs 0
-- Link native code information into debug blocks
-- See Note [What is this unwinding business?] in "GHC.Cmm.DebugBlock".
let !ldbgs = cmmDebugLink (ngs_labels ngs') (ngs_unwinds ngs') ndbgs
platform = targetPlatform dflags
unless (null ldbgs) $
dumpIfSet_dyn dflags Opt_D_dump_debug "Debug Infos" FormatText
dumpIfSet_dyn logger dflags Opt_D_dump_debug "Debug Infos" FormatText
(vcat $ map (pdoc platform) ldbgs)
-- Accumulate debug information for emission in finishNativeGen.
let ngs'' = ngs' { ngs_debug = ngs_debug ngs' ++ ldbgs, ngs_labels = [] }
return (us', ngs'')
cmmNativeGenStream dflags config modLoc ncgImpl h us'
cmmNativeGenStream logger dflags config modLoc ncgImpl h us'
cmm_stream' ngs''
where ncglabel = text "NCG"
......@@ -354,7 +358,8 @@ cmmNativeGenStream dflags config modLoc ncgImpl h us cmm_stream ngs
--
cmmNativeGens :: forall statics instr jumpDest.
(OutputableP Platform statics, Outputable jumpDest, Instruction instr)
=> DynFlags
=> Logger
-> DynFlags
-> NCGConfig
-> ModLocation
-> NcgImpl statics instr jumpDest
......@@ -366,7 +371,7 @@ cmmNativeGens :: forall statics instr jumpDest.
-> Int
-> IO (NativeGenAcc statics instr, UniqSupply)
cmmNativeGens dflags config modLoc ncgImpl h dbgMap = go
cmmNativeGens logger dflags config modLoc ncgImpl h dbgMap = go
where
go :: UniqSupply -> [RawCmmDecl]
-> NativeGenAcc statics instr -> Int
......@@ -379,7 +384,7 @@ cmmNativeGens dflags config modLoc ncgImpl h dbgMap = go
let fileIds = ngs_dwarfFiles ngs
(us', fileIds', native, imports, colorStats, linearStats, unwinds)
<- {-# SCC "cmmNativeGen" #-}
cmmNativeGen dflags modLoc ncgImpl us fileIds dbgMap
cmmNativeGen logger dflags modLoc ncgImpl us fileIds dbgMap
cmm count
-- Generate .file directives for every new file that has been
......@@ -391,7 +396,7 @@ cmmNativeGens dflags config modLoc ncgImpl h dbgMap = go
pprDecl (f,n) = text "\t.file " <> ppr n <+>
pprFilePathString (unpackFS f)
emitNativeCode dflags config h $ vcat $
emitNativeCode logger dflags config h $ vcat $
map pprDecl newFileIds ++
map (pprNatCmmDecl ncgImpl) native
......@@ -416,14 +421,14 @@ cmmNativeGens dflags config modLoc ncgImpl h dbgMap = go
go us' cmms ngs' (count + 1)
emitNativeCode :: DynFlags -> NCGConfig -> BufHandle -> SDoc -> IO ()
emitNativeCode dflags config h sdoc = do
emitNativeCode :: Logger -> DynFlags -> NCGConfig -> BufHandle -> SDoc -> IO ()
emitNativeCode logger dflags config h sdoc = do
let ctx = ncgAsmContext config
{-# SCC "pprNativeCode" #-} bufLeftRenderSDoc ctx h sdoc
-- dump native code
dumpIfSet_dyn dflags
dumpIfSet_dyn logger dflags
Opt_D_dump_asm "Asm code" FormatASM
sdoc
......@@ -432,7 +437,8 @@ emitNativeCode dflags config h sdoc = do
-- Global conflict graph and NGC stats
cmmNativeGen
:: forall statics instr jumpDest. (Instruction instr, OutputableP Platform statics, Outputable jumpDest)
=> DynFlags
=> Logger
-> DynFlags
-> ModLocation
-> NcgImpl statics instr jumpDest
-> UniqSupply
......@@ -449,7 +455,7 @@ cmmNativeGen
, LabelMap [UnwindPoint] -- unwinding information for blocks
)
cmmNativeGen dflags modLoc ncgImpl us fileIds dbgMap cmm count
cmmNativeGen logger dflags modLoc ncgImpl us fileIds dbgMap cmm count
= do
let config = ncgConfig ncgImpl
let platform = ncgPlatform config
......@@ -469,7 +475,7 @@ cmmNativeGen dflags modLoc ncgImpl us fileIds dbgMap cmm count
{-# SCC "cmmToCmm" #-}
cmmToCmm config fixed_cmm
dumpIfSet_dyn dflags
dumpIfSet_dyn logger dflags
Opt_D_dump_opt_cmm "Optimised Cmm" FormatCMM