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.Core.Llvm.Convert.Base
import DDC.Llvm.Syntax.Type
import DDC.Llvm.Syntax.Attr
import DDC.Core.Salt.Platform
import DDC.Type.Env
import DDC.Type.Compounds
import DDC.Type.Predicates
import DDC.Base.Pretty
import qualified DDC.Core.Salt as A
import qualified DDC.Core.Salt.Name as A
import qualified 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 A.Name -> C.Type A.Name -> ConvertM Type
convertType pp kenv tt
= case tt of
C.TVar u
-> case Env.lookup u kenv of
Nothing
-> throw $ ErrorInvalidBound u
$ Just "Type variable not in kind environment."
Just k
| isDataKind k
-> return $ TPointer (tObj pp)
| otherwise
-> throw $ ErrorInvalidBound u
$ Just "Bound type variable does not have kind Data."
C.TCon tc
-> convTyCon pp tc
C.TApp{}
| Just (A.NamePrimTyCon A.PrimTyConPtr, [_r, t2])
<- takePrimTyConApps tt
-> do t2' <- convertType pp kenv t2
return $ TPointer t2'
C.TApp{}
-> do (tsArgs, tResult) <- convertSuperType pp kenv tt
return
$ 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
_ -> throw $ ErrorInvalidType tt
$ Just "Cannot convert type."
convertSuperType
:: Platform
-> KindEnv A.Name
-> C.Type A.Name
-> ConvertM ([Type], Type)
convertSuperType pp kenv tt
= case tt of
C.TApp{}
| (_, tsArgs, tResult) <- takeTFunWitArgResult tt
, not $ null tsArgs
-> do tsArgs' <- mapM (convertType pp kenv) tsArgs
tResult' <- convertType pp kenv tResult
return (tsArgs', tResult')
C.TForall b t
-> let kenv' = Env.extend b kenv
in convertSuperType pp kenv' t
_ -> throw $ ErrorInvalidType tt
$ Just $ "Cannot use this as the type of a super."
++ show (takeTFunArgResult tt)
importedFunctionDeclOfType
:: Platform
-> KindEnv A.Name
-> C.ImportValue A.Name
-> Maybe (C.ExportSource A.Name)
-> A.Name
-> C.Type A.Name
-> Maybe (ConvertM FunctionDecl)
importedFunctionDeclOfType pp kenv isrc mesrc nSuper tt
| C.ImportValueModule{} <- isrc
= Just $ do
let Just strName
= liftM renderPlain
$ A.seaNameOfSuper (Just isrc) mesrc nSuper
(tsArgs, tResult) <- convertSuperType pp kenv tt
let mkParam t = Param t []
return $ FunctionDecl
{ declName = A.sanitizeName strName
, declLinkage = External
, declCallConv = CC_Ccc
, declReturnType = tResult
, declParamListType = FixedArgs
, declParams = map mkParam tsArgs
, declAlign = AlignBytes (platformAlignBytes pp) }
| C.ImportValueSea strName _ <- isrc
= Just $ do
(tsArgs, tResult) <- convertSuperType pp kenv tt
let mkParam t = Param t []
return $ 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 A.Name -> ConvertM Type
convTyCon platform tycon
= case tycon of
C.TyConSpec C.TcConUnit
-> return $ TPointer (tObj platform)
C.TyConBound (C.UPrim A.NameObjTyCon _) _
-> return $ tObj platform
C.TyConBound (C.UPrim (A.NamePrimTyCon tc) _) _
-> case tc of
A.PrimTyConVoid -> return $ TVoid
A.PrimTyConBool -> return $ TInt 1
A.PrimTyConNat -> return $ TInt (8 * platformAddrBytes platform)
A.PrimTyConInt -> return $ TInt (8 * platformAddrBytes platform)
A.PrimTyConWord bits -> return $ TInt (fromIntegral bits)
A.PrimTyConTag -> return $ TInt (8 * platformTagBytes platform)
A.PrimTyConAddr -> return $ TInt (8 * platformAddrBytes platform)
A.PrimTyConFloat bits
-> case bits of
32 -> return TFloat
64 -> return TDouble
80 -> return TFloat80
128 -> return TFloat128
_ -> throw $ ErrorInvalidTyCon tycon
$ Just "Float has a non-standard width."
A.PrimTyConTextLit -> return $ tPtr (TInt 8)
_ -> throw $ ErrorInvalidTyCon tycon
$ Just "Not a primitive type constructor."
_ -> throw $ ErrorInvalidTyCon tycon
$ Just "Cannot convert type constructor."
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