module DDC.Core.Salt.Runtime
(
Config (..)
, runtimeImportKinds
, runtimeImportTypes
, rTop
, xGetTag
, xAllocBoxed
, xGetFieldOfBoxed
, xSetFieldOfBoxed
, xAllocRawSmall
, xPayloadOfRawSmall
, xCreate
, xRead
, xWrite
, xPeekBuffer
, xPokeBuffer
, xFail
, xReturn)
where
import DDC.Core.Salt.Compounds
import DDC.Core.Salt.Name
import DDC.Core.Salt.Env
import DDC.Core.Compounds
import DDC.Core.Module
import DDC.Core.Exp
import qualified Data.Map as Map
import Data.Map (Map)
data Config
= Config
{
configHeapSize :: Integer
}
runtimeImportKinds :: Map Name (QualName Name, Kind Name)
runtimeImportKinds
= Map.fromList
[ rn ukTop ]
where rn (UName n, t) = (n, (QualName (ModuleName ["Runtime"]) n, t))
rn _ = error "runtimeImportKinds: all runtime bindings must be named."
runtimeImportTypes :: Map Name (QualName Name, Type Name)
runtimeImportTypes
= Map.fromList
[ rn utGetTag
, rn utAllocBoxed
, rn utGetFieldOfBoxed
, rn utSetFieldOfBoxed
, rn utAllocRawSmall
, rn utPayloadOfRawSmall ]
where rn (UName n, t) = (n, (QualName (ModuleName ["Runtime"]) n, t))
rn _ = error "runtimeImportTypes: all runtime bindings must be named."
rTop :: Type Name
rTop = TVar (fst ukTop)
ukTop :: (Bound Name, Kind Name)
ukTop
= ( UName (NameVar "rT")
, kRegion)
xGetTag :: a -> Type Name -> Exp a Name -> Exp a Name
xGetTag a tR x2
= xApps a (XVar a $ fst utGetTag)
[ XType tR, x2 ]
utGetTag :: (Bound Name, Type Name)
utGetTag
= ( UName (NameVar "getTag")
, tForall kRegion $ \r -> tPtr r tObj `tFunPE` tTag)
xAllocBoxed :: a -> Type Name -> Integer -> Exp a Name -> Exp a Name
xAllocBoxed a tR tag x2
= xApps a (XVar a $ fst utAllocBoxed)
[ XType tR
, XCon a (mkDaConAlg (NameLitTag tag) tTag)
, x2]
utAllocBoxed :: (Bound Name, Type Name)
utAllocBoxed
= ( UName (NameVar "allocBoxed")
, tForall kRegion $ \r -> (tTag `tFunPE` tNat `tFunPE` tPtr r tObj))
xGetFieldOfBoxed
:: a
-> Type Name
-> Type Name
-> Exp a Name
-> Integer
-> Exp a Name
xGetFieldOfBoxed a trPrime tField x2 offset
= xApps a (XVar a $ fst utGetFieldOfBoxed)
[ XType trPrime, XType tField
, x2
, xNat a offset ]
utGetFieldOfBoxed :: (Bound Name, Type Name)
utGetFieldOfBoxed
= ( UName (NameVar "getFieldOfBoxed")
, tForalls [kRegion, kData]
$ \[r1, t2]
-> tPtr r1 tObj
`tFunPE` tNat
`tFunPE` t2)
xSetFieldOfBoxed
:: a
-> Type Name
-> Type Name
-> Exp a Name
-> Integer
-> Exp a Name
-> Exp a Name
xSetFieldOfBoxed a trPrime tField x2 offset val
= xApps a (XVar a $ fst utSetFieldOfBoxed)
[ XType trPrime, XType tField
, x2
, xNat a offset
, val]
utSetFieldOfBoxed :: (Bound Name, Type Name)
utSetFieldOfBoxed
= ( UName (NameVar "setFieldOfBoxed")
, tForalls [kRegion, kData]
$ \[r1, t2]
-> tPtr r1 tObj
`tFunPE` tNat
`tFunPE` t2
`tFunPE` tVoid)
xAllocRawSmall :: a -> Type Name -> Integer -> Exp a Name -> Exp a Name
xAllocRawSmall a tR tag x2
= xApps a (XVar a $ fst utAllocRawSmall)
[ XType tR
, xTag a tag
, x2]
utAllocRawSmall :: (Bound Name, Type Name)
utAllocRawSmall
= ( UName (NameVar "allocRawSmall")
, tForall kRegion $ \r -> (tTag `tFunPE` tNat `tFunPE` tPtr r tObj))
xPayloadOfRawSmall :: a -> Type Name -> Exp a Name -> Exp a Name
xPayloadOfRawSmall a tR x2
= xApps a (XVar a $ fst utPayloadOfRawSmall)
[XType tR, x2]
utPayloadOfRawSmall :: (Bound Name, Type Name)
utPayloadOfRawSmall
= ( UName (NameVar "payloadOfRawSmall")
, tForall kRegion $ \r -> (tFunPE (tPtr r tObj) (tPtr r (tWord 8))))
xCreate :: a -> Integer -> Exp a Name
xCreate a bytes
= XApp a (XVar a uCreate)
(xNat a bytes)
uCreate :: Bound Name
uCreate = UPrim (NamePrimOp $ PrimStore $ PrimStoreCreate)
(tNat `tFunPE` tVoid)
xRead :: a -> Type Name -> Exp a Name -> Integer -> Exp a Name
xRead a tField xAddr offset
= XApp a (XApp a (XApp a (XVar a uRead)
(XType tField))
xAddr)
(xNat a offset)
uRead :: Bound Name
uRead = UPrim (NamePrimOp $ PrimStore $ PrimStoreRead)
(tForall kData $ \t -> tAddr `tFunPE` tNat `tFunPE` t)
xWrite :: a -> Type Name -> Exp a Name -> Integer -> Exp a Name -> Exp a Name
xWrite a tField xAddr offset xVal
= XApp a (XApp a (XApp a (XApp a (XVar a uWrite)
(XType tField))
xAddr)
(xNat a offset))
xVal
uWrite :: Bound Name
uWrite = UPrim (NamePrimOp $ PrimStore $ PrimStoreWrite)
(tForall kData $ \t -> tAddr `tFunPE` tNat `tFunPE` t `tFunPE` tVoid)
xPeekBuffer :: a -> Type Name -> Type Name -> Exp a Name -> Integer -> Exp a Name
xPeekBuffer a r t xPtr offset
= let castedPtr = xCast a r t (tWord 8) xPtr
in XApp a (XApp a (XApp a (XApp a (XVar a uPeek)
(XType r))
(XType t))
castedPtr)
(xNat a offset)
uPeek :: Bound Name
uPeek = UPrim (NamePrimOp $ PrimStore $ PrimStorePeek)
(typeOfPrimStore PrimStorePeek)
xPokeBuffer :: a -> Type Name -> Type Name -> Exp a Name -> Integer -> Exp a Name -> Exp a Name
xPokeBuffer a r t xPtr offset xVal
= let castedPtr = xCast a r t (tWord 8) xPtr
in XApp a (XApp a (XApp a (XApp a (XApp a (XVar a uPoke)
(XType r))
(XType t))
castedPtr)
(xNat a offset))
xVal
uPoke :: Bound Name
uPoke = UPrim (NamePrimOp $ PrimStore $ PrimStorePoke)
(typeOfPrimStore PrimStorePoke)
xCast :: a -> Type Name -> Type Name -> Type Name -> Exp a Name -> Exp a Name
xCast a r toType fromType xPtr
= XApp a (XApp a (XApp a (XApp a (XVar a uCast)
(XType r))
(XType toType))
(XType fromType))
xPtr
uCast :: Bound Name
uCast = UPrim (NamePrimOp $ PrimStore $ PrimStoreCastPtr)
(typeOfPrimStore PrimStoreCastPtr)
xFail :: a -> Type Name -> Exp a Name
xFail a t
= XApp a (XVar a uFail) (XType t)
where uFail = UPrim (NamePrimOp (PrimControl PrimControlFail)) tFail
tFail = TForall (BAnon kData) (TVar $ UIx 0)
xReturn :: a -> Type Name -> Exp a Name -> Exp a Name
xReturn a t x
= XApp a (XApp a (XVar a (UPrim (NamePrimOp (PrimControl PrimControlReturn))
(tForall kData $ \t1 -> t1 `tFunPE` t1)))
(XType t))
x