diff --git a/ghc-simple.cabal b/ghc-simple.cabal --- a/ghc-simple.cabal +++ b/ghc-simple.cabal @@ -1,5 +1,5 @@ name: ghc-simple -version: 0.1.1.0 +version: 0.1.2.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 diff --git a/src/Language/Haskell/GHC/Simple.hs b/src/Language/Haskell/GHC/Simple.hs --- a/src/Language/Haskell/GHC/Simple.hs +++ b/src/Language/Haskell/GHC/Simple.hs @@ -1,10 +1,13 @@ {-# LANGUAGE CPP, PatternGuards #-} -- | Simplified interface to the GHC API. module Language.Haskell.GHC.Simple ( + -- * Entry points + compile, compileWith, compileFold, + -- * Configuration, input and output types module Simple.Types, - Compile, StgModule, + getDynFlagsForConfig, -- * GHC re-exports for processing STG and Core module CoreSyn, module StgSyn, module Module, @@ -15,10 +18,7 @@ module DynFlags, module SrcLoc, ModSummary (..), ModGuts (..), PkgKey, - pkgKeyString, modulePkgKey, - - -- * Entry points - compile, compileWith, genericCompile + pkgKeyString, modulePkgKey ) where -- GHC scaffolding @@ -31,6 +31,7 @@ import SrcLoc import Outputable import Hooks +import StaticFlags (discardStaticFlags) -- Convenience re-exports for fiddling with STG import StgSyn @@ -56,6 +57,7 @@ import Language.Haskell.GHC.Simple.PrimIface as Simple.PrimIface import Language.Haskell.GHC.Simple.Types as Simple.Types import Language.Haskell.GHC.Simple.Impl +import System.IO.Unsafe -- | Compile a list of targets and their dependencies into intermediate code. -- Uses settings from the the default 'CompConfig'. @@ -63,74 +65,54 @@ => [String] -- ^ List of compilation targets. A target can be either a module -- or a file name. - -> IO (CompResult a) + -> IO (CompResult [CompiledModule a]) compile = compileWith defaultConfig -- | Compile a list of targets and their dependencies using a custom -- configuration. compileWith :: Compile a - => CompConfig + => CompConfig a -- ^ 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 + -> IO (CompResult [CompiledModule a]) +compileWith cfg = compileFold (cfg {cfgGhcPipeline = toCode}) consMod [] --- | 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 +consMod :: [CompiledModule a] -> CompiledModule a -> IO [CompiledModule a] +consMod xs x = return (x:xs) - -- Parse and update dynamic flags - dfs <- getSessionDynFlags - (dfs', files2, _dynwarns) <- parseDynamicFlags dfs flags - let dfs'' = cfgUpdateDynFlags cfg $ dfs' { - log_action = logger (log_action dfs') warns - } +-- | Obtain the dynamic flags and extra targets that would be used to compile +-- anything with the given config. +getDynFlagsForConfig :: CompConfig a -> IO (DynFlags, [String]) +getDynFlagsForConfig cfg = initStaticFlags `seq` do + ws <- newIORef [] + runGhc (maybe (Just libdir) Just (cfgGhcLibDir cfg)) $ do + setDFS cfg (discardStaticFlags (cfgGhcFlags cfg)) ws - -- Update prim interface hook name and cache if we're using a custom - -- GHC.Prim interface, setting the dynflags in the process. - case cfgCustomPrimIface cfg of - Just (nfo, strs) -> setPrimIface dfs'' nfo strs - _ -> void $ setSessionDynFlags dfs'' +-- | Set and return the appropriate dynflags and extra targets for the given +-- config. +setDFS :: CompConfig a -- ^ Compilation configuration. + -> [String] -- ^ Dynamic GHC command line flags. + -> IORef [Warning] -- ^ IORef to use for logging warnings. + -> Ghc (DynFlags, [String]) +setDFS cfg flags warns = do + -- Parse and update dynamic flags + dfs <- getSessionDynFlags + (dfs', files2, _dynwarns) <- parseDynamicFlags dfs (map noLoc flags) + let dfs'' = cfgUpdateDynFlags cfg $ dfs' { + log_action = logger (log_action dfs') warns + } - -- Generate code and report results - 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 - } + -- Update prim interface hook name and cache if we're using a custom + -- GHC.Prim interface, setting the dynflags in the process. + case cfgCustomPrimIface cfg of + Just (nfo, strs) -> setPrimIface dfs'' nfo strs + _ -> void $ setSessionDynFlags dfs'' + finaldfs <- getSessionDynFlags + return (finaldfs, map unLoc files2) where - setPrimIface dfs nfo strs = do - void $ setSessionDynFlags dfs { - hooks = (hooks dfs) {ghcPrimIfaceHook = Just $ primIface nfo strs} - } - getSession >>= liftIO . fixPrimopTypes nfo strs - logger deflog warns dfs severity srcspan style msg | cfgUseGhcErrorLogger cfg = do logger' deflog warns dfs severity srcspan style msg @@ -153,13 +135,65 @@ logger' output _ dfs sev srcspan style msg = do output dfs sev srcspan style msg + setPrimIface dfs nfo strs = do + void $ setSessionDynFlags dfs { + hooks = (hooks dfs) {ghcPrimIfaceHook = Just $ primIface nfo strs} + } + getSession >>= liftIO . fixPrimopTypes nfo strs + + +-- | Left fold over a list of compilation targets and their dependencies. +-- +-- Sometimes you don't just want a huge pile of intermediate code lying +-- around; chances are you either want to dump it to file or combine it with +-- some other intermediate code, without having to keep it all in memory at +-- the same time. +compileFold :: CompConfig b + -- ^ GHC pipeline configuration. + -> (a -> CompiledModule b -> IO a) + -- ^ Compilation function. + -> a + -- ^ Initial accumulator. + -> [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) +compileFold cfg comp acc files = initStaticFlags `seq` do + warns <- newIORef [] + runGhc (maybe (Just libdir) Just (cfgGhcLibDir cfg)) $ do + (_, files2) <- setDFS cfg (discardStaticFlags (cfgGhcFlags cfg)) warns + ecode <- genCode ghcPipeline comp acc (files ++ 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 + ghcPipeline = toCompiledModule $ cfgGhcPipeline cfg + +{-# NOINLINE initStaticFlags #-} +-- | Use lazy evaluation to only call 'parseStaticFlags' once. +initStaticFlags :: [Located String] +initStaticFlags = unsafePerformIO $ fmap fst (parseStaticFlags []) + -- | Map a compilation function over each 'ModSummary' in the dependency graph -- of a list of targets. genCode :: GhcMonad m - => (DynFlags -> ModSummary -> m a) + => (ModSummary -> m a) + -> (b -> a -> IO b) + -> b -> [String] - -> m (Either [Error] (DynFlags, [a])) -genCode comp files = do + -> m (Either [Error] (DynFlags, b)) +genCode comp usercomp acc files = do dfs <- getSessionDynFlags merrs <- handleSourceError (maybeErrors dfs) $ do ts <- mapM (flip guessTarget Nothing) files @@ -170,7 +204,7 @@ Just errs -> return $ Left errs _ -> do mss <- depanal [] False - code <- mapM (comp dfs . noLog) mss + code <- foldM (\a x -> comp (noLog x) >>= liftIO . usercomp a) acc mss return $ Right (dfs, code) where -- We logged everything when we did @load@, we don't want to do it twice. diff --git a/src/Language/Haskell/GHC/Simple/Impl.hs b/src/Language/Haskell/GHC/Simple/Impl.hs --- a/src/Language/Haskell/GHC/Simple/Impl.hs +++ b/src/Language/Haskell/GHC/Simple/Impl.hs @@ -33,20 +33,15 @@ 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 + toCode = toSimplifiedCore instance Compile ModGuts where - toCode = const toModGuts + toCode = toModGuts -- | Package ID/key of a module. modulePkgKey :: Module -> PkgKey @@ -71,12 +66,11 @@ -- | Compile a 'ModSummary' into a module with metadata using a custom -- compilation function. toCompiledModule :: GhcMonad m - => (DynFlags -> ModSummary -> m a) - -> DynFlags + => (ModSummary -> m a) -> ModSummary -> m (CompiledModule a) -toCompiledModule comp dfs ms = do - code <- comp dfs ms +toCompiledModule comp ms = do + code <- comp ms ts <- getTargets return $ CompiledModule { modSummary = ms, @@ -101,8 +95,9 @@ -- | 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 = +toSimplifiedStg :: GhcMonad m => ModSummary -> m [StgBinding] +toSimplifiedStg ms = do + dfs <- getSessionDynFlags toSimplifiedCore ms >>= prepare dfs ms >>= toStgBindings dfs ms -- | Compile a 'ModSummary' into a 'CgGuts', containing all information about diff --git a/src/Language/Haskell/GHC/Simple/Types.hs b/src/Language/Haskell/GHC/Simple/Types.hs --- a/src/Language/Haskell/GHC/Simple/Types.hs +++ b/src/Language/Haskell/GHC/Simple/Types.hs @@ -1,12 +1,13 @@ -- | Config, input and output types for the simplified GHC API. module Language.Haskell.GHC.Simple.Types ( - -- Configuration + -- * GHC pipeline configuration + Compile (..), CompConfig, defaultConfig, cfgGhcFlags, cfgUseTargetsFromFlags, cfgUpdateDynFlags, cfgGhcLibDir, - cfgUseGhcErrorLogger, cfgCustomPrimIface, + cfgUseGhcErrorLogger, cfgCustomPrimIface, cfgGhcPipeline, - -- Results and errors + -- * Compilation results and errors CompiledModule (..), CompResult (..), Error (..), @@ -17,9 +18,16 @@ import GHC import Language.Haskell.GHC.Simple.PrimIface -data CompConfig = CompConfig { - -- | GHC command line flags to control the Haskell to STG compilation - -- pipeline. Both static and dynamic flags may be set here. +-- | 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 :: ModSummary -> Ghc a + +-- | GHC pipeline configuration, parameterized over the intermediate code +-- produced by the pipeline. +data CompConfig a = CompConfig { + -- | GHC command line dynamic flags to control the Haskell to STG + -- compilation pipeline. -- For instance, passing @["-O2", "-DHELLO"]@ here is equivalent to -- passing @-O2 -DHELLO@ to the @ghc@ binary. -- @@ -69,18 +77,27 @@ -- -- Default: @Nothing@ cfgCustomPrimIface :: Maybe (PrimOp -> PrimOpInfo, - PrimOp -> Arity -> StrictSig) + PrimOp -> Arity -> StrictSig), + + -- | Use a custom GHC pipeline to generate intermediate code. Useful if + -- the provided instances for @[StgBinding]@ etc. don't quite do what you + -- want them to. See "Language.Haskell.GHC.Simple.Impl" for more + -- information about custom pipelines. + -- + -- Default: @toCode@ + cfgGhcPipeline :: ModSummary -> Ghc a } -- | Default configuration. -defaultConfig :: CompConfig +defaultConfig :: Compile a => CompConfig a defaultConfig = CompConfig { cfgGhcFlags = [], cfgUseTargetsFromFlags = True, cfgUpdateDynFlags = id, cfgUseGhcErrorLogger = False, cfgGhcLibDir = Nothing, - cfgCustomPrimIface = Nothing + cfgCustomPrimIface = Nothing, + cfgGhcPipeline = toCode } -- | Compiler output and metadata for a given module. @@ -141,7 +158,7 @@ data CompResult a = Success { -- | Result of the compilation. - compResult :: [CompiledModule a], + compResult :: a, -- | Warnings that occurred during compilation. compWarnings :: [Warning],