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.3 +version: 0.4 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 @@ -31,11 +31,13 @@ other-extensions: CPP, PatternGuards, FlexibleInstances build-depends: - ghc >=7.8, - base >=4.7 && <4.9, - ghc-paths >=0.1 && <0.2, - directory >=1.2 && <1.3, - filepath >=1.3 && <1.5 + ghc >=7.8 && <8.1, + base >=4.7 && <5, + ghc-paths >=0.1 && <0.2, + directory >=1.2 && <1.3, + filepath >=1.3 && <1.5, + bytestring >=0.10 && <0.11, + binary >=0.6 && <0.9 hs-source-dirs: src default-language: 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 @@ -6,7 +6,6 @@ -- * Configuration, input and output types module Simple.Types, - StgModule, getDynFlagsForConfig, -- * GHC re-exports for processing STG and Core @@ -54,53 +53,75 @@ import Module -- Misc. stuff -import GHC.Paths (libdir) +import Data.Binary +import qualified Data.ByteString.Lazy as BS import Data.IORef import Control.Monad +import GHC.Paths (libdir) +import System.Directory +import System.FilePath +import System.IO +import System.IO.Unsafe + +-- Internals 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'. -compile :: Compile a - => [String] +compile :: (Intermediate a, Binary b) + => (ModMetadata -> a -> IO b) + -- ^ Compilation function from some intermediate language to the + -- desired output. The output type needs to be an instance of + -- 'Binary', as it will be cached after compilation to speed up + -- future recompilation. + -- This function is called once per module. Due to caching of modules + -- which don't need to be recompiled, it will not necessarily be + -- called once per module included in the return value of @compile@. + -> [String] -- ^ List of compilation targets. A target can be either a module -- or a file name. - -> IO (CompResult [CompiledModule a]) + -> IO (CompResult [CompiledModule b]) compile = compileWith defaultConfig -- | Compile a list of targets and their dependencies using a custom -- configuration. -compileWith :: Compile a - => CompConfig a +compileWith :: (Intermediate a, Binary b) + => CompConfig -- ^ GHC pipeline configuration. + -> (ModMetadata -> a -> IO b) + -- ^ Compilation function. -> [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 [CompiledModule a]) -compileWith cfg = compileFold (cfg {cfgGhcPipeline = toCode}) consMod [] + -> IO (CompResult [CompiledModule b]) +compileWith cfg comp = compileFold cfg comp consMod [] consMod :: [CompiledModule a] -> CompiledModule a -> IO [CompiledModule a] consMod xs x = return (x:xs) -- | 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 :: CompConfig -> IO (DynFlags, [String]) getDynFlagsForConfig cfg = initStaticFlags `seq` do ws <- newIORef [] runGhc (maybe (Just libdir) Just (cfgGhcLibDir cfg)) $ do - setDFS cfg (discardStaticFlags (cfgGhcFlags cfg)) ws + setDFS cfg (discardStaticFlags (cfgGhcFlags cfg)) ws noComp +noComp :: FilePath -> ModSummary -> CgGuts -> CompPipeline () +noComp _ _ _ = return () + -- | Set and return the appropriate dynflags and extra targets for the given -- config. -setDFS :: CompConfig a -- ^ Compilation configuration. +setDFS :: CompConfig -- ^ Compilation configuration. -> [String] -- ^ Dynamic GHC command line flags. -> IORef [Warning] -- ^ IORef to use for logging warnings. + -> (FilePath -> ModSummary -> CgGuts -> CompPipeline ()) + -- ^ Per-module compilation function. -> Ghc (DynFlags, [String]) -setDFS cfg flags warns = do +setDFS cfg flags warns comp = do -- Parse and update dynamic flags dfs <- getSessionDynFlags (dfs', files2, _dynwarns) <- parseDynamicFlags dfs (map noLoc flags) @@ -118,20 +139,43 @@ finaldfs <- getSessionDynFlags return (finaldfs, map unLoc files2) where +#if __GLASGOW_HASKELL__ >= 800 +#define LOG(dfs,sev,span,sty,msg) (deflog dfs reason sev span sty msg) + logger deflog warns dfs reason severity srcspan style msg +#else +#define LOG(dfs,sev,span,sty,msg) (deflog dfs sev span sty msg) logger deflog warns dfs severity srcspan style msg +#endif | cfgUseGhcErrorLogger cfg = do +#if __GLASGOW_HASKELL__ >= 800 + logger' deflog warns dfs reason severity srcspan style msg +#else logger' deflog warns dfs severity srcspan style msg +#endif -- 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 + SevWarning -> LOG(dfs, severity, srcspan, style, msg) + SevError -> LOG(dfs, severity, srcspan, style, msg) _ -> return () | otherwise = do +#if __GLASGOW_HASKELL__ >= 800 + logger' deflog warns dfs reason severity srcspan style msg +#else logger' deflog warns dfs severity srcspan style msg +#endif -- Collect warnings and supress errors, since we're collecting those -- separately. +#if __GLASGOW_HASKELL__ >= 800 + 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 reason sev srcspan style msg = do + output dfs reason sev srcspan style msg +#else logger' _ w dfs SevWarning srcspan _style msg = do liftIO $ atomicModifyIORef' w $ \ws -> (Warning srcspan (showSDoc dfs msg) : ws, ()) @@ -139,6 +183,7 @@ return () logger' output _ dfs sev srcspan style msg = do output dfs sev srcspan style msg +#endif setPrimIface dfs nfo strs = do void $ setSessionDynFlags dfs { @@ -146,34 +191,76 @@ } getSession >>= liftIO . fixPrimopTypes nfo strs + -- TODO: get rid of the @runPhase@ from the HscOut phase + phaseHook _ p@(HscOut src mod_name result) inp dfs = do + loc <- getLocation src mod_name + setModLocation loc + let next = hscPostBackendPhase dfs src (hscTarget dfs) + case result of + HscRecomp cgguts ms -> do + outfile <- phaseOutputFilename next + comp (ml_hi_file loc) ms cgguts + runPhase p inp dfs + _ -> + runPhase p inp dfs phaseHook stop (RealPhase p) inp _ | p `elem` stop = return (RealPhase StopLn, inp) phaseHook _ p inp dfs = runPhase p inp dfs +-- | Write a module to cache file. +writeModCache :: Binary a => CompConfig -> ModSummary -> a -> IO () +writeModCache cfg ms m = do + createDirectoryIfMissing True (takeDirectory cachefile) + BS.writeFile cachefile (encode m) + where + cachefile = cacheFileFor cfg (ms_mod_name ms) +-- | Read a module from cache file. +readModCache :: Binary a + => CompConfig + -> ModMetadata + -> [Target] + -> IO (CompiledModule a) +readModCache cfg meta tgts = do + m <- decode `fmap` BS.readFile cachefile + return $ CompiledModule m meta (mmSummary meta `isTarget` tgts) + where + cachefile = cacheFileFor cfg (ms_mod_name (mmSummary meta)) + +-- | Get the cache file for the given 'ModSummary' under the given +-- configuration. +cacheFileFor :: CompConfig -> ModuleName -> FilePath +cacheFileFor cfg name = + maybe "" id (cfgCacheDirectory cfg) modfile + where + modfile = moduleNameSlashes name <.> cfgCacheFileExt cfg + -- | 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 +compileFold :: (Intermediate a, Binary b) + => CompConfig -- ^ GHC pipeline configuration. - -> (a -> CompiledModule b -> IO a) - -- ^ Compilation function. - -> a + -> (ModMetadata -> a -> IO b) + -- ^ Per module compilation function. + -> (acc -> CompiledModule b -> IO acc) + -- ^ Folding function. + -> acc -- ^ 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 [] + -> IO (CompResult acc) +compileFold cfg comp f acc files = initStaticFlags `seq` do + warns <- newIORef [] -- all warnings produced by GHC runGhc (maybe (Just libdir) Just (cfgGhcLibDir cfg)) $ do - (_, files2) <- setDFS cfg (discardStaticFlags (cfgGhcFlags cfg)) warns - ecode <- genCode cfg ghcPipeline comp acc (files ++ files2) + (_, files2) <- setDFS cfg dfs warns compileToCache + ecode <- genCode cfg f acc (files ++ files2) ws <- liftIO $ readIORef warns case ecode of Right (finaldfs, code) -> @@ -188,8 +275,24 @@ compWarnings = ws } where - ghcPipeline = toCompiledModule cfg $ cfgGhcPipeline cfg + dfs = discardStaticFlags (cfgGhcFlags cfg) + compileToCache hifile ms cgguts = do + source <- prepare ms cgguts + liftIO $ comp (toModMetadata cfg ms) source >>= writeModCache cfg ms +-- | Is @ms@ in the list of targets? +isTarget :: ModSummary -> [Target] -> Bool +isTarget ms = any (`isTargetOf` ms) + +-- | 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 + {-# NOINLINE initStaticFlags #-} -- | Use lazy evaluation to only call 'parseStaticFlags' once. initStaticFlags :: [Located String] @@ -197,43 +300,61 @@ -- | Map a compilation function over each 'ModSummary' in the dependency graph -- of a list of targets. -genCode :: GhcMonad m - => CompConfig t - -> (ModSummary -> m a) - -> (b -> a -> IO b) - -> b - -> [String] - -> m (Either [Error] (DynFlags, b)) -genCode cfg comp usercomp acc files = do +genCode :: (GhcMonad m, Binary b) + => CompConfig + -> (a -> CompiledModule b -> IO a) + -> a + -> [String] + -> m (Either [Error] (DynFlags, a)) +genCode cfg f acc files = do dfs <- getSessionDynFlags - merrs <- handleSourceError (maybeErrors dfs) $ do + eerrs <- 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 + + -- Compile all modules; if cached code file is gone, then force + -- recompilation + (loads, mss) <- do + loads <- load LoadAllTargets mss <- depanal [] False - code <- foldM (\a x -> comp (noLog x) >>= liftIO . usercomp a) acc mss - return $ Right (dfs, code) + recomp <- filterM needRecomp mss + if null recomp + then return (loads, mss) + else do + mapM_ (liftIO . removeFile . ml_obj_file . ms_location) recomp + loads' <- load LoadAllTargets + mss' <- depanal [] False + return (loads', mss') + + acc' <- liftIO $ foldM (loadCachedMod ts) acc mss + return $ if succeeded loads then Right acc' else Left [] + case eerrs of + Left errs -> return $ Left errs + Right acc -> return $ Right (dfs, acc) 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 ()}} + needRecomp = + liftIO . fmap not . doesFileExist . cacheFileFor cfg . ms_mod_name + loadCachedMod tgts acc ms = + readModCache cfg (toModMetadata cfg ms) tgts >>= f acc + maybeErrors dfs | cfgUseGhcErrorLogger cfg = \srcerr -> liftIO $ do let msgs = srcErrorMessages srcerr printBagOfErrors dfs msgs - return . Just . map (fromErrMsg dfs) $ bagToList msgs + return . Left . map (fromErrMsg dfs) $ bagToList msgs | otherwise = - return . Just . map (fromErrMsg dfs) . bagToList . srcErrorMessages + return . Left . map (fromErrMsg dfs) . bagToList . srcErrorMessages fromErrMsg :: DynFlags -> ErrMsg -> Error fromErrMsg dfs e = Error { errorSpan = errMsgSpan e, +#if __GLASGOW_HASKELL__ >= 800 + errorMessage = showSDocForUser dfs ctx (pprLocErrMsg e), + errorExtraInfo = "" +#else errorMessage = showSDocForUser dfs ctx (errMsgShortDoc e), errorExtraInfo = showSDocForUser dfs ctx (errMsgExtraInfo e) +#endif } where ctx = errMsgContext e 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 @@ -1,15 +1,10 @@ {-# LANGUAGE FlexibleInstances, CPP, PatternGuards #-} -- | Lower level building blocks for custom code generation. module Language.Haskell.GHC.Simple.Impl ( - Compile (..), - Ghc, StgModule, PkgKey, + Ghc, PkgKey, liftIO, toSimplifiedStg, - toSimplifiedCore, - toModGuts, - simplify, - prepare, toStgBindings, - toCompiledModule, + toModMetadata, modulePkgKey, pkgKeyString ) where @@ -25,10 +20,13 @@ import CoreSyn import CoreToStg import SimplStg -#if __GLASGOW_HASKELL__ < 710 -import qualified Module as M (modulePackageId, packageIdString, PackageId) -#else +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 @@ -37,15 +35,16 @@ import System.Directory (doesFileExist, createDirectoryIfMissing) import Language.Haskell.GHC.Simple.Types -type StgModule = CompiledModule [StgBinding] -instance Compile [StgBinding] where - toCode = toSimplifiedStg +instance Intermediate [StgBinding] where + prepare = toSimplifiedStg -instance Compile CgGuts where - toCode = toSimplifiedCore +instance Intermediate CgGuts where + prepare _ = return -instance Compile ModGuts where - toCode = toModGuts +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 @@ -53,106 +52,58 @@ -- | 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 +#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 --- | Compile a 'ModSummary' into a module with metadata using a custom --- compilation function. -toCompiledModule :: GhcMonad m - => CompConfig a - -> (ModSummary -> m a) - -> ModSummary - -> m (CompiledModule a) -toCompiledModule cfg comp ms = do - code <- comp ms - ts <- getTargets - dfs <- getSessionDynFlags - iface <- getModIface dfs - let hifile = ml_hi_file $ ms_location ms - when (cfgAlwaysCreateHiFiles cfg) . liftIO $ do - exists <- doesFileExist hifile - unless exists $ do - createDirectoryIfMissing True (takeDirectory hifile) - writeBinIface dfs hifile iface - 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, - modInterface = iface, - modInterfaceFile = hifile, - modCompiledModule = code - } - where - getModIface dfs = do - env <- getSession - pkgIfaceTbl <- eps_PIT `fmap` liftIO (readIORef (hsc_EPS env)) - let homePkgTbl = hsc_HPT env - case lookupIfaceByModule dfs homePkgTbl pkgIfaceTbl (ms_mod ms) of - Just mi -> return mi - _ -> error "Module interface does not exist!" - - --- | 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 +-- | 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 -- for more information about STG and how it relates to core and Haskell. -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 --- 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 +toSimplifiedStg :: ModSummary -> CgGuts -> CompPipeline [StgBinding] +toSimplifiedStg ms cgguts = do + env <- hsc_env `fmap` getPipeState + let dfs = hsc_dflags env + liftIO $ do + prog <- prepareCore env dfs ms cgguts + stg <- coreToStg dfs (ms_mod ms) prog + fst `fmap` stg2stg dfs (ms_mod ms) stg -- | 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 +prepareCore :: HscEnv -> DynFlags -> ModSummary -> CgGuts -> IO CoreProgram +prepareCore env dfs _ms p = do +#if __GLASGOW_HASKELL__ >= 800 + liftIO $ 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 - --- | 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/PrimIface.hs b/src/Language/Haskell/GHC/Simple/PrimIface.hs --- a/src/Language/Haskell/GHC/Simple/PrimIface.hs +++ b/src/Language/Haskell/GHC/Simple/PrimIface.hs @@ -25,7 +25,13 @@ primIface, fixPrimopTypes ) where import IfaceEnv (initNameCache) -import PrelInfo (wiredInThings, primOpRules, ghcPrimIds) +import PrelInfo (primOpRules, ghcPrimIds) +#if __GLASGOW_HASKELL__ < 800 +import PrelInfo (wiredInThings) +#else +import PrelInfo (wiredInIds, primOpId) +import TcTypeNats (typeNatTyCons) +#endif import PrimOp hiding (primOpSig) import IdInfo import Rules @@ -63,21 +69,34 @@ mi_fix_fn = mkIfaceFixCache fixies } where - fixies = (getOccName seqId, Fixity 0 InfixR) : + fixies = (getOccName seqId, fixity "seq" 0 InfixR) : [(primOpOcc op, f) | op <- allThePrimOps , Just f <- [primOpFixity op]] +#if __GLASGOW_HASKELL__ >= 800 + fixity = Fixity +#else + fixity _ = Fixity +#endif exports :: (PrimOp -> PrimOpInfo) -> (PrimOp -> Arity -> StrictSig) -> [IfaceExport] exports nfo str = concat [ - map (Avail . idName) ghcPrimIds, - map (Avail . idName . (fixPrimOp nfo str)) allThePrimOps, - [ AvailTC n [n] + map avail ghcPrimIds, + map (avail . (fixPrimOp nfo str)) allThePrimOps, + [ availTC n | tc <- funTyCon : coercibleTyCon : primTyCons, let n = tyConName tc] ] - + where +#if __GLASGOW_HASKELL__ >= 800 + avail = Avail NotPatSyn . idName + availTC n = AvailTC n [n] [] +#else + avail = Avail . idName + availTC n = AvailTC n [n] +#endif + -- | Fix primop types in the name cache. fixPrimopTypes :: (PrimOp -> PrimOpInfo) -> (PrimOp -> Arity -> StrictSig) @@ -95,6 +114,27 @@ map (getName . AnId . fixPrimOp nfo str) allThePrimOps ] +#if __GLASGOW_HASKELL__ >= 800 +-- This list is used only to initialise HscMain.knownKeyNames +-- to ensure that when you say "Prelude.map" in your source code, you +-- get a Name with the correct known key (See Note [Known-key names]) +wiredInThings + = concat + [ -- Wired in TyCons and their implicit Ids + tycon_things + , concatMap implicitTyThings tycon_things + + -- Wired in Ids + , map AnId wiredInIds + + -- PrimOps + , map (AnId . primOpId) allThePrimOps + ] + where + tycon_things = map ATyCon ([funTyCon] ++ primTyCons ++ wiredInTyCons + ++ typeNatTyCons) +#endif + -- | Primitive operation signature: constists of the op's type, arity and -- strictness annotations. data PrimOpSig = PrimOpSig { @@ -130,7 +170,11 @@ Type | GenPrimOp OccName -- string :: \/a1..an . T1 -> .. -> Tk -> T +#if __GLASGOW_HASKELL__ >= 800 + [TyBinder] +#else [TyVar] +#endif [Type] Type @@ -147,12 +191,17 @@ unique = mkPrimOpIdUnique $ primOpTag op nfo = flip setCallArityInfo (opArity sig) $ noCafIdInfo `setStrictnessInfo` opStrictness sig - `setSpecInfo` si + `setRuleInfo` ri `setArityInfo` opArity sig `setInlinePragInfo` neverInlinePragma - si = mkSpecInfo $ case primOpRules name op of + ri = mkRuleInfo $ case primOpRules name op of Just r -> [r] _ -> [] +#if __GLASGOW_HASKELL__ < 800 + mkRuleInfo = mkSpecInfo + infixl 1 `setRuleInfo` + setRuleInfo = setSpecInfo +#endif -- | Create a 'PrimOpInfo' for dyadic, monadic and compare primops. -- Needed by GHC-generated primop info includes. @@ -163,5 +212,9 @@ -- | Create a general 'PrimOpInfo'. Needed by GHC-generated primop info -- includes. +#if __GLASGOW_HASKELL__ >= 800 +mkGenPrimOp :: FastString -> [TyBinder] -> [Type] -> Type -> PrimOpInfo +#else mkGenPrimOp :: FastString -> [TyVar] -> [Type] -> Type -> PrimOpInfo +#endif mkGenPrimOp str tvs tys ty = GenPrimOp (mkVarOccFS str) tvs tys ty 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,17 +1,18 @@ -- | Config, input and output types for the simplified GHC API. module Language.Haskell.GHC.Simple.Types ( -- * GHC pipeline configuration - Compile (..), + Intermediate (..), CompConfig, defaultConfig, cfgGhcFlags, cfgUseTargetsFromFlags, cfgUpdateDynFlags, cfgGhcLibDir, - cfgUseGhcErrorLogger, cfgCustomPrimIface, cfgGhcPipeline, - cfgAlwaysCreateHiFiles, cfgStopPhases, + cfgUseGhcErrorLogger, cfgCustomPrimIface, cfgStopPhases, + cfgCacheDirectory, cfgCacheFileExt, -- * Convenience functions for common settings combinations ncgPhases, disableCodeGen, -- * Compilation results and errors + ModMetadata (..), CompiledModule (..), CompResult (..), Error (..), @@ -20,17 +21,20 @@ ) where import GHC +import HscTypes (CgGuts) import DriverPhases +import DriverPipeline (CompPipeline) import Language.Haskell.GHC.Simple.PrimIface +import Data.Binary (Binary) --- | 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 +-- | An intermediate source language, usable as the the input for a +-- 'Compile' compilation function. +class Intermediate a where + prepare :: ModSummary -> CgGuts -> CompPipeline a -- | GHC pipeline configuration, parameterized over the intermediate code -- produced by the pipeline. -data CompConfig a = CompConfig { +data CompConfig = CompConfig { -- | GHC command line dynamic flags to control the Haskell to STG -- compilation pipeline. -- For instance, passing @["-O2", "-DHELLO"]@ here is equivalent to @@ -84,6 +88,17 @@ cfgCustomPrimIface :: Maybe (PrimOp -> PrimOpInfo, PrimOp -> Arity -> StrictSig), + -- | Cache directory for compiled code. If @Nothing@, the current directory + -- is used. + -- + -- Default: @Nothing@ + cfgCacheDirectory :: Maybe FilePath, + + -- | File extension of cache files. + -- + -- Default: @cache@ + cfgCacheFileExt :: String, + -- | Stop compilation when any of these this phases are reached, -- without performing it. If you are doing custom code generation and -- don't want GHC to generate any code - for instance when writing a @@ -91,31 +106,11 @@ -- @ncgPhases@. -- -- Default: @[]@ - cfgStopPhases :: [Phase], - - -- | 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, - - -- | Always ensure that the interface file indicated by the - -- 'modInterfaceFile' field of 'CompiledModule' exists? - -- When compiling with @hscTarget = HscNothing@, GHC will not - -- automatically create module interface files. - -- This is undesirable if, for instance, one wants the compiler to - -- generate interface files as well as custom generated code, but not - -- invoke any standard GHC code generator such as the LLVM or NCG - -- generators. - -- - -- Default: @True@ - cfgAlwaysCreateHiFiles :: Bool + cfgStopPhases :: [Phase] } -- | Default configuration. -defaultConfig :: Compile a => CompConfig a +defaultConfig :: CompConfig defaultConfig = CompConfig { cfgGhcFlags = [], cfgUseTargetsFromFlags = True, @@ -123,9 +118,9 @@ cfgUseGhcErrorLogger = False, cfgGhcLibDir = Nothing, cfgCustomPrimIface = Nothing, - cfgStopPhases = [], - cfgGhcPipeline = toCode, - cfgAlwaysCreateHiFiles = True + cfgCacheDirectory = Nothing, + cfgCacheFileExt = "cache", + cfgStopPhases = [] } -- | Phases in which the native code generator is invoked. You want to stop @@ -134,7 +129,7 @@ ncgPhases = [CmmCpp, Cmm, As False, As True] -- | Disable any native code generation and linking. -disableCodeGen :: CompConfig a -> CompConfig a +disableCodeGen :: CompConfig -> CompConfig disableCodeGen cfg = cfg { cfgStopPhases = ncgPhases, cfgUpdateDynFlags = asmTarget . cfgUpdateDynFlags cfg @@ -143,40 +138,42 @@ asmTarget dfs = dfs {hscTarget = HscAsm, ghcLink = NoLink} -- | Compiler output and metadata for a given module. -data CompiledModule a = CompiledModule { +data CompiledModule a = CompiledModule { + -- | Module data generated by compilation; usually bindings of some kind. + modCompiledModule :: a, + + -- | Metadata for the compiled module. + modMetadata :: ModMetadata, + + -- | Was the module a target of the current compilation, as opposed to + -- a dependency of some target? + modIsTarget :: Bool + } + +-- | Metadata for a module under compilation. +data ModMetadata = ModMetadata { -- | 'ModSummary' for the module, as given by GHC. - modSummary :: ModSummary, + mmSummary :: 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, + mmName :: 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, + mmPackageKey :: String, -- | Was the module compiler from a @hs-boot@ file? - modSourceIsHsBoot :: Bool, + mmSourceIsHsBoot :: Bool, -- | The Haskell source the module was compiled from, if any. - modSourceFile :: Maybe FilePath, - - -- | 'ModIface' structure corresponding to this module. - -- If 'modInterfaceFile' exists, it contains this structure. - modInterface :: ModIface, + mmSourceFile :: Maybe FilePath, -- | Interface file corresponding to this module. - modInterfaceFile :: FilePath, - - -- | Module data generated by compilation; usually bindings of some kind. - modCompiledModule :: a + mmInterfaceFile :: FilePath } -- | A GHC error message. @@ -223,5 +220,5 @@ -- | Does the given 'CompResult' represent a successful compilation? compSuccess :: CompResult a -> Bool -compSuccess (Success {}) = True -compSuccess _ = False +compSuccess Success{} = True +compSuccess _ = False