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.0.0 +version: 0.1.1.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 @@ -26,15 +26,14 @@ exposed-modules: Language.Haskell.GHC.Simple, Language.Haskell.GHC.Simple.Impl - other-modules: + Language.Haskell.GHC.Simple.PrimIface 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 + ghc-paths >=0.1 && <0.2 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 @@ -1,12 +1,12 @@ {-# LANGUAGE CPP, PatternGuards #-} -- | Simplified interface to the GHC API. module Language.Haskell.GHC.Simple ( - -- Configuration, input and output types + -- * Configuration, input and output types module Simple.Types, Compile, StgModule, - -- GHC re-exports needed to meaningfully process STG and Core. + -- * GHC re-exports for processing STG and Core module CoreSyn, module StgSyn, module Module, module Id, module IdInfo, module Var, module Literal, module DataCon, module OccName, module Name, @@ -17,7 +17,7 @@ PkgKey, pkgKeyString, modulePkgKey, - -- Entry points + -- * Entry points compile, compileWith, genericCompile ) where @@ -30,6 +30,7 @@ import Bag import SrcLoc import Outputable +import Hooks -- Convenience re-exports for fiddling with STG import StgSyn @@ -51,6 +52,8 @@ -- Misc. stuff import GHC.Paths (libdir) import Data.IORef +import Control.Monad +import Language.Haskell.GHC.Simple.PrimIface as Simple.PrimIface import Language.Haskell.GHC.Simple.Types as Simple.Types import Language.Haskell.GHC.Simple.Impl @@ -61,7 +64,7 @@ -- ^ List of compilation targets. A target can be either a module -- or a file name. -> IO (CompResult a) -compile = compileWith def +compile = compileWith defaultConfig -- | Compile a list of targets and their dependencies using a custom -- configuration. @@ -92,12 +95,21 @@ (flags, _staticwarns) <- parseStaticFlags $ map noLoc (cfgGhcFlags cfg) warns <- newIORef [] runGhc (maybe (Just libdir) Just (cfgGhcLibDir cfg)) $ do + + -- 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 } - _ <- setSessionDynFlags dfs'' + + -- 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'' + + -- Generate code and report results ecode <- genCode (toCompiledModule comp) (files ++ map unLoc files2) ws <- liftIO $ readIORef warns case ecode of @@ -113,6 +125,12 @@ compWarnings = ws } 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 diff --git a/src/Language/Haskell/GHC/Simple/PrimIface.hs b/src/Language/Haskell/GHC/Simple/PrimIface.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/GHC/Simple/PrimIface.hs @@ -0,0 +1,167 @@ +{-# LANGUAGE CPP #-} +-- | Facilities for using a custom GHC.Prim interface. +-- +-- The simplest(?) way to use this is to generate primop info +-- using the @genprimopcode@ program from GHC, making any desired changes +-- to those files, and passing the @primOpInfo@ and @primOpStrictness@ +-- functions defined therein as the @cfgCustomPrimIface@ member of +-- your config. +-- +-- Your strictness and info functions need to support all the +-- primops exported by the GHC version in use, making code written for this +-- interface rather less portable than code using the rest of @ghc-simple@. +-- +-- This functionality is probably what you want if you are making a cross +-- compiler, to prevent the types of GHC primops from changing depending on +-- the compiler host platform. +-- +-- If you are *not* making a cross compiler, chances are you will not want to +-- touch this with a ten foot pole. +module Language.Haskell.GHC.Simple.PrimIface ( + module Demand, module TysWiredIn, module FastString, module CmmType, + module BasicTypes, + PrimOp (..), PrimOpInfo (..), + mkGenPrimOp, mkDyadic, mkMonadic, mkCompare, + primIface, fixPrimopTypes + ) where +import IfaceEnv (initNameCache) +import PrelInfo (wiredInThings, primOpRules, ghcPrimIds) +import PrimOp hiding (primOpSig) +import IdInfo +import Rules +import PrelNames +import Name +import BasicTypes +import Type +import Unique +import Id +import TysWiredIn +import TysPrim +import FastString +import Demand +import HscTypes +import Avail +import MkId (seqId) +import Data.IORef (modifyIORef') +import TyCon +import CmmType + +#if __GLASGOW_HASKELL__ < 710 +setCallArityInfo :: IdInfo -> Arity -> IdInfo +setCallArityInfo i _ = i +#endif + +-- | Module interface for @GHC.Prim@, with the given function applied to each +-- primop. +primIface :: (PrimOp -> PrimOpInfo) + -> (PrimOp -> Arity -> StrictSig) + -> ModIface +primIface nfo str = (emptyModIface gHC_PRIM) { + mi_exports = exports nfo str, + mi_decls = [], + mi_fixities = fixies, + mi_fix_fn = mkIfaceFixCache fixies + } + where + fixies = (getOccName seqId, Fixity 0 InfixR) : + [(primOpOcc op, f) + | op <- allThePrimOps + , Just f <- [primOpFixity op]] + +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] + | tc <- funTyCon : coercibleTyCon : primTyCons, let n = tyConName tc] + ] + +-- | Fix primop types in the name cache. +fixPrimopTypes :: (PrimOp -> PrimOpInfo) + -> (PrimOp -> Arity -> StrictSig) + -> HscEnv + -> IO () +fixPrimopTypes nfo str env = do + modifyIORef' (hsc_NC env) fixNC + where + isPrim (AnId v) = isPrimOpId v + isPrim _ = False + + fixNC (NameCache us _) = initNameCache us $ concat [ + [getName thing | thing <- wiredInThings, not (isPrim thing)], + basicKnownKeyNames, + map (getName . AnId . fixPrimOp nfo str) allThePrimOps + ] + +-- | Primitive operation signature: constists of the op's type, arity and +-- strictness annotations. +data PrimOpSig = PrimOpSig { + opType :: !Type, + opArity :: !Arity, + opStrictness :: !StrictSig + } + +-- | Get the signature of a primitive operation. +primOpSig :: (PrimOp -> PrimOpInfo) + -> (PrimOp -> Arity -> StrictSig) + -> PrimOp + -> PrimOpSig +primOpSig nfo str op = PrimOpSig { + opType = typ, + opArity = arity, + opStrictness = str op arity + } + where + (typ, arity) = + case nfo op of + Monadic _ t -> (mkForAllTys [] $ mkFunTys [t] t, 1) + Dyadic _ t -> (mkForAllTys [] $ mkFunTys [t,t] t, 2) + Compare _ t -> (mkForAllTys [] $ mkFunTys [t,t] intPrimTy, 2) + GenPrimOp _ tvs ts t -> (mkForAllTys tvs $ mkFunTys ts t, length ts) + +data PrimOpInfo + = Dyadic OccName -- string :: T -> T -> T + Type + | Monadic OccName -- string :: T -> T + Type + | Compare OccName -- string :: T -> T -> Bool + Type + + | GenPrimOp OccName -- string :: \/a1..an . T1 -> .. -> Tk -> T + [TyVar] + [Type] + Type + +fixPrimOp :: (PrimOp -> PrimOpInfo) + -> (PrimOp -> Arity -> StrictSig) + -> PrimOp + -> Id +fixPrimOp opnfo str op = + var + where + sig = primOpSig opnfo str op + var = mkGlobalId (PrimOpId op) name (opType sig) nfo + name = mkWiredInName gHC_PRIM (primOpOcc op) unique (AnId var) UserSyntax + unique = mkPrimOpIdUnique $ primOpTag op + nfo = flip setCallArityInfo (opArity sig) $ + noCafIdInfo `setStrictnessInfo` opStrictness sig + `setSpecInfo` si + `setArityInfo` opArity sig + `setInlinePragInfo` neverInlinePragma + si = mkSpecInfo $ case primOpRules name op of + Just r -> [r] + _ -> [] + +-- | Create a 'PrimOpInfo' for dyadic, monadic and compare primops. +-- Needed by GHC-generated primop info includes. +mkDyadic, mkMonadic, mkCompare :: FastString -> Type -> PrimOpInfo +mkDyadic str ty = Dyadic (mkVarOccFS str) ty +mkMonadic str ty = Monadic (mkVarOccFS str) ty +mkCompare str ty = Compare (mkVarOccFS str) ty + +-- | Create a general 'PrimOpInfo'. Needed by GHC-generated primop info +-- includes. +mkGenPrimOp :: FastString -> [TyVar] -> [Type] -> Type -> PrimOpInfo +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,25 +1,21 @@ -- | Config, input and output types for the simplified GHC API. module Language.Haskell.GHC.Simple.Types ( - Default (..), - -- Configuration CompConfig, + defaultConfig, cfgGhcFlags, cfgUseTargetsFromFlags, cfgUpdateDynFlags, cfgGhcLibDir, - cfgUseGhcErrorLogger, + cfgUseGhcErrorLogger, cfgCustomPrimIface, -- Results and errors CompiledModule (..), CompResult (..), Error (..), Warning (..), - ghcSuccess + compSuccess ) where --- GHC imports import GHC - --- Misc. stuff -import Data.Default +import Language.Haskell.GHC.Simple.PrimIface data CompConfig = CompConfig { -- | GHC command line flags to control the Haskell to STG compilation @@ -63,17 +59,29 @@ -- of the system's default GHC compiler will be used. -- -- Default: @Nothing@ - cfgGhcLibDir :: Maybe FilePath + cfgGhcLibDir :: Maybe FilePath, + + -- | Use a custom interface for @GHC.Prim@. + -- This is useful if you want to, for instance, compile to a 32 bit + -- target architecture on a 64 bit host. + -- + -- For more information, see "Language.Haskell.GHC.Simple.PrimIface". + -- + -- Default: @Nothing@ + cfgCustomPrimIface :: Maybe (PrimOp -> PrimOpInfo, + PrimOp -> Arity -> StrictSig) } -instance Default CompConfig where - def = CompConfig { - cfgGhcFlags = [], - cfgUseTargetsFromFlags = True, - cfgUpdateDynFlags = id, - cfgUseGhcErrorLogger = False, - cfgGhcLibDir = Nothing - } +-- | Default configuration. +defaultConfig :: CompConfig +defaultConfig = CompConfig { + cfgGhcFlags = [], + cfgUseTargetsFromFlags = True, + cfgUpdateDynFlags = id, + cfgUseGhcErrorLogger = False, + cfgGhcLibDir = Nothing, + cfgCustomPrimIface = Nothing + } -- | Compiler output and metadata for a given module. data CompiledModule a = CompiledModule { @@ -151,6 +159,6 @@ } -- | Does the given 'CompResult' represent a successful compilation? -ghcSuccess :: CompResult a -> Bool -ghcSuccess (Success {}) = True -ghcSuccess _ = False +compSuccess :: CompResult a -> Bool +compSuccess (Success {}) = True +compSuccess _ = False