llvm-tf-3.0.2: src/LLVM/Core/Vector.hs

{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
module LLVM.Core.Vector (MkVector(..), vector, ) where

import LLVM.Core.Type
import LLVM.Core.Data
import LLVM.ExecutionEngine.Target

import Types.Data.Num

import Foreign.Ptr (castPtr)
import Foreign.Storable (Storable(..))
import Foreign.Marshal.Array (peekArray, pokeArray)

import Data.Function (on)
import System.IO.Unsafe (unsafePerformIO)


-- XXX Should these really be here?
class (PositiveT n, IsPrimitive a) => MkVector n a where
    type Tuple n a :: *
    toVector :: Tuple n a -> Vector n a
    fromVector :: Vector n a -> Tuple n a

{-
instance (IsPrimitive a) => MkVector (Value a) D1 (Value a) where
    toVector a = Vector [a]
-}

instance (IsPrimitive a) => MkVector D2 a where
    type Tuple D2 a = (a,a)
    toVector (a1, a2) = Vector [a1, a2]
    fromVector (Vector [a1, a2]) = (a1, a2)
    fromVector _ = error "fromVector: impossible"

instance (IsPrimitive a) => MkVector D4 a where
    type Tuple D4 a = (a,a,a,a)
    toVector (a1, a2, a3, a4) = Vector [a1, a2, a3, a4]
    fromVector (Vector [a1, a2, a3, a4]) = (a1, a2, a3, a4)
    fromVector _ = error "fromVector: impossible"

instance (IsPrimitive a) => MkVector D8 a where
    type Tuple D8 a = (a,a,a,a,a,a,a,a)
    toVector (a1, a2, a3, a4, a5, a6, a7, a8) = Vector [a1, a2, a3, a4, a5, a6, a7, a8]
    fromVector (Vector [a1, a2, a3, a4, a5, a6, a7, a8]) = (a1, a2, a3, a4, a5, a6, a7, a8)
    fromVector _ = error "fromVector: impossible"

instance (Storable a, PositiveT n, IsPrimitive a) => Storable (Vector n a) where
    sizeOf a = storeSizeOfType ourTargetData (typeRef a)
    alignment a = aBIAlignmentOfType ourTargetData (typeRef a)
    peek p = fmap Vector $ peekArray (fromIntegerT (undefined :: n)) (castPtr p :: Ptr a)
    poke p (Vector vs) = pokeArray (castPtr p :: Ptr a) vs

-- XXX The JITer target data.  This isn't really right.
ourTargetData :: TargetData
ourTargetData = unsafePerformIO getTargetData

--------------------------------------

unVector :: Vector n a -> [a]
unVector (Vector xs) = xs

-- |Make a constant vector.  Replicates or truncates the list to get length /n/.
-- This behaviour is consistent with that of 'LLVM.Core.CodeGen.constVector'.
vector :: forall a n. (PositiveT n) => [a] -> Vector n a
vector xs =
   Vector (take (fromIntegerT (undefined :: n)) (cycle xs))

replic :: forall a n. (PositiveT n) => a -> Vector n a
replic = Vector . replicate (fromIntegerT (undefined :: n))


binop :: (a -> b -> c) -> Vector n a -> Vector n b -> Vector n c
binop op xs ys = Vector $ zipWith op (unVector xs) (unVector ys)

unop :: (a -> b) -> Vector n a -> Vector n b
unop op = Vector . map op . unVector

instance (Eq a, PositiveT n) => Eq (Vector n a) where
    (==) = (==) `on` unVector

instance (Ord a, PositiveT n) => Ord (Vector n a) where
    compare = compare `on` unVector

instance (Num a, PositiveT n) => Num (Vector n a) where
    (+) = binop (+)
    (-) = binop (-)
    (*) = binop (*)
    negate = unop negate
    abs = unop abs
    signum = unop signum
    fromInteger = replic . fromInteger

instance (Enum a, PositiveT n) => Enum (Vector n a) where
    succ = unop succ
    pred = unop pred
    fromEnum = error "Vector fromEnum"
    toEnum = replic . toEnum

instance (Real a, PositiveT n) => Real (Vector n a) where
    toRational = error "Vector toRational"

instance (Integral a, PositiveT n) => Integral (Vector n a) where
    quot = binop quot
    rem  = binop rem
    div  = binop div
    mod  = binop mod
    quotRem (Vector xs) (Vector ys) = (Vector qs, Vector rs) where (qs, rs) = unzip $ zipWith quotRem xs ys
    divMod  (Vector xs) (Vector ys) = (Vector qs, Vector rs) where (qs, rs) = unzip $ zipWith divMod  xs ys
    toInteger = error "Vector toInteger"

instance (Fractional a, PositiveT n) => Fractional (Vector n a) where
    (/) = binop (/)
    fromRational = replic . fromRational

instance (RealFrac a, PositiveT n) => RealFrac (Vector n a) where
    properFraction = error "Vector properFraction"

instance (Floating a, PositiveT n) => Floating (Vector n a) where
    pi = replic pi
    sqrt = unop sqrt
    log = unop log
    logBase = binop logBase
    (**) = binop (**)
    exp = unop exp
    sin = unop sin
    cos = unop cos
    tan = unop tan
    asin = unop asin
    acos = unop acos
    atan = unop atan
    sinh = unop sinh
    cosh = unop cosh
    tanh = unop tanh
    asinh = unop asinh
    acosh = unop acosh
    atanh = unop atanh

instance (RealFloat a, PositiveT n) => RealFloat (Vector n a) where
    floatRadix = floatRadix . head . unVector
    floatDigits = floatDigits . head . unVector
    floatRange = floatRange . head . unVector
    decodeFloat = error "Vector decodeFloat"
    encodeFloat = error "Vector encodeFloat"
    exponent _ = 0
    scaleFloat 0 x = x
    scaleFloat _ _ = error "Vector scaleFloat"
    isNaN = error "Vector isNaN"
    isInfinite = error "Vector isInfinite"
    isDenormalized = error "Vector isDenormalized"
    isNegativeZero = error "Vector isNegativeZero"
    isIEEE = isIEEE . head . unVector