1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
|
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ScopedTypeVariables #-}
module LoadCmmGroup
( loadPath
, loadCmm
, loadHs
)
where
-- Read a .hs or .cmm file and convert it to a list of `CmmGroup`s.
import Control.Monad.IO.Class
import System.FilePath as FilePath
import System.IO
import GHC
import GHC.Cmm
import GHC.Cmm.Parser
import GHC.Core.Lint.Interactive
import GHC.Core.TyCon
import GHC.CoreToStg
import GHC.CoreToStg.Prep
import GHC.Data.Stream hiding (mapM, map)
import GHC.Driver.Config.Cmm.Parser (initCmmParserConfig)
import GHC.Driver.Config.CoreToStg.Prep
import GHC.Driver.Config.StgToCmm (initStgToCmmConfig)
import GHC.Driver.Env
import GHC.Driver.Errors.Types
import GHC.Driver.Main
import GHC.Stg.FVs
import GHC.Stg.Syntax
import GHC.StgToCmm (codeGen)
import GHC.Types.CostCentre (emptyCollectedCCs)
import GHC.Types.HpcInfo (emptyHpcInfo)
import GHC.Types.IPE (emptyInfoTableProvMap)
import GHC.Unit.Home
import GHC.Unit.Module.ModGuts
import GHC.Utils.Error
import GHC.Utils.Misc (fstOf3)
import GHC.Utils.Outputable
loadPath :: FilePath -> Ghc [CmmGroup]
loadPath path =
case takeExtension path of
".hs" -> loadHs path
".cmm" -> fmap (: []) $ loadCmm path
_ -> do liftIO $ hPutStrLn stderr $ "File with unknown extension: " ++ path
return []
loadHs :: FilePath -> Ghc [CmmGroup]
loadHs path = do
target <- guessTarget path Nothing Nothing
setTargets [target]
mgraph <- depanal [] False
fmap concat $ mapM cmmOfSummary $ mgModSummaries mgraph
cmmOfSummary :: ModSummary -> GHC.Ghc [CmmGroup]
cmmOfSummary summ = do
dflags <- getSessionDynFlags
env <- getSession
guts <- liftIO $ frontend dflags env summ
stg <- stgify summ guts
logger <- getLogger
let infotable = emptyInfoTableProvMap
tycons = []
ccs = emptyCollectedCCs
stg' = depSortWithAnnotStgPgm (ms_mod summ) stg
hpcinfo = emptyHpcInfo False
tmpfs = hsc_tmpfs env
stg_to_cmm dflags mod = codeGen logger tmpfs (initStgToCmmConfig dflags mod)
(groups, _infos) <-
liftIO $
collectAll $
stg_to_cmm dflags (ms_mod summ) infotable tycons ccs stg' hpcinfo
return groups
frontend :: DynFlags -> HscEnv -> ModSummary -> IO ModGuts
frontend _dflags env summary = do
parsed <- hscParse env summary
(checked, _) <- hscTypecheckRename env summary parsed
hscDesugar env summary checked >>= hscSimplify env []
loadCmm :: FilePath -> Ghc CmmGroup
loadCmm path = do
env <- getSession
liftIO (slurpCmm env path)
stgify :: ModSummary -> ModGuts -> Ghc [StgTopBinding]
stgify summary guts = do
hsc_env <- getSession
let dflags = hsc_dflags hsc_env
prepd_binds <- liftIO $ do
cp_cfg <- initCorePrepConfig hsc_env
corePrepPgm (hsc_logger hsc_env) cp_cfg (initCorePrepPgmConfig dflags (interactiveInScope $ hsc_IC hsc_env)) this_mod location core_binds data_tycons
return $ fstOf3 $ coreToStg dflags (ms_mod summary) (ms_location summary) prepd_binds
where this_mod = mg_module guts
location = ms_location summary
core_binds = mg_binds guts
data_tycons = filter isDataTyCon tycons
tycons = mg_tcs guts
slurpCmm :: HscEnv -> FilePath -> IO (CmmGroup)
slurpCmm hsc_env filename = runHsc hsc_env $ do
let dflags = hsc_dflags hsc_env
let logger = hsc_logger hsc_env
let home_unit = hsc_home_unit hsc_env
-- Make up a module name to give the NCG. We can't pass bottom here
-- lest we reproduce #11784.
mod_name = mkModuleName $ "Cmm$" ++ FilePath.takeFileName filename
cmm_mod = mkHomeModule home_unit mod_name
cmmpConfig = initCmmParserConfig dflags
(cmm, _) <- ioMsgMaybe
$ do
(warns,errs,cmm) <- withTiming logger (text "ParseCmm"<+>brackets (text filename)) (\_ -> ())
$ parseCmmFile cmmpConfig cmm_mod home_unit filename
let msgs = warns `unionMessages` errs
return (GhcPsMessage <$> msgs, cmm)
return cmm
collectAll :: Monad m => Stream m a b -> m ([a], b)
collectAll = gobble . runStream
where gobble (Done b) = return ([], b)
gobble (Effect e) = e >>= gobble
gobble (Yield a s) = do (as, b) <- gobble s
return (a:as, b)
|
