Add Cmm related hooks

* stgToCmm hook
* cmmToRawCmm hook

These hooks are used by Asterius and could be useful to other clients of
the GHC API.

It increases the Parser dependencies (test CountParserDeps) to 184. It's
still less than 200 which was the initial request (cf
https://mail.haskell.org/pipermail/ghc-devs/2019-September/018122.html)
so I think it's ok to merge this.

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 =