accelerate-0.7.1.0: Data/Array/Accelerate/CUDA/CodeGen.hs
{-# LANGUAGE GADTs, PatternGuards, ExistentialQuantification, ScopedTypeVariables #-}
-- |
-- Module : Data.Array.Accelerate.CUDA.CodeGen
-- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee, Trevor L. McDonell
-- License : BSD3
--
-- Maintainer : Manuel M T Chakravarty <chak@cse.unsw.edu.au>
-- Stability : experimental
-- Portability : non-portable (GHC extensions)
--
module Data.Array.Accelerate.CUDA.CodeGen (codeGenAcc, CUTranslSkel)
where
import Prelude hiding (mod)
import Data.Char
import Language.C
import Control.Applicative
import Control.Monad.State
import Data.Array.Accelerate.Type
import Data.Array.Accelerate.Tuple
import Data.Array.Accelerate.Pretty ()
import Data.Array.Accelerate.Analysis.Type
import qualified Data.Array.Accelerate.AST as AST
import qualified Data.Array.Accelerate.Array.Sugar as Sugar
import qualified Foreign.Storable as F
import Data.Array.Accelerate.CUDA.CodeGen.Data
import Data.Array.Accelerate.CUDA.CodeGen.Util
import Data.Array.Accelerate.CUDA.CodeGen.Skeleton
-- Array expressions
-- ~~~~~~~~~~~~~~~~~
-- | Generate CUDA device code for an array expression
--
codeGenAcc :: AST.OpenAcc aenv a -> CUTranslSkel
codeGenAcc acc =
let (CUTranslSkel code skel, fvar) = runState (codeGenAcc' acc) []
CTranslUnit decl node = code
in
CUTranslSkel (CTranslUnit (fvar ++ decl) node) skel
-- FIXME:
-- The actual code generation workhorse. We run under a state which keeps track
-- of the free array variables encountered so far. This is used to determine
-- which reference to texture read from. Assumes the same traversal behaviour
-- during execution.
--
-- FRAGILE.
--
type CG a = State [CExtDecl] a
codeGenAcc' :: AST.OpenAcc aenv a -> CG CUTranslSkel
codeGenAcc' op@(AST.Map f1 a1) = mkMap (codeGenAccType op) (codeGenAccType a1) <$> codeGenFun f1
codeGenAcc' op@(AST.ZipWith f1 a1 a2) = mkZipWith (codeGenAccType op) (codeGenAccType a1) (codeGenAccType a2) <$> codeGenFun f1
codeGenAcc' (AST.Replicate _ e1 a1) = mkReplicate (codeGenAccType a1) <$> codeGenExp e1
codeGenAcc' (AST.Index _ a1 e1) = mkIndex (codeGenAccType a1) <$> codeGenExp e1
codeGenAcc' (AST.Fold f1 e1 _) = mkFold (codeGenExpType e1) <$> codeGenExp e1 <*> codeGenFun f1
codeGenAcc' (AST.FoldSeg f1 e1 _ _) = mkFoldSeg (codeGenExpType e1) <$> codeGenExp e1 <*> codeGenFun f1
codeGenAcc' (AST.Scanl f1 e1 _) = mkScanl (codeGenExpType e1) <$> codeGenExp e1 <*> codeGenFun f1
codeGenAcc' (AST.Scanr f1 e1 _) = mkScanr (codeGenExpType e1) <$> codeGenExp e1 <*> codeGenFun f1
codeGenAcc' (AST.Permute f1 _ f2 a1) = mkPermute (codeGenAccType a1) <$> codeGenFun f1 <*> codeGenFun f2
codeGenAcc' (AST.Backpermute _ f1 a1) = mkBackpermute (codeGenAccType a1) <$> codeGenFun f1
codeGenAcc' _ =
error "codeGenAcc: internal error"
-- Embedded expressions
-- ~~~~~~~~~~~~~~~~~~~~
-- Function abstraction
--
codeGenFun :: AST.OpenFun env aenv t -> CG [CExpr]
codeGenFun (AST.Lam lam) = codeGenFun lam
codeGenFun (AST.Body body) = codeGenExp body
unit :: a -> [a]
unit x = [x]
-- Implementation of 'IndexScalar' and 'Shape' demonstrate that array
-- computations must be hoisted out of scalar expressions before code generation
-- or execution: kernel functions can not invoke other array computations.
--
-- TLM 2010-06-24: Shape for free array variables??
--
codeGenExp :: forall env aenv t. AST.OpenExp env aenv t -> CG [CExpr]
codeGenExp (AST.Shape _) = return . unit $ CVar (internalIdent "shape") internalNode
codeGenExp (AST.PrimConst c) = return . unit $ codeGenPrimConst c
codeGenExp (AST.PrimApp f arg) = unit . codeGenPrim f <$> codeGenExp arg
codeGenExp (AST.Const c) = return $ codeGenConst (Sugar.elemType (undefined::t)) c
codeGenExp (AST.Var i) =
let var = CVar (internalIdent ('x' : show (idxToInt i))) internalNode
in case codeGenTupleType (Sugar.elemType (undefined::t)) of
[_] -> return [var]
cps -> return . reverse . take (length cps) . flip map ['a'..] $
\c -> CMember var (internalIdent [c]) False internalNode
codeGenExp (AST.Cond p e1 e2) = do
[a] <- codeGenExp p
[b] <- codeGenExp e1
[c] <- codeGenExp e2
return [CCond a (Just b) c internalNode]
codeGenExp (AST.Tuple t) = codeGenTup t
codeGenExp (AST.Prj idx e) = do
[var] <- codeGenExp e
return [CMember var (internalIdent [enumFrom 'a' !! prjToInt idx]) False internalNode]
codeGenExp (AST.IndexScalar a1 e1) = do
n <- length <$> get
[i] <- codeGenExp e1
let ty = codeGenTupleTex (accType a1)
fv = map (\x -> "tex" ++ show x) [n..]
modify (++ zipWith globalDecl ty fv)
return (zipWith (indexArray i) fv ty)
where
globalDecl ty name = CDeclExt (CDecl (map CTypeSpec ty) [(Just (CDeclr (Just (internalIdent name)) [] Nothing [] internalNode),Nothing,Nothing)] internalNode)
indexArray idx name [CDoubleType _] = CCall (CVar (internalIdent "indexDArray") internalNode) [CVar (internalIdent name) internalNode, idx] internalNode
indexArray idx name _ = CCall (CVar (internalIdent "indexArray") internalNode) [CVar (internalIdent name) internalNode, idx] internalNode
-- Tuples are defined as snoc-lists, so generate code right-to-left
--
codeGenTup :: Tuple (AST.OpenExp env aenv) t -> CG [CExpr]
codeGenTup NilTup = return []
codeGenTup (t `SnocTup` e) = (++) <$> codeGenTup t <*> codeGenExp e
-- Convert a typed de Brujin index to the corresponding integer
--
idxToInt :: AST.Idx env t -> Int
idxToInt AST.ZeroIdx = 0
idxToInt (AST.SuccIdx idx) = 1 + idxToInt idx
-- Convert a tuple index into the corresponding integer
--
prjToInt :: TupleIdx t e -> Int
prjToInt ZeroTupIdx = 0
prjToInt (SuccTupIdx idx) = 1 + prjToInt idx
-- Types
-- ~~~~~
-- Generate types for the reified elements of an array computation
--
codeGenAccType :: AST.OpenAcc aenv (Sugar.Array dim e) -> [CType]
codeGenAccType = codeGenTupleType . accType
codeGenExpType :: AST.OpenExp aenv env t -> [CType]
codeGenExpType = codeGenTupleType . expType
-- Implementation
--
codeGenTupleType :: TupleType a -> [CType]
codeGenTupleType UnitTuple = []
codeGenTupleType (SingleTuple ty) = [codeGenScalarType ty]
codeGenTupleType (PairTuple t1 t0) = codeGenTupleType t1 ++ codeGenTupleType t0
codeGenScalarType :: ScalarType a -> CType
codeGenScalarType (NumScalarType ty) = codeGenNumType ty
codeGenScalarType (NonNumScalarType ty) = codeGenNonNumType ty
codeGenNumType :: NumType a -> CType
codeGenNumType (IntegralNumType ty) = codeGenIntegralType ty
codeGenNumType (FloatingNumType ty) = codeGenFloatingType ty
codeGenIntegralType :: IntegralType a -> CType
codeGenIntegralType (TypeInt8 _) = [CTypeDef (internalIdent "int8_t") internalNode]
codeGenIntegralType (TypeInt16 _) = [CTypeDef (internalIdent "int16_t") internalNode]
codeGenIntegralType (TypeInt32 _) = [CTypeDef (internalIdent "int32_t") internalNode]
codeGenIntegralType (TypeInt64 _) = [CTypeDef (internalIdent "int64_t") internalNode]
codeGenIntegralType (TypeWord8 _) = [CTypeDef (internalIdent "uint8_t") internalNode]
codeGenIntegralType (TypeWord16 _) = [CTypeDef (internalIdent "uint16_t") internalNode]
codeGenIntegralType (TypeWord32 _) = [CTypeDef (internalIdent "uint32_t") internalNode]
codeGenIntegralType (TypeWord64 _) = [CTypeDef (internalIdent "uint64_t") internalNode]
codeGenIntegralType (TypeCShort _) = [CShortType internalNode]
codeGenIntegralType (TypeCUShort _) = [CUnsigType internalNode, CShortType internalNode]
codeGenIntegralType (TypeCInt _) = [CIntType internalNode]
codeGenIntegralType (TypeCUInt _) = [CUnsigType internalNode, CIntType internalNode]
codeGenIntegralType (TypeCLong _) = [CLongType internalNode, CIntType internalNode]
codeGenIntegralType (TypeCULong _) = [CUnsigType internalNode, CLongType internalNode, CIntType internalNode]
codeGenIntegralType (TypeCLLong _) = [CLongType internalNode, CLongType internalNode, CIntType internalNode]
codeGenIntegralType (TypeCULLong _) = [CUnsigType internalNode, CLongType internalNode, CLongType internalNode, CIntType internalNode]
codeGenIntegralType (TypeInt _) =
case F.sizeOf (undefined::Int) of
4 -> [CTypeDef (internalIdent "int32_t") internalNode]
8 -> [CTypeDef (internalIdent "int64_t") internalNode]
_ -> error "we can never get here"
codeGenIntegralType (TypeWord _) =
case F.sizeOf (undefined::Int) of
4 -> [CTypeDef (internalIdent "uint32_t") internalNode]
8 -> [CTypeDef (internalIdent "uint64_t") internalNode]
_ -> error "we can never get here"
codeGenFloatingType :: FloatingType a -> CType
codeGenFloatingType (TypeFloat _) = [CFloatType internalNode]
codeGenFloatingType (TypeDouble _) = [CDoubleType internalNode]
codeGenFloatingType (TypeCFloat _) = [CFloatType internalNode]
codeGenFloatingType (TypeCDouble _) = [CDoubleType internalNode]
codeGenNonNumType :: NonNumType a -> CType
codeGenNonNumType (TypeBool _) = [CUnsigType internalNode, CCharType internalNode]
codeGenNonNumType (TypeChar _) = [CCharType internalNode]
codeGenNonNumType (TypeCChar _) = [CCharType internalNode]
codeGenNonNumType (TypeCSChar _) = [CSignedType internalNode, CCharType internalNode]
codeGenNonNumType (TypeCUChar _) = [CUnsigType internalNode, CCharType internalNode]
-- Texture types
--
codeGenTupleTex :: TupleType a -> [CType]
codeGenTupleTex UnitTuple = []
codeGenTupleTex (SingleTuple t) = [codeGenScalarTex t]
codeGenTupleTex (PairTuple t1 t0) = codeGenTupleTex t1 ++ codeGenTupleTex t0
codeGenScalarTex :: ScalarType a -> CType
codeGenScalarTex (NumScalarType ty) = codeGenNumTex ty
codeGenScalarTex (NonNumScalarType ty) = codeGenNonNumTex ty;
codeGenNumTex :: NumType a -> CType
codeGenNumTex (IntegralNumType ty) = codeGenIntegralTex ty
codeGenNumTex (FloatingNumType ty) = codeGenFloatingTex ty
codeGenIntegralTex :: IntegralType a -> CType
codeGenIntegralTex (TypeInt8 _) = [CTypeDef (internalIdent "TexInt8") internalNode]
codeGenIntegralTex (TypeInt16 _) = [CTypeDef (internalIdent "TexInt16") internalNode]
codeGenIntegralTex (TypeInt32 _) = [CTypeDef (internalIdent "TexInt32") internalNode]
codeGenIntegralTex (TypeInt64 _) = [CTypeDef (internalIdent "TexInt64") internalNode]
codeGenIntegralTex (TypeWord8 _) = [CTypeDef (internalIdent "TexWord8") internalNode]
codeGenIntegralTex (TypeWord16 _) = [CTypeDef (internalIdent "TexWord16") internalNode]
codeGenIntegralTex (TypeWord32 _) = [CTypeDef (internalIdent "TexWord32") internalNode]
codeGenIntegralTex (TypeWord64 _) = [CTypeDef (internalIdent "TexWord64") internalNode]
codeGenIntegralTex (TypeCShort _) = [CTypeDef (internalIdent "TexCShort") internalNode]
codeGenIntegralTex (TypeCUShort _) = [CTypeDef (internalIdent "TexCUShort") internalNode]
codeGenIntegralTex (TypeCInt _) = [CTypeDef (internalIdent "TexCInt") internalNode]
codeGenIntegralTex (TypeCUInt _) = [CTypeDef (internalIdent "TexCUInt") internalNode]
codeGenIntegralTex (TypeCLong _) = [CTypeDef (internalIdent "TexCLong") internalNode]
codeGenIntegralTex (TypeCULong _) = [CTypeDef (internalIdent "TexCULong") internalNode]
codeGenIntegralTex (TypeCLLong _) = [CTypeDef (internalIdent "TexCLLong") internalNode]
codeGenIntegralTex (TypeCULLong _) = [CTypeDef (internalIdent "TexCULLong") internalNode]
codeGenIntegralTex (TypeInt _) =
case F.sizeOf (undefined::Int) of
4 -> [CTypeDef (internalIdent "TexInt32") internalNode]
8 -> [CTypeDef (internalIdent "TexInt64") internalNode]
_ -> error "we can never get here"
codeGenIntegralTex (TypeWord _) =
case F.sizeOf (undefined::Word) of
4 -> [CTypeDef (internalIdent "TexWord32") internalNode]
8 -> [CTypeDef (internalIdent "TexWord64") internalNode]
_ -> error "we can never get here"
codeGenFloatingTex :: FloatingType a -> CType
codeGenFloatingTex (TypeFloat _) = [CTypeDef (internalIdent "TexFloat") internalNode]
codeGenFloatingTex (TypeCFloat _) = [CTypeDef (internalIdent "TexCFloat") internalNode]
codeGenFloatingTex (TypeDouble _) = [CTypeDef (internalIdent "TexDouble") internalNode]
codeGenFloatingTex (TypeCDouble _) = [CTypeDef (internalIdent "TexCDouble") internalNode]
-- TLM 2010-06-29:
-- Bool and Char can be implemented once the array types in
-- Data.Array.Accelerate.[CUDA.]Array.Data are made concrete.
--
codeGenNonNumTex :: NonNumType a -> CType
codeGenNonNumTex (TypeBool _) = error "codeGenNonNumTex :: Bool"
codeGenNonNumTex (TypeChar _) = error "codeGenNonNumTex :: Char"
codeGenNonNumTex (TypeCChar _) = [CTypeDef (internalIdent "TexCChar") internalNode]
codeGenNonNumTex (TypeCSChar _) = [CTypeDef (internalIdent "TexCSChar") internalNode]
codeGenNonNumTex (TypeCUChar _) = [CTypeDef (internalIdent "TexCUChar") internalNode]
-- Scalar Primitives
-- ~~~~~~~~~~~~~~~~~
codeGenPrimConst :: AST.PrimConst a -> CExpr
codeGenPrimConst (AST.PrimMinBound ty) = codeGenMinBound ty
codeGenPrimConst (AST.PrimMaxBound ty) = codeGenMaxBound ty
codeGenPrimConst (AST.PrimPi ty) = codeGenPi ty
codeGenPrim :: AST.PrimFun p -> [CExpr] -> CExpr
codeGenPrim (AST.PrimAdd _) [a,b] = CBinary CAddOp a b internalNode
codeGenPrim (AST.PrimSub _) [a,b] = CBinary CSubOp a b internalNode
codeGenPrim (AST.PrimMul _) [a,b] = CBinary CMulOp a b internalNode
codeGenPrim (AST.PrimNeg _) [a] = CUnary CMinOp a internalNode
codeGenPrim (AST.PrimAbs ty) [a] = codeGenAbs ty a
codeGenPrim (AST.PrimSig ty) [a] = codeGenSig ty a
codeGenPrim (AST.PrimQuot ty) [a,b] = codeGenQuot ty a b
codeGenPrim (AST.PrimRem _) [a,b] = CBinary CRmdOp a b internalNode
codeGenPrim (AST.PrimIDiv _) [a,b] = CBinary CDivOp a b internalNode
codeGenPrim (AST.PrimMod ty) [a,b] = codeGenMod ty a b
codeGenPrim (AST.PrimBAnd _) [a,b] = CBinary CAndOp a b internalNode
codeGenPrim (AST.PrimBOr _) [a,b] = CBinary COrOp a b internalNode
codeGenPrim (AST.PrimBXor _) [a,b] = CBinary CXorOp a b internalNode
codeGenPrim (AST.PrimBNot _) [a] = CUnary CCompOp a internalNode
codeGenPrim (AST.PrimBShiftL _) [a,b] = CBinary CShlOp a b internalNode
codeGenPrim (AST.PrimBShiftR _) [a,b] = CBinary CShrOp a b internalNode
codeGenPrim (AST.PrimBRotateL _) [a,b] = codeGenBRotateL a b
codeGenPrim (AST.PrimBRotateR _) [a,b] = codeGenBRotateR a b
codeGenPrim (AST.PrimFDiv _) [a,b] = CBinary CDivOp a b internalNode
codeGenPrim (AST.PrimRecip ty) [a] = codeGenRecip ty a
codeGenPrim (AST.PrimSin ty) [a] = ccall (FloatingNumType ty) "sin" [a]
codeGenPrim (AST.PrimCos ty) [a] = ccall (FloatingNumType ty) "cos" [a]
codeGenPrim (AST.PrimTan ty) [a] = ccall (FloatingNumType ty) "tan" [a]
codeGenPrim (AST.PrimAsin ty) [a] = ccall (FloatingNumType ty) "asin" [a]
codeGenPrim (AST.PrimAcos ty) [a] = ccall (FloatingNumType ty) "acos" [a]
codeGenPrim (AST.PrimAtan ty) [a] = ccall (FloatingNumType ty) "atan" [a]
codeGenPrim (AST.PrimAsinh ty) [a] = ccall (FloatingNumType ty) "asinh" [a]
codeGenPrim (AST.PrimAcosh ty) [a] = ccall (FloatingNumType ty) "acosh" [a]
codeGenPrim (AST.PrimAtanh ty) [a] = ccall (FloatingNumType ty) "atanh" [a]
codeGenPrim (AST.PrimExpFloating ty) [a] = ccall (FloatingNumType ty) "exp" [a]
codeGenPrim (AST.PrimSqrt ty) [a] = ccall (FloatingNumType ty) "sqrt" [a]
codeGenPrim (AST.PrimLog ty) [a] = ccall (FloatingNumType ty) "log" [a]
codeGenPrim (AST.PrimFPow ty) [a,b] = ccall (FloatingNumType ty) "pow" [a,b]
codeGenPrim (AST.PrimLogBase ty) [a,b] = codeGenLogBase ty a b
codeGenPrim (AST.PrimLt _) [a,b] = CBinary CLeOp a b internalNode
codeGenPrim (AST.PrimGt _) [a,b] = CBinary CGrOp a b internalNode
codeGenPrim (AST.PrimLtEq _) [a,b] = CBinary CLeqOp a b internalNode
codeGenPrim (AST.PrimGtEq _) [a,b] = CBinary CGeqOp a b internalNode
codeGenPrim (AST.PrimEq _) [a,b] = CBinary CEqOp a b internalNode
codeGenPrim (AST.PrimNEq _) [a,b] = CBinary CNeqOp a b internalNode
codeGenPrim (AST.PrimMax ty) [a,b] = codeGenMax ty a b
codeGenPrim (AST.PrimMin ty) [a,b] = codeGenMin ty a b
codeGenPrim AST.PrimLAnd [a,b] = CBinary CLndOp a b internalNode
codeGenPrim AST.PrimLOr [a,b] = CBinary CLorOp a b internalNode
codeGenPrim AST.PrimLNot [a] = CUnary CNegOp a internalNode
codeGenPrim AST.PrimOrd [a] = CCast (CDecl [CTypeSpec (CIntType internalNode)] [] internalNode) a internalNode
codeGenPrim AST.PrimChr [a] = CCast (CDecl [CTypeSpec (CCharType internalNode)] [] internalNode) a internalNode
codeGenPrim AST.PrimRoundFloatInt [a] = CCall (CVar (internalIdent "lroundf") internalNode) [a] internalNode -- TLM: (int) rintf(x) ??
codeGenPrim AST.PrimTruncFloatInt [a] = CCall (CVar (internalIdent "ltruncf") internalNode) [a] internalNode
codeGenPrim AST.PrimIntFloat [a] = CCast (CDecl [CTypeSpec (CFloatType internalNode)] [] internalNode) a internalNode -- TLM: __int2float_[rn,rz,ru,rd](a) ??
codeGenPrim AST.PrimBoolToInt [a] = CCast (CDecl [CTypeSpec (CIntType internalNode)] [] internalNode) a internalNode
-- If the argument lists are not the correct length
codeGenPrim _ _ =
error "Data.Array.Accelerate.CUDA: inconsistent valuation"
-- Implementation
--
codeGenConst :: TupleType a -> a -> [CExpr]
codeGenConst UnitTuple _ = []
codeGenConst (SingleTuple ty) c = [codeGenScalar ty c]
codeGenConst (PairTuple ty1 ty0) (cs,c) = codeGenConst ty1 cs ++ codeGenConst ty0 c
codeGenScalar :: ScalarType a -> a -> CExpr
codeGenScalar (NumScalarType (IntegralNumType ty))
| IntegralDict <- integralDict ty
= CConst . flip CIntConst internalNode . cInteger . fromIntegral
codeGenScalar (NumScalarType (FloatingNumType ty))
| FloatingDict <- floatingDict ty
= CConst . flip CFloatConst internalNode . cFloat . fromRational . toRational
codeGenScalar (NonNumScalarType (TypeBool _)) = fromBool
codeGenScalar (NonNumScalarType (TypeChar _)) =
CConst . flip CCharConst internalNode . cChar
codeGenScalar (NonNumScalarType (TypeCChar _)) =
CConst . flip CCharConst internalNode . cChar . chr . fromIntegral
codeGenScalar (NonNumScalarType (TypeCUChar _)) =
CConst . flip CCharConst internalNode . cChar . chr . fromIntegral
codeGenScalar (NonNumScalarType (TypeCSChar _)) =
CConst . flip CCharConst internalNode . cChar . chr . fromIntegral
codeGenPi :: FloatingType a -> CExpr
codeGenPi ty | FloatingDict <- floatingDict ty
= codeGenScalar (NumScalarType (FloatingNumType ty)) pi
codeGenMinBound :: BoundedType a -> CExpr
codeGenMinBound (IntegralBoundedType ty)
| IntegralDict <- integralDict ty
= codeGenScalar (NumScalarType (IntegralNumType ty)) minBound
codeGenMinBound (NonNumBoundedType ty)
| NonNumDict <- nonNumDict ty
= codeGenScalar (NonNumScalarType ty) minBound
codeGenMaxBound :: BoundedType a -> CExpr
codeGenMaxBound (IntegralBoundedType ty)
| IntegralDict <- integralDict ty
= codeGenScalar (NumScalarType (IntegralNumType ty)) maxBound
codeGenMaxBound (NonNumBoundedType ty)
| NonNumDict <- nonNumDict ty
= codeGenScalar (NonNumScalarType ty) maxBound
codeGenAbs :: NumType a -> CExpr -> CExpr
codeGenAbs ty@(IntegralNumType _) x = ccall ty "abs" [x]
codeGenAbs ty@(FloatingNumType _) x = ccall ty "fabs" [x]
codeGenSig :: NumType a -> CExpr -> CExpr
codeGenSig ty@(IntegralNumType t) a
| IntegralDict <- integralDict t
= CCond (CBinary CGeqOp a (codeGenScalar (NumScalarType ty) 0) internalNode)
(Just (codeGenScalar (NumScalarType ty) 1))
(codeGenScalar (NumScalarType ty) 0)
internalNode
codeGenSig ty@(FloatingNumType t) a
| FloatingDict <- floatingDict t
= CCond (CBinary CGeqOp a (codeGenScalar (NumScalarType ty) 0) internalNode)
(Just (codeGenScalar (NumScalarType ty) 1))
(codeGenScalar (NumScalarType ty) 0)
internalNode
codeGenQuot :: IntegralType a -> CExpr -> CExpr -> CExpr
codeGenQuot = error "Data.Array.Accelerate.CUDA.CodeGen: PrimQuot"
codeGenMod :: IntegralType a -> CExpr -> CExpr -> CExpr
codeGenMod = error "Data.Array.Accelerate.CUDA.CodeGen: PrimMod"
-- TLM 2010-06-29:
-- It would be nice we could use something like Language.C.Parser.execParser
-- to suck in the C code directly, instead of storing this long and messy
-- abstract syntax. The problem lies in injecting our `x' and `i' expressions.
--
-- T rotl(T x, int i)
-- {
-- return (i &= 8 * sizeof(x) - 1) == 0 ? x : x << i | x >> 8 * sizeof(x) - i;
-- }
--
codeGenBRotateL :: CExpr -> CExpr -> CExpr
codeGenBRotateL x i =
CCond (CBinary CEqOp (CAssign CAndAssOp i (CBinary CSubOp (CBinary CMulOp (CConst (CIntConst (cInteger 8) internalNode)) (CSizeofExpr x internalNode) internalNode) (CConst (CIntConst (cInteger 1) internalNode)) internalNode) internalNode) (CConst (CIntConst (cInteger 0) internalNode)) internalNode) (Just x) (CBinary COrOp (CBinary CShlOp x i internalNode) (CBinary CShrOp x (CBinary CSubOp (CBinary CMulOp (CConst (CIntConst (cInteger 8) internalNode)) (CSizeofExpr x internalNode) internalNode) i internalNode) internalNode) internalNode) internalNode
-- T rotr(T x, int i)
-- {
-- return (i &= 8 * sizeof(x) - 1) == 0 ? x : x >> i | x << 8 * sizeof(x) - i;
-- }
--
codeGenBRotateR :: CExpr -> CExpr -> CExpr
codeGenBRotateR x i =
CCond (CBinary CEqOp (CAssign CAndAssOp i (CBinary CSubOp (CBinary CMulOp (CConst (CIntConst (cInteger 8) internalNode)) (CSizeofExpr x internalNode) internalNode) (CConst (CIntConst (cInteger 1) internalNode)) internalNode) internalNode) (CConst (CIntConst (cInteger 0) internalNode)) internalNode) (Just x) (CBinary COrOp (CBinary CShrOp x i internalNode) (CBinary CShlOp x (CBinary CSubOp (CBinary CMulOp (CConst (CIntConst (cInteger 8) internalNode)) (CSizeofExpr x internalNode) internalNode) i internalNode) internalNode) internalNode) internalNode
codeGenRecip :: FloatingType a -> CExpr -> CExpr
codeGenRecip ty x | FloatingDict <- floatingDict ty
= CBinary CDivOp (codeGenScalar (NumScalarType (FloatingNumType ty)) 1) x internalNode
codeGenLogBase :: FloatingType a -> CExpr -> CExpr -> CExpr
codeGenLogBase ty x y = let a = ccall (FloatingNumType ty) "log" [x]
b = ccall (FloatingNumType ty) "log" [y]
in
CBinary CDivOp b a internalNode
codeGenMin :: ScalarType a -> CExpr -> CExpr -> CExpr
codeGenMin (NumScalarType ty@(IntegralNumType _)) a b = ccall ty "min" [a,b]
codeGenMin (NumScalarType ty@(FloatingNumType _)) a b = ccall ty "fmin" [a,b]
codeGenMin (NonNumScalarType _) _ _ = undefined
codeGenMax :: ScalarType a -> CExpr -> CExpr -> CExpr
codeGenMax (NumScalarType ty@(IntegralNumType _)) a b = ccall ty "max" [a,b]
codeGenMax (NumScalarType ty@(FloatingNumType _)) a b = ccall ty "fmax" [a,b]
codeGenMax (NonNumScalarType _) _ _ = undefined
-- Helper Functions
-- ~~~~~~~~~~~~~~~~
ccall :: NumType a -> String -> [CExpr] -> CExpr
ccall (IntegralNumType _) fn args = CCall (CVar (internalIdent fn) internalNode) args internalNode
ccall (FloatingNumType ty) fn args = CCall (CVar (internalIdent (fn `postfix` ty)) internalNode) args internalNode
where
postfix :: String -> FloatingType a -> String
postfix x (TypeFloat _) = x ++ "f"
postfix x (TypeCFloat _) = x ++ "f"
postfix x _ = x