module DDC.Core.Llvm.Convert.Type
(
convertType
, convertSuperType
, importedFunctionDeclOfType
, tObj, sObj, aObj
, tPtr, tAddr, tNat, tInt, tTag
, convTyCon
, isVoidT
, isSignedT
, isUnsignedT
, isIntegralT
, isFloatingT)
where
import DDC.Llvm.Syntax.Type
import DDC.Llvm.Syntax.Attr
import DDC.Core.Llvm.LlvmM
import DDC.Core.Salt.Platform
import DDC.Core.Llvm.Convert.Erase
import DDC.Type.Env
import DDC.Type.Compounds
import DDC.Type.Predicates
import DDC.Base.Pretty
import DDC.Core.Salt as A
import DDC.Core.Salt.Name as A
import DDC.Core.Salt.Convert as A
import qualified DDC.Core.Module as C
import qualified DDC.Core.Exp as C
import qualified DDC.Type.Env as Env
import Control.Monad
convertType :: Platform -> KindEnv Name -> C.Type Name -> Type
convertType pp kenv tt
= case tt of
C.TVar u
-> case Env.lookup u kenv of
Nothing
-> die $ "Type variable not in kind environment." ++ show u
Just k
| isDataKind k -> TPointer (tObj pp)
| otherwise -> die "Invalid type variable."
C.TCon tc
-> convTyCon pp tc
C.TApp{}
| Just (NamePrimTyCon PrimTyConPtr, [_r, t2])
<- takePrimTyConApps tt
-> TPointer (convertType pp kenv t2)
C.TApp{}
| (tsArgs, tResult) <- convertSuperType pp kenv tt
-> TPointer $ TFunction
$ FunctionDecl
{ declName = "dummy.function.name"
, declLinkage = Internal
, declCallConv = CC_Ccc
, declReturnType = tResult
, declParamListType = FixedArgs
, declParams = [Param t [] | t <- tsArgs]
, declAlign = AlignBytes (platformAlignBytes pp) }
C.TForall b t
-> let kenv' = Env.extend b kenv
in convertType pp kenv' t
_ -> die ("Invalid Type " ++ show tt)
convertSuperType
:: Platform
-> KindEnv Name
-> C.Type Name
-> ([Type], Type)
convertSuperType pp kenv tt
= let tt' = eraseWitTApps tt
in case tt' of
C.TApp{}
| (tsArgs, tResult) <- takeTFunArgResult tt'
, not $ null tsArgs
-> let tsArgs' = map (convertType pp kenv) tsArgs
tResult' = convertType pp kenv tResult
in (tsArgs', tResult')
C.TForall b t
-> let kenv' = Env.extend b kenv
in convertSuperType pp kenv' t
_ -> die ("Invalid super type" ++ show tt')
importedFunctionDeclOfType
:: Platform
-> KindEnv Name
-> C.ImportSource Name
-> Maybe (C.ExportSource Name)
-> Name
-> C.Type Name
-> Maybe FunctionDecl
importedFunctionDeclOfType pp kenv isrc mesrc nSuper tt
| C.ImportSourceModule{} <- isrc
= let Just strName = liftM renderPlain
$ seaNameOfSuper (Just isrc) mesrc nSuper
(tsArgs, tResult) = convertSuperType pp kenv tt
mkParam t = Param t []
in Just $ FunctionDecl
{ declName = A.sanitizeName strName
, declLinkage = External
, declCallConv = CC_Ccc
, declReturnType = tResult
, declParamListType = FixedArgs
, declParams = map mkParam tsArgs
, declAlign = AlignBytes (platformAlignBytes pp) }
| C.ImportSourceSea strName _ <- isrc
= let (tsArgs, tResult) = convertSuperType pp kenv tt
mkParam t = Param t []
in Just $ FunctionDecl
{ declName = A.sanitizeName strName
, declLinkage = External
, declCallConv = CC_Ccc
, declReturnType = tResult
, declParamListType = FixedArgs
, declParams = map mkParam tsArgs
, declAlign = AlignBytes (platformAlignBytes pp) }
importedFunctionDeclOfType _ _ _ _ _ _
= Nothing
convTyCon :: Platform -> C.TyCon Name -> Type
convTyCon platform tycon
= case tycon of
C.TyConSpec C.TcConUnit
-> tObj platform
C.TyConBound (C.UPrim NameObjTyCon _) _
-> tObj platform
C.TyConBound (C.UPrim (NamePrimTyCon tc) _) _
-> case tc of
PrimTyConVoid -> TVoid
PrimTyConBool -> TInt 1
PrimTyConNat -> TInt (8 * platformAddrBytes platform)
PrimTyConInt -> TInt (8 * platformAddrBytes platform)
PrimTyConWord bits -> TInt (fromIntegral bits)
PrimTyConTag -> TInt (8 * platformTagBytes platform)
PrimTyConAddr -> TInt (8 * platformAddrBytes platform)
PrimTyConString -> TPointer (TInt 8)
PrimTyConFloat bits
-> case bits of
32 -> TFloat
64 -> TDouble
80 -> TFloat80
128 -> TFloat128
_ -> die "Invalid width for float type constructor."
_ -> die "Invalid primitive type constructor."
_ -> die $ "Invalid type constructor '" ++ show tycon ++ "'"
sObj, tObj :: Platform -> Type
sObj platform = TStruct [TInt (8 * platformObjBytes platform)]
tObj platform = TAlias (aObj platform)
aObj :: Platform -> TypeAlias
aObj platform = TypeAlias "s.Obj" (sObj platform)
tPtr :: Type -> Type
tPtr t = TPointer t
tAddr :: Platform -> Type
tAddr pp = TInt (8 * platformAddrBytes pp)
tNat :: Platform -> Type
tNat pp = TInt (8 * platformAddrBytes pp)
tInt :: Platform -> Type
tInt pp = TInt (8 * platformAddrBytes pp)
tTag :: Platform -> Type
tTag pp = TInt (8 * platformTagBytes pp)
isVoidT :: C.Type A.Name -> Bool
isVoidT (C.TCon (C.TyConBound (C.UPrim (A.NamePrimTyCon A.PrimTyConVoid) _) _))
= True
isVoidT _ = False
isSignedT :: C.Type A.Name -> Bool
isSignedT tt
= case tt of
C.TCon (C.TyConBound (C.UPrim (A.NamePrimTyCon tc) _) _)
-> A.primTyConIsSigned tc
_ -> False
isUnsignedT :: C.Type A.Name -> Bool
isUnsignedT tt
= case tt of
C.TCon (C.TyConBound (C.UPrim (A.NamePrimTyCon tc) _) _)
-> A.primTyConIsUnsigned tc
_ -> False
isIntegralT :: C.Type A.Name -> Bool
isIntegralT tt
= case tt of
C.TCon (C.TyConBound (C.UPrim (A.NamePrimTyCon tc) _) _)
-> A.primTyConIsIntegral tc
_ -> False
isFloatingT :: C.Type A.Name -> Bool
isFloatingT tt
= case tt of
C.TCon (C.TyConBound (C.UPrim (A.NamePrimTyCon tc) _) _)
-> A.primTyConIsFloating tc
_ -> False