/
Impl.hs
109 lines (98 loc) · 3.44 KB
/
Impl.hs
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
{-# LANGUAGE FlexibleInstances, CPP, PatternGuards #-}
-- | Lower level building blocks for custom code generation.
module Language.Haskell.GHC.Simple.Impl (
Ghc, PkgKey,
liftIO,
toSimplifiedStg,
toModMetadata,
modulePkgKey, pkgKeyString
) where
-- GHC scaffolding
import BinIface
import GHC hiding (Warning)
import GhcMonad (liftIO)
import HscMain
import HscTypes
import TidyPgm
import CorePrep
import StgSyn
import CoreSyn
import CoreToStg
import SimplStg
import DriverPipeline
#if __GLASGOW_HASKELL__ >= 800
import qualified Module as M (moduleUnitId, unitIdString, UnitId)
#elif __GLASGOW_HASKELL__ >= 710
import qualified Module as M (modulePackageKey, packageKeyString, PackageKey)
#else
import qualified Module as M (modulePackageId, packageIdString, PackageId)
#endif
import Control.Monad
import Data.IORef
import System.FilePath (takeDirectory)
import System.Directory (doesFileExist, createDirectoryIfMissing)
import Language.Haskell.GHC.Simple.Types
instance Intermediate [StgTopBinding] where
prepare = toSimplifiedStg
instance Intermediate CgGuts where
prepare _ = return
instance Intermediate CoreProgram where
prepare ms cgguts = do
env <- hsc_env `fmap` getPipeState
liftIO $ prepareCore env (hsc_dflags env) ms cgguts
-- | Package ID/key of a module.
modulePkgKey :: Module -> PkgKey
-- | String representation of a package ID/key.
pkgKeyString :: PkgKey -> String
#if __GLASGOW_HASKELL__ >= 800
-- | Synonym for 'M.UnitId', to bridge a slight incompatibility between
-- GHC 7.8/7.10/8.0.
type PkgKey = M.UnitId
modulePkgKey = M.moduleUnitId
pkgKeyString = M.unitIdString
#elif __GLASGOW_HASKELL__ >= 710
-- | Synonym for 'M.PackageKey', to bridge a slight incompatibility between
-- GHC 7.8 and 7.10.
type PkgKey = M.PackageKey
modulePkgKey = M.modulePackageKey
pkgKeyString = M.packageKeyString
#else
-- | Synonym for 'M.PackageId', to bridge a slight incompatibility between
-- GHC 7.8 and 7.10.
type PkgKey = M.PackageId
modulePkgKey = M.modulePackageId
pkgKeyString = M.packageIdString
#endif
-- | Build a 'ModMetadata' out of a 'ModSummary'.
toModMetadata :: CompConfig
-> ModSummary
-> ModMetadata
toModMetadata cfg ms = ModMetadata {
mmSummary = ms,
mmName = moduleNameString $ ms_mod_name ms,
mmPackageKey = pkgKeyString . modulePkgKey $ ms_mod ms,
mmSourceIsHsBoot = ms_hsc_src ms == HsBootFile,
mmSourceFile = ml_hs_file $ ms_location ms,
mmInterfaceFile = ml_hi_file $ ms_location ms
}
-- | Compile a 'ModSummary' into a list of simplified 'StgBinding's.
-- See <https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/StgSynType>
-- for more information about STG and how it relates to core and Haskell.
toSimplifiedStg :: ModSummary -> CgGuts -> CompPipeline [StgTopBinding]
toSimplifiedStg ms cgguts = do
env <- hsc_env `fmap` getPipeState
let dfs = hsc_dflags env
liftIO $ do
prog <- prepareCore env dfs ms cgguts
let stg = fst $ coreToStg dfs (ms_mod ms) prog
stg2stg dfs stg
-- | Prepare a core module for code generation.
prepareCore :: HscEnv -> DynFlags -> ModSummary -> CgGuts -> IO CoreProgram
prepareCore env dfs _ms p = do
#if __GLASGOW_HASKELL__ >= 800
liftIO $ fst <$> corePrepPgm env (ms_mod _ms) (ms_location _ms) (cg_binds p) (cg_tycons p)
#elif __GLASGOW_HASKELL__ >= 710
liftIO $ corePrepPgm env (ms_location _ms) (cg_binds p) (cg_tycons p)
#else
liftIO $ corePrepPgm dfs env (cg_binds p) (cg_tycons p)
#endif