Commit 0c5cd771 authored by Alp Mestanogullari's avatar Alp Mestanogullari Committed by Marge Bot

compiler: emit finer grained codegen events to eventlog

parent 5e960287
......@@ -48,6 +48,7 @@ import Hoopl.Collections
import GHC.Platform
import Maybes
import DynFlags
import ErrUtils (withTiming)
import Panic
import UniqSupply
import MonadUtils
......@@ -70,13 +71,17 @@ cmmToRawCmm :: DynFlags -> Stream IO CmmGroup ()
-> IO (Stream IO RawCmmGroup ())
cmmToRawCmm dflags cmms
= do { uniqs <- mkSplitUniqSupply 'i'
; let do_one uniqs cmm = do
case initUs uniqs $ concatMapM (mkInfoTable dflags) cmm of
(b,uniqs') -> return (uniqs',b)
-- NB. strictness fixes a space leak. DO NOT REMOVE.
; let do_one uniqs cmm =
-- NB. strictness fixes a space leak. DO NOT REMOVE.
withTiming (return dflags) (text "Cmm -> Raw Cmm") forceRes $
case initUs uniqs $ concatMapM (mkInfoTable dflags) cmm of
(b,uniqs') -> return (uniqs',b)
; return (Stream.mapAccumL do_one uniqs cmms >> return ())
}
where forceRes (uniqs, rawcmms) =
uniqs `seq` foldr (\decl r -> decl `seq` r) () rawcmms
-- Make a concrete info table, represented as a list of CmmStatic
-- (it can't be simply a list of Word, because the SRT field is
-- represented by a label+offset expression).
......
......@@ -39,7 +39,7 @@ cmmPipeline
-> CmmGroup -- Input C-- with Procedures
-> IO (ModuleSRTInfo, CmmGroup) -- Output CPS transformed C--
cmmPipeline hsc_env srtInfo prog =
cmmPipeline hsc_env srtInfo prog = withTiming (return dflags) (text "Cmm pipeline") forceRes $
do let dflags = hsc_dflags hsc_env
tops <- {-# SCC "tops" #-} mapM (cpsTop hsc_env) prog
......@@ -49,6 +49,10 @@ cmmPipeline hsc_env srtInfo prog =
return (srtInfo, cmms)
where forceRes (info, group) =
info `seq` foldr (\decl r -> decl `seq` r) () group
dflags = hsc_dflags hsc_env
cpsTop :: HscEnv -> CmmDecl -> IO (CAFEnv, [CmmDecl])
cpsTop _ p@(CmmData {}) = return (mapEmpty, [p])
......
......@@ -32,6 +32,7 @@ import CLabel
import StgSyn
import DynFlags
import ErrUtils
import HscTypes
import CostCentre
......@@ -70,7 +71,7 @@ codeGen dflags this_mod data_tycons
; cgref <- liftIO $ newIORef =<< initC
; let cg :: FCode () -> Stream IO CmmGroup ()
cg fcode = do
cmm <- liftIO $ do
cmm <- liftIO . withTiming (return dflags) (text "STG -> Cmm") (`seq` ()) $ do
st <- readIORef cgref
let (a,st') = runC dflags this_mod st (getCmm fcode)
......
......@@ -120,28 +120,29 @@ outputC dflags filenm cmm_stream packages
-- ToDo: make the C backend consume the C-- incrementally, by
-- pushing the cmm_stream inside (c.f. nativeCodeGen)
rawcmms <- Stream.collect cmm_stream
-- figure out which header files to #include in the generated .hc file:
--
-- * extra_includes from packages
-- * -#include options from the cmdline and OPTIONS pragmas
-- * the _stub.h file, if there is one.
--
let rts = getPackageDetails dflags rtsUnitId
let cc_injects = unlines (map mk_include (includes rts))
mk_include h_file =
case h_file of
'"':_{-"-} -> "#include "++h_file
'<':_ -> "#include "++h_file
_ -> "#include \""++h_file++"\""
let pkg_names = map installedUnitIdString packages
doOutput filenm $ \ h -> do
hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n")
hPutStr h cc_injects
writeCs dflags h rawcmms
withTiming (return dflags) (text "C codegen") id $ do
-- figure out which header files to #include in the generated .hc file:
--
-- * extra_includes from packages
-- * -#include options from the cmdline and OPTIONS pragmas
-- * the _stub.h file, if there is one.
--
let rts = getPackageDetails dflags rtsUnitId
let cc_injects = unlines (map mk_include (includes rts))
mk_include h_file =
case h_file of
'"':_{-"-} -> "#include "++h_file
'<':_ -> "#include "++h_file
_ -> "#include \""++h_file++"\""
let pkg_names = map installedUnitIdString packages
doOutput filenm $ \ h -> do
hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n")
hPutStr h cc_injects
writeCs dflags h rawcmms
{-
************************************************************************
......
......@@ -335,7 +335,7 @@ finishNativeGen :: Instruction instr
-> NativeGenAcc statics instr
-> IO UniqSupply
finishNativeGen dflags modLoc bufh@(BufHandle _ _ h) us ngs
= do
= withTiming (return dflags) (text "NCG") (`seq` ()) $ do
-- Write debug data and finish
let emitDw = debugLevel dflags > 0
us' <- if not emitDw then return us else do
......@@ -401,29 +401,34 @@ cmmNativeGenStream dflags this_mod modLoc ncgImpl h us cmm_stream ngs
},
us)
Right (cmms, cmm_stream') -> do
-- Generate debug information
let debugFlag = debugLevel dflags > 0
!ndbgs | debugFlag = cmmDebugGen modLoc cmms
| otherwise = []
dbgMap = debugToMap ndbgs
-- Generate native code
(ngs',us') <- cmmNativeGens dflags this_mod modLoc ncgImpl h
dbgMap us cmms ngs 0
-- Link native code information into debug blocks
-- See Note [What is this unwinding business?] in Debug.
let !ldbgs = cmmDebugLink (ngs_labels ngs') (ngs_unwinds ngs') ndbgs
dumpIfSet_dyn dflags Opt_D_dump_debug "Debug Infos"
(vcat $ map ppr ldbgs)
-- Accumulate debug information for emission in finishNativeGen.
let ngs'' = ngs' { ngs_debug = ngs_debug ngs' ++ ldbgs, ngs_labels = [] }
(us', ngs'') <-
withTiming (return dflags)
ncglabel (\(a, b) -> a `seq` b `seq` ()) $ do
-- Generate debug information
let debugFlag = debugLevel dflags > 0
!ndbgs | debugFlag = cmmDebugGen modLoc cmms
| otherwise = []
dbgMap = debugToMap ndbgs
-- Generate native code
(ngs',us') <- cmmNativeGens dflags this_mod modLoc ncgImpl h
dbgMap us cmms ngs 0
-- Link native code information into debug blocks
-- See Note [What is this unwinding business?] in Debug.
let !ldbgs = cmmDebugLink (ngs_labels ngs') (ngs_unwinds ngs') ndbgs
dumpIfSet_dyn dflags Opt_D_dump_debug "Debug Infos"
(vcat $ map ppr ldbgs)
-- Accumulate debug information for emission in finishNativeGen.
let ngs'' = ngs' { ngs_debug = ngs_debug ngs' ++ ldbgs, ngs_labels = [] }
return (us', ngs'')
cmmNativeGenStream dflags this_mod modLoc ncgImpl h us'
cmm_stream' ngs''
where ncglabel = text "NCG"
-- | Do native code generation on all these cmms.
--
cmmNativeGens :: forall statics instr jumpDest.
......
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