module DDC.Core.Salt.Runtime
(
Config (..)
, runtimeImportKinds
, runtimeImportTypes
, rTop
, xGetTag
, xAllocBoxed
, xGetFieldOfBoxed
, xSetFieldOfBoxed
, xAllocRaw
, xPayloadOfRaw
, xAllocSmall
, xPayloadOfSmall
, xAllocThunk
, xArgsOfThunk
, xSetFieldOfThunk
, xExtendThunk
, xCopyArgsOfThunk
, xApplyThunk
, xRunThunk
, xErrorDefault)
where
import DDC.Core.Salt.Compounds
import DDC.Core.Salt.Name
import DDC.Core.Exp.Annot
import DDC.Core.Module
import DDC.Base.Pretty
import qualified Data.Map as Map
import Data.Map (Map)
data Config
= Config
{
configHeapSize :: Integer
}
runtimeImportKinds :: Map Name (ImportType Name)
runtimeImportKinds
= Map.fromList
[ rn ukTop ]
where rn (UName n, t) = (n, ImportTypeAbstract t)
rn _ = error "ddc-core-salt: all runtime bindings must be named."
runtimeImportTypes :: Map Name (ImportValue Name)
runtimeImportTypes
= Map.fromList
[ rn utGetTag
, rn utAllocBoxed
, rn utGetFieldOfBoxed
, rn utSetFieldOfBoxed
, rn utAllocSmall
, rn utPayloadOfSmall
, rn utAllocRaw
, rn utPayloadOfRaw
, rn utAllocThunk
, rn utArgsOfThunk
, rn utSetFieldOfThunk
, rn utExtendThunk
, rn utCopyArgsOfThunk
, rn utRunThunk
, rn (utApplyThunk 0)
, rn (utApplyThunk 1)
, rn (utApplyThunk 2)
, rn (utApplyThunk 3)
, rn (utApplyThunk 4)
, rn utErrorDefault]
where rn (UName n, t) = (n, ImportValueSea (renderPlain $ ppr n) t)
rn _ = error "ddc-core-salt: 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 a tR, x2 ]
utGetTag :: (Bound Name, Type Name)
utGetTag
= ( UName (NameVar "getTag")
, tForall kRegion $ \r -> tPtr r tObj `tFun` tTag)
xAllocThunk
:: a
-> Type Name
-> Exp a Name
-> Exp a Name
-> Exp a Name
-> Exp a Name
-> Exp a Name
-> Exp a Name
xAllocThunk a tR xFun xParam xBoxes xArgs xRun
= xApps a (XVar a $ fst utAllocThunk)
[ XType a tR, xFun, xParam, xBoxes, xArgs, xRun]
utAllocThunk :: (Bound Name, Type Name)
utAllocThunk
= ( UName (NameVar "allocThunk")
, tForall kRegion
$ \tR -> (tAddr `tFun` tNat `tFun` tNat `tFun` tNat
`tFun` tNat `tFun` tPtr tR tObj))
xCopyArgsOfThunk
:: a -> Type Name -> Type Name
-> Exp a Name -> Exp a Name -> Exp a Name -> Exp a Name -> Exp a Name
xCopyArgsOfThunk a tRSrc tRDst xSrc xDst xIndex xLen
= xApps a (XVar a $ fst utCopyArgsOfThunk)
[ XType a tRSrc, XType a tRDst, xSrc, xDst, xIndex, xLen ]
utCopyArgsOfThunk :: (Bound Name, Type Name)
utCopyArgsOfThunk
= ( UName (NameVar "copyThunk")
, tForalls [kRegion, kRegion]
$ \[tR1, tR2] -> (tPtr tR1 tObj
`tFun` tPtr tR2 tObj
`tFun` tNat `tFun` tNat
`tFun` tPtr tR2 tObj))
xExtendThunk
:: a -> Type Name -> Type Name
-> Exp a Name -> Exp a Name -> Exp a Name
xExtendThunk a tRSrc tRDst xSrc xMore
= xApps a (XVar a $ fst utExtendThunk)
[ XType a tRSrc, XType a tRDst, xSrc, xMore ]
utExtendThunk :: (Bound Name, Type Name)
utExtendThunk
= ( UName (NameVar "extendThunk")
, tForalls [kRegion, kRegion]
$ \[tR1, tR2] -> (tPtr tR1 tObj `tFun` tNat `tFun` tPtr tR2 tObj))
xArgsOfThunk
:: a -> Type Name
-> Exp a Name -> Exp a Name
xArgsOfThunk a tR xThunk
= xApps a (XVar a $ fst utArgsOfThunk)
[ XType a tR, xThunk ]
utArgsOfThunk :: (Bound Name, Type Name)
utArgsOfThunk
= ( UName (NameVar "argsThunk")
, tForall kRegion
$ \tR -> (tPtr tR tObj `tFun` tNat))
xSetFieldOfThunk
:: a
-> Type Name
-> Type Name
-> Exp a Name
-> Exp a Name
-> Exp a Name
-> Exp a Name
-> Exp a Name
xSetFieldOfThunk a tR tC xObj xBase xIndex xVal
= xApps a (XVar a $ fst utSetFieldOfThunk)
[ XType a tR, XType a tC, xObj, xBase, xIndex, xVal]
utSetFieldOfThunk :: (Bound Name, Type Name)
utSetFieldOfThunk
= ( UName (NameVar "setThunk")
, tForalls [kRegion, kRegion]
$ \[tR1, tR2]
-> (tPtr tR1 tObj
`tFun` tNat `tFun` tNat
`tFun` tPtr tR2 tObj `tFun` tVoid))
xApplyThunk
:: a -> Int
-> [Exp a Name] -> Exp a Name
xApplyThunk a arity xsArgs
= xApps a (XVar a $ fst (utApplyThunk arity)) xsArgs
utApplyThunk :: Int -> (Bound Name, Type Name)
utApplyThunk arity
= let krThunk = kRegion
krsArg = replicate arity kRegion
krResult = kRegion
ks = [krThunk] ++ krsArg ++ [krResult]
t = tForalls ks $ \rs
-> let (rThunk : rsMore) = rs
rsArg = take arity rsMore
[rResult] = drop arity rsMore
Just t' = tFunOfList
$ [tPtr rThunk tObj]
++ [tPtr r tObj | r <- rsArg]
++ [tPtr rResult tObj]
in t'
in ( UName (NameVar $ "apply" ++ show arity)
, t )
xRunThunk
:: a
-> Type Name
-> Type Name
-> Exp a Name
-> Exp a Name
xRunThunk a trThunk trResult xArg
= xApps a (XVar a $ fst utRunThunk)
[XType a trThunk, XType a trResult, xArg]
utRunThunk :: (Bound Name, Type Name)
utRunThunk
= ( UName (NameVar $ "runThunk")
, tForalls [kRegion, kRegion]
$ \[tR1, tR2] -> tPtr tR1 tObj `tFun` tPtr tR2 tObj)
xAllocBoxed :: a -> Type Name -> Integer -> Exp a Name -> Exp a Name
xAllocBoxed a tR tag x2
= xApps a (XVar a $ fst utAllocBoxed)
[ XType a tR
, XCon a (DaConPrim (NamePrimLit (PrimLitTag tag)) tTag)
, x2]
utAllocBoxed :: (Bound Name, Type Name)
utAllocBoxed
= ( UName (NameVar "allocBoxed")
, tForall kRegion $ \r -> (tTag `tFun` tNat `tFun` tPtr r tObj))
xGetFieldOfBoxed
:: a
-> Type Name
-> Type Name
-> Exp a Name
-> Integer
-> Exp a Name
xGetFieldOfBoxed a trPrime trField x2 offset
= xApps a (XVar a $ fst utGetFieldOfBoxed)
[ XType a trPrime, XType a trField
, x2
, xNat a offset ]
utGetFieldOfBoxed :: (Bound Name, Type Name)
utGetFieldOfBoxed
= ( UName (NameVar "getBoxed")
, tForalls [kRegion, kRegion]
$ \[r1, r2]
-> tPtr r1 tObj
`tFun` tNat
`tFun` tPtr r2 tObj)
xSetFieldOfBoxed
:: a
-> Type Name
-> Type Name
-> Exp a Name
-> Integer
-> Exp a Name
-> Exp a Name
xSetFieldOfBoxed a trPrime trField x2 offset val
= xApps a (XVar a $ fst utSetFieldOfBoxed)
[ XType a trPrime, XType a trField
, x2
, xNat a offset
, val]
utSetFieldOfBoxed :: (Bound Name, Type Name)
utSetFieldOfBoxed
= ( UName (NameVar "setBoxed")
, tForalls [kRegion, kRegion]
$ \[r1, t2] -> tPtr r1 tObj `tFun` tNat `tFun` tPtr t2 tObj `tFun` tVoid)
xAllocRaw :: a -> Type Name -> Integer -> Exp a Name -> Exp a Name
xAllocRaw a tR tag x2
= xApps a (XVar a $ fst utAllocRaw)
[ XType a tR, xTag a tag, x2]
utAllocRaw :: (Bound Name, Type Name)
utAllocRaw
= ( UName (NameVar "allocRaw")
, tForall kRegion $ \r -> (tTag `tFun` tNat `tFun` tPtr r tObj))
xPayloadOfRaw :: a -> Type Name -> Exp a Name -> Exp a Name
xPayloadOfRaw a tR x2
= xApps a (XVar a $ fst utPayloadOfRaw)
[XType a tR, x2]
utPayloadOfRaw :: (Bound Name, Type Name)
utPayloadOfRaw
= ( UName (NameVar "payloadRaw")
, tForall kRegion $ \r -> (tFun (tPtr r tObj) (tPtr r (tWord 8))))
xAllocSmall :: a -> Type Name -> Integer -> Exp a Name -> Exp a Name
xAllocSmall a tR tag x2
= xApps a (XVar a $ fst utAllocSmall)
[ XType a tR, xTag a tag, x2]
utAllocSmall :: (Bound Name, Type Name)
utAllocSmall
= ( UName (NameVar "allocSmall")
, tForall kRegion $ \r -> (tTag `tFun` tNat `tFun` tPtr r tObj))
xPayloadOfSmall :: a -> Type Name -> Exp a Name -> Exp a Name
xPayloadOfSmall a tR x2
= xApps a (XVar a $ fst utPayloadOfSmall)
[XType a tR, x2]
utPayloadOfSmall :: (Bound Name, Type Name)
utPayloadOfSmall
= ( UName (NameVar "payloadSmall")
, tForall kRegion $ \r -> (tFun (tPtr r tObj) (tPtr r (tWord 8))))
xErrorDefault :: a -> Exp a Name -> Exp a Name -> Exp a Name
xErrorDefault a xStr xLine
= xApps a (XVar a $ fst utErrorDefault)
[xStr, xLine]
utErrorDefault :: (Bound Name, Type Name)
utErrorDefault
= ( UName (NameVar "primErrorDefault")
, tTextLit `tFun` tNat `tFun` tPtr rTop tObj)