module DDC.Core.Salt.Env
( primDataDefs
, primKindEnv
, primTypeEnv
, typeOfPrimOp
, typeOfPrimArith
, typeOfPrimCast
, typeOfPrimCall
, typeOfPrimControl
, typeOfPrimStore
, typeOfPrimLit
, typeIsUnboxed)
where
import DDC.Core.Salt.Compounds.PrimArith
import DDC.Core.Salt.Compounds.PrimCast
import DDC.Core.Salt.Compounds.PrimControl
import DDC.Core.Salt.Compounds.PrimStore
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
[ makeDataDefAlg
(NamePrimTyCon PrimTyConBool)
[]
(Just [ (NamePrimLit (PrimLitBool True), [])
, (NamePrimLit (PrimLitBool False), []) ])
, makeDataDefAlg (NamePrimTyCon PrimTyConNat) [] Nothing
, makeDataDefAlg (NamePrimTyCon PrimTyConInt) [] Nothing
, makeDataDefAlg (NamePrimTyCon PrimTyConSize) [] Nothing
, makeDataDefAlg (NamePrimTyCon (PrimTyConWord 8)) [] Nothing
, makeDataDefAlg (NamePrimTyCon (PrimTyConWord 16)) [] Nothing
, makeDataDefAlg (NamePrimTyCon (PrimTyConWord 32)) [] Nothing
, makeDataDefAlg (NamePrimTyCon (PrimTyConWord 64)) [] Nothing
, makeDataDefAlg (NamePrimTyCon (PrimTyConFloat 32)) [] Nothing
, makeDataDefAlg (NamePrimTyCon (PrimTyConFloat 64)) [] Nothing
, makeDataDefAlg (NamePrimTyCon PrimTyConTag) [] Nothing
, makeDataDefAlg (NamePrimTyCon PrimTyConTextLit) [] Nothing
, makeDataDefAlg (NamePrimTyCon PrimTyConPtr) [] 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
NameVar "rT" -> Just $ kRegion
_ -> Nothing
kindOfPrimTyCon :: PrimTyCon -> Kind Name
kindOfPrimTyCon tc
= case tc of
PrimTyConVoid -> kData
PrimTyConBool -> kData
PrimTyConNat -> kData
PrimTyConInt -> kData
PrimTyConSize -> kData
PrimTyConWord _ -> kData
PrimTyConFloat _ -> kData
PrimTyConAddr -> kData
PrimTyConPtr -> kRegion `kFun` kData `kFun` kData
PrimTyConTag -> kData
PrimTyConVec _ -> kData `kFun` kData
PrimTyConTextLit -> kData
primTypeEnv :: Env Name
primTypeEnv = Env.setPrimFun typeOfName Env.empty
typeOfName :: Name -> Maybe (Type Name)
typeOfName nn
= case nn of
NamePrimOp p -> Just $ typeOfPrimOp p
NamePrimLit lit -> Just $ typeOfPrimLit lit
_ -> Nothing
typeOfPrimOp :: PrimOp -> Type Name
typeOfPrimOp pp
= case pp of
PrimArith op -> typeOfPrimArith op
PrimCast cc -> typeOfPrimCast cc
PrimCall pc -> typeOfPrimCall pc
PrimControl pc -> typeOfPrimControl pc
PrimStore ps -> typeOfPrimStore ps
typeOfPrimLit :: PrimLit -> Type Name
typeOfPrimLit lit
= case lit of
PrimLitVoid -> tVoid
PrimLitBool _ -> tBool
PrimLitNat _ -> tNat
PrimLitInt _ -> tInt
PrimLitSize _ -> tSize
PrimLitWord _ bits -> tWord bits
PrimLitFloat _ bits -> tFloat bits
PrimLitTextLit _ -> tTextLit
PrimLitTag _ -> tTag
typeOfPrimCall :: PrimCall -> Type Name
typeOfPrimCall cc
= case cc of
PrimCallStd arity
-> makePrimCallStdType arity
PrimCallTail arity
-> makePrimCallTailType arity
makePrimCallStdType :: Int -> Type Name
makePrimCallStdType arity
= let Just t = tFunOfList ([tAddr] ++ replicate arity tAddr ++ [tAddr])
in t
makePrimCallTailType :: Int -> Type Name
makePrimCallTailType arity
= let tSuper = foldr tFun
(TVar (UIx 0))
(reverse [TVar (UIx i) | i <- [1..arity]])
tCall = foldr TForall (tSuper `tFun` tSuper)
[BAnon k | k <- replicate (arity + 1) kData]
in tCall
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