diff options
| -rw-r--r-- | compiler/main/Hooks.hs | 14 | ||||
| -rw-r--r-- | compiler/main/HscMain.hs | 10 | ||||
| -rw-r--r-- | testsuite/tests/parser/should_run/CountParserDeps.hs | 2 |
3 files changed, 21 insertions, 5 deletions
diff --git a/compiler/main/Hooks.hs b/compiler/main/Hooks.hs index a562b3e33f..d5ced7d5a0 100644 --- a/compiler/main/Hooks.hs +++ b/compiler/main/Hooks.hs @@ -21,6 +21,8 @@ module Hooks ( Hooks , runRnSpliceHook , getValueSafelyHook , createIservProcessHook + , stgToCmmHook + , cmmToRawCmmHook ) where import GhcPrelude @@ -43,6 +45,12 @@ import SrcLoc import Type import System.Process import BasicTypes +import Module +import TyCon +import CostCentre +import GHC.Stg.Syntax +import Stream +import Cmm import GHC.Hs.Extension import Data.Maybe @@ -73,6 +81,8 @@ emptyHooks = Hooks , runRnSpliceHook = Nothing , getValueSafelyHook = Nothing , createIservProcessHook = Nothing + , stgToCmmHook = Nothing + , cmmToRawCmmHook = Nothing } data Hooks = Hooks @@ -95,6 +105,10 @@ data Hooks = Hooks , getValueSafelyHook :: Maybe (HscEnv -> Name -> Type -> IO (Maybe HValue)) , createIservProcessHook :: Maybe (CreateProcess -> IO ProcessHandle) + , stgToCmmHook :: Maybe (DynFlags -> Module -> [TyCon] -> CollectedCCs + -> [CgStgTopBinding] -> HpcInfo -> Stream IO CmmGroup ()) + , cmmToRawCmmHook :: Maybe (DynFlags -> Maybe Module -> Stream IO CmmGroup () + -> IO (Stream IO RawCmmGroup ())) } getHooked :: (Functor f, HasDynFlags f) => (Hooks -> Maybe a) -> a -> f a diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index 7d99c467c1..e98184e056 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -74,7 +74,7 @@ module HscMain , hscCompileCoreExpr' -- We want to make sure that we export enough to be able to redefine -- hscFileFrontEnd in client code - , hscParse', hscSimplify', hscDesugar', tcRnModule' + , hscParse', hscSimplify', hscDesugar', tcRnModule', doCodeGen , getHscEnv , hscSimpleIface' , oneShotMsg @@ -1454,7 +1454,8 @@ hscGenHardCode hsc_env cgguts location output_filename = do ------------------ Code output ----------------------- rawcmms0 <- {-# SCC "cmmToRawCmm" #-} - cmmToRawCmm dflags cmms + lookupHook cmmToRawCmmHook + (\dflg _ -> cmmToRawCmm dflg) dflags dflags (Just this_mod) cmms let dump a = do unless (null a) $ @@ -1516,7 +1517,8 @@ hscCompileCmmFile hsc_env filename output_filename = runHsc hsc_env $ do unless (null cmmgroup) $ dumpIfSet_dyn dflags Opt_D_dump_cmm "Output Cmm" FormatCMM (ppr cmmgroup) - rawCmms <- cmmToRawCmm dflags (Stream.yield cmmgroup) + rawCmms <- lookupHook cmmToRawCmmHook + (\dflgs _ -> cmmToRawCmm dflgs) dflags dflags Nothing (Stream.yield cmmgroup) _ <- codeOutput dflags cmm_mod output_filename no_loc NoStubs [] [] rawCmms return () @@ -1544,7 +1546,7 @@ doCodeGen hsc_env this_mod data_tycons let cmm_stream :: Stream IO CmmGroup () cmm_stream = {-# SCC "StgToCmm" #-} - StgToCmm.codeGen dflags this_mod data_tycons + lookupHook stgToCmmHook StgToCmm.codeGen dflags dflags this_mod data_tycons cost_centre_info stg_binds_w_fvs hpc_info -- codegen consumes a stream of CmmGroup, and produces a new diff --git a/testsuite/tests/parser/should_run/CountParserDeps.hs b/testsuite/tests/parser/should_run/CountParserDeps.hs index 67a2eef8c8..b035c98e0d 100644 --- a/testsuite/tests/parser/should_run/CountParserDeps.hs +++ b/testsuite/tests/parser/should_run/CountParserDeps.hs @@ -31,7 +31,7 @@ main = do let num = sizeUniqSet modules -- print num -- print (map moduleNameString $ nonDetEltsUniqSet modules) - unless (num < 165) $ exitWith (ExitFailure num) + unless (num < 190) $ exitWith (ExitFailure num) parserDeps :: FilePath -> IO (UniqSet ModuleName) parserDeps libdir = |