├── .gitignore ├── .travis.yml ├── LICENSE ├── README.md ├── Setup.hs ├── ghc-simple.cabal └── src └── Language └── Haskell └── GHC ├── Simple.hs └── Simple ├── Impl.hs ├── PrimIface.hs └── Types.hs /.gitignore: -------------------------------------------------------------------------------- 1 | .* 2 | *~ 3 | \#* 4 | *.hi 5 | *.o 6 | dist/ 7 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: haskell 2 | 3 | ghc: 4 | - 8.4.4 5 | - 8.6.3 6 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015 Anton Ekblad 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included 12 | in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ghc-simple 2 | ========== 3 | 4 | The GHC API is a great tool for working with Haskell code. Unfortunately, it's 5 | also fairly opaque and hard to get started with. This library abstracts away 6 | the intricacies of working with the GHC API, giving a general, no-nonsense way 7 | to extract highly optimized (or not, depending on your use case) Core, STG, 8 | custom intermediate code, and other information from Haskell code. 9 | 10 | 11 | TODO 12 | ---- 13 | 14 | * Caching and loading generated code on demand based on symbol (and/or module) 15 | dependencies. 16 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /ghc-simple.cabal: -------------------------------------------------------------------------------- 1 | name: ghc-simple 2 | version: 0.4 3 | synopsis: Simplified interface to the GHC API. 4 | description: The GHC API is a great tool for working with Haskell code. 5 | Unfortunately, it's also fairly opaque and hard to get 6 | started with. This library abstracts away the intricacies 7 | of working with the GHC API, giving a general, no-nonsense 8 | way to extract highly optimized (or not, depending on your 9 | use case) Core, STG, custom intermediate code, and other 10 | information from Haskell code. 11 | homepage: https://github.com/valderman/ghc-simple 12 | license: MIT 13 | license-file: LICENSE 14 | author: Anton Ekblad 15 | maintainer: anton@ekblad.cc 16 | copyright: © 2015, 2016 Anton Ekblad 17 | category: Development 18 | build-type: Simple 19 | cabal-version: >=1.10 20 | 21 | source-repository head 22 | type: git 23 | location: https://github.com/valderman/ghc-simple.git 24 | 25 | library 26 | exposed-modules: 27 | Language.Haskell.GHC.Simple, 28 | Language.Haskell.GHC.Simple.Impl 29 | Language.Haskell.GHC.Simple.PrimIface 30 | Language.Haskell.GHC.Simple.Types 31 | other-extensions: 32 | CPP, PatternGuards, FlexibleInstances 33 | build-depends: 34 | ghc >=8.4 && <8.7, 35 | base >=4.7 && <5, 36 | ghc-paths >=0.1 && <0.2, 37 | directory >=1.3 && <1.4, 38 | filepath >=1.3 && <1.5, 39 | bytestring >=0.10 && <0.11, 40 | binary >=0.6 && <0.9 41 | hs-source-dirs: 42 | src 43 | default-language: 44 | Haskell2010 45 | 46 | -------------------------------------------------------------------------------- /src/Language/Haskell/GHC/Simple.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP, PatternGuards #-} 2 | -- | Simplified interface to the GHC API. 3 | module Language.Haskell.GHC.Simple ( 4 | -- * Entry points 5 | compile, compileWith, compileFold, 6 | 7 | -- * Configuration, input and output types 8 | module Simple.Types, 9 | getDynFlagsForConfig, 10 | 11 | -- * GHC re-exports for processing STG and Core 12 | module CoreSyn, module StgSyn, module Module, 13 | module Id, module IdInfo, module Var, module Literal, module DataCon, 14 | module OccName, module Name, 15 | module Type, module TysPrim, module TyCon, 16 | module ForeignCall, module PrimOp, 17 | module DynFlags, module SrcLoc, 18 | module DriverPhases, 19 | ModSummary (..), ModGuts (..), 20 | PkgKey, 21 | pkgKeyString, modulePkgKey 22 | ) where 23 | 24 | -- GHC scaffolding 25 | import GHC hiding (Warning) 26 | import GhcMonad (liftIO) 27 | import DynFlags 28 | import HscTypes 29 | import ErrUtils 30 | import Bag 31 | import SrcLoc 32 | import Outputable 33 | import Hooks 34 | import DriverPhases 35 | import DriverPipeline 36 | 37 | -- Convenience re-exports for fiddling with STG 38 | import StgSyn 39 | import CoreSyn 40 | import Name hiding (varName) 41 | import Type 42 | import TysPrim 43 | import TyCon 44 | import Literal 45 | import Var hiding (setIdExported, setIdNotExported, lazySetIdInfo) 46 | import Id 47 | import IdInfo 48 | import OccName hiding (varName) 49 | import DataCon 50 | import ForeignCall 51 | import PrimOp 52 | import Module 53 | 54 | -- Misc. stuff 55 | import Data.Binary 56 | import qualified Data.ByteString.Lazy as BS 57 | import Data.IORef 58 | import Control.Monad 59 | import GHC.Paths (libdir) 60 | import System.Directory 61 | import System.FilePath 62 | import System.IO 63 | import System.IO.Unsafe 64 | 65 | -- Internals 66 | import Language.Haskell.GHC.Simple.PrimIface as Simple.PrimIface 67 | import Language.Haskell.GHC.Simple.Types as Simple.Types 68 | import Language.Haskell.GHC.Simple.Impl 69 | 70 | -- | Compile a list of targets and their dependencies into intermediate code. 71 | -- Uses settings from the the default 'CompConfig'. 72 | compile :: (Intermediate a, Binary b) 73 | => (ModMetadata -> a -> IO b) 74 | -- ^ Compilation function from some intermediate language to the 75 | -- desired output. The output type needs to be an instance of 76 | -- 'Binary', as it will be cached after compilation to speed up 77 | -- future recompilation. 78 | -- This function is called once per module. Due to caching of modules 79 | -- which don't need to be recompiled, it will not necessarily be 80 | -- called once per module included in the return value of @compile@. 81 | -> [String] 82 | -- ^ List of compilation targets. A target can be either a module 83 | -- or a file name. 84 | -> IO (CompResult [CompiledModule b]) 85 | compile = compileWith defaultConfig 86 | 87 | -- | Compile a list of targets and their dependencies using a custom 88 | -- configuration. 89 | compileWith :: (Intermediate a, Binary b) 90 | => CompConfig 91 | -- ^ GHC pipeline configuration. 92 | -> (ModMetadata -> a -> IO b) 93 | -- ^ Compilation function. 94 | -> [String] 95 | -- ^ List of compilation targets. A target can be either a module 96 | -- or a file name. Targets may also be read from the specified 97 | -- 'CompConfig', if 'cfgUseTargetsFromFlags' is set. 98 | -> IO (CompResult [CompiledModule b]) 99 | compileWith cfg comp = compileFold cfg comp consMod [] 100 | 101 | consMod :: [CompiledModule a] -> CompiledModule a -> IO [CompiledModule a] 102 | consMod xs x = return (x:xs) 103 | 104 | -- | Obtain the dynamic flags and extra targets that would be used to compile 105 | -- anything with the given config. 106 | getDynFlagsForConfig :: CompConfig -> IO (DynFlags, [String]) 107 | getDynFlagsForConfig cfg = do 108 | ws <- newIORef [] 109 | runGhc (maybe (Just libdir) Just (cfgGhcLibDir cfg)) $ do 110 | setDFS cfg (cfgGhcFlags cfg) ws noComp 111 | 112 | noComp :: FilePath -> ModSummary -> CgGuts -> CompPipeline () 113 | noComp _ _ _ = return () 114 | 115 | -- | Set and return the appropriate dynflags and extra targets for the given 116 | -- config. 117 | setDFS :: CompConfig -- ^ Compilation configuration. 118 | -> [String] -- ^ Dynamic GHC command line flags. 119 | -> IORef [Warning] -- ^ IORef to use for logging warnings. 120 | -> (FilePath -> ModSummary -> CgGuts -> CompPipeline ()) 121 | -- ^ Per-module compilation function. 122 | -> Ghc (DynFlags, [String]) 123 | setDFS cfg flags warns comp = do 124 | -- Parse and update dynamic flags 125 | dfs <- getSessionDynFlags 126 | (dfs', files2, _dynwarns) <- parseDynamicFlags dfs (map noLoc flags) 127 | let ps = cfgStopPhases cfg 128 | dfs'' = cfgUpdateDynFlags cfg $ dfs' { 129 | log_action = logger (log_action dfs') warns, 130 | hooks = (hooks dfs') {runPhaseHook = Just $ phaseHook ps} 131 | } 132 | 133 | -- Update prim interface hook name and cache if we're using a custom 134 | -- GHC.Prim interface, setting the dynflags in the process. 135 | case cfgCustomPrimIface cfg of 136 | Just (nfo, strs) -> setPrimIface dfs'' nfo strs 137 | _ -> void $ setSessionDynFlags dfs'' 138 | finaldfs <- getSessionDynFlags 139 | return (finaldfs, map unLoc files2) 140 | where 141 | #if __GLASGOW_HASKELL__ >= 800 142 | #define LOG(dfs,sev,span,sty,msg) (deflog dfs reason sev span sty msg) 143 | logger deflog warns dfs reason severity srcspan style msg 144 | #else 145 | #define LOG(dfs,sev,span,sty,msg) (deflog dfs sev span sty msg) 146 | logger deflog warns dfs severity srcspan style msg 147 | #endif 148 | | cfgUseGhcErrorLogger cfg = do 149 | #if __GLASGOW_HASKELL__ >= 800 150 | logger' deflog warns dfs reason severity srcspan style msg 151 | #else 152 | logger' deflog warns dfs severity srcspan style msg 153 | #endif 154 | -- Messages other than warnings and errors are already logged by GHC 155 | -- by default. 156 | case severity of 157 | SevWarning -> LOG(dfs, severity, srcspan, style, msg) 158 | SevError -> LOG(dfs, severity, srcspan, style, msg) 159 | _ -> return () 160 | | otherwise = do 161 | #if __GLASGOW_HASKELL__ >= 800 162 | logger' deflog warns dfs reason severity srcspan style msg 163 | #else 164 | logger' deflog warns dfs severity srcspan style msg 165 | #endif 166 | 167 | -- Collect warnings and supress errors, since we're collecting those 168 | -- separately. 169 | #if __GLASGOW_HASKELL__ >= 800 170 | logger' _ w dfs _ SevWarning srcspan _style msg = do 171 | liftIO $ atomicModifyIORef' w $ \ws -> 172 | (Warning srcspan (showSDoc dfs msg) : ws, ()) 173 | logger' _ _ _ _ SevError _ _ _ = do 174 | return () 175 | logger' output _ dfs reason sev srcspan style msg = do 176 | output dfs reason sev srcspan style msg 177 | #else 178 | logger' _ w dfs SevWarning srcspan _style msg = do 179 | liftIO $ atomicModifyIORef' w $ \ws -> 180 | (Warning srcspan (showSDoc dfs msg) : ws, ()) 181 | logger' _ _ _ SevError _ _ _ = do 182 | return () 183 | logger' output _ dfs sev srcspan style msg = do 184 | output dfs sev srcspan style msg 185 | #endif 186 | 187 | setPrimIface dfs nfo strs = do 188 | void $ setSessionDynFlags dfs { 189 | hooks = (hooks dfs) {ghcPrimIfaceHook = Just $ primIface nfo strs} 190 | } 191 | getSession >>= liftIO . fixPrimopTypes nfo strs 192 | 193 | -- TODO: get rid of the @runPhase@ from the HscOut phase 194 | phaseHook _ p@(HscOut src mod_name result) inp dfs = do 195 | loc <- getLocation src mod_name 196 | setModLocation loc 197 | let next = hscPostBackendPhase dfs src (hscTarget dfs) 198 | case result of 199 | HscRecomp cgguts ms -> do 200 | outfile <- phaseOutputFilename next 201 | comp (ml_hi_file loc) ms cgguts 202 | runPhase p inp dfs 203 | _ -> 204 | runPhase p inp dfs 205 | phaseHook stop (RealPhase p) inp _ | p `elem` stop = 206 | return (RealPhase StopLn, inp) 207 | phaseHook _ p inp dfs = 208 | runPhase p inp dfs 209 | 210 | -- | Write a module to cache file. 211 | writeModCache :: Binary a => CompConfig -> ModSummary -> a -> IO () 212 | writeModCache cfg ms m = do 213 | createDirectoryIfMissing True (takeDirectory cachefile) 214 | BS.writeFile cachefile (encode m) 215 | where 216 | cachefile = cacheFileFor cfg (ms_mod_name ms) 217 | 218 | -- | Read a module from cache file. 219 | readModCache :: Binary a 220 | => CompConfig 221 | -> ModMetadata 222 | -> [Target] 223 | -> IO (CompiledModule a) 224 | readModCache cfg meta tgts = do 225 | m <- decode `fmap` BS.readFile cachefile 226 | return $ CompiledModule m meta (mmSummary meta `isTarget` tgts) 227 | where 228 | cachefile = cacheFileFor cfg (ms_mod_name (mmSummary meta)) 229 | 230 | -- | Get the cache file for the given 'ModSummary' under the given 231 | -- configuration. 232 | cacheFileFor :: CompConfig -> ModuleName -> FilePath 233 | cacheFileFor cfg name = 234 | maybe "" id (cfgCacheDirectory cfg) modfile 235 | where 236 | modfile = moduleNameSlashes name <.> cfgCacheFileExt cfg 237 | 238 | -- | Left fold over a list of compilation targets and their dependencies. 239 | -- 240 | -- Sometimes you don't just want a huge pile of intermediate code lying 241 | -- around; chances are you either want to dump it to file or combine it with 242 | -- some other intermediate code, without having to keep it all in memory at 243 | -- the same time. 244 | compileFold :: (Intermediate a, Binary b) 245 | => CompConfig 246 | -- ^ GHC pipeline configuration. 247 | -> (ModMetadata -> a -> IO b) 248 | -- ^ Per module compilation function. 249 | -> (acc -> CompiledModule b -> IO acc) 250 | -- ^ Folding function. 251 | -> acc 252 | -- ^ Initial accumulator. 253 | -> [String] 254 | -- ^ List of compilation targets. A target can be either a module 255 | -- or a file name. Targets may also be read from the specified 256 | -- 'CompConfig', if 'cfgUseTargetsFromFlags' is set. 257 | -> IO (CompResult acc) 258 | compileFold cfg comp f acc files = do 259 | warns <- newIORef [] -- all warnings produced by GHC 260 | runGhc (maybe (Just libdir) Just (cfgGhcLibDir cfg)) $ do 261 | (_, files2) <- setDFS cfg dfs warns compileToCache 262 | ecode <- genCode cfg f acc (files ++ files2) 263 | ws <- liftIO $ readIORef warns 264 | case ecode of 265 | Right (finaldfs, code) -> 266 | return Success { 267 | compResult = code, 268 | compWarnings = ws, 269 | compDynFlags = finaldfs 270 | } 271 | Left es -> 272 | return Failure { 273 | compErrors = es, 274 | compWarnings = ws 275 | } 276 | where 277 | dfs = cfgGhcFlags cfg 278 | compileToCache hifile ms cgguts = do 279 | source <- prepare ms cgguts 280 | liftIO $ comp (toModMetadata cfg ms) source >>= writeModCache cfg ms 281 | 282 | -- | Is @ms@ in the list of targets? 283 | isTarget :: ModSummary -> [Target] -> Bool 284 | isTarget ms = any (`isTargetOf` ms) 285 | 286 | -- | Is @t@ the target that corresponds to @ms@? 287 | isTargetOf :: Target -> ModSummary -> Bool 288 | isTargetOf t ms = 289 | case targetId t of 290 | TargetModule mn -> ms_mod_name ms == mn 291 | TargetFile fn _ 292 | | ModLocation (Just f) _ _ <- ms_location ms -> f == fn 293 | _ -> False 294 | 295 | -- | Map a compilation function over each 'ModSummary' in the dependency graph 296 | -- of a list of targets. 297 | genCode :: (GhcMonad m, Binary b) 298 | => CompConfig 299 | -> (a -> CompiledModule b -> IO a) 300 | -> a 301 | -> [String] 302 | -> m (Either [Error] (DynFlags, a)) 303 | genCode cfg f acc files = do 304 | dfs <- getSessionDynFlags 305 | eerrs <- handleSourceError (maybeErrors dfs) $ do 306 | ts <- mapM (flip guessTarget Nothing) files 307 | setTargets ts 308 | 309 | -- Compile all modules; if cached code file is gone, then force 310 | -- recompilation 311 | (loads, mss) <- do 312 | loads <- load LoadAllTargets 313 | mss <- mgModSummaries <$> depanal [] False 314 | recomp <- filterM needRecomp mss 315 | if null recomp 316 | then return (loads, mss) 317 | else do 318 | mapM_ (liftIO . removeFile . ml_obj_file . ms_location) recomp 319 | loads' <- load LoadAllTargets 320 | mss' <- mgModSummaries <$> depanal [] False 321 | return (loads', mss') 322 | 323 | acc' <- liftIO $ foldM (loadCachedMod ts) acc mss 324 | return $ if succeeded loads then Right acc' else Left [] 325 | case eerrs of 326 | Left errs -> return $ Left errs 327 | Right acc -> return $ Right (dfs, acc) 328 | where 329 | needRecomp = 330 | liftIO . fmap not . doesFileExist . cacheFileFor cfg . ms_mod_name 331 | loadCachedMod tgts acc ms = 332 | readModCache cfg (toModMetadata cfg ms) tgts >>= f acc 333 | 334 | maybeErrors dfs 335 | | cfgUseGhcErrorLogger cfg = \srcerr -> liftIO $ do 336 | let msgs = srcErrorMessages srcerr 337 | printBagOfErrors dfs msgs 338 | return . Left . map (fromErrMsg dfs) $ bagToList msgs 339 | | otherwise = 340 | return . Left . map (fromErrMsg dfs) . bagToList . srcErrorMessages 341 | 342 | fromErrMsg :: DynFlags -> ErrMsg -> Error 343 | fromErrMsg dfs e = Error { 344 | errorSpan = errMsgSpan e, 345 | #if __GLASGOW_HASKELL__ >= 800 346 | errorMessage = showSDocForUser dfs ctx (pprLocErrMsg e), 347 | errorExtraInfo = "" 348 | #else 349 | errorMessage = showSDocForUser dfs ctx (errMsgShortDoc e), 350 | errorExtraInfo = showSDocForUser dfs ctx (errMsgExtraInfo e) 351 | #endif 352 | } 353 | where 354 | ctx = errMsgContext e 355 | -------------------------------------------------------------------------------- /src/Language/Haskell/GHC/Simple/Impl.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances, CPP, PatternGuards #-} 2 | -- | Lower level building blocks for custom code generation. 3 | module Language.Haskell.GHC.Simple.Impl ( 4 | Ghc, PkgKey, 5 | liftIO, 6 | toSimplifiedStg, 7 | toModMetadata, 8 | modulePkgKey, pkgKeyString 9 | ) where 10 | 11 | -- GHC scaffolding 12 | import BinIface 13 | import GHC hiding (Warning) 14 | import GhcMonad (liftIO) 15 | import HscMain 16 | import HscTypes 17 | import TidyPgm 18 | import CorePrep 19 | import StgSyn 20 | import CoreSyn 21 | import CoreToStg 22 | import SimplStg 23 | import DriverPipeline 24 | #if __GLASGOW_HASKELL__ >= 800 25 | import qualified Module as M (moduleUnitId, unitIdString, UnitId) 26 | #elif __GLASGOW_HASKELL__ >= 710 27 | import qualified Module as M (modulePackageKey, packageKeyString, PackageKey) 28 | #else 29 | import qualified Module as M (modulePackageId, packageIdString, PackageId) 30 | #endif 31 | 32 | import Control.Monad 33 | import Data.IORef 34 | import System.FilePath (takeDirectory) 35 | import System.Directory (doesFileExist, createDirectoryIfMissing) 36 | import Language.Haskell.GHC.Simple.Types 37 | 38 | instance Intermediate [StgTopBinding] where 39 | prepare = toSimplifiedStg 40 | 41 | instance Intermediate CgGuts where 42 | prepare _ = return 43 | 44 | instance Intermediate CoreProgram where 45 | prepare ms cgguts = do 46 | env <- hsc_env `fmap` getPipeState 47 | liftIO $ prepareCore env (hsc_dflags env) ms cgguts 48 | 49 | -- | Package ID/key of a module. 50 | modulePkgKey :: Module -> PkgKey 51 | 52 | -- | String representation of a package ID/key. 53 | pkgKeyString :: PkgKey -> String 54 | 55 | #if __GLASGOW_HASKELL__ >= 800 56 | -- | Synonym for 'M.UnitId', to bridge a slight incompatibility between 57 | -- GHC 7.8/7.10/8.0. 58 | type PkgKey = M.UnitId 59 | modulePkgKey = M.moduleUnitId 60 | pkgKeyString = M.unitIdString 61 | #elif __GLASGOW_HASKELL__ >= 710 62 | -- | Synonym for 'M.PackageKey', to bridge a slight incompatibility between 63 | -- GHC 7.8 and 7.10. 64 | type PkgKey = M.PackageKey 65 | modulePkgKey = M.modulePackageKey 66 | pkgKeyString = M.packageKeyString 67 | #else 68 | -- | Synonym for 'M.PackageId', to bridge a slight incompatibility between 69 | -- GHC 7.8 and 7.10. 70 | type PkgKey = M.PackageId 71 | modulePkgKey = M.modulePackageId 72 | pkgKeyString = M.packageIdString 73 | #endif 74 | 75 | -- | Build a 'ModMetadata' out of a 'ModSummary'. 76 | toModMetadata :: CompConfig 77 | -> ModSummary 78 | -> ModMetadata 79 | toModMetadata cfg ms = ModMetadata { 80 | mmSummary = ms, 81 | mmName = moduleNameString $ ms_mod_name ms, 82 | mmPackageKey = pkgKeyString . modulePkgKey $ ms_mod ms, 83 | mmSourceIsHsBoot = ms_hsc_src ms == HsBootFile, 84 | mmSourceFile = ml_hs_file $ ms_location ms, 85 | mmInterfaceFile = ml_hi_file $ ms_location ms 86 | } 87 | 88 | -- | Compile a 'ModSummary' into a list of simplified 'StgBinding's. 89 | -- See 90 | -- for more information about STG and how it relates to core and Haskell. 91 | toSimplifiedStg :: ModSummary -> CgGuts -> CompPipeline [StgTopBinding] 92 | toSimplifiedStg ms cgguts = do 93 | env <- hsc_env `fmap` getPipeState 94 | let dfs = hsc_dflags env 95 | liftIO $ do 96 | prog <- prepareCore env dfs ms cgguts 97 | let stg = fst $ coreToStg dfs (ms_mod ms) prog 98 | stg2stg dfs stg 99 | 100 | -- | Prepare a core module for code generation. 101 | prepareCore :: HscEnv -> DynFlags -> ModSummary -> CgGuts -> IO CoreProgram 102 | prepareCore env dfs _ms p = do 103 | #if __GLASGOW_HASKELL__ >= 800 104 | liftIO $ fst <$> corePrepPgm env (ms_mod _ms) (ms_location _ms) (cg_binds p) (cg_tycons p) 105 | #elif __GLASGOW_HASKELL__ >= 710 106 | liftIO $ corePrepPgm env (ms_location _ms) (cg_binds p) (cg_tycons p) 107 | #else 108 | liftIO $ corePrepPgm dfs env (cg_binds p) (cg_tycons p) 109 | #endif 110 | -------------------------------------------------------------------------------- /src/Language/Haskell/GHC/Simple/PrimIface.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | -- | Facilities for using a custom GHC.Prim interface. 3 | -- 4 | -- The simplest(?) way to use this is to generate primop info 5 | -- using the @genprimopcode@ program from GHC, making any desired changes 6 | -- to those files, and passing the @primOpInfo@ and @primOpStrictness@ 7 | -- functions defined therein as the @cfgCustomPrimIface@ member of 8 | -- your config. 9 | -- 10 | -- Your strictness and info functions need to support all the 11 | -- primops exported by the GHC version in use, making code written for this 12 | -- interface rather less portable than code using the rest of @ghc-simple@. 13 | -- 14 | -- This functionality is probably what you want if you are making a cross 15 | -- compiler, to prevent the types of GHC primops from changing depending on 16 | -- the compiler host platform. 17 | -- 18 | -- If you are *not* making a cross compiler, chances are you will not want to 19 | -- touch this with a ten foot pole. 20 | module Language.Haskell.GHC.Simple.PrimIface ( 21 | module Demand, module TysWiredIn, module FastString, module CmmType, 22 | module BasicTypes, 23 | PrimOp (..), PrimOpInfo (..), 24 | mkGenPrimOp, mkDyadic, mkMonadic, mkCompare, 25 | primIface, fixPrimopTypes 26 | ) where 27 | import NameCache(initNameCache, NameCache(..)) 28 | import PrelInfo (primOpRules, ghcPrimIds) 29 | #if __GLASGOW_HASKELL__ < 800 30 | import PrelInfo (wiredInThings) 31 | #else 32 | import PrelInfo (wiredInIds, primOpId) 33 | import TcTypeNats (typeNatTyCons) 34 | #endif 35 | import PrimOp hiding (primOpSig) 36 | import IdInfo 37 | import Rules 38 | import PrelNames 39 | import Name 40 | import BasicTypes 41 | import Type 42 | import Unique 43 | import Id 44 | import TysWiredIn 45 | import TysPrim 46 | import FastString 47 | import Demand 48 | import HscTypes 49 | import Avail 50 | import MkId (seqId) 51 | import Data.IORef (modifyIORef') 52 | import TyCon 53 | import CmmType 54 | 55 | #if __GLASGOW_HASKELL__ < 710 56 | setCallArityInfo :: IdInfo -> Arity -> IdInfo 57 | setCallArityInfo i _ = i 58 | #endif 59 | 60 | -- | Module interface for @GHC.Prim@, with the given function applied to each 61 | -- primop. 62 | primIface :: (PrimOp -> PrimOpInfo) 63 | -> (PrimOp -> Arity -> StrictSig) 64 | -> ModIface 65 | primIface nfo str = (emptyModIface gHC_PRIM) { 66 | mi_exports = exports nfo str, 67 | mi_decls = [], 68 | mi_fixities = fixies, 69 | mi_fix_fn = mkIfaceFixCache fixies 70 | } 71 | where 72 | fixies = (getOccName seqId, fixity (SourceText "seq") 0 InfixR) : 73 | [(primOpOcc op, f) 74 | | op <- allThePrimOps 75 | , Just f <- [primOpFixity op]] 76 | #if __GLASGOW_HASKELL__ >= 800 77 | fixity = Fixity 78 | #else 79 | fixity _ = Fixity 80 | #endif 81 | 82 | exports :: (PrimOp -> PrimOpInfo) 83 | -> (PrimOp -> Arity -> StrictSig) 84 | -> [IfaceExport] 85 | exports nfo str = concat [ 86 | map avail ghcPrimIds, 87 | map (avail . (fixPrimOp nfo str)) allThePrimOps, 88 | [ availTC n 89 | | tc <- funTyCon : coercibleTyCon : primTyCons, let n = tyConName tc] 90 | ] 91 | where 92 | avail = Avail . idName 93 | availTC n = AvailTC n [n] [] 94 | 95 | -- | Fix primop types in the name cache. 96 | fixPrimopTypes :: (PrimOp -> PrimOpInfo) 97 | -> (PrimOp -> Arity -> StrictSig) 98 | -> HscEnv 99 | -> IO () 100 | fixPrimopTypes nfo str env = do 101 | modifyIORef' (hsc_NC env) fixNC 102 | where 103 | isPrim (AnId v) = isPrimOpId v 104 | isPrim _ = False 105 | 106 | fixNC (NameCache us _) = initNameCache us $ concat [ 107 | [getName thing | thing <- wiredInThings, not (isPrim thing)], 108 | basicKnownKeyNames, 109 | map (getName . AnId . fixPrimOp nfo str) allThePrimOps 110 | ] 111 | 112 | #if __GLASGOW_HASKELL__ >= 800 113 | -- This list is used only to initialise HscMain.knownKeyNames 114 | -- to ensure that when you say "Prelude.map" in your source code, you 115 | -- get a Name with the correct known key (See Note [Known-key names]) 116 | wiredInThings 117 | = concat 118 | [ -- Wired in TyCons and their implicit Ids 119 | tycon_things 120 | , concatMap implicitTyThings tycon_things 121 | 122 | -- Wired in Ids 123 | , map AnId wiredInIds 124 | 125 | -- PrimOps 126 | , map (AnId . primOpId) allThePrimOps 127 | ] 128 | where 129 | tycon_things = map ATyCon ([funTyCon] ++ primTyCons ++ wiredInTyCons 130 | ++ typeNatTyCons) 131 | #endif 132 | 133 | -- | Primitive operation signature: constists of the op's type, arity and 134 | -- strictness annotations. 135 | data PrimOpSig = PrimOpSig { 136 | opType :: !Type, 137 | opArity :: !Arity, 138 | opStrictness :: !StrictSig 139 | } 140 | 141 | -- | Get the signature of a primitive operation. 142 | primOpSig :: (PrimOp -> PrimOpInfo) 143 | -> (PrimOp -> Arity -> StrictSig) 144 | -> PrimOp 145 | -> PrimOpSig 146 | primOpSig nfo str op = PrimOpSig { 147 | opType = typ, 148 | opArity = arity, 149 | opStrictness = str op arity 150 | } 151 | where 152 | (typ, arity) = 153 | case nfo op of 154 | Monadic _ t -> (mkForAllTys [] $ mkFunTys [t] t, 1) 155 | Dyadic _ t -> (mkForAllTys [] $ mkFunTys [t,t] t, 2) 156 | Compare _ t -> (mkForAllTys [] $ mkFunTys [t,t] intPrimTy, 2) 157 | GenPrimOp _ tvs ts t -> (mkForAllTys tvs $ mkFunTys ts t, length ts) 158 | 159 | data PrimOpInfo 160 | = Dyadic OccName -- string :: T -> T -> T 161 | Type 162 | | Monadic OccName -- string :: T -> T 163 | Type 164 | | Compare OccName -- string :: T -> T -> Bool 165 | Type 166 | 167 | | GenPrimOp OccName -- string :: \/a1..an . T1 -> .. -> Tk -> T 168 | [TyVarBinder] 169 | [Type] 170 | Type 171 | 172 | fixPrimOp :: (PrimOp -> PrimOpInfo) 173 | -> (PrimOp -> Arity -> StrictSig) 174 | -> PrimOp 175 | -> Id 176 | fixPrimOp opnfo str op = 177 | var 178 | where 179 | sig = primOpSig opnfo str op 180 | var = mkGlobalId (PrimOpId op) name (opType sig) nfo 181 | name = mkWiredInName gHC_PRIM (primOpOcc op) unique (AnId var) UserSyntax 182 | unique = mkPrimOpIdUnique $ primOpTag op 183 | nfo = flip setCallArityInfo (opArity sig) $ 184 | noCafIdInfo `setStrictnessInfo` opStrictness sig 185 | `setRuleInfo` ri 186 | `setArityInfo` opArity sig 187 | `setInlinePragInfo` neverInlinePragma 188 | ri = mkRuleInfo $ case primOpRules name op of 189 | Just r -> [r] 190 | _ -> [] 191 | #if __GLASGOW_HASKELL__ < 800 192 | mkRuleInfo = mkSpecInfo 193 | infixl 1 `setRuleInfo` 194 | setRuleInfo = setSpecInfo 195 | #endif 196 | 197 | -- | Create a 'PrimOpInfo' for dyadic, monadic and compare primops. 198 | -- Needed by GHC-generated primop info includes. 199 | mkDyadic, mkMonadic, mkCompare :: FastString -> Type -> PrimOpInfo 200 | mkDyadic str ty = Dyadic (mkVarOccFS str) ty 201 | mkMonadic str ty = Monadic (mkVarOccFS str) ty 202 | mkCompare str ty = Compare (mkVarOccFS str) ty 203 | 204 | -- | Create a general 'PrimOpInfo'. Needed by GHC-generated primop info 205 | -- includes. 206 | mkGenPrimOp :: FastString -> [TyVarBinder] -> [Type] -> Type -> PrimOpInfo 207 | mkGenPrimOp str tvs tys ty = GenPrimOp (mkVarOccFS str) tvs tys ty 208 | -------------------------------------------------------------------------------- /src/Language/Haskell/GHC/Simple/Types.hs: -------------------------------------------------------------------------------- 1 | -- | Config, input and output types for the simplified GHC API. 2 | module Language.Haskell.GHC.Simple.Types ( 3 | -- * GHC pipeline configuration 4 | Intermediate (..), 5 | CompConfig, 6 | defaultConfig, 7 | cfgGhcFlags, cfgUseTargetsFromFlags, cfgUpdateDynFlags, cfgGhcLibDir, 8 | cfgUseGhcErrorLogger, cfgCustomPrimIface, cfgStopPhases, 9 | cfgCacheDirectory, cfgCacheFileExt, 10 | 11 | -- * Convenience functions for common settings combinations 12 | ncgPhases, disableCodeGen, 13 | 14 | -- * Compilation results and errors 15 | ModMetadata (..), 16 | CompiledModule (..), 17 | CompResult (..), 18 | Error (..), 19 | Warning (..), 20 | compSuccess 21 | ) where 22 | 23 | import GHC 24 | import HscTypes (CgGuts) 25 | import DriverPhases 26 | import DriverPipeline (CompPipeline) 27 | import Language.Haskell.GHC.Simple.PrimIface 28 | import Data.Binary (Binary) 29 | 30 | -- | An intermediate source language, usable as the the input for a 31 | -- 'Compile' compilation function. 32 | class Intermediate a where 33 | prepare :: ModSummary -> CgGuts -> CompPipeline a 34 | 35 | -- | GHC pipeline configuration, parameterized over the intermediate code 36 | -- produced by the pipeline. 37 | data CompConfig = CompConfig { 38 | -- | GHC command line dynamic flags to control the Haskell to STG 39 | -- compilation pipeline. 40 | -- For instance, passing @["-O2", "-DHELLO"]@ here is equivalent to 41 | -- passing @-O2 -DHELLO@ to the @ghc@ binary. 42 | -- 43 | -- Note that flags set here are overridden by any changes to 'DynFlags' 44 | -- performed by 'cfgUpdateDynFlags', and that '--make' mode is always 45 | -- in effect. 46 | -- 47 | -- Default: @[]@ 48 | cfgGhcFlags :: [String], 49 | 50 | -- | If file or module names are found among the 'cfgGhcFlags', 51 | -- should they be used as targets, in addition to any targets given by 52 | -- other arguments to 'withStg' et al? 53 | -- 54 | -- Default: @True@ 55 | cfgUseTargetsFromFlags :: Bool, 56 | 57 | -- | Modify the dynamic flags governing the compilation process. 58 | -- Changes made here take precedence over any flags passed through 59 | -- 'cfgGhcFlags'. 60 | -- 61 | -- Default: @id@ 62 | cfgUpdateDynFlags :: DynFlags -> DynFlags, 63 | 64 | -- | Use GHC's standard logger to log errors and warnings to the command 65 | -- line? Errors and warnings are always collected and returned, 66 | -- regardless of the value of this setting. 67 | -- 68 | -- Output other than errors and warnings (dumps, etc.) are logged using 69 | -- the standard logger by default. For finer control over logging 70 | -- behavior, you should override 'log_action' in 'cfgUpdateDynFlags'. 71 | -- 72 | -- Default: @False@ 73 | cfgUseGhcErrorLogger :: Bool, 74 | 75 | -- | Path to GHC's library directory. If 'Nothing', the library directory 76 | -- of the system's default GHC compiler will be used. 77 | -- 78 | -- Default: @Nothing@ 79 | cfgGhcLibDir :: Maybe FilePath, 80 | 81 | -- | Use a custom interface for @GHC.Prim@. 82 | -- This is useful if you want to, for instance, compile to a 32 bit 83 | -- target architecture on a 64 bit host. 84 | -- 85 | -- For more information, see "Language.Haskell.GHC.Simple.PrimIface". 86 | -- 87 | -- Default: @Nothing@ 88 | cfgCustomPrimIface :: Maybe (PrimOp -> PrimOpInfo, 89 | PrimOp -> Arity -> StrictSig), 90 | 91 | -- | Cache directory for compiled code. If @Nothing@, the current directory 92 | -- is used. 93 | -- 94 | -- Default: @Nothing@ 95 | cfgCacheDirectory :: Maybe FilePath, 96 | 97 | -- | File extension of cache files. 98 | -- 99 | -- Default: @cache@ 100 | cfgCacheFileExt :: String, 101 | 102 | -- | Stop compilation when any of these this phases are reached, 103 | -- without performing it. If you are doing custom code generation and 104 | -- don't want GHC to generate any code - for instance when writing a 105 | -- cross compiler - you will probably want to set this to 106 | -- @ncgPhases@. 107 | -- 108 | -- Default: @[]@ 109 | cfgStopPhases :: [Phase] 110 | } 111 | 112 | -- | Default configuration. 113 | defaultConfig :: CompConfig 114 | defaultConfig = CompConfig { 115 | cfgGhcFlags = [], 116 | cfgUseTargetsFromFlags = True, 117 | cfgUpdateDynFlags = id, 118 | cfgUseGhcErrorLogger = False, 119 | cfgGhcLibDir = Nothing, 120 | cfgCustomPrimIface = Nothing, 121 | cfgCacheDirectory = Nothing, 122 | cfgCacheFileExt = "cache", 123 | cfgStopPhases = [] 124 | } 125 | 126 | -- | Phases in which the native code generator is invoked. You want to stop 127 | -- at these phases when writing a cross compiler. 128 | ncgPhases :: [Phase] 129 | ncgPhases = [CmmCpp, Cmm, As False, As True] 130 | 131 | -- | Disable any native code generation and linking. 132 | disableCodeGen :: CompConfig -> CompConfig 133 | disableCodeGen cfg = cfg { 134 | cfgStopPhases = ncgPhases, 135 | cfgUpdateDynFlags = asmTarget . cfgUpdateDynFlags cfg 136 | } 137 | where 138 | asmTarget dfs = dfs {hscTarget = HscAsm, ghcLink = NoLink} 139 | 140 | -- | Compiler output and metadata for a given module. 141 | data CompiledModule a = CompiledModule { 142 | -- | Module data generated by compilation; usually bindings of some kind. 143 | modCompiledModule :: a, 144 | 145 | -- | Metadata for the compiled module. 146 | modMetadata :: ModMetadata, 147 | 148 | -- | Was the module a target of the current compilation, as opposed to 149 | -- a dependency of some target? 150 | modIsTarget :: Bool 151 | } 152 | 153 | -- | Metadata for a module under compilation. 154 | data ModMetadata = ModMetadata { 155 | -- | 'ModSummary' for the module, as given by GHC. 156 | mmSummary :: ModSummary, 157 | 158 | -- | String representation of the module's name, not qualified with a 159 | -- package key. 160 | -- 'ModuleName' representation can be obtained from the module's 161 | -- 'stgModSummary'. 162 | mmName :: String, 163 | 164 | -- | String representation of the module's package key. 165 | -- 'PackageKey' representation can be obtained from the module's 166 | -- 'stgModSummary'. 167 | mmPackageKey :: String, 168 | 169 | -- | Was the module compiler from a @hs-boot@ file? 170 | mmSourceIsHsBoot :: Bool, 171 | 172 | -- | The Haskell source the module was compiled from, if any. 173 | mmSourceFile :: Maybe FilePath, 174 | 175 | -- | Interface file corresponding to this module. 176 | mmInterfaceFile :: FilePath 177 | } 178 | 179 | -- | A GHC error message. 180 | data Error = Error { 181 | -- | Where did the error occur? 182 | errorSpan :: SrcSpan, 183 | 184 | -- | Description of the error. 185 | errorMessage :: String, 186 | 187 | -- | More verbose description of the error. 188 | errorExtraInfo :: String 189 | } 190 | 191 | -- | A GHC warning. 192 | data Warning = Warning { 193 | -- | Where did the warning occur? 194 | warnSpan :: SrcSpan, 195 | 196 | -- | What was the warning about? 197 | warnMessage :: String 198 | } 199 | 200 | -- | Result of a compilation. 201 | data CompResult a 202 | = Success { 203 | -- | Result of the compilation. 204 | compResult :: a, 205 | 206 | -- | Warnings that occurred during compilation. 207 | compWarnings :: [Warning], 208 | 209 | -- | Initial 'DynFlags' used by this compilation, collected from 'Config' 210 | -- data. 211 | compDynFlags :: DynFlags 212 | } 213 | | Failure { 214 | -- | Errors that occurred during compilation. 215 | compErrors :: [Error], 216 | 217 | -- | Warnings that occurred during compilation. 218 | compWarnings :: [Warning] 219 | } 220 | 221 | -- | Does the given 'CompResult' represent a successful compilation? 222 | compSuccess :: CompResult a -> Bool 223 | compSuccess Success{} = True 224 | compSuccess _ = False 225 | --------------------------------------------------------------------------------