diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Revision history for FAI + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/FAI.cabal b/FAI.cabal new file mode 100644 --- /dev/null +++ b/FAI.cabal @@ -0,0 +1,59 @@ +-- Initial FAI.cabal generated by cabal init. For further documentation, +-- see http://haskell.org/cabal/users-guide/ + +name: FAI +version: 0.1.0.10 +synopsis: Haskell Foreign Accelerate Interface +description: The haskell interface for foreign accelerate framework. +homepage: https://github.com/Qinka/HaskellFAI +license: LGPL-3 +license-file: LICENSE +author: Johann Lee +maintainer: me@qinka.pro +copyright: (C) 2018 Johann Lee +category: Accelerate +build-type: Simple +extra-source-files: ChangeLog.md +cabal-version: >=1.21 + +flag enable-cuda + default: True + description: Enable the Nvidia's CUDA platform. + +library + exposed-modules: Foreign.FAI.Types + , Foreign.FAI.Platform.Host + -- other-modules: + other-extensions: MultiParamTypeClasses + , GADTs + , TypeFamilies + , QuasiQuotes + , TemplateHaskell + reexported-modules: Language.C.Inline + build-depends: base >= 4 && < 5 + , inline-c >= 0.6 + hs-source-dirs: src + default-language: Haskell2010 + + if(flag(enable-cuda)) + extra-libraries: cudart + exposed-modules: Foreign.FAI.Platform.CUDA + + +test-suite spec + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: test + ghc-options: -Wall + build-depends: base + , FAI + , inline-c + , hspec + other-modules: Foreign.FAI.Platform.HostSpec + , Foreign.FAI.Platform.CUDASpec + other-extensions: CPP + , TypeFamilies + + default-language: Haskell2010 + if(flag(enable-cuda)) + cpp-options: -DENABLE_CUDA diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,165 @@ + GNU LESSER GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + + This version of the GNU Lesser General Public License incorporates +the terms and conditions of version 3 of the GNU General Public +License, supplemented by the additional permissions listed below. + + 0. Additional Definitions. + + As used herein, "this License" refers to version 3 of the GNU Lesser +General Public License, and the "GNU GPL" refers to version 3 of the GNU +General Public License. + + "The Library" refers to a covered work governed by this License, +other than an Application or a Combined Work as defined below. + + An "Application" is any work that makes use of an interface provided +by the Library, but which is not otherwise based on the Library. +Defining a subclass of a class defined by the Library is deemed a mode +of using an interface provided by the Library. + + A "Combined Work" is a work produced by combining or linking an +Application with the Library. The particular version of the Library +with which the Combined Work was made is also called the "Linked +Version". + + The "Minimal Corresponding Source" for a Combined Work means the +Corresponding Source for the Combined Work, excluding any source code +for portions of the Combined Work that, considered in isolation, are +based on the Application, and not on the Linked Version. + + The "Corresponding Application Code" for a Combined Work means the +object code and/or source code for the Application, including any data +and utility programs needed for reproducing the Combined Work from the +Application, but excluding the System Libraries of the Combined Work. + + 1. Exception to Section 3 of the GNU GPL. + + You may convey a covered work under sections 3 and 4 of this License +without being bound by section 3 of the GNU GPL. + + 2. Conveying Modified Versions. + + If you modify a copy of the Library, and, in your modifications, a +facility refers to a function or data to be supplied by an Application +that uses the facility (other than as an argument passed when the +facility is invoked), then you may convey a copy of the modified +version: + + a) under this License, provided that you make a good faith effort to + ensure that, in the event an Application does not supply the + function or data, the facility still operates, and performs + whatever part of its purpose remains meaningful, or + + b) under the GNU GPL, with none of the additional permissions of + this License applicable to that copy. + + 3. Object Code Incorporating Material from Library Header Files. + + The object code form of an Application may incorporate material from +a header file that is part of the Library. You may convey such object +code under terms of your choice, provided that, if the incorporated +material is not limited to numerical parameters, data structure +layouts and accessors, or small macros, inline functions and templates +(ten or fewer lines in length), you do both of the following: + + a) Give prominent notice with each copy of the object code that the + Library is used in it and that the Library and its use are + covered by this License. + + b) Accompany the object code with a copy of the GNU GPL and this license + document. + + 4. Combined Works. + + You may convey a Combined Work under terms of your choice that, +taken together, effectively do not restrict modification of the +portions of the Library contained in the Combined Work and reverse +engineering for debugging such modifications, if you also do each of +the following: + + a) Give prominent notice with each copy of the Combined Work that + the Library is used in it and that the Library and its use are + covered by this License. + + b) Accompany the Combined Work with a copy of the GNU GPL and this license + document. + + c) For a Combined Work that displays copyright notices during + execution, include the copyright notice for the Library among + these notices, as well as a reference directing the user to the + copies of the GNU GPL and this license document. + + d) Do one of the following: + + 0) Convey the Minimal Corresponding Source under the terms of this + License, and the Corresponding Application Code in a form + suitable for, and under terms that permit, the user to + recombine or relink the Application with a modified version of + the Linked Version to produce a modified Combined Work, in the + manner specified by section 6 of the GNU GPL for conveying + Corresponding Source. + + 1) Use a suitable shared library mechanism for linking with the + Library. A suitable mechanism is one that (a) uses at run time + a copy of the Library already present on the user's computer + system, and (b) will operate properly with a modified version + of the Library that is interface-compatible with the Linked + Version. + + e) Provide Installation Information, but only if you would otherwise + be required to provide such information under section 6 of the + GNU GPL, and only to the extent that such information is + necessary to install and execute a modified version of the + Combined Work produced by recombining or relinking the + Application with a modified version of the Linked Version. (If + you use option 4d0, the Installation Information must accompany + the Minimal Corresponding Source and Corresponding Application + Code. If you use option 4d1, you must provide the Installation + Information in the manner specified by section 6 of the GNU GPL + for conveying Corresponding Source.) + + 5. Combined Libraries. + + You may place library facilities that are a work based on the +Library side by side in a single library together with other library +facilities that are not Applications and are not covered by this +License, and convey such a combined library under terms of your +choice, if you do both of the following: + + a) Accompany the combined library with a copy of the same work based + on the Library, uncombined with any other library facilities, + conveyed under the terms of this License. + + b) Give prominent notice with the combined library that part of it + is a work based on the Library, and explaining where to find the + accompanying uncombined form of the same work. + + 6. Revised Versions of the GNU Lesser General Public License. + + The Free Software Foundation may publish revised and/or new versions +of the GNU Lesser General Public License from time to time. Such new +versions will be similar in spirit to the present version, but may +differ in detail to address new problems or concerns. + + Each version is given a distinguishing version number. If the +Library as you received it specifies that a certain numbered version +of the GNU Lesser General Public License "or any later version" +applies to it, you have the option of following the terms and +conditions either of that published version or of any later version +published by the Free Software Foundation. If the Library as you +received it does not specify a version number of the GNU Lesser +General Public License, you may choose any version of the GNU Lesser +General Public License ever published by the Free Software Foundation. + + If the Library as you received it specifies that a proxy can decide +whether future versions of the GNU Lesser General Public License shall +apply, that proxy's public statement of acceptance of any version is +permanent authorization for you to choose that version for the +Library. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/Foreign/FAI/Platform/CUDA.hs b/src/Foreign/FAI/Platform/CUDA.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/FAI/Platform/CUDA.hs @@ -0,0 +1,145 @@ +{- + +Copyright (C) 2018 Johann Lee + +This fiel is part of HaskellFAI + +HaskellFAI is free software: you can redistribute it and/or modify +it under the terms of the GNU Less General Public License as published by +the Free Software Foundation, either version 3 of the License, +or (at your option) any later version. + +Haskell is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warrenty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU Less General Public License for more details. + +You should have received a copy of the GNU Less General Public License +along with HaskellFAI. If not, see . + +-} + +{-| +Module: Foreign.FAI.Platform.CUDA +Description: The CUDA platform instance. +Copyright: (C) 2018 Johann Lee +License: LGPL3 +Maintainer: me@qinka.pro +Stability: experimental +Portability: unknown + +The CUDA platform instance. +-} + +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + + +module Foreign.FAI.Platform.CUDA + ( CUDA(..) + , Pf(..) + ) where + +import Control.Monad +import Foreign.C.Types +import Foreign.FAI.Platform.Host (Host) +import Foreign.FAI.Types +import Foreign.ForeignPtr +import Foreign.Ptr +import qualified Language.C.Inline as C + +C.include "" +C.include "" + +data CUDA = CUDA + +type instance Pf CUDA Float = Float +type instance Pf CUDA Double = Double +type instance Pf CUDA Int = Int +type instance Pf CUDA Word = Word + +cudaMemAllocate :: CInt -> IO (Ptr a) +cudaMemAllocate n = + castPtr <$> [C.block| void* { + void * ptr = 0; + cudaError_t err = cudaMalloc((void*)&ptr, $(int n)); + if (err != cudaSuccess) { + printf("Failed to allocate memory, %d", err); + ptr = 0; + } + return ptr;}|] + +cudaMemRelease :: Ptr a -> IO () +cudaMemRelease n' = [C.exp| void { cudaFree($(void *n)) }|] + where n = castPtr n' + +cudaMemReleaseP :: IO (FinalizerPtr a) +cudaMemReleaseP = castPtrToFunPtr <$> [C.exp| void* {*cudaFree}|] + +cudaMemCopy :: (Ptr () -> Ptr () -> CInt -> IO CInt) + -> ForeignPtr a -> ForeignPtr b -> CInt -> IO () +cudaMemCopy doCopy fdst fsrc size = + withForeignPtr fdst $ \dst' -> + withForeignPtr fsrc $ \src' -> + let dst = castPtr dst' + src = castPtr src' + in do + rt <- doCopy dst src size + when (rt /= 0) $ error "Fail to copy." + +doCopyHC :: Ptr () -> Ptr () -> CInt -> IO CInt +doCopyHC dst src size = + [C.block| int { + cudaError_t err = cudaMemcpy($(void *dst), $(void *src), + $(int size), cudaMemcpyHostToDevice); + if(err != cudaSuccess) { + printf("Failed to copy memory(HC), %d", err); + return -1; + } + return 0;}|] + +doCopyCH :: Ptr () -> Ptr () -> CInt -> IO CInt +doCopyCH dst src size = + [C.block| int { + cudaError_t err = cudaMemcpy($(void *dst), $(void *src), + $(int size), cudaMemcpyDeviceToHost); + if(err != cudaSuccess) { + printf("Failed to copy memory(HC), %d", err); + return -1; + } + return 0;}|] + +doCopyCC :: Ptr () -> Ptr () -> CInt -> IO CInt +doCopyCC dst src size = + [C.block| int { + cudaError_t err = cudaMemcpy($(void *dst), $(void *src), + $(int size), cudaMemcpyDeviceToDevice); + if(err != cudaSuccess) { + printf("Failed to copy memory(HC), %d", err); + return -1; + } + return 0;}|] + + +instance FAI CUDA where + faiMemAllocate _ = cudaMemAllocate . fromIntegral + faiMemRelease _ = cudaMemRelease + faiMemReleaseP _ = Right <$> cudaMemReleaseP + +instance FAICopy Host CUDA where + faiMemCopy dst src = do + when (bufSize dst /= bufSize src) $ error "Different size." + cudaMemCopy doCopyHC (bufPtr dst) (bufPtr src) $ fromIntegral $ bufSize dst + +instance FAICopy CUDA Host where + faiMemCopy dst src = do + when (bufSize dst /= bufSize src) $ error "Different size." + cudaMemCopy doCopyCH (bufPtr dst) (bufPtr src) $ fromIntegral $ bufSize dst + +instance FAICopy CUDA CUDA where + faiMemCopy dst src = do + when (bufSize dst /= bufSize src) $ error "Different size." + cudaMemCopy doCopyCC (bufPtr dst) (bufPtr src) $ fromIntegral $ bufSize dst + diff --git a/src/Foreign/FAI/Platform/Host.hs b/src/Foreign/FAI/Platform/Host.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/FAI/Platform/Host.hs @@ -0,0 +1,111 @@ +{- + +Copyright (C) 2018 Johann Lee + +This fiel is part of HaskellFAI + +HaskellFAI is free software: you can redistribute it and/or modify +it under the terms of the GNU Less General Public License as published by +the Free Software Foundation, either version 3 of the License, +or (at your option) any later version. + +Haskell is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warrenty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU Less General Public License for more details. + +You should have received a copy of the GNU Less General Public License +along with HaskellFAI. If not, see . + +-} + +{-| +Module: Foreign.FAI.Platform.Host +Description: The host platform instance. +Copyright: (C) 2018 Johann Lee +License: LGPL3 +Maintainer: me@qinka.pro +Stability: experimental +Portability: unknown + +The host platform instance. +-} + +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + + +module Foreign.FAI.Platform.Host + ( Host(..) + , Pf(..) + , bufFromList + , bufToList + ) where + +import Control.Monad +import Foreign.C.Types +import Foreign.FAI.Types +import Foreign.ForeignPtr +import Foreign.Marshal.Array +import Foreign.Ptr +import Foreign.Storable +import qualified Language.C.Inline as C +import System.IO.Unsafe + +C.include "" +C.include "" + +data Host = Host + +type instance Pf Host Float = Float +type instance Pf Host Double = Double +type instance Pf Host Int = Int +type instance Pf Host Word = Word + +hostMemAllocate :: CInt -> IO (Ptr a) +hostMemAllocate n = castPtr <$> [C.exp| void* { malloc($(int n))}|] + +hostMemRelease :: Ptr a -> IO () +hostMemRelease n' = [C.exp| void { free($(void *n)) }|] + where n = castPtr n' + +hostMemReleaseP :: IO (FinalizerPtr a) +hostMemReleaseP = castPtrToFunPtr <$> [C.exp| void* {*free}|] + +hostMemCopy :: ForeignPtr a -> ForeignPtr a -> CInt -> IO () +hostMemCopy fdst fsrc size = + withForeignPtr fdst $ \dst' -> + withForeignPtr fsrc $ \src' -> + let dst = castPtr dst' + src = castPtr src' + in void $ [C.exp| void* {memcpy($(void *dst), $(void *src), $(int size))} |] + +instance FAI Host where + faiMemAllocate _ = hostMemAllocate . fromIntegral + faiMemRelease _ = hostMemRelease + faiMemReleaseP _ = Right <$> hostMemReleaseP + +instance FAICopy Host Host where + faiMemCopy dst src = do + when (bufSize dst /= bufSize src) $ error "Different size." + hostMemCopy (bufPtr dst) (bufPtr src) $ fromIntegral $ bufSize dst + + +hostAccReturn :: a -> Accelerate Host a +hostAccReturn = return + +bufFromList :: (Storable b, Pf Host a ~ b) => [b] -> Buffer Host a +bufFromList ls = unsafePerformIO $ do + bf <- fst <$> doAccelerate (hostAccReturn () >> newBuffer (length ls)) undefined + withForeignPtr (bufPtr bf) $ \ptr -> + pokeArray ptr ls + return bf + +bufToList :: (Storable b, Pf Host a ~ b) => Buffer Host a -> [b] +bufToList bf = unsafePerformIO $ + withForeignPtr (bufPtr bf) $ \ptr -> + peekBuf undefined ptr + where peekBuf :: Storable a => a -> Ptr a -> IO [a] + peekBuf = peekArray . (bufSize bf `div`) . sizeOf diff --git a/src/Foreign/FAI/Types.hs b/src/Foreign/FAI/Types.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/FAI/Types.hs @@ -0,0 +1,175 @@ +{- + +Copyright (C) 2018 Johann Lee + +This fiel is part of HaskellFAI + +HaskellFAI is free software: you can redistribute it and/or modify +it under the terms of the GNU Less General Public License as published by +the Free Software Foundation, either version 3 of the License, +or (at your option) any later version. + +Haskell is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warrenty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU Less General Public License for more details. + +You should have received a copy of the GNU Less General Public License +along with HaskellFAI. If not, see . + +-} + +{-| +Module: Foreign.FAI.Types +Description: The types and the class of FAI +Copyright: (C) 2018 Johann Lee +License: LGPL3 +Maintainer: me@qinka.pro +Stability: experimental +Portability: unknown + +The types and the class of FAI. +-} + +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} + +module Foreign.FAI.Types + ( Pf(..) + , Buffer(..) + , Context(..) + , Accelerate(..) + , FAI(..) + , FAICopy(..) + , newBuffer + , dupBuffer + , dupBufferD + , liftIO + , accelerate + ) where + +import Control.Monad +import Control.Monad.IO.Class (MonadIO (..)) +import Foreign.ForeignPtr +import Foreign.Ptr +import Foreign.Storable + +type family Pf p t :: * + +data Buffer p a = Buffer + { bufPtr :: ForeignPtr (Pf p a) -- ^ pointer + , bufSize :: Int -- ^ number of size + } + deriving (Show, Eq) + +newtype Context p = Context + { unContextPtr :: Ptr (Context p) + } + deriving (Show, Eq) + +newtype Accelerate p a = Accelerate + { doAccelerate :: Context p -> IO (a, Context p) + } + +accelerate :: Context p -> Accelerate p a -> IO a +accelerate cc = (fst <$>) . flip doAccelerate cc + +class FAI p where + faiMemAllocate :: Context p + -> Int -- ^ size + -> IO (Ptr a) -- ^ Pointer + faiMemRelease :: Context p + -> Ptr a -- ^ Pointer + -> IO () + faiMemReleaseP :: Context p + -> IO (Either + (FinalizerEnvPtr (Context p) a) + (FinalizerPtr a)) + -- ^ pointer of the function + -- of release the pointer + +class (FAI p1, FAI p2) => FAICopy p1 p2 where + faiMemCopy :: (Storable b, (Pf p1 a) ~ b, Storable c, (Pf p2 a) ~ c) + => Buffer p2 a -- ^ Destination + -> Buffer p1 a -- ^ Source + -> IO () + +instance Functor (Accelerate p) where + fmap f (Accelerate a) = Accelerate $ \c -> do + (r,c') <- a c + return (f r, c') + +instance Applicative (Accelerate p) where + pure x = Accelerate $ \c -> return (x, c) + (<*>) (Accelerate ff) (Accelerate fa) = Accelerate $ \c1 -> do + (r1,c2) <- fa c1 + (r2,c3) <- ff c2 + return (r2 r1, c3) + +instance Monad (Accelerate p) where + (>>=) (Accelerate a) mf = Accelerate $ \c1 -> do + (r1, c2) <- a c1 + let (Accelerate m) = mf r1 + m c2 + +instance MonadIO (Accelerate p) where + liftIO m = Accelerate $ \c -> (\r -> (r,c)) <$> m + +autoNewForeignPtr :: Either + (FinalizerEnvPtr (Context p) (Pf p a)) + (FinalizerPtr (Pf p a)) + -> Context p + -> Ptr (Pf p a) + -> Int + -> IO (Buffer p a) +autoNewForeignPtr fin cc ptr size = fmap (`Buffer` size) $ case fin of + Left f -> newForeignPtrEnv f (unContextPtr cc) ptr + Right f -> newForeignPtr f ptr + +newBuffer :: (FAI p, Storable b, (Pf p a) ~ b) + => Int -- ^ number of items + -> Accelerate p (Buffer p a) +newBuffer n = Accelerate $ \cc -> do + fin <- faiMemReleaseP cc + (ptr, size) <- alloc cc undefined + when (nullPtr == ptr) $ error "Can not allocate memory." + buf <- autoNewForeignPtr fin cc ptr size + return (buf, cc) + where alloc :: (FAI p, Storable b) => Context p -> b -> IO (Ptr b, Int) + alloc cc u = + let size = n * sizeOf u + in (\p -> (p, size)) <$> faiMemAllocate cc (n * sizeOf u) + +-- | without copy things +dupBuffer :: ( FAICopy p1 p2, FAI p1, FAI p2 + , Storable b, Pf p2 a ~ b, Pf p1 a ~ b) + => Bool + -> Buffer p1 a + -> Accelerate p2 (Buffer p2 a) +dupBuffer is buf = Accelerate $ \cc -> dup cc is buf + +dupBufferD :: ( FAICopy p2 p1, FAI p1, FAI p2 + , Storable b, Pf p2 a ~ b, Pf p1 a ~ b) + => Bool + -> Buffer p2 a + -> Accelerate p2 (Buffer p1 a) +dupBufferD is buf = Accelerate $ \cc -> replaceContext cc <$> dup undefined is buf + +replaceContext :: Context p2 -> (a, Context p1) -> (a, Context p2) +replaceContext cc (a, _) = (a, cc) + +dup :: ( FAICopy p1 p2, FAI p1, FAI p2 + , Storable b, Pf p2 a ~ b, Pf p1 a ~ b) + => Context p2 + -> Bool + -> Buffer p1 a + -> IO (Buffer p2 a, Context p2) +dup cc is buf = do + fin <- faiMemReleaseP cc + let size = bufSize buf + ptr <- faiMemAllocate cc size + bDst <- autoNewForeignPtr fin cc ptr size + when is $ faiMemCopy bDst buf + return (bDst, cc) + diff --git a/test/Foreign/FAI/Platform/CUDASpec.hs b/test/Foreign/FAI/Platform/CUDASpec.hs new file mode 100644 --- /dev/null +++ b/test/Foreign/FAI/Platform/CUDASpec.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} + +module Foreign.FAI.Platform.CUDASpec + ( spec + ) where + + +import Test.Hspec + +#ifdef ENABLE_CUDA + +import Foreign.FAI.Platform.CUDA +import Foreign.FAI.Platform.Host +import Foreign.FAI.Types +import Foreign.ForeignPtr +import Foreign.Marshal.Array +import Foreign.Ptr +import Foreign.Storable + +peekBuffer :: (Storable b, Pf Host a ~ b) => Buffer Host a -> IO [b] +peekBuffer (Buffer fp len) = withForeignPtr fp $ \p -> peekArray len p + +peekBufferA :: (Storable b, Pf Host a ~ b, Pf CUDA a ~ b) => Buffer CUDA a -> Accelerate CUDA [b] +peekBufferA b = do + hostBuffer <- dupBufferD True b + liftIO $ peekBuffer hostBuffer + + +spec :: Spec +spec = do + describe "Test CUDA" $ do + it "copy and same" $ do + let acc = accelerate cc $ do + let arr1 = [1..100] :: [Float] + b1 = bufFromList arr1 :: Buffer Host Float + liftIO $ print b1 + b2 <- dupBuffer True b1 :: Accelerate CUDA (Buffer CUDA Float) + liftIO $ print b2 + b3 <- dupBufferD True b2 + liftIO $ print b3 + let arr2 = bufToList b3 + return (arr1, arr2) + (arr1, arr2) <- acc + arr1 `shouldBe` arr2 + +cc = Context nullPtr + +#else +spec = describe "Skip CUDA Test" $ it "Do nothing" $ putStrLn "Skip." +-- ENABLE_CUDA +#endif diff --git a/test/Foreign/FAI/Platform/HostSpec.hs b/test/Foreign/FAI/Platform/HostSpec.hs new file mode 100644 --- /dev/null +++ b/test/Foreign/FAI/Platform/HostSpec.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE TypeFamilies #-} + +module Foreign.FAI.Platform.HostSpec + ( spec + ) where + + +import Foreign.FAI.Types +import Foreign.FAI.Platform.Host +import Test.Hspec +import Foreign.Ptr +import Foreign.ForeignPtr +import Foreign.Marshal.Array +import Foreign.Storable + +peekBuffer :: (Storable b, Pf Host a ~ b) => Buffer Host a -> IO [b] +peekBuffer (Buffer fp len) = withForeignPtr fp $ \p -> peek undefined p len + where peek :: (Storable b) => b -> Ptr b-> Int -> IO [b] + peek u ptr i = peekArray (i `div` sizeOf u) ptr + +peekBufferA :: (Storable b, Pf Host a ~ b) => Buffer Host a -> Accelerate Host [b] +peekBufferA b = liftIO $ peekBuffer b + + +spec :: Spec +spec = do + describe "Allocate buffer" $ do + it "newBuffer" $ do + let acc = accelerate cc $ do + b <- newBuffer 20 :: Accelerate Host (Buffer Host Float) + liftIO $ print b + peekBufferA b >>= liftIO. print + return () + acc `shouldReturn` () + it "dupBuffer" $ do + let acc = accelerate cc $ do + b1 <- newBuffer 20 :: Accelerate Host (Buffer Host Float) + peekBufferA b1 >>= liftIO . print + b2 <- dupBuffer False b1 + peekBufferA b2 >>= liftIO . print + return () + acc `shouldReturn` () + describe "Test host" $ do + it "copy and same" $ do + let acc = accelerate cc $ do + let arr1 = [1..100] :: [Float] + b1 = bufFromList arr1 :: Buffer Host Float + b2 <- dupBuffer True b1 :: Accelerate Host (Buffer Host Float) + let arr2 = bufToList b2 + return (arr1, arr2) + (arr1, arr2) <- acc + arr1 `shouldBe` arr2 + +cc = Context nullPtr diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}