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
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]
]
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
]
data PrimOpSig = PrimOpSig {
opType :: !Type,
opArity :: !Arity,
opStrictness :: !StrictSig
}
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
Type
| Monadic OccName
Type
| Compare OccName
Type
| GenPrimOp OccName
[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]
_ -> []
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
mkGenPrimOp :: FastString -> [TyVar] -> [Type] -> Type -> PrimOpInfo
mkGenPrimOp str tvs tys ty = GenPrimOp (mkVarOccFS str) tvs tys ty