FAI 0.1.0.10 → 0.1.0.17
raw patch · 9 files changed
+370/−129 lines, 9 files
Files
- FAI.cabal +23/−6
- src/Foreign/FAI.hs +109/−0
- src/Foreign/FAI/Internal.hs +74/−0
- src/Foreign/FAI/Platform/CUDA.hs +12/−2
- src/Foreign/FAI/Platform/Host.hs +9/−24
- src/Foreign/FAI/Platform/Host/Debug.hs +96/−0
- src/Foreign/FAI/Types.hs +20/−74
- test/Foreign/FAI/Platform/CUDASpec.hs +5/−5
- test/Foreign/FAI/Platform/HostSpec.hs +22/−18
FAI.cabal view
@@ -2,10 +2,11 @@ -- see http://haskell.org/cabal/users-guide/ name: FAI -version: 0.1.0.10 +version: 0.1.0.17 synopsis: Haskell Foreign Accelerate Interface description: The haskell interface for foreign accelerate framework. homepage: https://github.com/Qinka/HaskellFAI +bug-reports: https://github.com/Qinka/HaskellFAI/issues license: LGPL-3 license-file: LICENSE author: Johann Lee @@ -15,29 +16,39 @@ build-type: Simple extra-source-files: ChangeLog.md cabal-version: >=1.21 +stability: experimental flag enable-cuda default: True + manual: False description: Enable the Nvidia's CUDA platform. library - exposed-modules: Foreign.FAI.Types + exposed-modules: Foreign.FAI , Foreign.FAI.Platform.Host - -- other-modules: + , Foreign.FAI.Platform.Host.Debug + , Foreign.FAI.Types + , Foreign.FAI.Internal + other-extensions: MultiParamTypeClasses , GADTs , TypeFamilies , QuasiQuotes , TemplateHaskell + reexported-modules: Language.C.Inline + build-depends: base >= 4 && < 5 - , inline-c >= 0.6 + , inline-c >= 0.6 + hs-source-dirs: src default-language: Haskell2010 + ghc-options: -Wall - if(flag(enable-cuda)) + if (flag(enable-cuda)) extra-libraries: cudart exposed-modules: Foreign.FAI.Platform.CUDA + -- , Foreign.FAI.Platform.CUDA.Debug test-suite spec @@ -56,4 +67,10 @@ default-language: Haskell2010 if(flag(enable-cuda)) - cpp-options: -DENABLE_CUDA+ cpp-options: -DENABLE_CUDA + +source-repository head + type: git + location: https://github.com/Qinka/HaskellFAI.git + branch: dev/master + subdir: FAI
+ src/Foreign/FAI.hs view
@@ -0,0 +1,109 @@+{- + +Copyright (C) 2018 Johann Lee <mer@qinka.pro> + +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 <http://www.gnu.org/licenses/>. + +-} + +{-| +Module: Foreign.FAI +Description: The Haskell Foreign Accelerate Interace. +Copyright: (C) 2018 Johann Lee <me@qinka.pro> +License: LGPL3 +Maintainer: me@qinka.pro +Stability: experimental +Portability: unknown + +The Haskell Foreign Accelerate Interace. +-} + +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} + +module Foreign.FAI + ( Pf + , Buffer(..) + , Context(..) + , Accelerate(..) + , FAI(..) + , FAICopy(..) + , FinalizerContextPtr + , accelerate + , newBuffer + , newBufferIO + , dupBuffer + , dupBufferIO + , dupBufferD + , liftIO + ) where + +import Control.Monad +import Foreign.FAI.Internal +import Foreign.FAI.Types +import Foreign.Ptr + +-- | run the @Accelerate@. +accelerate :: Context p -> Accelerate p a -> IO a +accelerate cc = (fst <$>) . flip doAccelerate cc + +-- | Allocate new buffer (IO) +newBufferIO :: (FAI p, Storable b, (Pf p a) ~ b) + => Int -- ^ number of items + -> Context p -- ^ platform context + -> IO (Buffer p a, Context p) -- ^ Buffer and (new) context +newBufferIO n 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 c' u = + let size = n * sizeOf u + in (\p -> (p, size)) <$> faiMemAllocate c' (n * sizeOf u) + +-- | Allocate buffer +newBuffer :: (FAI p, Storable b, (Pf p a) ~ b) + => Int -- ^ number of items + -> Accelerate p (Buffer p a) -- ^ buffer +newBuffer = Accelerate .newBufferIO + +-- | Duplicate buffer (IO) +dupBufferIO :: ( FAICopy p1 p2, FAI p1, FAI p2 + , Storable b, Pf p2 a ~ b, Pf p1 a ~ b) + => Bool -- ^ Whether copy data + -> Buffer p1 a -- ^ buffer (src) + -> Context p2 -- ^ platform context + -> IO (Buffer p2 a, Context p2) -- ^ buffer (dst) and context +dupBufferIO is buf cc = dup cc is buf + +-- | Duplicate buffer +dupBuffer :: ( FAICopy p1 p2, FAI p1, FAI p2 + , Storable b, Pf p2 a ~ b, Pf p1 a ~ b) + => Bool -- ^ Whether copy data + -> Buffer p1 a -- ^ buffer (src) + -> Accelerate p2 (Buffer p2 a) -- ^ buffer (dst) +dupBuffer is buf = Accelerate (dupBufferIO is buf) + +-- | Duplicate buffer (for debug) +dupBufferD :: ( FAICopy p2 p1, FAI p1, FAI p2 + , Storable b, Pf p2 a ~ b, Pf p1 a ~ b) + => Bool -- ^ Whether copy data + -> Buffer p2 a -- ^ buffer (src) + -> Accelerate p2 (Buffer p1 a) -- ^ buffer (dst) +dupBufferD is buf = Accelerate $ \cc -> replaceContext cc <$> dup undefined is buf
+ src/Foreign/FAI/Internal.hs view
@@ -0,0 +1,74 @@+{- + +Copyright (C) 2018 Johann Lee <mer@qinka.pro> + +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 <http://www.gnu.org/licenses/>. + +-} + +{-| +Module: Foreign.FAI.Internal +Description: The internal functions. +Copyright: (C) 2018 Johann Lee <me@qinka.pro> +License: LGPL3 +Maintainer: me@qinka.pro +Stability: experimental +Portability: unknown + +The internal functions. +-} + +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} + +module Foreign.FAI.Internal + ( autoNewForeignPtr + , dup + , replaceContext + ) where + +import Control.Monad +import Foreign.FAI.Types +import Foreign.ForeignPtr + +-- | allocate new foreign pointer +autoNewForeignPtr :: FinalizerContextPtr p (Pf p a) -- ^ Context p concerned finalizer + -> Context p -- ^ Context + -> Ptr (Pf p a) -- ^ pointer + -> Int -- ^ Size + -> IO (Buffer p a) -- ^ buffer +autoNewForeignPtr fin cc ptr size = fmap (`Buffer` size) $ case fin of + Left f -> newForeignPtrEnv f (unContextPtr cc) ptr + Right f -> newForeignPtr f ptr + +replaceContext :: Context p2 -> (a, Context p1) -> (a, Context p2) +replaceContext cc (a, _) = (a, cc) + +-- | Duplicate data +dup :: ( FAICopy p1 p2, FAI p1, FAI p2 + , Storable b, Pf p2 a ~ b, Pf p1 a ~ b) + => Context p2 -- ^ context + -> Bool -- ^ whether copy data + -> Buffer p1 a -- ^ buffer (src) + -> IO (Buffer p2 a, Context p2) -- ^ buffer (dst) +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)
src/Foreign/FAI/Platform/CUDA.hs view
@@ -39,7 +39,8 @@ module Foreign.FAI.Platform.CUDA ( CUDA(..) - , Pf(..) + , Pf + , nullCUDAContext ) where import Control.Monad @@ -53,6 +54,13 @@ C.include "<cuda_runtime.h>" C.include "<stdio.h>" +-- | CUDA backend (cudart required) +-- +-- @cudaMallc@ is used to allocate memory from data. +-- +-- @cudaFree@ is used to free pointer. +-- +-- @cudaMemcpy@ is used to copy data between Host and CUDA. data CUDA = CUDA type instance Pf CUDA Float = Float @@ -122,7 +130,6 @@ } return 0;}|] - instance FAI CUDA where faiMemAllocate _ = cudaMemAllocate . fromIntegral faiMemRelease _ = cudaMemRelease @@ -143,3 +150,6 @@ when (bufSize dst /= bufSize src) $ error "Different size." cudaMemCopy doCopyCC (bufPtr dst) (bufPtr src) $ fromIntegral $ bufSize dst +-- | Null pointer context of CUDA +nullCUDAContext :: Context CUDA +nullCUDAContext = Context nullPtr
src/Foreign/FAI/Platform/Host.hs view
@@ -39,24 +39,23 @@ module Foreign.FAI.Platform.Host ( Host(..) - , Pf(..) - , bufFromList - , bufToList + , Pf + , nullHostContext ) 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 +import qualified Language.C.Inline as C C.include "<string.h>" C.include "<stdlib.h>" +-- | Host backend (use C runtime) +-- +-- The @malloc@ and @free@ are used for memory management. data Host = Host type instance Pf Host Float = Float @@ -92,20 +91,6 @@ 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 +-- | Null pointer context of Host +nullHostContext :: Context Host +nullHostContext = Context nullPtr
+ src/Foreign/FAI/Platform/Host/Debug.hs view
@@ -0,0 +1,96 @@+{- + +Copyright (C) 2018 Johann Lee <mer@qinka.pro> + +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 <http://www.gnu.org/licenses/>. + +-} + +{-| +Module: Foreign.FAI.Platform.Host.Debug +Description: The debug component for Host. +Copyright: (C) 2018 Johann Lee <me@qinka.pro> +License: LGPL3 +Maintainer: me@qinka.pro +Stability: experimental +Portability: unknown + +The debug component for Host. +-} + +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} + +module Foreign.FAI.Platform.Host.Debug + ( peekHostBuffer + , pokeHostBuffer + , toHostBuffer + , unsafePeekHostBuffer + , unsafeToHostBuffer + ) where + +import Foreign.FAI +import Foreign.FAI.Platform.Host +import Foreign.FAI.Types +import Foreign.ForeignPtr +import Foreign.Marshal.Array +import System.IO.Unsafe + +-- | Copy the data from pointer to Haskell list. +peekHostBuffer :: (Storable b, Pf Host a ~ b) + => Buffer Host a -- ^ Buffer + -> IO [b] -- ^ Haskell list +peekHostBuffer bf = + withForeignPtr (bufPtr bf) $ \ptr -> + peekBuf undefined ptr + where peekBuf :: Storable a => a -> Ptr a -> IO [a] + peekBuf = peekArray . (bufSize bf `div`) . sizeOf + +-- | Copy the data from Haskell list into pointer. +pokeHostBuffer :: (Storable b, Pf Host a ~ b) + => Buffer Host a -- ^ Host buffer + -> [b] -- ^ list + -> IO () +pokeHostBuffer (Buffer fp s) ls = do + withForeignPtr fp $ \ptr -> + pokeArray ptr $ take len ls + return () + where lsLen = length ls + bfLen = s `div` sizeOf (head ls) + len = min bfLen lsLen + +-- | Transform list to host buffer. +toHostBuffer :: (Storable b, Pf Host a ~ b) + => [b] -- ^ List + -> IO (Buffer Host a) -- ^ Host buffer +toHostBuffer ls = do + bf <- fst <$> newBufferIO (length ls) cc + withForeignPtr (bufPtr bf) $ \ptr -> + pokeArray ptr ls + return bf + where cc :: Context Host + cc = Context undefined +-- | Unsafe peek +unsafePeekHostBuffer :: (Storable b,Pf Host a ~ b) + => Buffer Host a + -> [b] +unsafePeekHostBuffer = unsafePerformIO . peekHostBuffer + +-- | Unsafe poke +unsafeToHostBuffer :: (Storable b, Pf Host a ~ b) + => [b] + -> Buffer Host a +unsafeToHostBuffer = unsafePerformIO . toHostBuffer
src/Foreign/FAI/Types.hs view
@@ -36,59 +36,63 @@ {-# LANGUAGE TypeFamilies #-} module Foreign.FAI.Types - ( Pf(..) + ( Pf , Buffer(..) , Context(..) , Accelerate(..) , FAI(..) , FAICopy(..) - , newBuffer - , dupBuffer - , dupBufferD + , FinalizerContextPtr + , Storable(..) + , Ptr + , ForeignPtr , liftIO - , accelerate ) where -import Control.Monad import Control.Monad.IO.Class (MonadIO (..)) import Foreign.ForeignPtr import Foreign.Ptr import Foreign.Storable +-- | Platform types type family Pf p t :: * +-- | buffer hosted pointer and size data Buffer p a = Buffer - { bufPtr :: ForeignPtr (Pf p a) -- ^ pointer - , bufSize :: Int -- ^ number of size + { bufPtr :: {-# UNPACK #-} !(ForeignPtr (Pf p a)) -- ^ pointer + , bufSize :: {-# UNPACK #-} !Int -- ^ number of size } deriving (Show, Eq) +-- | Context of platform newtype Context p = Context { unContextPtr :: Ptr (Context p) } deriving (Show, Eq) +-- | Accelearate type. 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 +-- | Context concened finalizer +type FinalizerContextPtr p a = + Either (FinalizerEnvPtr (Context p) a) (FinalizerPtr a) +-- | FAI interface class FAI p where - faiMemAllocate :: Context p + faiMemAllocate :: Context p -- ^ Context -> Int -- ^ size -> IO (Ptr a) -- ^ Pointer - faiMemRelease :: Context p + faiMemRelease :: Context p -- ^ Context -> Ptr a -- ^ Pointer -> IO () - faiMemReleaseP :: Context p - -> IO (Either - (FinalizerEnvPtr (Context p) a) - (FinalizerPtr a)) + faiMemReleaseP :: Context p -- ^ Context + -> IO (FinalizerContextPtr p a) -- ^ pointer of the function -- of release the pointer +-- | Copy data from platform @p1@ to platform @p2@. 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 @@ -115,61 +119,3 @@ 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) -
test/Foreign/FAI/Platform/CUDASpec.hs view
@@ -5,14 +5,14 @@ ( spec ) where - import Test.Hspec #ifdef ENABLE_CUDA +import Foreign.FAI import Foreign.FAI.Platform.CUDA import Foreign.FAI.Platform.Host -import Foreign.FAI.Types +import Foreign.FAI.Platform.Host.Debug import Foreign.ForeignPtr import Foreign.Marshal.Array import Foreign.Ptr @@ -33,13 +33,13 @@ it "copy and same" $ do let acc = accelerate cc $ do let arr1 = [1..100] :: [Float] - b1 = bufFromList arr1 :: Buffer Host Float + b1 = unsafeToHostBuffer arr1 :: Buffer Host Float liftIO $ print b1 b2 <- dupBuffer True b1 :: Accelerate CUDA (Buffer CUDA Float) liftIO $ print b2 - b3 <- dupBufferD True b2 + b3 <- dupBufferD True b2 :: Accelerate CUDA (Buffer Host Float) liftIO $ print b3 - let arr2 = bufToList b3 + let arr2 = unsafePeekHostBuffer b3 return (arr1, arr2) (arr1, arr2) <- acc arr1 `shouldBe` arr2
test/Foreign/FAI/Platform/HostSpec.hs view
@@ -4,22 +4,15 @@ ( spec ) where - -import Foreign.FAI.Types -import Foreign.FAI.Platform.Host +import Foreign.FAI +import Foreign.FAI.Platform.Host +import Foreign.FAI.Platform.Host.Debug +import Foreign.Ptr +import Foreign.Storable 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 +peekBufferA = liftIO . peekHostBuffer spec :: Spec @@ -29,7 +22,7 @@ let acc = accelerate cc $ do b <- newBuffer 20 :: Accelerate Host (Buffer Host Float) liftIO $ print b - peekBufferA b >>= liftIO. print + peekBufferA b >>= liftIO . print return () acc `shouldReturn` () it "dupBuffer" $ do @@ -40,15 +33,26 @@ peekBufferA b2 >>= liftIO . print return () acc `shouldReturn` () + describe "Debug" $ do + it "peek and poke" $ do + ls <- accelerate cc $ do + bf <- newBuffer 10 :: Accelerate Host (Buffer Host Float) + liftIO (peekHostBuffer bf) >>= liftIO . print + liftIO $ pokeHostBuffer bf [0..9] + ls <- liftIO (peekHostBuffer bf) + liftIO $ print ls + return ls + ls `shouldBe` [0..9] 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 + b1 = unsafeToHostBuffer arr1 :: Buffer Host Float b2 <- dupBuffer True b1 :: Accelerate Host (Buffer Host Float) - let arr2 = bufToList b2 + let arr2 = unsafePeekHostBuffer b2 return (arr1, arr2) - (arr1, arr2) <- acc + (arr1, arr2) <- acc arr1 `shouldBe` arr2 - + +cc :: Context Host cc = Context nullPtr