{-# LANGUAGE GADTs #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} -- | -- Module : Data.Array.Accelerate.CUDA.CodeGen -- Copyright : [2008..2014] Manuel M T Chakravarty, Gabriele Keller -- [2009..2014] Trevor L. McDonell -- License : BSD3 -- -- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- -- Generate types for the reified elements of an array computation -- module Data.Array.Accelerate.CUDA.CodeGen.Type ( -- surface types accType, accTypeTex, segmentsType, expType, eltType, eltTypeTex, eltSizeOf, -- working with reified dictionaries TypeOf(..), signedIntegralNum, unsignedIntegralNum, ) where -- friends import Data.Array.Accelerate.Array.Data import Data.Array.Accelerate.Error import Data.Array.Accelerate.Type import Data.Array.Accelerate.Trafo import qualified Data.Array.Accelerate.Array.Sugar as Sugar import qualified Data.Array.Accelerate.Analysis.Type as Sugar -- libraries import Data.Bits import Language.C.Quote.CUDA import qualified Data.Typeable as T import qualified Language.C as C class TypeOf a where typeOf :: a -> C.Type texTypeOf :: a -> C.Type instance TypeOf (ScalarType a) where typeOf = cScalarType texTypeOf = cScalarTypeTex instance TypeOf (NumType a) where typeOf = cNumType texTypeOf = cNumTypeTex instance TypeOf (IntegralType a) where typeOf = cIntegralType texTypeOf = cIntegralTypeTex instance TypeOf (FloatingType a) where typeOf = cFloatingType texTypeOf = cFloatingTypeTex instance TypeOf (NonNumType a) where typeOf = cNonNumType texTypeOf = cNonNumTypeTex -- Surface element types -- --------------------- accType :: DelayedOpenAcc aenv (Sugar.Array dim e) -> [C.Type] accType = cTupleType . Sugar.delayedAccType expType :: DelayedOpenExp aenv env t -> [C.Type] expType = cTupleType . Sugar.preExpType Sugar.delayedAccType segmentsType :: DelayedOpenAcc aenv (Sugar.Segments i) -> C.Type segmentsType seg | [s] <- accType seg = s | otherwise = $internalError "accType" "non-scalar segment type" eltType :: Sugar.Elt a => a {- dummy -} -> [C.Type] eltType = cTupleType . Sugar.eltType eltTypeTex :: Sugar.Elt a => a {- dummy -} -> [C.Type] eltTypeTex = cTupleTypeTex . Sugar.eltType eltSizeOf :: Sugar.Elt a => a {- dummy -} -> [Int] eltSizeOf = sizeOf' . Sugar.eltType where sizeOf' :: TupleType a -> [Int] sizeOf' UnitTuple = [] sizeOf' x@(SingleTuple _) = [Sugar.sizeOf x] sizeOf' (PairTuple a b) = sizeOf' a ++ sizeOf' b cTupleType :: TupleType a -> [C.Type] cTupleType UnitTuple = [] cTupleType (SingleTuple ty) = [cScalarType ty] cTupleType (PairTuple t1 t0) = cTupleType t1 ++ cTupleType t0 cScalarType :: ScalarType a -> C.Type cScalarType (NumScalarType ty) = cNumType ty cScalarType (NonNumScalarType ty) = cNonNumType ty cNumType :: NumType a -> C.Type cNumType (IntegralNumType ty) = cIntegralType ty cNumType (FloatingNumType ty) = cFloatingType ty cIntegralType :: IntegralType a -> C.Type cIntegralType (TypeInt8 _) = typename "Int8" cIntegralType (TypeInt16 _) = typename "Int16" cIntegralType (TypeInt32 _) = typename "Int32" cIntegralType (TypeInt64 _) = typename "Int64" cIntegralType (TypeWord8 _) = typename "Word8" cIntegralType (TypeWord16 _) = typename "Word16" cIntegralType (TypeWord32 _) = typename "Word32" cIntegralType (TypeWord64 _) = typename "Word64" cIntegralType (TypeCShort _) = [cty|short|] cIntegralType (TypeCUShort _) = [cty|unsigned short|] cIntegralType (TypeCInt _) = [cty|int|] cIntegralType (TypeCUInt _) = [cty|unsigned int|] cIntegralType (TypeCLong _) = [cty|long int|] cIntegralType (TypeCULong _) = [cty|unsigned long int|] cIntegralType (TypeCLLong _) = [cty|long long int|] cIntegralType (TypeCULLong _) = [cty|unsigned long long int|] cIntegralType (TypeInt _) = typename (T.showsTypeRep (T.typeOf (undefined::HTYPE_INT)) "") cIntegralType (TypeWord _) = typename (T.showsTypeRep (T.typeOf (undefined::HTYPE_WORD)) "") cFloatingType :: FloatingType a -> C.Type cFloatingType (TypeFloat _) = [cty|float|] cFloatingType (TypeCFloat _) = [cty|float|] cFloatingType (TypeDouble _) = [cty|double|] cFloatingType (TypeCDouble _) = [cty|double|] cNonNumType :: NonNumType a -> C.Type cNonNumType (TypeBool _) = typename "Word8" cNonNumType (TypeChar _) = typename "Word32" cNonNumType (TypeCChar _) = [cty|char|] cNonNumType (TypeCSChar _) = [cty|signed char|] cNonNumType (TypeCUChar _) = [cty|unsigned char|] -- Texture types -- ------------- accTypeTex :: DelayedOpenAcc aenv (Sugar.Array dim e) -> [C.Type] accTypeTex = cTupleTypeTex . Sugar.delayedAccType -- Implementation -- cTupleTypeTex :: TupleType a -> [C.Type] cTupleTypeTex UnitTuple = [] cTupleTypeTex (SingleTuple t) = [cScalarTypeTex t] cTupleTypeTex (PairTuple t1 t0) = cTupleTypeTex t1 ++ cTupleTypeTex t0 cScalarTypeTex :: ScalarType a -> C.Type cScalarTypeTex (NumScalarType ty) = cNumTypeTex ty cScalarTypeTex (NonNumScalarType ty) = cNonNumTypeTex ty; cNumTypeTex :: NumType a -> C.Type cNumTypeTex (IntegralNumType ty) = cIntegralTypeTex ty cNumTypeTex (FloatingNumType ty) = cFloatingTypeTex ty cIntegralTypeTex :: IntegralType a -> C.Type cIntegralTypeTex (TypeInt8 _) = typename "TexInt8" cIntegralTypeTex (TypeInt16 _) = typename "TexInt16" cIntegralTypeTex (TypeInt32 _) = typename "TexInt32" cIntegralTypeTex (TypeInt64 _) = typename "TexInt64" cIntegralTypeTex (TypeWord8 _) = typename "TexWord8" cIntegralTypeTex (TypeWord16 _) = typename "TexWord16" cIntegralTypeTex (TypeWord32 _) = typename "TexWord32" cIntegralTypeTex (TypeWord64 _) = typename "TexWord64" cIntegralTypeTex (TypeCShort _) = typename "TexCShort" cIntegralTypeTex (TypeCUShort _) = typename "TexCUShort" cIntegralTypeTex (TypeCInt _) = typename "TexCInt" cIntegralTypeTex (TypeCUInt _) = typename "TexCUInt" cIntegralTypeTex (TypeCLong _) = typename "TexCLong" cIntegralTypeTex (TypeCULong _) = typename "TexCULong" cIntegralTypeTex (TypeCLLong _) = typename "TexCLLong" cIntegralTypeTex (TypeCULLong _) = typename "TexCULLong" cIntegralTypeTex (TypeInt _) = typename ("TexInt" ++ show (finiteBitSize (undefined::Int))) cIntegralTypeTex (TypeWord _) = typename ("TexWord" ++ show (finiteBitSize (undefined::Word))) cFloatingTypeTex :: FloatingType a -> C.Type cFloatingTypeTex (TypeFloat _) = typename "TexFloat" cFloatingTypeTex (TypeCFloat _) = typename "TexCFloat" cFloatingTypeTex (TypeDouble _) = typename "TexDouble" cFloatingTypeTex (TypeCDouble _) = typename "TexCDouble" cNonNumTypeTex :: NonNumType a -> C.Type cNonNumTypeTex (TypeBool _) = typename "TexWord8" cNonNumTypeTex (TypeChar _) = typename "TexWord32" cNonNumTypeTex (TypeCChar _) = typename "TexCChar" cNonNumTypeTex (TypeCSChar _) = typename "TexCSChar" cNonNumTypeTex (TypeCUChar _) = typename "TexCUChar" -- Utilities -- --------- typename :: String -> C.Type typename name = [cty| typename $id:name |] signedIntegralNum :: IntegralType a -> Bool signedIntegralNum t = case t of TypeInt _ -> True TypeInt8 _ -> True TypeInt16 _ -> True TypeInt32 _ -> True TypeInt64 _ -> True TypeCShort _ -> True TypeCInt _ -> True TypeCLong _ -> True TypeCLLong _ -> True _ -> False unsignedIntegralNum :: IntegralType a -> Bool unsignedIntegralNum = not . signedIntegralNum