diff options
author | Alp Mestanogullari <alpmestan@gmail.com> | 2019-07-24 21:46:49 +0200 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2019-08-02 22:20:14 -0400 |
commit | 0c5cd771a8792ca4a4a553d3d4636e32191ef936 (patch) | |
tree | cf6c57187c5b399c98bcdcffa8a69c8e36017d0f | |
parent | 5e960287b74ce2e11be98dbf7c1dc4ce2d7e0d9a (diff) | |
download | haskell-0c5cd771a8792ca4a4a553d3d4636e32191ef936.tar.gz |
compiler: emit finer grained codegen events to eventlog
-rw-r--r-- | compiler/cmm/CmmInfo.hs | 13 | ||||
-rw-r--r-- | compiler/cmm/CmmPipeline.hs | 6 | ||||
-rw-r--r-- | compiler/codeGen/StgCmm.hs | 3 | ||||
-rw-r--r-- | compiler/main/CodeOutput.hs | 45 | ||||
-rw-r--r-- | compiler/nativeGen/AsmCodeGen.hs | 45 |
5 files changed, 64 insertions, 48 deletions
diff --git a/compiler/cmm/CmmInfo.hs b/compiler/cmm/CmmInfo.hs index 16ab6ed587..2f54aca74e 100644 --- a/compiler/cmm/CmmInfo.hs +++ b/compiler/cmm/CmmInfo.hs @@ -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). diff --git a/compiler/cmm/CmmPipeline.hs b/compiler/cmm/CmmPipeline.hs index a6d981a7f9..4ad93598aa 100644 --- a/compiler/cmm/CmmPipeline.hs +++ b/compiler/cmm/CmmPipeline.hs @@ -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]) diff --git a/compiler/codeGen/StgCmm.hs b/compiler/codeGen/StgCmm.hs index 6cdb14880a..83409b6b24 100644 --- a/compiler/codeGen/StgCmm.hs +++ b/compiler/codeGen/StgCmm.hs @@ -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) diff --git a/compiler/main/CodeOutput.hs b/compiler/main/CodeOutput.hs index 6f80df9676..4133526532 100644 --- a/compiler/main/CodeOutput.hs +++ b/compiler/main/CodeOutput.hs @@ -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 {- ************************************************************************ diff --git a/compiler/nativeGen/AsmCodeGen.hs b/compiler/nativeGen/AsmCodeGen.hs index 6e9450fd85..40a1e0b067 100644 --- a/compiler/nativeGen/AsmCodeGen.hs +++ b/compiler/nativeGen/AsmCodeGen.hs @@ -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. |