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.

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

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

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 =

[Shayne Fletcher]

@hsyl20 It's a fair jump (in the wrong direction 😉) but, you are right, it's less than 200 so since this change is making the world a better place then let's do it!

[Sylvain Henry]

Yes sorry for that :/ Once the renaming is complete (#13009 (closed)) my plan is to try to reduce "wrong" dependencies between subparts of the compiler so I hope I'll manage to get a fair jump in the other direction.