ghc-simple 0.1.3 → 0.4
raw patch · 5 files changed
Files
- ghc-simple.cabal +8/−6
- src/Language/Haskell/GHC/Simple.hs +168/−47
- src/Language/Haskell/GHC/Simple/Impl.hs +56/−105
- src/Language/Haskell/GHC/Simple/PrimIface.hs +61/−8
- src/Language/Haskell/GHC/Simple/Types.hs +51/−54
ghc-simple.cabal view
@@ -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:
src/Language/Haskell/GHC/Simple.hs view
@@ -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
src/Language/Haskell/GHC/Simple/Impl.hs view
@@ -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 <https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/StgSynType> -- 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
src/Language/Haskell/GHC/Simple/PrimIface.hs view
@@ -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
src/Language/Haskell/GHC/Simple/Types.hs view
@@ -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