module DDC.Core.Salt.Env
( primDataDefs
, primKindEnv
, primTypeEnv
, typeOfPrimArith
, typeOfPrimCast
, typeOfPrimCall
, typeOfPrimControl
, typeOfPrimStore
, typeIsUnboxed)
where
import DDC.Core.Salt.Compounds
import DDC.Core.Salt.Name
import DDC.Type.DataDef
import DDC.Type.Compounds
import DDC.Type.Predicates
import DDC.Type.Exp
import DDC.Type.Env (Env)
import qualified DDC.Type.Env as Env
primDataDefs :: DataDefs Name
primDataDefs
= fromListDataDefs
[ DataDef
(NamePrimTyCon PrimTyConBool)
[]
(Just [ (NameLitBool True, [])
, (NameLitBool False, []) ])
, DataDef (NamePrimTyCon PrimTyConNat) [] Nothing
, DataDef (NamePrimTyCon PrimTyConInt) [] Nothing
, DataDef (NamePrimTyCon PrimTyConTag) [] Nothing
, DataDef (NamePrimTyCon (PrimTyConWord 8)) [] Nothing
, DataDef (NamePrimTyCon (PrimTyConWord 16)) [] Nothing
, DataDef (NamePrimTyCon (PrimTyConWord 32)) [] Nothing
, DataDef (NamePrimTyCon (PrimTyConWord 64)) [] Nothing
, DataDef (NamePrimTyCon (PrimTyConFloat 32)) [] Nothing
, DataDef (NamePrimTyCon (PrimTyConFloat 64)) [] Nothing
]
primKindEnv :: Env Name
primKindEnv = Env.setPrimFun kindOfName Env.empty
kindOfName :: Name -> Maybe (Kind Name)
kindOfName nn
= case nn of
NameObjTyCon -> Just $ kData
NamePrimTyCon tc -> Just $ kindOfPrimTyCon tc
_ -> Nothing
kindOfPrimTyCon :: PrimTyCon -> Kind Name
kindOfPrimTyCon tc
= case tc of
PrimTyConVoid -> kData
PrimTyConBool -> kData
PrimTyConNat -> kData
PrimTyConInt -> kData
PrimTyConWord _ -> kData
PrimTyConFloat _ -> kData
PrimTyConAddr -> kData
PrimTyConPtr -> (kRegion `kFun` kData `kFun` kData)
PrimTyConTag -> kData
PrimTyConString -> kData
primTypeEnv :: Env Name
primTypeEnv = Env.setPrimFun typeOfName Env.empty
typeOfName :: Name -> Maybe (Type Name)
typeOfName nn
= case nn of
NamePrimOp p -> Just $ typeOfPrim p
NameLitVoid -> Just $ tVoid
NameLitBool _ -> Just $ tBool
NameLitNat _ -> Just $ tNat
NameLitInt _ -> Just $ tInt
NameLitWord _ bits -> Just $ tWord bits
NameLitTag _ -> Just $ tTag
_ -> Nothing
typeOfPrim :: PrimOp -> Type Name
typeOfPrim pp
= case pp of
PrimArith op -> typeOfPrimArith op
PrimCast cc -> typeOfPrimCast cc
PrimCall pc -> typeOfPrimCall pc
PrimControl pc -> typeOfPrimControl pc
PrimStore ps -> typeOfPrimStore ps
typeOfPrimArith :: PrimArith -> Type Name
typeOfPrimArith op
= case op of
PrimArithNeg -> tForall kData $ \t -> t `tFunPE` t
PrimArithAdd -> tForall kData $ \t -> t `tFunPE` t `tFunPE` t
PrimArithSub -> tForall kData $ \t -> t `tFunPE` t `tFunPE` t
PrimArithMul -> tForall kData $ \t -> t `tFunPE` t `tFunPE` t
PrimArithDiv -> tForall kData $ \t -> t `tFunPE` t `tFunPE` t
PrimArithMod -> tForall kData $ \t -> t `tFunPE` t `tFunPE` t
PrimArithRem -> tForall kData $ \t -> t `tFunPE` t `tFunPE` t
PrimArithEq -> tForall kData $ \t -> t `tFunPE` t `tFunPE` tBool
PrimArithNeq -> tForall kData $ \t -> t `tFunPE` t `tFunPE` tBool
PrimArithGt -> tForall kData $ \t -> t `tFunPE` t `tFunPE` tBool
PrimArithLt -> tForall kData $ \t -> t `tFunPE` t `tFunPE` tBool
PrimArithLe -> tForall kData $ \t -> t `tFunPE` t `tFunPE` tBool
PrimArithGe -> tForall kData $ \t -> t `tFunPE` t `tFunPE` tBool
PrimArithAnd -> tBool `tFunPE` tBool `tFunPE` tBool
PrimArithOr -> tBool `tFunPE` tBool `tFunPE` tBool
PrimArithShl -> tForall kData $ \t -> t `tFunPE` t `tFunPE` t
PrimArithShr -> tForall kData $ \t -> t `tFunPE` t `tFunPE` t
PrimArithBAnd -> tForall kData $ \t -> t `tFunPE` t `tFunPE` t
PrimArithBOr -> tForall kData $ \t -> t `tFunPE` t `tFunPE` t
PrimArithBXOr -> tForall kData $ \t -> t `tFunPE` t `tFunPE` t
typeOfPrimCast :: PrimCast -> Type Name
typeOfPrimCast cc
= case cc of
PrimCastPromote
-> tForalls [kData, kData] $ \[t1, t2] -> t2 `tFunPE` t1
PrimCastTruncate
-> tForalls [kData, kData] $ \[t1, t2] -> t2 `tFunPE` t1
typeOfPrimCall :: PrimCall -> Type Name
typeOfPrimCall cc
= case cc of
PrimCallTail arity -> makePrimCallType arity
makePrimCallType :: Int -> Type Name
makePrimCallType arity
= let tSuper = foldr tFunPE
(TVar (UIx 0))
(reverse [TVar (UIx i) | i <- [1..arity]])
tCall = foldr TForall (tSuper `tFunPE` tSuper)
[BAnon k | k <- replicate (arity + 1) kData]
in tCall
typeOfPrimControl :: PrimControl -> Type Name
typeOfPrimControl pc
= case pc of
PrimControlFail -> tForall kData $ \t -> t
PrimControlReturn -> tForall kData $ \t -> t `tFunPE` t
typeOfPrimStore :: PrimStore -> Type Name
typeOfPrimStore jj
= case jj of
PrimStoreSize
-> tForall kData $ \_ -> tNat
PrimStoreSize2
-> tForall kData $ \_ -> tNat
PrimStoreCreate
-> tNat `tFunPE` tVoid
PrimStoreCheck
-> tNat `tFunPE` tBool
PrimStoreRecover
-> tNat `tFunPE` tVoid
PrimStoreAlloc
-> tNat `tFunPE` tAddr
PrimStoreRead
-> tForall kData $ \t -> tAddr `tFunPE` tNat `tFunPE` t
PrimStoreWrite
-> tForall kData $ \t -> tAddr `tFunPE` tNat `tFunPE` t `tFunPE` tVoid
PrimStorePlusAddr
-> tAddr `tFunPE` tNat `tFunPE` tAddr
PrimStoreMinusAddr
-> tAddr `tFunPE` tNat `tFunPE` tAddr
PrimStorePeek
-> tForalls [kRegion, kData] $ \[r,t] -> tPtr r t `tFunPE` tNat `tFunPE` t
PrimStorePoke
-> tForalls [kRegion, kData] $ \[r,t] -> tPtr r t `tFunPE` tNat `tFunPE` t `tFunPE` tVoid
PrimStorePlusPtr
-> tForalls [kRegion, kData] $ \[r,t] -> tPtr r t `tFunPE` tNat `tFunPE` tPtr r t
PrimStoreMinusPtr
-> tForalls [kRegion, kData] $ \[r,t] -> tPtr r t `tFunPE` tNat `tFunPE` tPtr r t
PrimStoreMakePtr
-> tForalls [kRegion, kData] $ \[r,t] -> tAddr `tFunPE` tPtr r t
PrimStoreTakePtr
-> tForalls [kRegion, kData] $ \[r,t] -> tPtr r t `tFunPE` tAddr
PrimStoreCastPtr
-> tForalls [kRegion, kData, kData] $ \[r,t1,t2] -> tPtr r t2 `tFunPE` tPtr r t1
typeIsUnboxed :: Type Name -> Bool
typeIsUnboxed tt
= case tt of
TVar{} -> False
TCon (TyConBound _ k)
| isDataKind k -> True
TCon _ -> False
TForall _ t -> typeIsUnboxed t
TApp{}
| Just (_tR, tTarget) <- takeTPtr tt
, tTarget == tObj
-> False
TApp t1 t2
-> typeIsUnboxed t1 || typeIsUnboxed t2
TSum{} -> False