diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2015 Anton Ekblad + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/ghc-simple.cabal b/ghc-simple.cabal new file mode 100644 --- /dev/null +++ b/ghc-simple.cabal @@ -0,0 +1,42 @@ +name: ghc-simple +version: 0.1.0.0 +synopsis: Simplified interface to the GHC API. +description: The GHC API is a great tool for working with Haskell code. + Unfortunately, it's also fairly opaque and hard to get + started with. This library abstracts away the intricacies + of working with the GHC API, giving a general, no-nonsense + way to extract highly optimized (or not, depending on your + use case) Core, STG, custom intermediate code, and other + information from Haskell code. +homepage: https://github.com/valderman/ghc-simple +license: MIT +license-file: LICENSE +author: Anton Ekblad +maintainer: anton@ekblad.cc +copyright: (c) 2015 Anton Ekblad +category: Development +build-type: Simple +cabal-version: >=1.10 + +source-repository head + type: git + location: https://github.com/valderman/ghc-simple.git + +library + exposed-modules: + Language.Haskell.GHC.Simple, + Language.Haskell.GHC.Simple.Impl + other-modules: + Language.Haskell.GHC.Simple.Types + other-extensions: + CPP, PatternGuards, FlexibleInstances + build-depends: + ghc >=7.8, + base >=4.7 && <4.9, + ghc-paths >=0.1 && <0.2, + data-default >=0.5 && <0.6 + hs-source-dirs: + src + default-language: + Haskell2010 + diff --git a/src/Language/Haskell/GHC/Simple.hs b/src/Language/Haskell/GHC/Simple.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/GHC/Simple.hs @@ -0,0 +1,171 @@ +{-# LANGUAGE CPP, PatternGuards #-} +-- | Simplified interface to the GHC API. +module Language.Haskell.GHC.Simple ( + -- Configuration, input and output types + module Simple.Types, + Compile, + StgModule, + + -- GHC re-exports needed to meaningfully process STG and Core. + module CoreSyn, module StgSyn, module Module, + module Id, module IdInfo, module Var, module Literal, module DataCon, + module OccName, module Name, + module Type, module TysPrim, module TyCon, + module ForeignCall, module PrimOp, + module DynFlags, module SrcLoc, + ModSummary (..), ModGuts (..), + PkgKey, + pkgKeyString, modulePkgKey, + + -- Entry points + compile, compileWith, genericCompile + ) where + +-- GHC scaffolding +import GHC hiding (Warning) +import GhcMonad (liftIO) +import DynFlags +import HscTypes +import ErrUtils +import Bag +import SrcLoc +import Outputable + +-- Convenience re-exports for fiddling with STG +import StgSyn +import CoreSyn +import Name hiding (varName) +import Type +import TysPrim +import TyCon +import Literal +import Var hiding (setIdExported, setIdNotExported, lazySetIdInfo) +import Id +import IdInfo +import OccName hiding (varName) +import DataCon +import ForeignCall +import PrimOp +import Module + +-- Misc. stuff +import GHC.Paths (libdir) +import Data.IORef +import Language.Haskell.GHC.Simple.Types as Simple.Types +import Language.Haskell.GHC.Simple.Impl + +-- | Compile a list of targets and their dependencies into intermediate code. +-- Uses settings from the the default 'CompConfig'. +compile :: Compile a + => [String] + -- ^ List of compilation targets. A target can be either a module + -- or a file name. + -> IO (CompResult a) +compile = compileWith def + +-- | Compile a list of targets and their dependencies using a custom +-- configuration. +compileWith :: Compile a + => CompConfig + -- ^ GHC pipeline configuration. + -> [String] + -- ^ List of compilation targets. A target can be either a module + -- or a file name. Targets may also be read from the specified + -- 'CompConfig', if 'cfgUseTargetsFromFlags' is set. + -> IO (CompResult a) +compileWith = genericCompile toCode + +-- | Compile a list of targets and their dependencies using a custom +-- configuration and compilation function in the 'Ghc' monad. See +-- "Language.Haskell.GHC.Simple.Impl" for more information about building +-- custom compilation functions. +genericCompile :: (DynFlags -> ModSummary -> Ghc a) + -- ^ Compilation function. + -> CompConfig + -- ^ GHC pipeline configuration. + -> [String] + -- ^ List of compilation targets. A target can be either a module + -- or a file name. Targets may also be read from the specified + -- 'CompConfig', if 'cfgUseTargetsFromFlags' is set. + -> IO (CompResult a) +genericCompile comp cfg files = do + (flags, _staticwarns) <- parseStaticFlags $ map noLoc (cfgGhcFlags cfg) + warns <- newIORef [] + runGhc (maybe (Just libdir) Just (cfgGhcLibDir cfg)) $ do + dfs <- getSessionDynFlags + (dfs', files2, _dynwarns) <- parseDynamicFlags dfs flags + let dfs'' = cfgUpdateDynFlags cfg $ dfs' { + log_action = logger (log_action dfs') warns + } + _ <- setSessionDynFlags dfs'' + ecode <- genCode (toCompiledModule comp) (files ++ map unLoc files2) + ws <- liftIO $ readIORef warns + case ecode of + Right (finaldfs, code) -> + return Success { + compResult = code, + compWarnings = ws, + compDynFlags = finaldfs + } + Left es -> + return Failure { + compErrors = es, + compWarnings = ws + } + where + logger deflog warns dfs severity srcspan style msg + | cfgUseGhcErrorLogger cfg = do + logger' deflog warns dfs severity srcspan style msg + -- Messages other than warnings and errors are already logged by GHC + -- by default. + case severity of + SevWarning -> deflog dfs severity srcspan style msg + SevError -> deflog dfs severity srcspan style msg + _ -> return () + | otherwise = do + logger' deflog warns dfs severity srcspan style msg + + -- Collect warnings and supress errors, since we're collecting those + -- separately. + logger' _ w dfs SevWarning srcspan _style msg = do + liftIO $ atomicModifyIORef' w $ \ws -> + (Warning srcspan (showSDoc dfs msg) : ws, ()) + logger' _ _ _ SevError _ _ _ = do + return () + logger' output _ dfs sev srcspan style msg = do + output dfs sev srcspan style msg + +-- | Map a compilation function over each 'ModSummary' in the dependency graph +-- of a list of targets. +genCode :: GhcMonad m + => (DynFlags -> ModSummary -> m a) + -> [String] + -> m (Either [Error] (DynFlags, [a])) +genCode comp files = do + dfs <- getSessionDynFlags + merrs <- handleSourceError (maybeErrors dfs) $ do + ts <- mapM (flip guessTarget Nothing) files + setTargets ts + loads <- load LoadAllTargets + return $ if succeeded loads then Nothing else Just [] + case merrs of + Just errs -> return $ Left errs + _ -> do + mss <- depanal [] False + code <- mapM (comp dfs . noLog) mss + return $ Right (dfs, code) + where + -- We logged everything when we did @load@, we don't want to do it twice. + noLog m = + m {ms_hspp_opts = (ms_hspp_opts m) {log_action = \_ _ _ _ _ -> return ()}} + maybeErrors dfs = + return . Just . map (fromErrMsg dfs) . bagToList . srcErrorMessages + +fromErrMsg :: DynFlags -> ErrMsg -> Error +fromErrMsg dfs e = Error { + errorSpan = errMsgSpan e, + errorMessage = showSDocForUser dfs ctx (errMsgShortDoc e), + errorExtraInfo = showSDocForUser dfs ctx (errMsgExtraInfo e) + } + where + ctx = errMsgContext e diff --git a/src/Language/Haskell/GHC/Simple/Impl.hs b/src/Language/Haskell/GHC/Simple/Impl.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/GHC/Simple/Impl.hs @@ -0,0 +1,140 @@ +{-# LANGUAGE FlexibleInstances, CPP, PatternGuards #-} +-- | Lower level building blocks for custom code generation. +module Language.Haskell.GHC.Simple.Impl ( + Compile (..), + Ghc, StgModule, PkgKey, + liftIO, + toSimplifiedStg, + toSimplifiedCore, + toModGuts, + simplify, + prepare, toStgBindings, + toCompiledModule, + modulePkgKey, pkgKeyString + ) where + +-- GHC scaffolding +import GHC hiding (Warning) +import GhcMonad (liftIO) +import HscMain +import HscTypes +import TidyPgm +import CorePrep +import StgSyn +import CoreSyn +import CoreToStg +import SimplStg +#if __GLASGOW_HASKELL__ < 710 +import qualified Module as M (modulePackageId, packageIdString, PackageId) +#else +import qualified Module as M (modulePackageKey, packageKeyString, PackageKey) +#endif + +import Control.Monad +import Language.Haskell.GHC.Simple.Types + +-- | Any type we can generate intermediate code for. +class Compile a where + -- | Generate some sort of code (or other output) from a Haskell module. + toCode :: DynFlags -> ModSummary -> Ghc a + +type StgModule = CompiledModule [StgBinding] +instance Compile [StgBinding] where + toCode = toSimplifiedStg + +instance Compile CgGuts where + toCode = const toSimplifiedCore + +instance Compile ModGuts where + toCode = const toModGuts + +-- | Package ID/key of a module. +modulePkgKey :: Module -> PkgKey + +-- | String representation of a package ID/key. +pkgKeyString :: PkgKey -> String + +#if __GLASGOW_HASKELL__ < 710 +-- | 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 +#else +-- | 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 +#endif + +-- | Compile a 'ModSummary' into a module with metadata using a custom +-- compilation function. +toCompiledModule :: GhcMonad m + => (DynFlags -> ModSummary -> m a) + -> DynFlags + -> ModSummary + -> m (CompiledModule a) +toCompiledModule comp dfs ms = do + code <- comp dfs ms + ts <- getTargets + return $ CompiledModule { + modSummary = ms, + modName = moduleNameString $ ms_mod_name ms, + modPackageKey = pkgKeyString . modulePkgKey $ ms_mod ms, + modIsTarget = any (`isTargetOf` ms) ts, + modSourceIsHsBoot = ms_hsc_src ms == HsBootFile, + modSourceFile = ml_hs_file $ ms_location ms, + modInterfaceFile = ml_hi_file $ ms_location ms, + modCompiledModule = code + } + +-- | Is @t@ the target that corresponds to @ms@? +isTargetOf :: Target -> ModSummary -> Bool +isTargetOf t ms = + case targetId t of + TargetModule mn -> ms_mod_name ms == mn + TargetFile fn _ + | ModLocation (Just f) _ _ <- ms_location ms -> f == fn + _ -> False + +-- | Compile a 'ModSummary' into a list of simplified 'StgBinding's. +-- See +-- for more information about STG and how it relates to core and Haskell. +toSimplifiedStg :: GhcMonad m => DynFlags -> ModSummary -> m [StgBinding] +toSimplifiedStg dfs ms = + toSimplifiedCore ms >>= prepare dfs ms >>= toStgBindings dfs ms + +-- | Compile a 'ModSummary' into a 'CgGuts', containing all information about +-- a core module that one could wish for. +toSimplifiedCore :: GhcMonad m => ModSummary -> m CgGuts +toSimplifiedCore = toModGuts >=> simplify + +-- | Parse, typecheck and desugar a module. Returned 'ModGuts' structure is not +-- simplified in any way. +toModGuts :: GhcMonad m => ModSummary -> m ModGuts +toModGuts = + parseModule >=> typecheckModule >=> desugarModule >=> return . coreModule + +-- | Simplify a core module for code generation. +simplify :: GhcMonad m => ModGuts -> m CgGuts +simplify mg = do + env <- getSession + liftIO $ hscSimplify env mg >>= tidyProgram env >>= return . fst + +-- | Prepare a core module for code generation. +prepare :: GhcMonad m => DynFlags -> ModSummary -> CgGuts -> m CoreProgram +prepare dfs _ms p = do + env <- getSession +#if __GLASGOW_HASKELL__ < 710 + liftIO $ corePrepPgm dfs env (cg_binds p) (cg_tycons p) +#else + liftIO $ corePrepPgm env (ms_location _ms) (cg_binds p) (cg_tycons p) +#endif + +-- | Turn a core module into a list of simplified STG bindings. +toStgBindings :: GhcMonad m + => DynFlags -> ModSummary -> CoreProgram -> m [StgBinding] +toStgBindings dfs ms p = liftIO $ do + stg <- coreToStg dfs (ms_mod ms) p + fst `fmap` stg2stg dfs (ms_mod ms) stg diff --git a/src/Language/Haskell/GHC/Simple/Types.hs b/src/Language/Haskell/GHC/Simple/Types.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/GHC/Simple/Types.hs @@ -0,0 +1,156 @@ +-- | Config, input and output types for the simplified GHC API. +module Language.Haskell.GHC.Simple.Types ( + Default (..), + + -- Configuration + CompConfig, + cfgGhcFlags, cfgUseTargetsFromFlags, cfgUpdateDynFlags, cfgGhcLibDir, + cfgUseGhcErrorLogger, + + -- Results and errors + CompiledModule (..), + CompResult (..), + Error (..), + Warning (..), + ghcSuccess + ) where + +-- GHC imports +import GHC + +-- Misc. stuff +import Data.Default + +data CompConfig = CompConfig { + -- | GHC command line flags to control the Haskell to STG compilation + -- pipeline. Both static and dynamic flags may be set here. + -- For instance, passing @["-O2", "-DHELLO"]@ here is equivalent to + -- passing @-O2 -DHELLO@ to the @ghc@ binary. + -- + -- Note that flags set here are overridden by any changes to 'DynFlags' + -- performed by 'cfgUpdateDynFlags', and that '--make' mode is always + -- in effect. + -- + -- Default: @[]@ + cfgGhcFlags :: [String], + + -- | If file or module names are found among the 'cfgGhcFlags', + -- should they be used as targets, in addition to any targets given by + -- other arguments to 'withStg' et al? + -- + -- Default: @True@ + cfgUseTargetsFromFlags :: Bool, + + -- | Modify the dynamic flags governing the compilation process. + -- Changes made here take precedence over any flags passed through + -- 'cfgGhcFlags'. + -- + -- Default: @id@ + cfgUpdateDynFlags :: DynFlags -> DynFlags, + + -- | Use GHC's standard logger to log errors and warnings to the command + -- line? Errors and warnings are always collected and returned, + -- regardless of the value of this setting. + -- + -- Output other than errors and warnings (dumps, etc.) are logged using + -- the standard logger by default. For finer control over logging + -- behavior, you should override 'log_action' in 'cfgUpdateDynFlags'. + -- + -- Default: @False@ + cfgUseGhcErrorLogger :: Bool, + + -- | Path to GHC's library directory. If 'Nothing', the library directory + -- of the system's default GHC compiler will be used. + -- + -- Default: @Nothing@ + cfgGhcLibDir :: Maybe FilePath + } + +instance Default CompConfig where + def = CompConfig { + cfgGhcFlags = [], + cfgUseTargetsFromFlags = True, + cfgUpdateDynFlags = id, + cfgUseGhcErrorLogger = False, + cfgGhcLibDir = Nothing + } + +-- | Compiler output and metadata for a given module. +data CompiledModule a = CompiledModule { + -- | 'ModSummary' for the module, as given by GHC. + modSummary :: ModSummary, + + -- | String representation of the module's name, not qualified with a + -- package key. + -- 'ModuleName' representation can be obtained from the module's + -- 'stgModSummary'. + modName :: String, + + -- | String representation of the module's package key. + -- 'PackageKey' representation can be obtained from the module's + -- 'stgModSummary'. + modPackageKey :: String, + + -- | Is this module a compilation target (as opposed to a dependency of + -- one)? + modIsTarget :: Bool, + + -- | Was the module compiler from a @hs-boot@ file? + modSourceIsHsBoot :: Bool, + + -- | The Haskell source the module was compiled from, if any. + modSourceFile :: Maybe FilePath, + + -- | Interface file corresponding to this module. + modInterfaceFile :: FilePath, + + -- | Module data generated by compilation; usually bindings of some kind. + modCompiledModule :: a + } + +-- | A GHC error message. +data Error = Error { + -- | Where did the error occur? + errorSpan :: SrcSpan, + + -- | Description of the error. + errorMessage :: String, + + -- | More verbose description of the error. + errorExtraInfo :: String + } + +-- | A GHC warning. +data Warning = Warning { + -- | Where did the warning occur? + warnSpan :: SrcSpan, + + -- | What was the warning about? + warnMessage :: String + } + +-- | Result of a compilation. +data CompResult a + = Success { + -- | Result of the compilation. + compResult :: [CompiledModule a], + + -- | Warnings that occurred during compilation. + compWarnings :: [Warning], + + -- | Initial 'DynFlags' used by this compilation, collected from 'Config' + -- data. + compDynFlags :: DynFlags + } + | Failure { + -- | Errors that occurred during compilation. + compErrors :: [Error], + + -- | Warnings that occurred during compilation. + compWarnings :: [Warning] + } + +-- | Does the given 'CompResult' represent a successful compilation? +ghcSuccess :: CompResult a -> Bool +ghcSuccess (Success {}) = True +ghcSuccess _ = False