Commit d561c8f6 authored by Sylvain Henry's avatar Sylvain Henry Committed by Marge Bot

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.
parent 3c9dc06b
Pipeline #14215 failed with stages
in 501 minutes and 11 seconds
......@@ -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
......
......@@ -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
......
......@@ -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)
  • @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!

  • 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.

Please register or sign in to reply
parserDeps :: FilePath -> IO (UniqSet ModuleName)
parserDeps libdir =
......
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