hLLVM-0.5.0.0: src/Llvm/Data/Conversion/TypeConversion.hs
{-# OPTIONS_GHC -cpp #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Llvm.Data.Conversion.TypeConversion where
import qualified Llvm.Data.Type as A
import qualified Llvm.Data.IrType as I
import qualified Data.Map as M
import Data.Either
#define FLC (I.FileLoc $(I.srcLoc))
type MP = M.Map A.LocalId A.Type
class TypeConversion mp l1 l2 where
tconvert :: mp -> l1 -> l2
{-Ast Type to Ir type conversion -}
instance TypeConversion () I.Dtype A.Type where
tconvert _ t = case t of
I.DtypeScalarI x -> tconvert () x
I.DtypeScalarF x -> tconvert () x
I.DtypeScalarP x -> tconvert () x
I.DtypeVectorI x -> tconvert () x
I.DtypeVectorF x -> tconvert () x
I.DtypeVectorP x -> tconvert () x
I.DtypeRecordD x -> tconvert () x
I.DtypeFirstClassD x -> tconvert () x
instance TypeConversion () I.ScalarType A.Type where
tconvert _ t = case t of
I.ScalarTypeI x -> tconvert () x
I.ScalarTypeF x -> tconvert () x
I.ScalarTypeP x -> tconvert () x
instance TypeConversion () (I.IntOrPtrType I.ScalarB) A.Type where
tconvert _ t = case t of
I.IntOrPtrTypeI x -> tconvert () x
I.IntOrPtrTypeP x -> tconvert () x
instance TypeConversion () (I.IntOrPtrType I.VectorB) A.Type where
tconvert _ t = case t of
I.IntOrPtrTypeI x -> tconvert () x
I.IntOrPtrTypeP x -> tconvert () x
instance TypeConversion () (Either I.Rtype (I.Type I.CodeFunB I.X)) A.Type where
tconvert _ (Left e) = tconvert () e
tconvert _ (Right e) = tconvert () (I.Tpointer (I.ucast e) 0)
instance TypeConversion () I.FormalParam A.FormalParam where
tconvert _ (I.FormalParamData dt pa1 ma fp pa2) = A.FormalParamData (tconvert () dt) pa1 ma fp pa2
tconvert _ (I.FormalParamMeta mk fp) = A.FormalParamMeta (tconvert () mk) fp
instance TypeConversion () I.FormalParamList A.FormalParamList where
tconvert _ (I.FormalParamList l ma fas) = A.FormalParamList (fmap (tconvert ()) l) ma fas
instance TypeConversion MP A.FormalParam I.FormalParam where
tconvert mp (A.FormalParamData dt pa1 ma fp pa2) =
I.FormalParamData (I.dcast FLC ((tconvert mp dt)::I.Utype)) pa1 ma fp pa2
tconvert mp (A.FormalParamMeta mk fp) = I.FormalParamMeta (tconvert mp mk) fp
instance TypeConversion MP A.FormalParamList I.FormalParamList where
tconvert mp (A.FormalParamList l ma fas) = I.FormalParamList (fmap (tconvert mp) l) ma fas
instance TypeConversion () I.Rtype A.Type where
tconvert _ t = case t of
I.RtypeScalarI x -> tconvert () x
I.RtypeScalarF x -> tconvert () x
I.RtypeScalarP x -> tconvert () x
I.RtypeVectorI x -> tconvert () x
I.RtypeVectorF x -> tconvert () x
I.RtypeVectorP x -> tconvert () x
I.RtypeRecordD x -> tconvert () x
I.RtypeFirstClassD x -> tconvert () x
I.RtypeVoidU _ -> A.Tvoid
instance TypeConversion () I.Etype A.Type where
tconvert _ t = case t of
I.EtypeScalarI x -> tconvert () x
I.EtypeScalarF x -> tconvert () x
I.EtypeScalarP x -> tconvert () x
I.EtypeVectorI x -> tconvert () x
I.EtypeVectorF x -> tconvert () x
I.EtypeVectorP x -> tconvert () x
I.EtypeRecordD x -> tconvert () x
I.EtypeOpaqueD x -> tconvert () x
I.EtypeFunX x -> tconvert () x
instance TypeConversion () I.Ftype A.Type where
tconvert _ t = case t of
I.FtypeScalarI x -> tconvert () x
I.FtypeScalarF x -> tconvert () x
I.FtypeScalarP x -> tconvert () x
I.FtypeVectorI x -> tconvert () x
I.FtypeVectorF x -> tconvert () x
I.FtypeVectorP x -> tconvert () x
I.FtypeFirstClassD x -> tconvert () x
instance TypeConversion MP A.TypeParamList I.TypeParamList where
tconvert mp (A.TypeParamList l ma) =
let (l1::[I.Utype]) = fmap (tconvert mp) l
in I.TypeParamList (fmap (I.dcast FLC) l1) ma
instance TypeConversion () I.TypeParamList A.TypeParamList where
tconvert _ (I.TypeParamList l ma) = A.TypeParamList (fmap (tconvert ()) l) ma
instance TypeConversion MP A.Type I.Utype where
tconvert _ (A.Tprimitive et) = case et of
A.TpI n -> I.UtypeScalarI $ I.TpI n
A.TpF n -> I.UtypeScalarF $ I.TpF n
A.TpV n -> I.UtypeScalarI $ I.TpV n
A.TpHalf -> I.UtypeScalarF $ I.TpHalf
A.TpFloat -> I.UtypeScalarF $ I.TpFloat
A.TpDouble -> I.UtypeScalarF $ I.TpDouble
A.TpFp128 -> I.UtypeScalarF $ I.TpFp128
A.TpX86Fp80 -> I.UtypeScalarF $ I.TpX86Fp80
A.TpPpcFp128 -> I.UtypeScalarF $ I.TpPpcFp128
A.TpX86Mmx -> I.UtypeScalarI $ I.TpX86Mmx
A.TpLabel -> I.UtypeLabelX $ I.TpLabel
tconvert _ A.Tvoid = I.ucast I.Tvoid
tconvert mp (A.Tarray n et) =
let (eta::I.Utype) = tconvert mp et
in case eta of
I.UtypeOpaqueD _ -> I.UtypeOpaqueD $ I.Topaque_array n (I.dcast FLC eta)
_ -> I.UtypeRecordD $ I.Tarray n (I.dcast FLC eta)
tconvert mp (A.Tvector n et) = case matchType mp et of
Tk_ScalarI -> let et1 = I.dcast FLC $ ((tconvert mp et)::I.Utype)
in I.UtypeVectorI $ I.TvectorI n et1
Tk_ScalarF -> let et1 = I.dcast FLC $ ((tconvert mp et)::I.Utype)
in I.UtypeVectorF $ I.TvectorF n et1
Tk_ScalarP -> let et1 = I.dcast FLC $ ((tconvert mp et)::I.Utype)
in I.UtypeVectorP $ I.TvectorP n et1
_ -> I.errorLoc FLC "$$$$$$$$$"
tconvert mp (A.Tstruct pk dts) =
let (dts0::[I.Utype]) = fmap (tconvert mp) dts
dts1 = fmap (\e -> case e of
I.UtypeOpaqueD ea -> Right ea
_ -> Left ((I.dcast FLC e)::I.Dtype)
) dts0
in if any isRight dts1 then I.UtypeOpaqueD (I.Topaque_struct pk dts1)
else I.UtypeRecordD (I.Tstruct pk $ lefts dts1)
tconvert mp (A.Tpointer et as) = let n1 = case as of
A.AddrSpace n -> n
A.AddrSpaceUnspecified -> 0
et1 = I.dcast FLC ((tconvert mp et)::I.Utype)
in I.UtypeScalarP $ I.Tpointer et1 n1
tconvert mp A.Topaque = I.ucast $ I.Topaque
tconvert mp tn@(A.Tname s) = case getTk mp (castTnameToLocalId tn) of
Tk_ScalarI -> I.ucast $ I.TnameScalarI s
Tk_ScalarF -> I.ucast $ I.TnameScalarF s
Tk_ScalarP -> I.ucast $ I.TnameScalarP s
Tk_VectorI -> I.ucast $ I.TnameVectorI s
Tk_VectorF -> I.ucast $ I.TnameVectorF s
Tk_VectorP -> I.ucast $ I.TnameVectorP s
Tk_RecordD -> I.ucast $ I.TnameRecordD s
Tk_CodeFunX -> I.ucast $ I.TnameCodeFunX s
Tk_Opaque -> I.ucast $ I.TnameOpaqueD s
tconvert mp tn@(A.TquoteName s) = case getTk mp (castTnameToLocalId tn) of
Tk_ScalarI -> I.ucast $ I.TquoteNameScalarI s
Tk_ScalarF -> I.ucast $ I.TquoteNameScalarF s
Tk_ScalarP -> I.ucast $ I.TquoteNameScalarP s
Tk_VectorI -> I.ucast $ I.TquoteNameVectorI s
Tk_VectorF -> I.ucast $ I.TquoteNameVectorF s
Tk_VectorP -> I.ucast $ I.TquoteNameVectorP s
Tk_RecordD -> I.ucast $ I.TquoteNameRecordD s
Tk_CodeFunX -> I.ucast $ I.TquoteNameCodeFunX s
Tk_Opaque -> I.ucast $ I.TquoteNameOpaqueD s
tconvert mp tn@(A.Tno s) = case getTk mp (castTnameToLocalId tn) of
Tk_ScalarI -> I.ucast $ I.TnoScalarI s
Tk_ScalarF -> I.ucast $ I.TnoScalarF s
Tk_ScalarP -> I.ucast $ I.TnoScalarP s
Tk_VectorI -> I.ucast $ I.TnoVectorI s
Tk_VectorF -> I.ucast $ I.TnoVectorF s
Tk_VectorP -> I.ucast $ I.TnoVectorP s
Tk_RecordD -> I.ucast $ I.TnoRecordD s
Tk_CodeFunX -> I.ucast $ I.TnoCodeFunX s
Tk_Opaque -> I.ucast $ I.TnoOpaqueD s
tconvert mp (A.Tfunction rt tp fa) =
let rt1 = I.dcast FLC ((tconvert mp rt)::I.Utype)
in I.UtypeFunX (I.Tfunction rt1 (tconvert mp tp) fa)
instance TypeConversion MP A.AddrSpace I.AddrSpace where
tconvert _ (A.AddrSpace n) = n
tconvert _ (A.AddrSpaceUnspecified) = 0
instance TypeConversion () I.AddrSpace A.AddrSpace where
tconvert _ 0 = A.AddrSpaceUnspecified
tconvert _ n = A.AddrSpace n
instance TypeConversion MP A.MetaKind I.MetaKind where
tconvert mp x = case x of
A.Mtype e -> I.Mtype (tconvert mp e)
A.Mmetadata -> I.Mmetadata
instance TypeConversion () I.MetaKind A.MetaKind where
tconvert _ x = case x of
I.Mtype e -> A.Mtype (tconvert () e)
I.Mmetadata -> A.Mmetadata
instance TypeConversion () (I.Type s r) A.Type where -- Primitive where
tconvert _ t = case t of
I.TpI n -> A.Tprimitive $ A.TpI n
I.TpF n -> A.Tprimitive $ A.TpF n
I.TpV n -> A.Tprimitive $ A.TpV n
I.TpHalf -> A.Tprimitive $ A.TpHalf
I.TpFloat -> A.Tprimitive $ A.TpFloat
I.TpDouble -> A.Tprimitive $ A.TpDouble
I.TpFp128 -> A.Tprimitive $ A.TpFp128
I.TpX86Fp80 -> A.Tprimitive $ A.TpX86Fp80
I.TpPpcFp128 -> A.Tprimitive $ A.TpPpcFp128
I.TpX86Mmx -> A.Tprimitive $ A.TpX86Mmx
I.Tpointer el 0 -> A.Tpointer (tconvert () el) A.AddrSpaceUnspecified
I.Tpointer el as -> A.Tpointer (tconvert () el) (A.AddrSpace as)
I.Tarray n dt -> A.Tarray n (tconvert () dt)
I.Tstruct p dts -> A.Tstruct p (fmap (tconvert ()) dts)
I.Tfirst_class_array n dt -> A.Tarray n (tconvert () dt)
I.Tfirst_class_struct p dts -> A.Tstruct p (fmap (tconvert ()) dts)
I.Tfirst_class_no n -> A.Tno n
I.Tfirst_class_name s -> A.Tname s
I.Tfirst_class_quoteName s -> A.TquoteName s
I.Topaque_struct p dts -> A.Tstruct p (fmap (either (tconvert()) (tconvert ())) dts)
I.Topaque_array n dt -> A.Tarray n (tconvert () dt)
I.TvectorI n dt -> A.Tvector n (tconvert () dt)
I.TvectorF n dt -> A.Tvector n (tconvert () dt)
I.TvectorP n dt -> A.Tvector n (tconvert () dt)
I.Tvoid -> A.Tvoid
I.TnoScalarI n -> A.Tno n
I.TnameScalarI s -> A.Tname s
I.TquoteNameScalarI s -> A.TquoteName s
I.TnoScalarF n -> A.Tno n
I.TnameScalarF s -> A.Tname s
I.TquoteNameScalarF s -> A.TquoteName s
I.TnoScalarP n -> A.Tno n
I.TnameScalarP s -> A.Tname s
I.TquoteNameScalarP s -> A.TquoteName s
I.TnoVectorI n -> A.Tno n
I.TnameVectorI s -> A.Tname s
I.TquoteNameVectorI s -> A.TquoteName s
I.TnoVectorF n -> A.Tno n
I.TnameVectorF s -> A.Tname s
I.TquoteNameVectorF s -> A.TquoteName s
I.TnoVectorP n -> A.Tno n
I.TnameVectorP s -> A.Tname s
I.TquoteNameVectorP s -> A.TquoteName s
I.TnoRecordD n -> A.Tno n
I.TnameRecordD s -> A.Tname s
I.TquoteNameRecordD s -> A.TquoteName s
I.TnoCodeFunX n -> A.Tno n
I.TnameCodeFunX s -> A.Tname s
I.TquoteNameCodeFunX s -> A.TquoteName s
I.TnoOpaqueD n -> A.Tno n
I.TnameOpaqueD s -> A.Tname s
I.TquoteNameOpaqueD s -> A.TquoteName s
I.Tfunction rt tp fa -> A.Tfunction (tconvert () rt) (tconvert () tp) fa
I.TpNull -> A.Tprimitive A.TpNull
I.TpLabel -> A.Tprimitive A.TpLabel
I.Topaque -> A.Topaque
instance TypeConversion () I.Utype A.Type where
tconvert _ t = case t of
I.UtypeScalarI x -> tconvert () x
I.UtypeScalarF x -> tconvert () x
I.UtypeScalarP x -> tconvert () x
I.UtypeVectorI x -> tconvert () x
I.UtypeVectorF x -> tconvert () x
I.UtypeVectorP x -> tconvert () x
I.UtypeRecordD x -> tconvert () x
I.UtypeFunX x -> tconvert () x
I.UtypeLabelX x -> tconvert () x
I.UtypeOpaqueD x -> tconvert () x
I.UtypeVoidU x -> tconvert () x
data Tk = Tk_ScalarI
| Tk_ScalarP
| Tk_ScalarF
| Tk_VectorI
| Tk_VectorF
| Tk_VectorP
| Tk_RecordD
| Tk_CodeFunX
| Tk_CodeLabelX
| Tk_Opaque
getTk :: MP -> A.LocalId -> Tk
getTk mp lid = case M.lookup lid mp of
Nothing -> error $ "undefined " ++ show lid
Just e -> matchType mp e
matchType :: MP -> A.Type -> Tk
matchType mp t = case t of
A.Tprimitive e -> case e of
A.TpI _ -> Tk_ScalarI
A.TpF _ -> Tk_ScalarF
A.TpV _ -> Tk_ScalarI
A.TpHalf -> Tk_ScalarF
A.TpFloat -> Tk_ScalarF
A.TpDouble -> Tk_ScalarF
A.TpFp128 -> Tk_ScalarF
A.TpX86Fp80 -> Tk_ScalarF
A.TpPpcFp128 -> Tk_ScalarF
A.TpX86Mmx -> Tk_ScalarI
A.TpLabel -> Tk_CodeLabelX
A.TpNull -> I.errorLoc FLC "TpNull"
A.Tarray _ _ -> Tk_RecordD
A.Tstruct _ _ -> Tk_RecordD
A.Tpointer _ _ -> Tk_ScalarP
A.Tfunction _ _ _ -> Tk_CodeFunX
A.Tvector _ e -> let ek = matchType mp e
in case ek of
Tk_ScalarI -> Tk_VectorI
Tk_ScalarF -> Tk_VectorF
Tk_ScalarP -> Tk_VectorP
_ -> error $ "RRRRRRR"
A.Tname _ -> getTk mp (castTnameToLocalId t)
A.TquoteName _ -> getTk mp (castTnameToLocalId t)
A.Tno _ -> getTk mp (castTnameToLocalId t)
A.Topaque -> Tk_Opaque
_ -> I.errorLoc FLC (show t)
castTnameToLocalId :: A.Type -> A.LocalId
castTnameToLocalId x = case x of
A.Tname s -> A.LocalIdAlphaNum s
A.TquoteName s -> A.LocalIdDqString s
A.Tno s -> A.LocalIdNum s