diff --git a/Data/Array/Accelerate/LLVM/Native.hs b/Data/Array/Accelerate/LLVM/Native.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/LLVM/Native.hs @@ -0,0 +1,193 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} +-- | +-- Module : Data.Array.Accelerate.LLVM.Native +-- Copyright : [2014..2017] Trevor L. McDonell +-- [2014..2014] Vinod Grover (NVIDIA Corporation) +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- +-- This module implements a backend for the /Accelerate/ language targeting +-- multicore CPUs. Expressions are on-line translated into LLVM code, which is +-- just-in-time executed in parallel over the available CPUs. Functions are +-- automatically parallel, provided you specify '+RTS -Nwhatever' on the command +-- line when running the program. +-- + +module Data.Array.Accelerate.LLVM.Native ( + + Acc, Arrays, + + -- * Synchronous execution + run, runWith, + run1, run1With, + stream, streamWith, + + -- * Asynchronous execution + Async, + wait, poll, cancel, + + runAsync, runAsyncWith, + run1Async, run1AsyncWith, + + -- * Execution targets + Native, Strategy, + createTarget, balancedParIO, unbalancedParIO, + +) where + +-- accelerate +import Data.Array.Accelerate.Async +import Data.Array.Accelerate.Trafo +import Data.Array.Accelerate.Array.Sugar ( Arrays ) +import Data.Array.Accelerate.Smart ( Acc ) +import Data.Array.Accelerate.LLVM.Native.Debug as Debug + +import Data.Array.Accelerate.LLVM.Native.Compile ( compileAcc, compileAfun ) +import Data.Array.Accelerate.LLVM.Native.Execute ( executeAcc, executeAfun1 ) +import Data.Array.Accelerate.LLVM.Native.State +import Data.Array.Accelerate.LLVM.Native.Target + +-- standard library +import Control.Monad.Trans +import System.IO.Unsafe +import Text.Printf + + +-- Accelerate: LLVM backend for multicore CPUs +-- ------------------------------------------- + +-- | Compile and run a complete embedded array program. +-- +-- NOTE: it is recommended to use 'run1' whenever possible. +-- +run :: Arrays a => Acc a -> a +run = runWith defaultTarget + +-- | As 'run', but execute using the specified target (thread gang). +-- +runWith :: Arrays a => Native -> Acc a -> a +runWith target a = unsafePerformIO (run' target a) + +-- | As 'run', but allow the computation to run asynchronously and return +-- immediately without waiting for the result. The status of the computation can +-- be queried using 'wait', 'poll', and 'cancel'. +-- +runAsync :: Arrays a => Acc a -> IO (Async a) +runAsync = runAsyncWith defaultTarget + +-- | As 'runAsync', but execute using the specified target (thread gang). +-- +runAsyncWith :: Arrays a => Native -> Acc a -> IO (Async a) +runAsyncWith target a = async (run' target a) + +run' :: Arrays a => Native -> Acc a -> IO a +run' target a = execute + where + !acc = convertAccWith (config target) a + execute = do + dumpGraph acc + evalNative target $ do + exec <- phase "compile" elapsedS (compileAcc acc) >>= dumpStats + res <- phase "execute" elapsedP (executeAcc exec) + return res + + +-- | Prepare and execute an embedded array program of one argument. +-- +-- This function can be used to improve performance in cases where the array +-- program is constant between invocations, because it enables us to bypass +-- front-end conversion stages and move directly to the execution phase. If you +-- have a computation applied repeatedly to different input data, use this, +-- specifying any changing aspects of the computation via the input parameter. +-- If the function is only evaluated once, this is equivalent to 'run'. +-- +-- To use 'run1' effectively you must express your program as a function of one +-- argument. If your program takes more than one argument, you can use +-- 'Data.Array.Accelerate.lift' and 'Data.Array.Accelerate.unlift' to tuple up +-- the arguments. +-- +-- At an example, once your program is expressed as a function of one argument, +-- instead of the usual: +-- +-- > step :: Acc (Vector a) -> Acc (Vector b) +-- > step = ... +-- > +-- > simulate :: Vector a -> Vector b +-- > simulate xs = run $ step (use xs) +-- +-- Instead write: +-- +-- > simulate xs = run1 step xs +-- +-- You can use the debugging options to check whether this is working +-- successfully by, for example, observing no output from the @-ddump-cc@ flag +-- at the second and subsequent invocations. +-- +-- See the programs in the 'accelerate-examples' package for examples. +-- +run1 :: (Arrays a, Arrays b) => (Acc a -> Acc b) -> a -> b +run1 = run1With defaultTarget + +-- | As 'run1', but execute using the specified target (thread gang). +-- +run1With :: (Arrays a, Arrays b) => Native -> (Acc a -> Acc b) -> a -> b +run1With = run1' unsafePerformIO + +-- | As 'run1', but execute asynchronously. +-- +run1Async :: (Arrays a, Arrays b) => (Acc a -> Acc b) -> a -> IO (Async b) +run1Async = run1AsyncWith defaultTarget + +-- | As 'run1Async', but execute using the specified target (thread gang). +-- +run1AsyncWith :: (Arrays a, Arrays b) => Native -> (Acc a -> Acc b) -> a -> IO (Async b) +run1AsyncWith = run1' async + +run1' :: (Arrays a, Arrays b) => (IO b -> c) -> Native -> (Acc a -> Acc b) -> a -> c +run1' using target f = \a -> using (execute a) + where + !acc = convertAfunWith (config target) f + !afun = unsafePerformIO $ do + dumpGraph acc + phase "compile" elapsedS (evalNative target (compileAfun acc)) >>= dumpStats + execute a = phase "execute" elapsedP (evalNative target (executeAfun1 afun a)) + + +-- | Stream a lazily read list of input arrays through the given program, +-- collecting results as we go. +-- +stream :: (Arrays a, Arrays b) => (Acc a -> Acc b) -> [a] -> [b] +stream = streamWith defaultTarget + +-- | As 'stream', but execute using the specified target (thread gang). +-- +streamWith :: (Arrays a, Arrays b) => Native -> (Acc a -> Acc b) -> [a] -> [b] +streamWith target f arrs = map go arrs + where + !go = run1With target f + + +-- How the Accelerate program should be evaluated. +-- +-- TODO: make sharing/fusion runtime configurable via debug flags or otherwise. +-- +config :: Native -> Phase +config target = phases + { convertOffsetOfSegment = gangSize target > 1 + } + + +-- Debugging +-- ========= + +dumpStats :: MonadIO m => a -> m a +dumpStats x = dumpSimplStats >> return x + +phase :: MonadIO m => String -> (Double -> Double -> String) -> m a -> m a +phase n fmt go = timed dump_phases (\wall cpu -> printf "phase %s: %s" n (fmt wall cpu)) go + diff --git a/Data/Array/Accelerate/LLVM/Native/Array/Data.hs b/Data/Array/Accelerate/LLVM/Native/Array/Data.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/LLVM/Native/Array/Data.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- | +-- Module : Data.Array.Accelerate.LLVM.Native.Array.Data +-- Copyright : [2014..2017] Trevor L. McDonell +-- [2014..2014] Vinod Grover (NVIDIA Corporation) +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.LLVM.Native.Array.Data ( + + module Data.Array.Accelerate.LLVM.Array.Data, + + cloneArray, + +) where + +-- accelerate +import Data.Array.Accelerate.Array.Sugar + +import Data.Array.Accelerate.LLVM.State +import Data.Array.Accelerate.LLVM.Array.Data +import Data.Array.Accelerate.LLVM.Native.Target +import Data.Array.Accelerate.LLVM.Native.Execute.Async () + +-- standard library +import Control.Monad.Trans +import Data.Word +import Foreign.C +import Foreign.Ptr +import Foreign.Storable + + +-- | Data instance for arrays in the native backend. We assume a shared-memory +-- machine, and just manipulate the underlying Haskell array directly. +-- +instance Remote Native + + +-- | Copy an array into a newly allocated array. This uses 'memcpy'. +-- +cloneArray :: (Shape sh, Elt e) => Array sh e -> LLVM Native (Array sh e) +cloneArray arr@(Array _ src) = liftIO $ do + out@(Array _ dst) <- allocateArray sh + copyR arrayElt src dst + return out + where + sh = shape arr + n = size sh + + copyR :: ArrayEltR e -> ArrayData e -> ArrayData e -> IO () + copyR ArrayEltRunit _ _ = return () + copyR (ArrayEltRpair aeR1 aeR2) ad1 ad2 = copyR aeR1 (fstArrayData ad1) (fstArrayData ad2) >> + copyR aeR2 (sndArrayData ad1) (sndArrayData ad2) + -- + copyR ArrayEltRint ad1 ad2 = copyPrim ad1 ad2 + copyR ArrayEltRint8 ad1 ad2 = copyPrim ad1 ad2 + copyR ArrayEltRint16 ad1 ad2 = copyPrim ad1 ad2 + copyR ArrayEltRint32 ad1 ad2 = copyPrim ad1 ad2 + copyR ArrayEltRint64 ad1 ad2 = copyPrim ad1 ad2 + copyR ArrayEltRword ad1 ad2 = copyPrim ad1 ad2 + copyR ArrayEltRword8 ad1 ad2 = copyPrim ad1 ad2 + copyR ArrayEltRword16 ad1 ad2 = copyPrim ad1 ad2 + copyR ArrayEltRword32 ad1 ad2 = copyPrim ad1 ad2 + copyR ArrayEltRword64 ad1 ad2 = copyPrim ad1 ad2 + copyR ArrayEltRfloat ad1 ad2 = copyPrim ad1 ad2 + copyR ArrayEltRdouble ad1 ad2 = copyPrim ad1 ad2 + copyR ArrayEltRbool ad1 ad2 = copyPrim ad1 ad2 + copyR ArrayEltRchar ad1 ad2 = copyPrim ad1 ad2 + copyR ArrayEltRcshort ad1 ad2 = copyPrim ad1 ad2 + copyR ArrayEltRcushort ad1 ad2 = copyPrim ad1 ad2 + copyR ArrayEltRcint ad1 ad2 = copyPrim ad1 ad2 + copyR ArrayEltRcuint ad1 ad2 = copyPrim ad1 ad2 + copyR ArrayEltRclong ad1 ad2 = copyPrim ad1 ad2 + copyR ArrayEltRculong ad1 ad2 = copyPrim ad1 ad2 + copyR ArrayEltRcllong ad1 ad2 = copyPrim ad1 ad2 + copyR ArrayEltRcullong ad1 ad2 = copyPrim ad1 ad2 + copyR ArrayEltRcfloat ad1 ad2 = copyPrim ad1 ad2 + copyR ArrayEltRcdouble ad1 ad2 = copyPrim ad1 ad2 + copyR ArrayEltRcchar ad1 ad2 = copyPrim ad1 ad2 + copyR ArrayEltRcschar ad1 ad2 = copyPrim ad1 ad2 + copyR ArrayEltRcuchar ad1 ad2 = copyPrim ad1 ad2 + + copyPrim :: forall e a. (ArrayElt e, ArrayPtrs e ~ Ptr a, Storable a) => ArrayData e -> ArrayData e -> IO () + copyPrim a1 a2 = do + let p1 = ptrsOfArrayData a1 + p2 = ptrsOfArrayData a2 + memcpy (castPtr p2) (castPtr p1) (n * sizeOf (undefined :: a)) + + +-- Standard C functions +-- -------------------- + +memcpy :: Ptr Word8 -> Ptr Word8 -> Int -> IO () +memcpy p q s = c_memcpy p q (fromIntegral s) >> return () + +foreign import ccall unsafe "string.h memcpy" c_memcpy + :: Ptr Word8 -> Ptr Word8 -> CSize -> IO (Ptr Word8) + diff --git a/Data/Array/Accelerate/LLVM/Native/CodeGen.hs b/Data/Array/Accelerate/LLVM/Native/CodeGen.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/LLVM/Native/CodeGen.hs @@ -0,0 +1,46 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- | +-- Module : Data.Array.Accelerate.LLVM.Native.CodeGen +-- Copyright : [2014..2017] Trevor L. McDonell +-- [2014..2014] Vinod Grover (NVIDIA Corporation) +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.LLVM.Native.CodeGen ( + + KernelMetadata(..), + +) where + +-- accelerate +import Data.Array.Accelerate.LLVM.CodeGen + +import Data.Array.Accelerate.LLVM.Native.CodeGen.Base +import Data.Array.Accelerate.LLVM.Native.CodeGen.Fold +import Data.Array.Accelerate.LLVM.Native.CodeGen.FoldSeg +import Data.Array.Accelerate.LLVM.Native.CodeGen.Generate +import Data.Array.Accelerate.LLVM.Native.CodeGen.Map +import Data.Array.Accelerate.LLVM.Native.CodeGen.Permute +import Data.Array.Accelerate.LLVM.Native.CodeGen.Scan +import Data.Array.Accelerate.LLVM.Native.Target + + +instance Skeleton Native where + map _ = mkMap + generate _ = mkGenerate + fold _ = mkFold + fold1 _ = mkFold1 + foldSeg _ = mkFoldSeg + fold1Seg _ = mkFold1Seg + scanl _ = mkScanl + scanl1 _ = mkScanl1 + scanl' _ = mkScanl' + scanr _ = mkScanr + scanr1 _ = mkScanr1 + scanr' _ = mkScanr' + permute _ = mkPermute + diff --git a/Data/Array/Accelerate/LLVM/Native/CodeGen/Base.hs b/Data/Array/Accelerate/LLVM/Native/CodeGen/Base.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/LLVM/Native/CodeGen/Base.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +-- | +-- Module : Data.Array.Accelerate.LLVM.Native.CodeGen.Base +-- Copyright : [2015..2017] Trevor L. McDonell +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.LLVM.Native.CodeGen.Base + where + +import Data.Array.Accelerate.Type +import Data.Array.Accelerate.LLVM.CodeGen.Base +import Data.Array.Accelerate.LLVM.CodeGen.Downcast +import Data.Array.Accelerate.LLVM.CodeGen.IR +import Data.Array.Accelerate.LLVM.CodeGen.Module +import Data.Array.Accelerate.LLVM.CodeGen.Monad +import Data.Array.Accelerate.LLVM.CodeGen.Sugar +import Data.Array.Accelerate.LLVM.Native.Target ( Native ) + +import LLVM.AST.Type.Name +import qualified LLVM.AST.Global as LLVM +import qualified LLVM.AST.Type as LLVM + + +-- | Generate function parameters that will specify the first and last (linear) +-- index of the array this thread should evaluate. +-- +gangParam :: (IR Int, IR Int, [LLVM.Parameter]) +gangParam = + let t = scalarType + start = "ix.start" + end = "ix.end" + in + (local t start, local t end, [ scalarParameter t start, scalarParameter t end ] ) + + +-- | The thread ID of a gang worker +-- +gangId :: (IR Int, [LLVM.Parameter]) +gangId = + let t = scalarType + tid = "ix.tid" + in + (local t tid, [ scalarParameter t tid ] ) + + +-- Global function definitions +-- --------------------------- + +data instance KernelMetadata Native = KM_Native () + +-- | Combine kernels into a single program +-- +(+++) :: IROpenAcc Native aenv a -> IROpenAcc Native aenv a -> IROpenAcc Native aenv a +IROpenAcc k1 +++ IROpenAcc k2 = IROpenAcc (k1 ++ k2) + +-- | Create a single kernel program +-- +makeOpenAcc :: Label -> [LLVM.Parameter] -> CodeGen () -> CodeGen (IROpenAcc Native aenv a) +makeOpenAcc name param kernel = do + body <- makeKernel name param kernel + return $ IROpenAcc [body] + +-- | Create a complete kernel function by running the code generation process +-- specified in the final parameter. +-- +makeKernel :: Label -> [LLVM.Parameter] -> CodeGen () -> CodeGen (Kernel Native aenv a) +makeKernel name param kernel = do + _ <- kernel + code <- createBlocks + return $ Kernel + { kernelMetadata = KM_Native () + , unKernel = LLVM.functionDefaults + { LLVM.returnType = LLVM.VoidType + , LLVM.name = downcast name + , LLVM.parameters = (param, False) + , LLVM.basicBlocks = code + } + } + diff --git a/Data/Array/Accelerate/LLVM/Native/CodeGen/Fold.hs b/Data/Array/Accelerate/LLVM/Native/CodeGen/Fold.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/LLVM/Native/CodeGen/Fold.hs @@ -0,0 +1,292 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +-- | +-- Module : Data.Array.Accelerate.LLVM.Native.CodeGen.Fold +-- Copyright : [2014..2017] Trevor L. McDonell +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.LLVM.Native.CodeGen.Fold + where + +-- accelerate +import Data.Array.Accelerate.Analysis.Match +import Data.Array.Accelerate.Array.Sugar +import Data.Array.Accelerate.Type + +import Data.Array.Accelerate.LLVM.Analysis.Match +import Data.Array.Accelerate.LLVM.CodeGen.Arithmetic as A +import Data.Array.Accelerate.LLVM.CodeGen.Array +import Data.Array.Accelerate.LLVM.CodeGen.Base +import Data.Array.Accelerate.LLVM.CodeGen.Constant +import Data.Array.Accelerate.LLVM.CodeGen.Environment +import Data.Array.Accelerate.LLVM.CodeGen.IR +import Data.Array.Accelerate.LLVM.CodeGen.Monad +import Data.Array.Accelerate.LLVM.CodeGen.Sugar + +import Data.Array.Accelerate.LLVM.Native.CodeGen.Base +import Data.Array.Accelerate.LLVM.Native.CodeGen.Generate +import Data.Array.Accelerate.LLVM.Native.CodeGen.Loop +import Data.Array.Accelerate.LLVM.Native.Target ( Native ) + +import Control.Applicative +import Prelude as P hiding ( length ) + + +-- Reduce a (possibly empty) array along the innermost dimension. The reduction +-- function must be associative to allow for an efficient parallel +-- implementation. The initial element does not need to be a neutral element of +-- the operator. +-- +mkFold + :: forall aenv sh e. (Shape sh, Elt e) + => Gamma aenv + -> IRFun2 Native aenv (e -> e -> e) + -> IRExp Native aenv e + -> IRDelayed Native aenv (Array (sh :. Int) e) + -> CodeGen (IROpenAcc Native aenv (Array sh e)) +mkFold aenv f z acc + | Just Refl <- matchShapeType (undefined::sh) (undefined::Z) + = (+++) <$> mkFoldAll aenv f (Just z) acc + <*> mkFoldFill aenv z + + | otherwise + = (+++) <$> mkFoldDim aenv f (Just z) acc + <*> mkFoldFill aenv z + + +-- Reduce a non-empty array along the innermost dimension. The reduction +-- function must be associative to allow for efficient parallel implementation. +-- +mkFold1 + :: forall aenv sh e. (Shape sh, Elt e) + => Gamma aenv + -> IRFun2 Native aenv (e -> e -> e) + -> IRDelayed Native aenv (Array (sh :. Int) e) + -> CodeGen (IROpenAcc Native aenv (Array sh e)) +mkFold1 aenv f acc + | Just Refl <- matchShapeType (undefined::sh) (undefined::Z) + = mkFoldAll aenv f Nothing acc + + | otherwise + = mkFoldDim aenv f Nothing acc + + +-- Reduce a multidimensional (>1) array along the innermost dimension. +-- +-- For simplicity, each element of the output (reduction along the entire length +-- of an innermost-dimension index) is computed by a single thread. +-- +mkFoldDim + :: forall aenv sh e. (Shape sh, Elt e) + => Gamma aenv + -> IRFun2 Native aenv (e -> e -> e) + -> Maybe (IRExp Native aenv e) + -> IRDelayed Native aenv (Array (sh :. Int) e) + -> CodeGen (IROpenAcc Native aenv (Array sh e)) +mkFoldDim aenv combine mseed IRDelayed{..} = + let + (start, end, paramGang) = gangParam + (arrOut, paramOut) = mutableArray ("out" :: Name (Array sh e)) + paramEnv = envParam aenv + -- + paramStride = scalarParameter scalarType ("ix.stride" :: Name Int) + stride = local scalarType ("ix.stride" :: Name Int) + in + makeOpenAcc "fold" (paramGang ++ paramStride : paramOut ++ paramEnv) $ do + + imapFromTo start end $ \seg -> do + from <- mul numType seg stride + to <- add numType from stride + -- + r <- case mseed of + Just seed -> do z <- seed + reduceFromTo from to (app2 combine) z (app1 delayedLinearIndex) + Nothing -> reduce1FromTo from to (app2 combine) (app1 delayedLinearIndex) + writeArray arrOut seg r + return_ + + +-- Reduce an array to single element. +-- +-- Since reductions consume arrays that have been fused into them, +-- a parallel fold requires two passes. At an example, take vector dot +-- product: +-- +-- > dotp xs ys = fold (+) 0 (zipWith (*) xs ys) +-- +-- 1. The first pass reads in the fused array data, in this case corresponding +-- to the function (\i -> (xs!i) * (ys!i)). +-- +-- 2. The second pass reads in the manifest array data from the first step and +-- directly reduces the array. This second step should be small and so is +-- usually just done by a single core. +-- +-- Note that the first step is split into two kernels, the second of which +-- reads a carry-in value of that thread's partial reduction, so that +-- threads can still participate in work-stealing. These kernels must not +-- be invoked over empty ranges. +-- +-- The final step is sequential reduction of the partial results. If this +-- is an exclusive reduction, the seed element is included at this point. +-- +mkFoldAll + :: forall aenv e. Elt e + => Gamma aenv -- ^ array environment + -> IRFun2 Native aenv (e -> e -> e) -- ^ combination function + -> Maybe (IRExp Native aenv e) -- ^ seed element, if this is an exclusive reduction + -> IRDelayed Native aenv (Vector e) -- ^ input data + -> CodeGen (IROpenAcc Native aenv (Scalar e)) +mkFoldAll aenv combine mseed arr = + foldr1 (+++) <$> sequence [ mkFoldAllS aenv combine mseed arr + , mkFoldAllP1 aenv combine arr + , mkFoldAllP2 aenv combine mseed + ] + + +-- Sequential reduction of an entire array to a single element +-- +mkFoldAllS + :: forall aenv e. Elt e + => Gamma aenv -- ^ array environment + -> IRFun2 Native aenv (e -> e -> e) -- ^ combination function + -> Maybe (IRExp Native aenv e) -- ^ seed element, if this is an exclusive reduction + -> IRDelayed Native aenv (Vector e) -- ^ input data + -> CodeGen (IROpenAcc Native aenv (Scalar e)) +mkFoldAllS aenv combine mseed IRDelayed{..} = + let + (start, end, paramGang) = gangParam + paramEnv = envParam aenv + (arrOut, paramOut) = mutableArray ("out" :: Name (Scalar e)) + zero = lift 0 :: IR Int + in + makeOpenAcc "foldAllS" (paramGang ++ paramOut ++ paramEnv) $ do + r <- case mseed of + Just seed -> do z <- seed + reduceFromTo start end (app2 combine) z (app1 delayedLinearIndex) + Nothing -> reduce1FromTo start end (app2 combine) (app1 delayedLinearIndex) + writeArray arrOut zero r + return_ + +-- Parallel reduction of an entire array to a single element, step 1. +-- +-- Threads reduce each stripe of the input into a temporary array, incorporating +-- any fused functions on the way. +-- +mkFoldAllP1 + :: forall aenv e. Elt e + => Gamma aenv -- ^ array environment + -> IRFun2 Native aenv (e -> e -> e) -- ^ combination function + -> IRDelayed Native aenv (Vector e) -- ^ input data + -> CodeGen (IROpenAcc Native aenv (Scalar e)) +mkFoldAllP1 aenv combine IRDelayed{..} = + let + (start, end, paramGang) = gangParam + paramEnv = envParam aenv + (arrTmp, paramTmp) = mutableArray ("tmp" :: Name (Vector e)) + length = local scalarType ("ix.length" :: Name Int) + stride = local scalarType ("ix.stride" :: Name Int) + paramLength = scalarParameter scalarType ("ix.length" :: Name Int) + paramStride = scalarParameter scalarType ("ix.stride" :: Name Int) + in + makeOpenAcc "foldAllP1" (paramGang ++ paramLength : paramStride : paramTmp ++ paramEnv) $ do + + -- A thread reduces a sequential (non-empty) stripe of the input and stores + -- that value into a temporary array at a specific index. The size of the + -- stripe is fixed, but work stealing occurs between stripe indices. This + -- method thus supports non-commutative operators because the order of + -- operations remains left-to-right. + -- + imapFromTo start end $ \i -> do + inf <- A.mul numType i stride + a <- A.add numType inf stride + sup <- A.min scalarType a length + r <- reduce1FromTo inf sup (app2 combine) (app1 delayedLinearIndex) + writeArray arrTmp i r + + return_ + +-- Parallel reduction of an entire array to a single element, step 2. +-- +-- A single thread reduces the temporary array to a single element. +-- +-- During execution, we choose a stripe size in phase 1 so that the temporary is +-- small-ish and thus suitable for sequential reduction. An alternative would be +-- to keep the stripe size constant and, for if the partial reductions array is +-- large, continuing reducing it in parallel. +-- +mkFoldAllP2 + :: forall aenv e. Elt e + => Gamma aenv -- ^ array environment + -> IRFun2 Native aenv (e -> e -> e) -- ^ combination function + -> Maybe (IRExp Native aenv e) -- ^ seed element, if this is an exclusive reduction + -> CodeGen (IROpenAcc Native aenv (Scalar e)) +mkFoldAllP2 aenv combine mseed = + let + (start, end, paramGang) = gangParam + paramEnv = envParam aenv + (arrTmp, paramTmp) = mutableArray ("tmp" :: Name (Vector e)) + (arrOut, paramOut) = mutableArray ("out" :: Name (Scalar e)) + zero = lift 0 :: IR Int + in + makeOpenAcc "foldAllP2" (paramGang ++ paramTmp ++ paramOut ++ paramEnv) $ do + r <- case mseed of + Just seed -> do z <- seed + reduceFromTo start end (app2 combine) z (readArray arrTmp) + Nothing -> reduce1FromTo start end (app2 combine) (readArray arrTmp) + writeArray arrOut zero r + return_ + + +-- Exclusive reductions over empty arrays (of any dimension) fill the lower +-- dimensions with the initial element +-- +mkFoldFill + :: (Shape sh, Elt e) + => Gamma aenv + -> IRExp Native aenv e + -> CodeGen (IROpenAcc Native aenv (Array sh e)) +mkFoldFill aenv seed = + mkGenerate aenv (IRFun1 (const seed)) + +-- Reduction loops +-- --------------- + +-- Reduction of a (possibly empty) index space. +-- +reduceFromTo + :: Elt a + => IR Int -- ^ starting index + -> IR Int -- ^ final index (exclusive) + -> (IR a -> IR a -> CodeGen (IR a)) -- ^ combination function + -> IR a -- ^ initial value + -> (IR Int -> CodeGen (IR a)) -- ^ function to retrieve element at index + -> CodeGen (IR a) +reduceFromTo m n f z get = + iterFromTo m n z $ \i acc -> do + x <- get i + y <- f acc x + return y + +-- Reduction of an array over a _non-empty_ index space. The array must +-- contain at least one element. +-- +reduce1FromTo + :: Elt a + => IR Int -- ^ starting index + -> IR Int -- ^ final index + -> (IR a -> IR a -> CodeGen (IR a)) -- ^ combination function + -> (IR Int -> CodeGen (IR a)) -- ^ function to retrieve element at index + -> CodeGen (IR a) +reduce1FromTo m n f get = do + z <- get m + m1 <- add numType m (ir numType (num numType 1)) + reduceFromTo m1 n f z get + diff --git a/Data/Array/Accelerate/LLVM/Native/CodeGen/FoldSeg.hs b/Data/Array/Accelerate/LLVM/Native/CodeGen/FoldSeg.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/LLVM/Native/CodeGen/FoldSeg.hs @@ -0,0 +1,177 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} +-- | +-- Module : Data.Array.Accelerate.LLVM.Native.CodeGen.FoldSeg +-- Copyright : [2014..2017] Trevor L. McDonell +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.LLVM.Native.CodeGen.FoldSeg + where + +-- accelerate +import Data.Array.Accelerate.Array.Sugar +import Data.Array.Accelerate.Type + +import Data.Array.Accelerate.LLVM.CodeGen.Arithmetic as A +import Data.Array.Accelerate.LLVM.CodeGen.Array +import Data.Array.Accelerate.LLVM.CodeGen.Base +import Data.Array.Accelerate.LLVM.CodeGen.Environment +import Data.Array.Accelerate.LLVM.CodeGen.IR +import Data.Array.Accelerate.LLVM.CodeGen.Exp ( indexHead ) +import Data.Array.Accelerate.LLVM.CodeGen.Loop +import Data.Array.Accelerate.LLVM.CodeGen.Monad +import Data.Array.Accelerate.LLVM.CodeGen.Sugar + +import Data.Array.Accelerate.LLVM.Native.CodeGen.Base +import Data.Array.Accelerate.LLVM.Native.CodeGen.Fold +import Data.Array.Accelerate.LLVM.Native.CodeGen.Loop +import Data.Array.Accelerate.LLVM.Native.Target ( Native ) + +import Control.Applicative +import Control.Monad +import Prelude as P + + +-- Segmented reduction along the innermost dimension of an array. Performs one +-- reduction per segment of the source array. +-- +mkFoldSeg + :: forall aenv sh i e. (Shape sh, IsIntegral i, Elt i, Elt e) + => Gamma aenv + -> IRFun2 Native aenv (e -> e -> e) + -> IRExp Native aenv e + -> IRDelayed Native aenv (Array (sh :. Int) e) + -> IRDelayed Native aenv (Segments i) + -> CodeGen (IROpenAcc Native aenv (Array (sh :. Int) e)) +mkFoldSeg aenv combine seed arr seg = + (+++) <$> mkFoldSegS aenv combine (Just seed) arr seg + <*> mkFoldSegP aenv combine (Just seed) arr seg + + +-- Segmented reduction along the innermost dimension of an array, where /all/ +-- segments are non-empty. +-- +mkFold1Seg + :: forall aenv sh i e. (Shape sh, IsIntegral i, Elt i, Elt e) + => Gamma aenv + -> IRFun2 Native aenv (e -> e -> e) + -> IRDelayed Native aenv (Array (sh :. Int) e) + -> IRDelayed Native aenv (Segments i) + -> CodeGen (IROpenAcc Native aenv (Array (sh :. Int) e)) +mkFold1Seg aenv combine arr seg = + (+++) <$> mkFoldSegS aenv combine Nothing arr seg + <*> mkFoldSegP aenv combine Nothing arr seg + + +-- Segmented reduction where a single processor reduces the entire array. The +-- segments array contains the length of each segment. +-- +mkFoldSegS + :: forall aenv sh i e. (Shape sh, IsIntegral i, Elt i, Elt e) + => Gamma aenv + -> IRFun2 Native aenv (e -> e -> e) + -> Maybe (IRExp Native aenv e) + -> IRDelayed Native aenv (Array (sh :. Int) e) + -> IRDelayed Native aenv (Segments i) + -> CodeGen (IROpenAcc Native aenv (Array (sh :. Int) e)) +mkFoldSegS aenv combine mseed arr seg = + let + (start, end, paramGang) = gangParam + (arrOut, paramOut) = mutableArray ("out" :: Name (Array (sh :. Int) e)) + paramEnv = envParam aenv + in + makeOpenAcc "foldSegS" (paramGang ++ paramOut ++ paramEnv) $ do + + -- Number of segments, useful only if reducing DIM2 and higher + ss <- indexHead <$> delayedExtent seg + + let test si = A.lt scalarType (A.fst si) end + initial = A.pair start (lift 0) + + body :: IR (Int,Int) -> CodeGen (IR (Int,Int)) + body (A.unpair -> (s,inf)) = do + -- We can avoid an extra division if this is a DIM1 array. Higher + -- dimensional reductions need to wrap around the segment array at + -- each new lower-dimensional index. + s' <- case rank (undefined::sh) of + 0 -> return s + _ -> A.rem integralType s ss + + len <- A.fromIntegral integralType numType =<< app1 (delayedLinearIndex seg) s' + sup <- A.add numType inf len + + r <- case mseed of + Just seed -> do z <- seed + reduceFromTo inf sup (app2 combine) z (app1 (delayedLinearIndex arr)) + Nothing -> reduce1FromTo inf sup (app2 combine) (app1 (delayedLinearIndex arr)) + writeArray arrOut s r + + t <- A.add numType s (lift 1) + return $ A.pair t sup + + void $ while test body initial + return_ + + +-- This implementation assumes that the segments array represents the offset +-- indices to the source array, rather than the lengths of each segment. The +-- segment-offset approach is required for parallel implementations. +-- +mkFoldSegP + :: forall aenv sh i e. (Shape sh, IsIntegral i, Elt i, Elt e) + => Gamma aenv + -> IRFun2 Native aenv (e -> e -> e) + -> Maybe (IRExp Native aenv e) + -> IRDelayed Native aenv (Array (sh :. Int) e) + -> IRDelayed Native aenv (Segments i) + -> CodeGen (IROpenAcc Native aenv (Array (sh :. Int) e)) +mkFoldSegP aenv combine mseed arr seg = + let + (start, end, paramGang) = gangParam + (arrOut, paramOut) = mutableArray ("out" :: Name (Array (sh :. Int) e)) + paramEnv = envParam aenv + in + makeOpenAcc "foldSegP" (paramGang ++ paramOut ++ paramEnv) $ do + + -- Number of segments and size of the innermost dimension. These are + -- required if we are reducing a DIM2 or higher array, to properly compute + -- the start and end indices of the portion of the array to reduce. Note + -- that this is a segment-offset array computed by 'scanl (+) 0' of the + -- segment length array, so its size has increased by one. + sz <- indexHead <$> delayedExtent arr + ss <- do n <- indexHead <$> delayedExtent seg + A.sub numType n (lift 1) + + imapFromTo start end $ \s -> do + + i <- case rank (undefined::sh) of + 0 -> return s + _ -> A.rem integralType s ss + j <- A.add numType i (lift 1) + u <- A.fromIntegral integralType numType =<< app1 (delayedLinearIndex seg) i + v <- A.fromIntegral integralType numType =<< app1 (delayedLinearIndex seg) j + + (inf,sup) <- A.unpair <$> case rank (undefined::sh) of + 0 -> return (A.pair u v) + _ -> do q <- A.quot integralType s ss + a <- A.mul numType q sz + A.pair <$> A.add numType u a <*> A.add numType v a + + r <- case mseed of + Just seed -> do z <- seed + reduceFromTo inf sup (app2 combine) z (app1 (delayedLinearIndex arr)) + Nothing -> reduce1FromTo inf sup (app2 combine) (app1 (delayedLinearIndex arr)) + + writeArray arrOut s r + + return_ + diff --git a/Data/Array/Accelerate/LLVM/Native/CodeGen/Generate.hs b/Data/Array/Accelerate/LLVM/Native/CodeGen/Generate.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/LLVM/Native/CodeGen/Generate.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- | +-- Module : Data.Array.Accelerate.LLVM.Native.CodeGen.Generate +-- Copyright : [2014..2017] Trevor L. McDonell +-- [2014..2014] Vinod Grover (NVIDIA Corporation) +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.LLVM.Native.CodeGen.Generate + where + +-- accelerate +import Data.Array.Accelerate.Array.Sugar ( Array, Shape, Elt ) + +import Data.Array.Accelerate.LLVM.CodeGen.Array +import Data.Array.Accelerate.LLVM.CodeGen.Base +import Data.Array.Accelerate.LLVM.CodeGen.Environment +import Data.Array.Accelerate.LLVM.CodeGen.Exp +import Data.Array.Accelerate.LLVM.CodeGen.Monad +import Data.Array.Accelerate.LLVM.CodeGen.Sugar + +import Data.Array.Accelerate.LLVM.Native.Target ( Native ) +import Data.Array.Accelerate.LLVM.Native.CodeGen.Base +import Data.Array.Accelerate.LLVM.Native.CodeGen.Loop + + +-- Construct a new array by applying a function to each index. Each thread +-- processes multiple adjacent elements. +-- +mkGenerate + :: forall aenv sh e. (Shape sh, Elt e) + => Gamma aenv + -> IRFun1 Native aenv (sh -> e) + -> CodeGen (IROpenAcc Native aenv (Array sh e)) +mkGenerate aenv apply = + let + (start, end, paramGang) = gangParam + (arrOut, paramOut) = mutableArray ("out" :: Name (Array sh e)) + paramEnv = envParam aenv + in + makeOpenAcc "generate" (paramGang ++ paramOut ++ paramEnv) $ do + + imapFromTo start end $ \i -> do + ix <- indexOfInt (irArrayShape arrOut) i -- convert to multidimensional index + r <- app1 apply ix -- apply generator function + writeArray arrOut i r -- store result + + return_ + diff --git a/Data/Array/Accelerate/LLVM/Native/CodeGen/Loop.hs b/Data/Array/Accelerate/LLVM/Native/CodeGen/Loop.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/LLVM/Native/CodeGen/Loop.hs @@ -0,0 +1,46 @@ +-- | +-- Module : Data.Array.Accelerate.LLVM.CodeGen.Native.Loop +-- Copyright : [2014..2017] Trevor L. McDonell +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.LLVM.Native.CodeGen.Loop + where + +-- accelerate +import Data.Array.Accelerate.Array.Sugar + +import Data.Array.Accelerate.LLVM.CodeGen.Arithmetic +import Data.Array.Accelerate.LLVM.CodeGen.IR +import Data.Array.Accelerate.LLVM.CodeGen.Monad +import qualified Data.Array.Accelerate.LLVM.CodeGen.Loop as Loop + + +-- | A standard 'for' loop, that steps from the start to end index executing the +-- given function at each index. +-- +imapFromTo + :: IR Int -- ^ starting index (inclusive) + -> IR Int -- ^ final index (exclusive) + -> (IR Int -> CodeGen ()) -- ^ apply at each index + -> CodeGen () +imapFromTo start end body = + Loop.imapFromStepTo start (lift 1) end body + +-- | Iterate with an accumulator between the start and end index, executing the +-- given function at each. +-- +iterFromTo + :: Elt a + => IR Int -- ^ starting index (inclusive) + -> IR Int -- ^ final index (exclusive) + -> IR a -- ^ initial value + -> (IR Int -> IR a -> CodeGen (IR a)) -- ^ apply at each index + -> CodeGen (IR a) +iterFromTo start end seed body = + Loop.iterFromStepTo start (lift 1) end seed body + diff --git a/Data/Array/Accelerate/LLVM/Native/CodeGen/Map.hs b/Data/Array/Accelerate/LLVM/Native/CodeGen/Map.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/LLVM/Native/CodeGen/Map.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- | +-- Module : Data.Array.Accelerate.LLVM.Native.CodeGen.Map +-- Copyright : [2014..2017] Trevor L. McDonell +-- [2014..2014] Vinod Grover (NVIDIA Corporation) +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.LLVM.Native.CodeGen.Map + where + +-- accelerate +import Data.Array.Accelerate.Array.Sugar ( Array, Elt ) + +import Data.Array.Accelerate.LLVM.CodeGen.Array +import Data.Array.Accelerate.LLVM.CodeGen.Base +import Data.Array.Accelerate.LLVM.CodeGen.Environment +import Data.Array.Accelerate.LLVM.CodeGen.Monad +import Data.Array.Accelerate.LLVM.CodeGen.Sugar + +import Data.Array.Accelerate.LLVM.Native.Target ( Native ) +import Data.Array.Accelerate.LLVM.Native.CodeGen.Base +import Data.Array.Accelerate.LLVM.Native.CodeGen.Loop + + +-- C Code +-- ====== +-- +-- float f(float); +-- +-- void map(float* __restrict__ out, const float* __restrict__ in, const int n) +-- { +-- for (int i = 0; i < n; ++i) +-- out[i] = f(in[i]); +-- +-- return; +-- } + +-- Corresponding LLVM +-- ================== +-- +-- define void @map(float* noalias nocapture %out, float* noalias nocapture %in, i32 %n) nounwind uwtable ssp { +-- %1 = icmp sgt i32 %n, 0 +-- br i1 %1, label %.lr.ph, label %._crit_edge +-- +-- .lr.ph: ; preds = %0, %.lr.ph +-- %indvars.iv = phi i64 [ %indvars.iv.next, %.lr.ph ], [ 0, %0 ] +-- %2 = getelementptr inbounds float* %in, i64 %indvars.iv +-- %3 = load float* %2, align 4 +-- %4 = tail call float @apply(float %3) nounwind +-- %5 = getelementptr inbounds float* %out, i64 %indvars.iv +-- store float %4, float* %5, align 4 +-- %indvars.iv.next = add i64 %indvars.iv, 1 +-- %lftr.wideiv = trunc i64 %indvars.iv.next to i32 +-- %exitcond = icmp eq i32 %lftr.wideiv, %n +-- br i1 %exitcond, label %._crit_edge, label %.lr.ph +-- +-- ._crit_edge: ; preds = %.lr.ph, %0 +-- ret void +-- } +-- +-- declare float @apply(float) +-- + + +-- Apply the given unary function to each element of an array. +-- +mkMap :: forall aenv sh a b. Elt b + => Gamma aenv + -> IRFun1 Native aenv (a -> b) + -> IRDelayed Native aenv (Array sh a) + -> CodeGen (IROpenAcc Native aenv (Array sh b)) +mkMap aenv apply IRDelayed{..} = + let + (start, end, paramGang) = gangParam + (arrOut, paramOut) = mutableArray ("out" :: Name (Array sh b)) + paramEnv = envParam aenv + in + makeOpenAcc "map" (paramGang ++ paramOut ++ paramEnv) $ do + + imapFromTo start end $ \i -> do + xs <- app1 delayedLinearIndex i + ys <- app1 apply xs + writeArray arrOut i ys + + return_ + diff --git a/Data/Array/Accelerate/LLVM/Native/CodeGen/Permute.hs b/Data/Array/Accelerate/LLVM/Native/CodeGen/Permute.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/LLVM/Native/CodeGen/Permute.hs @@ -0,0 +1,298 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +-- | +-- Module : Data.Array.Accelerate.LLVM.Native.CodeGen.Permute +-- Copyright : [2016..2017] Trevor L. McDonell +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.LLVM.Native.CodeGen.Permute + where + +-- accelerate +import Data.Array.Accelerate.Array.Sugar ( Array, Vector, Shape, Elt, eltType ) +import Data.Array.Accelerate.Error +import qualified Data.Array.Accelerate.Array.Sugar as S + +import Data.Array.Accelerate.LLVM.CodeGen.Arithmetic as A +import Data.Array.Accelerate.LLVM.CodeGen.Array +import Data.Array.Accelerate.LLVM.CodeGen.Base +import Data.Array.Accelerate.LLVM.CodeGen.Constant +import Data.Array.Accelerate.LLVM.CodeGen.Environment +import Data.Array.Accelerate.LLVM.CodeGen.Exp +import Data.Array.Accelerate.LLVM.CodeGen.IR +import Data.Array.Accelerate.LLVM.CodeGen.Monad +import Data.Array.Accelerate.LLVM.CodeGen.Permute +import Data.Array.Accelerate.LLVM.CodeGen.Ptr +import Data.Array.Accelerate.LLVM.CodeGen.Sugar + +import Data.Array.Accelerate.LLVM.Native.Target ( Native ) +import Data.Array.Accelerate.LLVM.Native.CodeGen.Base +import Data.Array.Accelerate.LLVM.Native.CodeGen.Loop + +import LLVM.AST.Type.AddrSpace +import LLVM.AST.Type.Instruction +import LLVM.AST.Type.Instruction.Atomic +import LLVM.AST.Type.Instruction.RMW as RMW +import LLVM.AST.Type.Instruction.Volatile +import LLVM.AST.Type.Representation + +import Control.Applicative +import Control.Monad ( void ) +import Data.Typeable +import Prelude + + +-- Forward permutation specified by an indexing mapping. The resulting array is +-- initialised with the given defaults, and any further values that are permuted +-- into the result array are added to the current value using the combination +-- function. +-- +-- The combination function must be /associative/ and /commutative/. Elements +-- that are mapped to the magic index 'ignore' are dropped. +-- +mkPermute + :: (Shape sh, Shape sh', Elt e) + => Gamma aenv + -> IRPermuteFun Native aenv (e -> e -> e) + -> IRFun1 Native aenv (sh -> sh') + -> IRDelayed Native aenv (Array sh e) + -> CodeGen (IROpenAcc Native aenv (Array sh' e)) +mkPermute aenv combine project arr = + (+++) <$> mkPermuteS aenv combine project arr + <*> mkPermuteP aenv combine project arr + + +-- Forward permutation which does not require locking the output array. This +-- could be because we are executing sequentially with a single thread, or +-- because the default values are unused (e.g. for a filter). +-- +-- We could also use this method if we can prove that the mapping function is +-- injective (distinct elements in the domain map to distinct elements in the +-- co-domain). +-- +mkPermuteS + :: forall aenv sh sh' e. (Shape sh, Shape sh', Elt e) + => Gamma aenv + -> IRPermuteFun Native aenv (e -> e -> e) + -> IRFun1 Native aenv (sh -> sh') + -> IRDelayed Native aenv (Array sh e) + -> CodeGen (IROpenAcc Native aenv (Array sh' e)) +mkPermuteS aenv IRPermuteFun{..} project IRDelayed{..} = + let + (start, end, paramGang) = gangParam + (arrOut, paramOut) = mutableArray ("out" :: Name (Array sh' e)) + paramEnv = envParam aenv + in + makeOpenAcc "permuteS" (paramGang ++ paramOut ++ paramEnv) $ do + + sh <- delayedExtent + + imapFromTo start end $ \i -> do + + ix <- indexOfInt sh i + ix' <- app1 project ix + + unless (ignore ix') $ do + j <- intOfIndex (irArrayShape arrOut) ix' + + -- project element onto the destination array and update + x <- app1 delayedLinearIndex i + y <- readArray arrOut j + r <- app2 combine x y + + writeArray arrOut j r + + return_ + + +-- Parallel forward permutation has to take special care because different +-- threads could concurrently try to update the same memory location. Where +-- available we make use of special atomic instructions and other optimisations, +-- but in the general case each element of the output array has a lock which +-- must be obtained by the thread before it can update that memory location. +-- +-- TODO: After too many failures to acquire the lock on an element, the thread +-- should back off and try a different element, adding this failed element to +-- a queue or some such. +-- +mkPermuteP + :: forall aenv sh sh' e. (Shape sh, Shape sh', Elt e) + => Gamma aenv + -> IRPermuteFun Native aenv (e -> e -> e) + -> IRFun1 Native aenv (sh -> sh') + -> IRDelayed Native aenv (Array sh e) + -> CodeGen (IROpenAcc Native aenv (Array sh' e)) +mkPermuteP aenv IRPermuteFun{..} project arr = + case atomicRMW of + Nothing -> mkPermuteP_mutex aenv combine project arr + Just (rmw, f) -> mkPermuteP_rmw aenv rmw f project arr + + +-- Parallel forward permutation function which uses atomic instructions to +-- implement lock-free array updates. +-- +mkPermuteP_rmw + :: forall aenv sh sh' e. (Shape sh, Shape sh', Elt e) + => Gamma aenv + -> RMWOperation + -> IRFun1 Native aenv (e -> e) + -> IRFun1 Native aenv (sh -> sh') + -> IRDelayed Native aenv (Array sh e) + -> CodeGen (IROpenAcc Native aenv (Array sh' e)) +mkPermuteP_rmw aenv rmw update project IRDelayed{..} = + let + (start, end, paramGang) = gangParam + (arrOut, paramOut) = mutableArray ("out" :: Name (Array sh' e)) + paramEnv = envParam aenv + in + makeOpenAcc "permuteP_rmw" (paramGang ++ paramOut ++ paramEnv) $ do + + sh <- delayedExtent + + imapFromTo start end $ \i -> do + + ix <- indexOfInt sh i + ix' <- app1 project ix + + unless (ignore ix') $ do + j <- intOfIndex (irArrayShape arrOut) ix' + x <- app1 delayedLinearIndex i + r <- app1 update x + + case rmw of + Exchange + -> writeArray arrOut j r + -- + _ | SingleTuple s <- eltType (undefined::e) + , Just adata <- gcast (irArrayData arrOut) + , Just r' <- gcast r + -> do + addr <- instr' $ GetElementPtr (asPtr defaultAddrSpace (op s adata)) [op integralType j] + -- + case s of + NumScalarType (IntegralNumType t) -> void . instr' $ AtomicRMW t NonVolatile rmw addr (op t r') (CrossThread, AcquireRelease) + NumScalarType t | RMW.Add <- rmw -> atomicCAS_rmw s (A.add t r') addr + NumScalarType t | RMW.Sub <- rmw -> atomicCAS_rmw s (A.sub t r') addr + _ -> case rmw of + RMW.Min -> atomicCAS_cmp s A.lt addr (op s r') + RMW.Max -> atomicCAS_cmp s A.gt addr (op s r') + _ -> $internalError "mkPermute_rmw" "unexpected transition" + -- + _ -> $internalError "mkPermute_rmw" "unexpected transition" + + return_ + + +-- Parallel forward permutation function which uses a spinlock to acquire +-- a mutex before updating the value at that location. +-- +mkPermuteP_mutex + :: forall aenv sh sh' e. (Shape sh, Shape sh', Elt e) + => Gamma aenv + -> IRFun2 Native aenv (e -> e -> e) + -> IRFun1 Native aenv (sh -> sh') + -> IRDelayed Native aenv (Array sh e) + -> CodeGen (IROpenAcc Native aenv (Array sh' e)) +mkPermuteP_mutex aenv combine project IRDelayed{..} = + let + (start, end, paramGang) = gangParam + (arrOut, paramOut) = mutableArray ("out" :: Name (Array sh' e)) + (arrLock, paramLock) = mutableArray ("lock" :: Name (Vector Word8)) + paramEnv = envParam aenv + in + makeOpenAcc "permuteP_mutex" (paramGang ++ paramOut ++ paramLock ++ paramEnv) $ do + + sh <- delayedExtent + + imapFromTo start end $ \i -> do + + ix <- indexOfInt sh i + ix' <- app1 project ix + + -- project element onto the destination array and (atomically) update + unless (ignore ix') $ do + j <- intOfIndex (irArrayShape arrOut) ix' + x <- app1 delayedLinearIndex i + + atomically arrLock j $ do + y <- readArray arrOut j + r <- app2 combine x y + writeArray arrOut j r + + return_ + + +-- Atomically execute the critical section only when the lock at the given array +-- index is obtained. The thread spins waiting for the lock to be released and +-- there is no backoff strategy in case the lock is contended. +-- +-- It is important that the thread loops trying to acquire the lock without +-- writing data anything until the lock value changes. Then, because of MESI +-- caching protocols there will be no bus traffic while the CPU waits for the +-- value to change. +-- +-- +-- +atomically + :: IRArray (Vector Word8) + -> IR Int + -> CodeGen a + -> CodeGen a +atomically barriers i action = do + let + lock = integral integralType 1 + unlock = integral integralType 0 + unlocked = lift 0 + -- + spin <- newBlock "spinlock.entry" + crit <- newBlock "spinlock.critical-section" + exit <- newBlock "spinlock.exit" + + addr <- instr' $ GetElementPtr (asPtr defaultAddrSpace (op integralType (irArrayData barriers))) [op integralType i] + _ <- br spin + + -- Atomically (attempt to) set the lock slot to the locked state. If the slot + -- was unlocked we just acquired it, otherwise the state remains unchanged and + -- we spin until it becomes available. + setBlock spin + old <- instr $ AtomicRMW integralType NonVolatile Exchange addr lock (CrossThread, Acquire) + ok <- A.eq scalarType old unlocked + _ <- cbr ok crit spin + + -- We just acquired the lock; perform the critical section then release the + -- lock and exit. For ("some") x86 processors, an unlocked MOV instruction + -- could be used rather than the slower XCHG, due to subtle memory ordering + -- rules. + setBlock crit + r <- action + _ <- instr $ AtomicRMW integralType NonVolatile Exchange addr unlock (CrossThread, Release) + _ <- br exit + + setBlock exit + return r + + +-- Helper functions +-- ---------------- + +-- Test whether the given index is the magic value 'ignore'. This operates +-- strictly rather than performing short-circuit (&&). +-- +ignore :: forall ix. Shape ix => IR ix -> CodeGen (IR Bool) +ignore (IR ix) = go (S.eltType (undefined::ix)) (S.fromElt (S.ignore::ix)) ix + where + go :: TupleType t -> t -> Operands t -> CodeGen (IR Bool) + go UnitTuple () OP_Unit = return (lift True) + go (PairTuple tsh tsz) (ish, isz) (OP_Pair sh sz) = do x <- go tsh ish sh + y <- go tsz isz sz + land' x y + go (SingleTuple t) ig sz = A.eq t (ir t (scalar t ig)) (ir t (op' t sz)) + diff --git a/Data/Array/Accelerate/LLVM/Native/CodeGen/Scan.hs b/Data/Array/Accelerate/LLVM/Native/CodeGen/Scan.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/LLVM/Native/CodeGen/Scan.hs @@ -0,0 +1,814 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} +-- | +-- Module : Data.Array.Accelerate.LLVM.Native.CodeGen.Scan +-- Copyright : [2014..2017] Trevor L. McDonell +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.LLVM.Native.CodeGen.Scan + where + +-- accelerate +import Data.Array.Accelerate.Analysis.Match +import Data.Array.Accelerate.Array.Sugar +import Data.Array.Accelerate.Type + +import Data.Array.Accelerate.LLVM.Analysis.Match +import Data.Array.Accelerate.LLVM.CodeGen.Arithmetic as A +import Data.Array.Accelerate.LLVM.CodeGen.Array +import Data.Array.Accelerate.LLVM.CodeGen.Base +import Data.Array.Accelerate.LLVM.CodeGen.Environment +import Data.Array.Accelerate.LLVM.CodeGen.Exp +import Data.Array.Accelerate.LLVM.CodeGen.IR ( IR ) +import Data.Array.Accelerate.LLVM.CodeGen.Loop +import Data.Array.Accelerate.LLVM.CodeGen.Monad +import Data.Array.Accelerate.LLVM.CodeGen.Sugar + +import Data.Array.Accelerate.LLVM.Native.CodeGen.Base +import Data.Array.Accelerate.LLVM.Native.CodeGen.Generate +import Data.Array.Accelerate.LLVM.Native.CodeGen.Loop +import Data.Array.Accelerate.LLVM.Native.Target ( Native ) + +import Control.Applicative +import Control.Monad +import Data.String ( fromString ) +import Data.Coerce as Safe +import Prelude as P + + +data Direction = L | R + +-- 'Data.List.scanl' style left-to-right exclusive scan, but with the +-- restriction that the combination function must be associative to enable +-- efficient parallel implementation. +-- +-- > scanl (+) 10 (use $ fromList (Z :. 10) [0..]) +-- > +-- > ==> Array (Z :. 11) [10,10,11,13,16,20,25,31,38,46,55] +-- +mkScanl + :: forall aenv sh e. (Shape sh, Elt e) + => Gamma aenv + -> IRFun2 Native aenv (e -> e -> e) + -> IRExp Native aenv e + -> IRDelayed Native aenv (Array (sh:.Int) e) + -> CodeGen (IROpenAcc Native aenv (Array (sh:.Int) e)) +mkScanl aenv combine seed arr + | Just Refl <- matchShapeType (undefined::sh) (undefined::Z) + = foldr1 (+++) <$> sequence [ mkScanS L aenv combine (Just seed) arr + , mkScanP L aenv combine (Just seed) arr + , mkScanFill aenv seed + ] + -- + | otherwise + = (+++) <$> mkScanS L aenv combine (Just seed) arr + <*> mkScanFill aenv seed + + +-- 'Data.List.scanl1' style left-to-right inclusive scan, but with the +-- restriction that the combination function must be associative to enable +-- efficient parallel implementation. The array must not be empty. +-- +-- > scanl1 (+) (use $ fromList (Z :. 10) [0..]) +-- > +-- > ==> Array (Z :. 10) [0,1,3,6,10,15,21,28,36,45] +-- +mkScanl1 + :: forall aenv sh e. (Shape sh, Elt e) + => Gamma aenv + -> IRFun2 Native aenv (e -> e -> e) + -> IRDelayed Native aenv (Array (sh:.Int) e) + -> CodeGen (IROpenAcc Native aenv (Array (sh:.Int) e)) +mkScanl1 aenv combine arr + | Just Refl <- matchShapeType (undefined::sh) (undefined::Z) + = (+++) <$> mkScanS L aenv combine Nothing arr + <*> mkScanP L aenv combine Nothing arr + -- + | otherwise + = mkScanS L aenv combine Nothing arr + + +-- Variant of 'scanl' where the final result is returned in a separate array. +-- +-- > scanr' (+) 10 (use $ fromList (Z :. 10) [0..]) +-- > +-- > ==> ( Array (Z :. 10) [10,10,11,13,16,20,25,31,38,46] +-- , Array Z [55] +-- ) +-- +mkScanl' + :: forall aenv sh e. (Shape sh, Elt e) + => Gamma aenv + -> IRFun2 Native aenv (e -> e -> e) + -> IRExp Native aenv e + -> IRDelayed Native aenv (Array (sh:.Int) e) + -> CodeGen (IROpenAcc Native aenv (Array (sh:.Int) e, Array sh e)) +mkScanl' aenv combine seed arr + | Just Refl <- matchShapeType (undefined::sh) (undefined::Z) + = foldr1 (+++) <$> sequence [ mkScan'S L aenv combine seed arr + , mkScan'P L aenv combine seed arr + , mkScan'Fill aenv seed + ] + -- + | otherwise + = (+++) <$> mkScan'S L aenv combine seed arr + <*> mkScan'Fill aenv seed + + +-- 'Data.List.scanr' style right-to-left exclusive scan, but with the +-- restriction that the combination function must be associative to enable +-- efficient parallel implementation. +-- +-- > scanr (+) 10 (use $ fromList (Z :. 10) [0..]) +-- > +-- > ==> Array (Z :. 11) [55,55,54,52,49,45,40,34,27,19,10] +-- +mkScanr + :: forall aenv sh e. (Shape sh, Elt e) + => Gamma aenv + -> IRFun2 Native aenv (e -> e -> e) + -> IRExp Native aenv e + -> IRDelayed Native aenv (Array (sh:.Int) e) + -> CodeGen (IROpenAcc Native aenv (Array (sh:.Int) e)) +mkScanr aenv combine seed arr + | Just Refl <- matchShapeType (undefined::sh) (undefined::Z) + = foldr1 (+++) <$> sequence [ mkScanS R aenv combine (Just seed) arr + , mkScanP R aenv combine (Just seed) arr + , mkScanFill aenv seed + ] + -- + | otherwise + = (+++) <$> mkScanS R aenv combine (Just seed) arr + <*> mkScanFill aenv seed + + +-- 'Data.List.scanr1' style right-to-left inclusive scan, but with the +-- restriction that the combination function must be associative to enable +-- efficient parallel implementation. The array must not be empty. +-- +-- > scanr (+) 10 (use $ fromList (Z :. 10) [0..]) +-- > +-- > ==> Array (Z :. 10) [45,45,44,42,39,35,30,24,17,9] +-- +mkScanr1 + :: forall aenv sh e. (Shape sh, Elt e) + => Gamma aenv + -> IRFun2 Native aenv (e -> e -> e) + -> IRDelayed Native aenv (Array (sh:.Int) e) + -> CodeGen (IROpenAcc Native aenv (Array (sh:.Int) e)) +mkScanr1 aenv combine arr + | Just Refl <- matchShapeType (undefined::sh) (undefined::Z) + = (+++) <$> mkScanS R aenv combine Nothing arr + <*> mkScanP R aenv combine Nothing arr + -- + | otherwise + = mkScanS R aenv combine Nothing arr + + +-- Variant of 'scanr' where the final result is returned in a separate array. +-- +-- > scanr' (+) 10 (use $ fromList (Z :. 10) [0..]) +-- > +-- > ==> ( Array (Z :. 10) [55,54,52,49,45,40,34,27,19,10] +-- , Array Z [55] +-- ) +-- +mkScanr' + :: forall aenv sh e. (Shape sh, Elt e) + => Gamma aenv + -> IRFun2 Native aenv (e -> e -> e) + -> IRExp Native aenv e + -> IRDelayed Native aenv (Array (sh:.Int) e) + -> CodeGen (IROpenAcc Native aenv (Array (sh:.Int) e, Array sh e)) +mkScanr' aenv combine seed arr + | Just Refl <- matchShapeType (undefined::sh) (undefined::Z) + = foldr1 (+++) <$> sequence [ mkScan'S R aenv combine seed arr + , mkScan'P R aenv combine seed arr + , mkScan'Fill aenv seed + ] + -- + | otherwise + = (+++) <$> mkScan'S R aenv combine seed arr + <*> mkScan'Fill aenv seed + + +-- If the innermost dimension of an exclusive scan is empty, then we just fill +-- the result with the seed element. +-- +mkScanFill + :: (Shape sh, Elt e) + => Gamma aenv + -> IRExp Native aenv e + -> CodeGen (IROpenAcc Native aenv (Array sh e)) +mkScanFill aenv seed = + mkGenerate aenv (IRFun1 (const seed)) + +mkScan'Fill + :: forall aenv sh e. (Shape sh, Elt e) + => Gamma aenv + -> IRExp Native aenv e + -> CodeGen (IROpenAcc Native aenv (Array (sh:.Int) e, Array sh e)) +mkScan'Fill aenv seed = + Safe.coerce <$> (mkScanFill aenv seed :: CodeGen (IROpenAcc Native aenv (Array sh e))) + + +-- A single thread sequentially scans along an entire innermost dimension. For +-- inclusive scans we can assume that the innermost-dimension is at least one +-- element. +-- +-- Note that we can use this both when there is a single thread, or in parallel +-- where threads are scheduled over the outer dimensions (segments). +-- +mkScanS + :: forall aenv sh e. Elt e + => Direction + -> Gamma aenv + -> IRFun2 Native aenv (e -> e -> e) + -> Maybe (IRExp Native aenv e) + -> IRDelayed Native aenv (Array (sh:.Int) e) + -> CodeGen (IROpenAcc Native aenv (Array (sh:.Int) e)) +mkScanS dir aenv combine mseed IRDelayed{..} = + let + (start, end, paramGang) = gangParam + (arrOut, paramOut) = mutableArray ("out" :: Name (Array (sh:.Int) e)) + paramEnv = envParam aenv + -- + next i = case dir of + L -> A.add numType i (lift 1) + R -> A.sub numType i (lift 1) + in + makeOpenAcc "scanS" (paramGang ++ paramOut ++ paramEnv) $ do + + sz <- indexHead <$> delayedExtent + szp1 <- A.add numType sz (lift 1) + szm1 <- A.sub numType sz (lift 1) + + -- loop over each lower-dimensional index (segment) + imapFromTo start end $ \seg -> do + + -- index i* is the index that we will read data from. Recall that the + -- supremum index is exclusive + i0 <- case dir of + L -> A.mul numType sz seg + R -> do x <- A.mul numType sz seg + y <- A.add numType szm1 x + return y + + -- index j* is the index that we write to. Recall that for exclusive scans + -- the output array inner dimension is one larger than the input. + j0 <- case mseed of + Nothing -> return i0 -- merge 'i' and 'j' indices whenever we can + Just{} -> case dir of + L -> A.mul numType szp1 seg + R -> do x <- A.mul numType szp1 seg + y <- A.add numType x sz + return y + + -- Evaluate or read the initial element. Update the read-from index + -- appropriately. + (v0,i1) <- case mseed of + Just seed -> (,) <$> seed <*> pure i0 + Nothing -> (,) <$> app1 delayedLinearIndex i0 <*> next i0 + + -- Write first element, then continue looping through the rest + writeArray arrOut j0 v0 + j1 <- next j0 + + iz <- case dir of + L -> A.add numType i0 sz + R -> A.sub numType i0 sz + + let cont i = case dir of + L -> A.lt scalarType i iz + R -> A.gt scalarType i iz + + void $ while (cont . A.fst3) + (\(A.untrip -> (i,j,v)) -> do + u <- app1 delayedLinearIndex i + v' <- case dir of + L -> app2 combine v u + R -> app2 combine u v + writeArray arrOut j v' + A.trip <$> next i <*> next j <*> pure v') + (A.trip i1 j1 v0) + + return_ + + +mkScan'S + :: forall aenv sh e. (Shape sh, Elt e) + => Direction + -> Gamma aenv + -> IRFun2 Native aenv (e -> e -> e) + -> IRExp Native aenv e + -> IRDelayed Native aenv (Array (sh:.Int) e) + -> CodeGen (IROpenAcc Native aenv (Array (sh:.Int) e, Array sh e)) +mkScan'S dir aenv combine seed IRDelayed{..} = + let + (start, end, paramGang) = gangParam + (arrOut, paramOut) = mutableArray ("out" :: Name (Array (sh:.Int) e)) + (arrSum, paramSum) = mutableArray ("sum" :: Name (Array sh e)) + paramEnv = envParam aenv + -- + next i = case dir of + L -> A.add numType i (lift 1) + R -> A.sub numType i (lift 1) + in + makeOpenAcc "scanS" (paramGang ++ paramOut ++ paramSum ++ paramEnv) $ do + + sz <- indexHead <$> delayedExtent + szm1 <- A.sub numType sz (lift 1) + + -- iterate over each lower-dimensional index (segment) + imapFromTo start end $ \seg -> do + + -- index to read data from + i0 <- case dir of + L -> A.mul numType seg sz + R -> do x <- A.mul numType sz seg + y <- A.add numType x szm1 + return y + + -- initial element + v0 <- seed + + iz <- case dir of + L -> A.add numType i0 sz + R -> A.sub numType i0 sz + + let cont i = case dir of + L -> A.lt scalarType i iz + R -> A.gt scalarType i iz + + -- Loop through the input. Only at the top of the loop to we write the + -- carry-in value (i.e. value from the last loop iteration) to the output + -- array. This ensures correct behaviour if the input array was empty. + r <- while (cont . A.fst) + (\(A.unpair -> (i,v)) -> do + writeArray arrOut i v + + u <- app1 delayedLinearIndex i + v' <- case dir of + L -> app2 combine v u + R -> app2 combine u v + i' <- next i + return $ A.pair i' v') + (A.pair i0 v0) + + -- write final reduction result + writeArray arrSum seg (A.snd r) + + return_ + + +mkScanP + :: forall aenv e. Elt e + => Direction + -> Gamma aenv + -> IRFun2 Native aenv (e -> e -> e) + -> Maybe (IRExp Native aenv e) + -> IRDelayed Native aenv (Vector e) + -> CodeGen (IROpenAcc Native aenv (Vector e)) +mkScanP dir aenv combine mseed arr = + foldr1 (+++) <$> sequence [ mkScanP1 dir aenv combine mseed arr + , mkScanP2 dir aenv combine + , mkScanP3 dir aenv combine mseed + ] + +-- Parallel scan, step 1. +-- +-- Threads scan a stripe of the input into a temporary array, incorporating the +-- initial element and any fused functions on the way. The final reduction +-- result of this chunk is written to a separate array. +-- +mkScanP1 + :: forall aenv e. Elt e + => Direction + -> Gamma aenv + -> IRFun2 Native aenv (e -> e -> e) + -> Maybe (IRExp Native aenv e) + -> IRDelayed Native aenv (Vector e) + -> CodeGen (IROpenAcc Native aenv (Vector e)) +mkScanP1 dir aenv combine mseed IRDelayed{..} = + let + (chunk, _, paramGang) = gangParam + (arrOut, paramOut) = mutableArray ("out" :: Name (Vector e)) + (arrTmp, paramTmp) = mutableArray ("tmp" :: Name (Vector e)) + paramEnv = envParam aenv + -- + steps = local scalarType ("ix.steps" :: Name Int) + paramSteps = scalarParameter scalarType ("ix.steps" :: Name Int) + stride = local scalarType ("ix.stride" :: Name Int) + paramStride = scalarParameter scalarType ("ix.stride" :: Name Int) + -- + next i = case dir of + L -> A.add numType i (lift 1) + R -> A.sub numType i (lift 1) + firstChunk = case dir of + L -> lift 0 + R -> steps + in + makeOpenAcc "scanP1" (paramGang ++ paramStride : paramSteps : paramOut ++ paramTmp ++ paramEnv) $ do + + len <- indexHead <$> delayedExtent + + -- A thread scans a non-empty stripe of the input, storing the final + -- reduction result into a separate array. + -- + -- For exclusive scans the first chunk must incorporate the initial element + -- into the input and output, while all other chunks increment their output + -- index by one. + inf <- A.mul numType chunk stride + a <- A.add numType inf stride + sup <- A.min scalarType a len + + -- index i* is the index that we read data from. Recall that the supremum + -- index is exclusive + i0 <- case dir of + L -> return inf + R -> next sup + + -- index j* is the index that we write to. Recall that for exclusive scan + -- the output array is one larger than the input; the first chunk uses + -- this spot to write the initial element, all other chunks shift by one. + j0 <- case mseed of + Nothing -> return i0 + Just _ -> case dir of + L -> if A.eq scalarType chunk firstChunk + then return i0 + else next i0 + R -> if A.eq scalarType chunk firstChunk + then return sup + else return i0 + + -- Evaluate/read the initial element for this chunk. Update the read-from + -- index appropriately + (v0,i1) <- A.unpair <$> case mseed of + Just seed -> if A.eq scalarType chunk firstChunk + then A.pair <$> seed <*> pure i0 + else A.pair <$> app1 delayedLinearIndex i0 <*> next i0 + Nothing -> A.pair <$> app1 delayedLinearIndex i0 <*> next i0 + + -- Write first element + writeArray arrOut j0 v0 + j1 <- next j0 + + -- Continue looping through the rest of the input + let cont i = + case dir of + L -> A.lt scalarType i sup + R -> A.gte scalarType i inf + + r <- while (cont . A.fst3) + (\(A.untrip -> (i,j,v)) -> do + u <- app1 delayedLinearIndex i + v' <- case dir of + L -> app2 combine v u + R -> app2 combine u v + writeArray arrOut j v' + A.trip <$> next i <*> next j <*> pure v') + (A.trip i1 j1 v0) + + -- Final reduction result of this chunk + writeArray arrTmp chunk (A.thd3 r) + + return_ + + +-- Parallel scan, step 2. +-- +-- A single thread performs an in-place inclusive scan of the partial block +-- sums. This forms the carry-in value which are added to the stripe partial +-- results in the final step. +-- +mkScanP2 + :: forall aenv e. Elt e + => Direction + -> Gamma aenv + -> IRFun2 Native aenv (e -> e -> e) + -> CodeGen (IROpenAcc Native aenv (Vector e)) +mkScanP2 dir aenv combine = + let + (start, end, paramGang) = gangParam + (arrTmp, paramTmp) = mutableArray ("tmp" :: Name (Vector e)) + paramEnv = envParam aenv + -- + cont i = case dir of + L -> A.lt scalarType i end + R -> A.gte scalarType i start + + next i = case dir of + L -> A.add numType i (lift 1) + R -> A.sub numType i (lift 1) + in + makeOpenAcc "scanP2" (paramGang ++ paramTmp ++ paramEnv) $ do + + i0 <- case dir of + L -> return start + R -> next end + + v0 <- readArray arrTmp i0 + i1 <- next i0 + + void $ while (cont . A.fst) + (\(A.unpair -> (i,v)) -> do + u <- readArray arrTmp i + i' <- next i + v' <- case dir of + L -> app2 combine v u + R -> app2 combine u v + writeArray arrTmp i v' + return $ A.pair i' v') + (A.pair i1 v0) + + return_ + + +-- Parallel scan, step 3. +-- +-- Threads combine every element of the partial block results with the carry-in +-- value computed from step 2. +-- +-- Note that we launch (chunks-1) threads, because the first chunk does not need +-- extra processing (has no carry-in value). +-- +mkScanP3 + :: forall aenv e. Elt e + => Direction + -> Gamma aenv + -> IRFun2 Native aenv (e -> e -> e) + -> Maybe (IRExp Native aenv e) + -> CodeGen (IROpenAcc Native aenv (Vector e)) +mkScanP3 dir aenv combine mseed = + let + (chunk, _, paramGang) = gangParam + (arrOut, paramOut) = mutableArray ("out" :: Name (Vector e)) + (arrTmp, paramTmp) = mutableArray ("tmp" :: Name (Vector e)) + paramEnv = envParam aenv + -- + stride = local scalarType ("ix.stride" :: Name Int) + paramStride = scalarParameter scalarType ("ix.stride" :: Name Int) + -- + next i = case dir of + L -> A.add numType i (lift 1) + R -> A.sub numType i (lift 1) + prev i = case dir of + L -> A.sub numType i (lift 1) + R -> A.add numType i (lift 1) + in + makeOpenAcc "scanP3" (paramGang ++ paramStride : paramOut ++ paramTmp ++ paramEnv) $ do + + -- Determine which chunk will be carrying in values for. Compute appropriate + -- start and end indices. + a <- case dir of + L -> next chunk + R -> pure chunk + + b <- A.mul numType a stride + c <- A.add numType b stride + d <- A.min scalarType c (indexHead (irArrayShape arrOut)) + + (inf,sup) <- case (dir,mseed) of + (L,Just _) -> (,) <$> next b <*> next d + _ -> (,) <$> pure b <*> pure d + + -- Carry in value from the previous chunk + e <- case dir of + L -> pure chunk + R -> prev chunk + carry <- readArray arrTmp e + + imapFromTo inf sup $ \i -> do + x <- readArray arrOut i + y <- case dir of + L -> app2 combine carry x + R -> app2 combine x carry + writeArray arrOut i y + + return_ + + +mkScan'P + :: forall aenv e. Elt e + => Direction + -> Gamma aenv + -> IRFun2 Native aenv (e -> e -> e) + -> IRExp Native aenv e + -> IRDelayed Native aenv (Vector e) + -> CodeGen (IROpenAcc Native aenv (Vector e, Scalar e)) +mkScan'P dir aenv combine seed arr = + foldr1 (+++) <$> sequence [ mkScan'P1 dir aenv combine seed arr + , mkScan'P2 dir aenv combine + , mkScan'P3 dir aenv combine + ] + +-- Parallel scan', step 1 +-- +-- Threads scan a stripe of the input into a temporary array. Similar to +-- exclusive scan, but since the size of the output array is the same as the +-- input, input and output indices are shifted by one. +-- +mkScan'P1 + :: forall aenv e. Elt e + => Direction + -> Gamma aenv + -> IRFun2 Native aenv (e -> e -> e) + -> IRExp Native aenv e + -> IRDelayed Native aenv (Vector e) + -> CodeGen (IROpenAcc Native aenv (Vector e, Scalar e)) +mkScan'P1 dir aenv combine seed IRDelayed{..} = + let + (chunk, _, paramGang) = gangParam + (arrOut, paramOut) = mutableArray ("out" :: Name (Vector e)) + (arrTmp, paramTmp) = mutableArray ("tmp" :: Name (Vector e)) + paramEnv = envParam aenv + -- + steps = local scalarType ("ix.steps" :: Name Int) + paramSteps = scalarParameter scalarType ("ix.steps" :: Name Int) + stride = local scalarType ("ix.stride" :: Name Int) + paramStride = scalarParameter scalarType ("ix.stride" :: Name Int) + -- + next i = case dir of + L -> A.add numType i (lift 1) + R -> A.sub numType i (lift 1) + + firstChunk = case dir of + L -> lift 0 + R -> steps + in + makeOpenAcc "scanP1" (paramGang ++ paramStride : paramSteps : paramOut ++ paramTmp ++ paramEnv) $ do + + -- Compute the start and end indices for this non-empty chunk of the input. + -- + len <- indexHead <$> delayedExtent + inf <- A.mul numType chunk stride + a <- A.add numType inf stride + sup <- A.min scalarType a len + + -- index i* is the index that we pull data from. + i0 <- case dir of + L -> return inf + R -> next sup + + -- index j* is the index that we write results to. The first chunk needs to + -- include the initial element, and all other chunks shift their results + -- across by one to make space. + j0 <- if A.eq scalarType chunk firstChunk + then pure i0 + else next i0 + + -- Evaluate/read the initial element. Update the read-from index + -- appropriately. + (v0,i1) <- A.unpair <$> if A.eq scalarType chunk firstChunk + then A.pair <$> seed <*> pure i0 + else A.pair <$> app1 delayedLinearIndex i0 <*> pure j0 + + -- Write the first element + writeArray arrOut j0 v0 + j1 <- next j0 + + -- Continue looping through the rest of the input + let cont i = + case dir of + L -> A.lt scalarType i sup + R -> A.gte scalarType i inf + + r <- while (cont . A.fst3) + (\(A.untrip-> (i,j,v)) -> do + u <- app1 delayedLinearIndex i + v' <- case dir of + L -> app2 combine v u + R -> app2 combine u v + writeArray arrOut j v' + A.trip <$> next i <*> next j <*> pure v') + (A.trip i1 j1 v0) + + -- Write the final reduction result of this chunk + writeArray arrTmp chunk (A.thd3 r) + + return_ + + +-- Parallel scan', step 2 +-- +-- Identical to mkScanP2, except we store the total scan result into a separate +-- array (rather than discard it). +-- +mkScan'P2 + :: forall aenv e. Elt e + => Direction + -> Gamma aenv + -> IRFun2 Native aenv (e -> e -> e) + -> CodeGen (IROpenAcc Native aenv (Vector e, Scalar e)) +mkScan'P2 dir aenv combine = + let + (start, end, paramGang) = gangParam + (arrTmp, paramTmp) = mutableArray ("tmp" :: Name (Vector e)) + (arrSum, paramSum) = mutableArray ("sum" :: Name (Scalar e)) + paramEnv = envParam aenv + -- + cont i = case dir of + L -> A.lt scalarType i end + R -> A.gte scalarType i start + + next i = case dir of + L -> A.add numType i (lift 1) + R -> A.sub numType i (lift 1) + in + makeOpenAcc "scanP2" (paramGang ++ paramSum ++ paramTmp ++ paramEnv) $ do + + i0 <- case dir of + L -> return start + R -> next end + + v0 <- readArray arrTmp i0 + i1 <- next i0 + + r <- while (cont . A.fst) + (\(A.unpair -> (i,v)) -> do + u <- readArray arrTmp i + i' <- next i + v' <- case dir of + L -> app2 combine v u + R -> app2 combine u v + writeArray arrTmp i v' + return $ A.pair i' v') + (A.pair i1 v0) + + writeArray arrSum (lift 0 :: IR Int) (A.snd r) + + return_ + + +-- Parallel scan', step 3 +-- +-- Similar to mkScanP3, except that indices are shifted by one since the output +-- array is the same size as the input (despite being an exclusive scan). +-- +-- Launch (chunks-1) threads, because the first chunk does not need extra +-- processing. +-- +mkScan'P3 + :: forall aenv e. Elt e + => Direction + -> Gamma aenv + -> IRFun2 Native aenv (e -> e -> e) + -> CodeGen (IROpenAcc Native aenv (Vector e, Scalar e)) +mkScan'P3 dir aenv combine = + let + (chunk, _, paramGang) = gangParam + (arrOut, paramOut) = mutableArray ("out" :: Name (Vector e)) + (arrTmp, paramTmp) = mutableArray ("tmp" :: Name (Vector e)) + paramEnv = envParam aenv + -- + stride = local scalarType ("ix.stride" :: Name Int) + paramStride = scalarParameter scalarType ("ix.stride" :: Name Int) + -- + next i = case dir of + L -> A.add numType i (lift 1) + R -> A.sub numType i (lift 1) + prev i = case dir of + L -> A.sub numType i (lift 1) + R -> A.add numType i (lift 1) + in + makeOpenAcc "scanP3" (paramGang ++ paramStride : paramOut ++ paramTmp ++ paramEnv) $ do + + -- Determine which chunk we will be carrying in the values of, and compute + -- the appropriate start and end indices + a <- case dir of + L -> next chunk + R -> pure chunk + + b <- A.mul numType a stride + c <- A.add numType b stride + d <- A.min scalarType c (indexHead (irArrayShape arrOut)) + + inf <- next b + sup <- next d + + -- Carry-value from the previous chunk + e <- case dir of + L -> pure chunk + R -> prev chunk + + carry <- readArray arrTmp e + + imapFromTo inf sup $ \i -> do + x <- readArray arrOut i + y <- case dir of + L -> app2 combine carry x + R -> app2 combine x carry + writeArray arrOut i y + + return_ + diff --git a/Data/Array/Accelerate/LLVM/Native/Compile.hs b/Data/Array/Accelerate/LLVM/Native/Compile.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/LLVM/Native/Compile.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- | +-- Module : Data.Array.Accelerate.LLVM.Native.Compile +-- Copyright : [2014..2017] Trevor L. McDonell +-- [2014..2014] Vinod Grover (NVIDIA Corporation) +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.LLVM.Native.Compile ( + + module Data.Array.Accelerate.LLVM.Compile, + module Data.Array.Accelerate.LLVM.Native.Compile.Module, + ExecutableR(..), + +) where + +-- llvm-general +import LLVM.AST hiding ( Module ) +import LLVM.Module as LLVM hiding ( Module ) +import LLVM.Context +import LLVM.Target +import LLVM.ExecutionEngine + +-- accelerate +import Data.Array.Accelerate.Error ( internalError ) +import Data.Array.Accelerate.Trafo ( DelayedOpenAcc ) + +import Data.Array.Accelerate.LLVM.CodeGen +import Data.Array.Accelerate.LLVM.Compile +import Data.Array.Accelerate.LLVM.State +import Data.Array.Accelerate.LLVM.CodeGen.Environment ( Gamma ) +import Data.Array.Accelerate.LLVM.CodeGen.Module ( unModule ) + +import Data.Array.Accelerate.LLVM.Native.Compile.Link +import Data.Array.Accelerate.LLVM.Native.Compile.Module +import Data.Array.Accelerate.LLVM.Native.Compile.Optimise + +import Data.Array.Accelerate.LLVM.Native.CodeGen ( ) +import Data.Array.Accelerate.LLVM.Native.Foreign ( ) +import Data.Array.Accelerate.LLVM.Native.Target +import qualified Data.Array.Accelerate.LLVM.Native.Debug as Debug + +-- standard library +import Control.Monad.Except ( runExceptT ) +import Control.Monad.State +import Data.Maybe + + +instance Compile Native where + data ExecutableR Native = NativeR { executableR :: Module } + compileForTarget = compileForNativeTarget + +instance Intrinsic Native + + +-- Compile an Accelerate expression for the native CPU target. +-- +compileForNativeTarget :: DelayedOpenAcc aenv a -> Gamma aenv -> LLVM Native (ExecutableR Native) +compileForNativeTarget acc aenv = do + target <- gets llvmTarget + + -- Generate code for this Acc operation + -- + let ast = unModule (llvmOfOpenAcc target acc aenv) + triple = fromMaybe "" (moduleTargetTriple ast) + datalayout = moduleDataLayout ast + + -- Lower the generated LLVM to an executable function(s) + -- + mdl <- liftIO . + compileModule $ \k -> + withContext $ \ctx -> + runExcept $ withModuleFromAST ctx ast $ \mdl -> + runExcept $ withNativeTargetMachine $ \machine -> + withTargetLibraryInfo triple $ \libinfo -> do + optimiseModule datalayout (Just machine) (Just libinfo) mdl + + Debug.when Debug.verbose $ do + Debug.traceIO Debug.dump_cc =<< moduleLLVMAssembly mdl + Debug.traceIO Debug.dump_asm =<< runExcept (moduleTargetAssembly machine mdl) + + withMCJIT ctx opt model ptrelim fast $ \mcjit -> do + withModuleInEngine mcjit mdl $ \exe -> do + k =<< getGlobalFunctions ast exe + + return $ NativeR mdl + + where + runExcept = either ($internalError "compileForNativeTarget") return <=< runExceptT + + opt = Just 3 -- optimisation level + model = Nothing -- code model? + ptrelim = Nothing -- True to disable frame pointer elimination + fast = Just True -- True to enable fast instruction selection + diff --git a/Data/Array/Accelerate/LLVM/Native/Compile/Link.hs b/Data/Array/Accelerate/LLVM/Native/Compile/Link.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/LLVM/Native/Compile/Link.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +-- | +-- Module : Data.Array.Accelerate.LLVM.Native.Compile.Link +-- Copyright : [2014..2017] Trevor L. McDonell +-- [2014..2014] Vinod Grover (NVIDIA Corporation) +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.LLVM.Native.Compile.Link + where + +-- llvm-hs +import LLVM.AST +import LLVM.AST.Global +import LLVM.ExecutionEngine + +-- accelerate +import Data.Array.Accelerate.Error + +-- standard library +import Data.Maybe + + +-- | Return function pointers to all of the global function definitions in the +-- given executable module. +-- +getGlobalFunctions + :: ExecutionEngine e f + => Module + -> ExecutableModule e + -> IO [(String, f)] +getGlobalFunctions ast exe + = mapM (\f -> (f,) `fmap` link f) + $ globalFunctions (moduleDefinitions ast) + where + link f = fromMaybe ($internalError "link" "function not found") `fmap` getFunction exe (Name f) + + +-- | Extract the names of the function definitions from a module +-- +-- TLM: move this somewhere it can be shared between Native/NVVM backend +-- +globalFunctions :: [Definition] -> [String] +globalFunctions defs = + [ n | GlobalDefinition Function{..} <- defs + , not (null basicBlocks) + , let Name n = name + ] + diff --git a/Data/Array/Accelerate/LLVM/Native/Compile/Module.hs b/Data/Array/Accelerate/LLVM/Native/Compile/Module.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/LLVM/Native/Compile/Module.hs @@ -0,0 +1,153 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +-- | +-- Module : Data.Array.Accelerate.LLVM.Native.Compile.Module +-- Copyright : [2014..2017] Trevor L. McDonell +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.LLVM.Native.Compile.Module ( + + Module, + compileModule, + execute, executeMain, + nm, + +) where + +-- accelerate +import Data.Array.Accelerate.Error +import Data.Array.Accelerate.Lifetime +import qualified Data.Array.Accelerate.LLVM.Native.Debug as Debug + +-- library +import Control.Exception +import Control.Concurrent +import Data.List +import Foreign.LibFFI +import Foreign.Ptr +import Text.Printf + + +-- | An encapsulation of the callable functions resulting from compiling +-- a module. +-- +data Module = Module {-# UNPACK #-} !(Lifetime FunctionTable) + +data FunctionTable = FunctionTable { functionTable :: [Function] } +type Function = (String, FunPtr ()) + +instance Show Module where + showsPrec p (Module m) + = showsPrec p (unsafeGetValue m) + +instance Show FunctionTable where + showsPrec _ f + = showString "<<" + . showString (intercalate "," [ n | (n,_) <- functionTable f ]) + . showString ">>" + + +-- | Execute a named function that was defined in the module. An error is thrown +-- if the requested function is not define in the module. +-- +-- The final argument is a continuation to which we pass a function you can call +-- to actually execute the foreign function. +-- +{-# INLINEABLE execute #-} +execute + :: Module + -> String + -> ((String, [Arg] -> IO ()) -> IO a) + -> IO a +execute mdl@(Module ft) name k = + withLifetime ft $ \FunctionTable{..} -> + case lookup name functionTable of + Just f -> k (name, \argv -> callFFI f retVoid argv) + Nothing -> $internalError "execute" (printf "function '%s' not found in module: %s\n" name (show mdl)) + + +-- | Execute the 'main' function of a module, which is just the first function +-- defined in the module. +-- +{-# INLINEABLE executeMain #-} +executeMain + :: Module + -> ((String, [Arg] -> IO ()) -> IO a) + -> IO a +executeMain (Module ft) k = + withLifetime ft $ \FunctionTable{..} -> + case functionTable of + [] -> $internalError "executeMain" "no functions defined in module" + (name,f):_ -> k (name, \argv -> callFFI f retVoid argv) + + +-- | Display the global (external) symbol table for this module. +-- +nm :: Module -> IO [String] +nm (Module ft) = + withLifetime ft $ \FunctionTable{..} -> + return $ map fst functionTable + + +-- Compile a given module into executable code. +-- +-- Note: [Executing JIT-compiled functions] +-- +-- We have the problem that the llvm-general functions dealing with the FFI are +-- exposed as bracketed 'with*' operations, rather than as separate +-- 'create*'/'destroy*' pairs. This is a good design that guarantees that +-- functions clean up their resources on exit, but also means that we can't +-- return a function pointer to the compiled code from within the bracketed +-- expression, because it will no longer be valid once we get around to +-- executing it, as it has already been deallocated! +-- +-- This function provides a wrapper that does the compilation step (first +-- argument) in a separate thread, returns the compiled functions, then waits +-- until they are no longer needed before allowing the finalisation routines to +-- proceed. +-- +compileModule :: (([Function] -> IO ()) -> IO ()) -> IO Module +compileModule compile = mask $ \restore -> do + main <- myThreadId + mfuns <- newEmptyMVar + mdone <- newEmptyMVar + _ <- forkIO . reflectExceptionsTo main . restore . compile $ \funs -> do + putMVar mfuns funs + takeMVar mdone -- thread blocks, keeping 'funs' alive + message "worker thread shutting down" -- we better have a matching message from 'finalise' + -- + funs <- takeMVar mfuns + ftab <- newLifetime (FunctionTable funs) + addFinalizer ftab (finalise mdone) + return (Module ftab) + +reflectExceptionsTo :: ThreadId -> IO () -> IO () +reflectExceptionsTo tid action = + catchNonThreadKilled action (throwTo tid) + +catchNonThreadKilled :: IO a -> (SomeException -> IO a) -> IO a +catchNonThreadKilled action handler = + action `catch` \e -> + case fromException e of + Just ThreadKilled -> throwIO e + _ -> handler e + +finalise :: MVar () -> IO () +finalise done = do + message "finalising function table" + putMVar done () + + +-- Debug +-- ----- + +{-# INLINE message #-} +message :: String -> IO () +message msg = Debug.traceIO Debug.dump_exec ("exec: " ++ msg) + diff --git a/Data/Array/Accelerate/LLVM/Native/Compile/Optimise.hs b/Data/Array/Accelerate/LLVM/Native/Compile/Optimise.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/LLVM/Native/Compile/Optimise.hs @@ -0,0 +1,143 @@ +-- | +-- Module : Data.Array.Accelerate.LLVM.Native.Compile.Optimise +-- Copyright : [2014..2017] Trevor L. McDonell +-- [2014..2014] Vinod Grover (NVIDIA Corporation) +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.LLVM.Native.Compile.Optimise ( + + optimiseModule + +) where + +-- llvm-hs +import LLVM.AST.DataLayout +import LLVM.Module +import LLVM.PassManager +import LLVM.Target + +-- accelerate +import qualified Data.Array.Accelerate.LLVM.Native.Debug as Debug + +-- standard library +import Text.Printf + + +-- | Run the standard optimisations on the given module when targeting a +-- specific machine and data layout. Specifically, this will run the +-- optimisation passes such that LLVM has the necessary information to +-- automatically vectorise loops (whenever it deems beneficial to do so). +-- +optimiseModule + :: Maybe DataLayout + -> Maybe TargetMachine + -> Maybe TargetLibraryInfo + -> Module + -> IO () +optimiseModule datalayout machine libinfo mdl = do + + let p1 = defaultCuratedPassSetSpec + { optLevel = Just 3 + , dataLayout = datalayout + , targetMachine = machine + , targetLibraryInfo = libinfo + , loopVectorize = Just True + , superwordLevelParallelismVectorize = Just True + } + b1 <- withPassManager p1 $ \pm -> runPassManager pm mdl + + Debug.traceIO Debug.dump_cc $ + printf "llvm: optimisation did work? %s" (show b1) + +{-- +-- The first gentle optimisation pass. I think this is usually done when loading +-- the module? +-- +-- This is the first section of output running 'opt -O3 -debug-pass=Arguments' +-- +-- Pass Arguments: +-- -datalayout -notti -basictti -x86tti -no-aa -tbaa -targetlibinfo -basicaa +-- -preverify -domtree -verify -simplifycfg -domtree -sroa -early-cse +-- -lower-expect +-- +prepass :: [Pass] +prepass = + [ SimplifyControlFlowGraph + , ScalarReplacementOfAggregates { requiresDominatorTree = True } + , EarlyCommonSubexpressionElimination + , LowerExpectIntrinsic + ] + +-- The main optimisation pipeline. This mostly matches the process of running +-- 'opt -O3 -debug-pass=Arguments'. We are missing dead argument elimination and +-- in particular, slp-vectorizer (super-word level parallelism). +-- +-- Pass Arguments: +-- -targetlibinfo -datalayout -notti -basictti -x86tti -no-aa -tbaa -basicaa +-- -globalopt -ipsccp -deadargelim -instcombine -simplifycfg -basiccg -prune-eh +-- -inline-cost -inline -functionattrs -argpromotion -sroa -domtree -early-cse +-- -lazy-value-info -jump-threading -correlated-propagation -simplifycfg +-- -instcombine -tailcallelim -simplifycfg -reassociate -domtree -loops +-- -loop-simplify -lcssa -loop-rotate -licm -lcssa -loop-unswitch -instcombine +-- -scalar-evolution -loop-simplify -lcssa -indvars -loop-idiom -loop-deletion +-- -loop-unroll -memdep -gvn -memdep -memcpyopt -sccp -instcombine +-- -lazy-value-info -jump-threading -correlated-propagation -domtree -memdep -dse +-- -loops -scalar-evolution -slp-vectorizer -adce -simplifycfg -instcombine +-- -barrier -domtree -loops -loop-simplify -lcssa -scalar-evolution +-- -loop-simplify -lcssa -loop-vectorize -instcombine -simplifycfg +-- -strip-dead-prototypes -globaldce -constmerge -preverify -domtree -verify +-- +optpass :: [Pass] +optpass = + [ + InterproceduralSparseConditionalConstantPropagation -- ipsccp + , InstructionCombining + , SimplifyControlFlowGraph + , PruneExceptionHandling + , FunctionInlining { functionInliningThreshold = 275 } -- -O2 => 275 + , FunctionAttributes + , ArgumentPromotion -- not needed? + , ScalarReplacementOfAggregates { requiresDominatorTree = True } -- false? + , EarlyCommonSubexpressionElimination + , JumpThreading + , CorrelatedValuePropagation + , SimplifyControlFlowGraph + , InstructionCombining + , TailCallElimination + , SimplifyControlFlowGraph + , Reassociate + , LoopRotate + , LoopInvariantCodeMotion + , LoopClosedSingleStaticAssignment + , LoopUnswitch { optimizeForSize = False } + , LoopInstructionSimplify + , InstructionCombining + , InductionVariableSimplify + , LoopIdiom + , LoopDeletion + , LoopUnroll { loopUnrollThreshold = Nothing + , count = Nothing + , allowPartial = Nothing } + , GlobalValueNumbering { noLoads = False } -- True to add memory dependency analysis + , SparseConditionalConstantPropagation + , InstructionCombining + , JumpThreading + , CorrelatedValuePropagation + , DeadStoreElimination + , defaultVectorizeBasicBlocks -- instead of slp-vectorizer? + , AggressiveDeadCodeElimination + , SimplifyControlFlowGraph + , InstructionCombining + , LoopVectorize + , InstructionCombining + , SimplifyControlFlowGraph + , GlobalDeadCodeElimination + , ConstantMerge + ] +--} + diff --git a/Data/Array/Accelerate/LLVM/Native/Debug.hs b/Data/Array/Accelerate/LLVM/Native/Debug.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/LLVM/Native/Debug.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeOperators #-} +-- | +-- Module : Data.Array.Accelerate.LLVM.Native.Debug +-- Copyright : [2014..2017] Trevor L. McDonell +-- [2014..2014] Vinod Grover (NVIDIA Corporation) +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.LLVM.Native.Debug ( + + module Data.Array.Accelerate.Debug, + module Data.Array.Accelerate.LLVM.Native.Debug, + +) where + +import Data.Array.Accelerate.Debug hiding ( elapsed ) +import qualified Data.Array.Accelerate.Debug as Debug + +import Text.Printf + + +-- | Display elapsed wall and CPU time, together with speedup fraction +-- +{-# INLINEABLE elapsedP #-} +elapsedP :: Double -> Double -> String +elapsedP wallTime cpuTime = + printf "%s (wall), %s (cpu), %.2f x speedup" + (showFFloatSIBase (Just 3) 1000 wallTime "s") + (showFFloatSIBase (Just 3) 1000 cpuTime "s") + (cpuTime / wallTime) + +-- | Display elapsed wall and CPU time +-- +{-# INLINEABLE elapsedS #-} +elapsedS :: Double -> Double -> String +elapsedS = Debug.elapsed + diff --git a/Data/Array/Accelerate/LLVM/Native/Execute.hs b/Data/Array/Accelerate/LLVM/Native/Execute.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/LLVM/Native/Execute.hs @@ -0,0 +1,517 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- | +-- Module : Data.Array.Accelerate.LLVM.Native.Execute +-- Copyright : [2014..2017] Trevor L. McDonell +-- [2014..2014] Vinod Grover (NVIDIA Corporation) +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.LLVM.Native.Execute ( + + executeAcc, executeAfun1, + +) where + +-- accelerate +import Data.Array.Accelerate.Error +import Data.Array.Accelerate.Array.Sugar +import Data.Array.Accelerate.Analysis.Match + +import Data.Array.Accelerate.LLVM.Analysis.Match +import Data.Array.Accelerate.LLVM.Execute +import Data.Array.Accelerate.LLVM.State + +import Data.Array.Accelerate.LLVM.Native.Array.Data +import Data.Array.Accelerate.LLVM.Native.Compile +import Data.Array.Accelerate.LLVM.Native.Execute.Async +import Data.Array.Accelerate.LLVM.Native.Execute.Environment +import Data.Array.Accelerate.LLVM.Native.Execute.Marshal +import Data.Array.Accelerate.LLVM.Native.Target +import qualified Data.Array.Accelerate.LLVM.Native.Debug as Debug + +-- Use work-stealing scheduler +import Data.Range.Range ( Range(..) ) +import Control.Parallel.Meta ( Executable(..) ) +import Data.Array.Accelerate.LLVM.Native.Execute.LBS + +-- library +import Data.Word ( Word8 ) +import Control.Monad.State ( gets ) +import Control.Monad.Trans ( liftIO ) +import Prelude hiding ( map, sum, scanl, scanr, init ) +import qualified Prelude as P + +import Foreign.C +import Foreign.LibFFI ( Arg ) +import Foreign.Ptr + + +-- Array expression evaluation +-- --------------------------- + +-- Computations are evaluated by traversing the AST bottom up, and for each node +-- distinguishing between three cases: +-- +-- 1. If it is a Use node, we return a reference to the array data. Even though +-- we execute with multiple cores, we assume a shared memory multiprocessor +-- machine. +-- +-- 2. If it is a non-skeleton node, such as a let binding or shape conversion, +-- then execute directly by updating the environment or similar. +-- +-- 3. If it is a skeleton node, then we need to execute the generated LLVM +-- code. +-- +instance Execute Native where + map = simpleOp + generate = simpleOp + transform = simpleOp + backpermute = simpleOp + fold = foldOp + fold1 = fold1Op + foldSeg = foldSegOp + fold1Seg = foldSegOp + scanl = scanOp + scanl1 = scan1Op + scanl' = scan'Op + scanr = scanOp + scanr1 = scan1Op + scanr' = scan'Op + permute = permuteOp + stencil1 = stencil1Op + stencil2 = stencil2Op + + +-- Skeleton implementation +-- ----------------------- + +-- Simple kernels just needs to know the shape of the output array. +-- +simpleOp + :: (Shape sh, Elt e) + => ExecutableR Native + -> Gamma aenv + -> Aval aenv + -> Stream + -> sh + -> LLVM Native (Array sh e) +simpleOp NativeR{..} gamma aenv () sh = do + Native{..} <- gets llvmTarget + liftIO $ do + out <- allocateArray sh + executeMain executableR $ \f -> + executeOp defaultLargePPT fillP f gamma aenv (IE 0 (size sh)) out + return out + +simpleNamed + :: (Shape sh, Elt e) + => String + -> ExecutableR Native + -> Gamma aenv + -> Aval aenv + -> Stream + -> sh + -> LLVM Native (Array sh e) +simpleNamed fun NativeR{..} gamma aenv () sh = do + Native{..} <- gets llvmTarget + liftIO $ do + out <- allocateArray sh + execute executableR fun $ \f -> + executeOp defaultLargePPT fillP f gamma aenv (IE 0 (size sh)) out + return out + + +-- Note: [Reductions] +-- +-- There are two flavours of reduction: +-- +-- 1. If we are collapsing to a single value, then threads reduce strips of +-- the input in parallel, and then a single thread reduces the partial +-- reductions to a single value. Load balancing occurs over the input +-- stripes. +-- +-- 2. If this is a multidimensional reduction, then each inner dimension is +-- handled by a single thread. Load balancing occurs over the outer +-- dimension indices. +-- +-- The entry points to executing the reduction are 'foldOp' and 'fold1Op', for +-- exclusive and inclusive reductions respectively. These functions handle +-- whether the input array is empty. If the input and output arrays are +-- non-empty, we then further dispatch (via 'foldCore') to 'foldAllOp' or +-- 'foldDimOp' for single or multidimensional reductions, respectively. +-- 'foldAllOp' in particular must execute specially whether the gang has +-- multiple worker threads which can process the array in parallel. +-- + +fold1Op + :: (Shape sh, Elt e) + => ExecutableR Native + -> Gamma aenv + -> Aval aenv + -> Stream + -> (sh :. Int) + -> LLVM Native (Array sh e) +fold1Op kernel gamma aenv stream sh@(sx :. sz) + = $boundsCheck "fold1" "empty array" (sz > 0) + $ case size sh of + 0 -> liftIO $ allocateArray sx -- empty, but possibly with non-zero dimensions + _ -> foldCore kernel gamma aenv stream sh + +foldOp + :: (Shape sh, Elt e) + => ExecutableR Native + -> Gamma aenv + -> Aval aenv + -> Stream + -> (sh :. Int) + -> LLVM Native (Array sh e) +foldOp kernel gamma aenv stream sh@(sx :. _) = + case size sh of + 0 -> simpleNamed "generate" kernel gamma aenv stream (listToShape (P.map (max 1) (shapeToList sx))) + _ -> foldCore kernel gamma aenv stream sh + +foldCore + :: (Shape sh, Elt e) + => ExecutableR Native + -> Gamma aenv + -> Aval aenv + -> Stream + -> (sh :. Int) + -> LLVM Native (Array sh e) +foldCore kernel gamma aenv stream sh + | Just Refl <- matchShapeType sh (undefined::DIM1) + = foldAllOp kernel gamma aenv stream sh + -- + | otherwise + = foldDimOp kernel gamma aenv stream sh + +foldAllOp + :: forall aenv e. Elt e + => ExecutableR Native + -> Gamma aenv + -> Aval aenv + -> Stream + -> DIM1 + -> LLVM Native (Scalar e) +foldAllOp NativeR{..} gamma aenv () (Z :. sz) = do + Native{..} <- gets llvmTarget + let + ncpu = gangSize + stride = defaultLargePPT `min` ((sz + ncpu - 1) `quot` ncpu) + steps = (sz + stride - 1) `quot` stride + -- + if ncpu == 1 || sz <= defaultLargePPT + then liftIO $ do + -- Sequential reduction + out <- allocateArray Z + execute executableR "foldAllS" $ \f -> + executeOp 1 fillS f gamma aenv (IE 0 sz) out + return out + + else liftIO $ do + -- Parallel reduction + out <- allocateArray Z + tmp <- allocateArray (Z :. steps) :: IO (Vector e) + -- + execute executableR "foldAllP1" $ \f1 -> do + execute executableR "foldAllP2" $ \f2 -> do + executeOp 1 fillP f1 gamma aenv (IE 0 steps) (sz, stride, tmp) + executeOp 1 fillS f2 gamma aenv (IE 0 steps) (tmp, out) + -- + return out + +foldDimOp + :: (Shape sh, Elt e) + => ExecutableR Native + -> Gamma aenv + -> Aval aenv + -> Stream + -> (sh :. Int) + -> LLVM Native (Array sh e) +foldDimOp NativeR{..} gamma aenv () (sh :. sz) = do + Native{..} <- gets llvmTarget + let ppt = defaultSmallPPT `max` (defaultLargePPT `quot` (max 1 sz)) + liftIO $ do + out <- allocateArray sh + executeMain executableR $ \f -> + executeOp ppt fillP f gamma aenv (IE 0 (size sh)) (sz, out) + return out + +foldSegOp + :: (Shape sh, Elt e) + => ExecutableR Native + -> Gamma aenv + -> Aval aenv + -> Stream + -> (sh :. Int) + -> (Z :. Int) + -> LLVM Native (Array (sh :. Int) e) +foldSegOp NativeR{..} gamma aenv () (sh :. _) (Z :. ss) = do + Native{..} <- gets llvmTarget + let + ncpu = gangSize + kernel | ncpu == 1 = "foldSegS" + | otherwise = "foldSegP" + n | ncpu == 1 = ss + | otherwise = ss - 1 -- segments array has been 'scanl (+) 0'`ed + ppt = n -- for 1D distribute evenly over threads; otherwise + -- -- compute all segments on an innermost dimension + liftIO $ do + out <- allocateArray (sh :. n) + execute executableR kernel $ \f -> + executeOp ppt fillP f gamma aenv (IE 0 (size (sh :. n))) out + return out + + +scanOp + :: (Shape sh, Elt e) + => ExecutableR Native + -> Gamma aenv + -> Aval aenv + -> Stream + -> sh :. Int + -> LLVM Native (Array (sh:.Int) e) +scanOp kernel gamma aenv stream (sz :. n) = + case n of + 0 -> simpleNamed "generate" kernel gamma aenv stream (sz :. 1) + _ -> scanCore kernel gamma aenv stream sz n (n+1) + +scan1Op + :: (Shape sh, Elt e) + => ExecutableR Native + -> Gamma aenv + -> Aval aenv + -> Stream + -> sh :. Int + -> LLVM Native (Array (sh:.Int) e) +scan1Op kernel gamma aenv stream (sz :. n) + = $boundsCheck "scan1" "empty array" (n > 0) + $ scanCore kernel gamma aenv stream sz n n + +scanCore + :: forall aenv sh e. (Shape sh, Elt e) + => ExecutableR Native + -> Gamma aenv + -> Aval aenv + -> Stream + -> sh + -> Int + -> Int + -> LLVM Native (Array (sh:.Int) e) +scanCore NativeR{..} gamma aenv () sz n m = do + Native{..} <- gets llvmTarget + let + ncpu = gangSize + stride = defaultLargePPT `min` ((n + ncpu - 1) `quot` ncpu) + steps = (n + stride - 1) `quot` stride + steps' = steps - 1 + -- + if ncpu == 1 || rank sz > 0 || n <= 2 * defaultLargePPT + then liftIO $ do + -- Either: + -- + -- 1. Sequential scan of an array of any rank + -- + -- 2. Parallel scan of multidimensional array: threads scan along the + -- length of the innermost dimension. Threads are scheduled over the + -- inner dimensions. + -- + -- 3. Small 1D array. Since parallel scan requires ~4n data transfer + -- compared to ~2n in the sequential case, it is only worthwhile if + -- the extra cores can offset the increased bandwidth requirements. + -- + out <- allocateArray (sz :. m) + execute executableR "scanS" $ \f -> + executeOp 1 fillP f gamma aenv (IE 0 (size sz)) out + return out + + else liftIO $ do + -- parallel one-dimensional scan + out <- allocateArray (sz :. m) + tmp <- allocateArray (Z :. steps) :: IO (Vector e) + -- + execute executableR "scanP1" $ \f1 -> do + execute executableR "scanP2" $ \f2 -> do + execute executableR "scanP3" $ \f3 -> do + executeOp 1 fillP f1 gamma aenv (IE 0 steps) (stride, steps', out, tmp) + executeOp 1 fillS f2 gamma aenv (IE 0 steps) tmp + executeOp 1 fillP f3 gamma aenv (IE 0 steps') (stride, out, tmp) + -- + return out + + +scan'Op + :: forall aenv sh e. (Shape sh, Elt e) + => ExecutableR Native + -> Gamma aenv + -> Aval aenv + -> Stream + -> sh :. Int + -> LLVM Native (Array (sh:.Int) e, Array sh e) +scan'Op native gamma aenv stream sh@(sz :. n) = + case n of + 0 -> do + out <- liftIO $ allocateArray (sz :. 0) + sum <- simpleNamed "generate" native gamma aenv stream sz + return (out, sum) + -- + _ -> scan'Core native gamma aenv stream sh + +scan'Core + :: forall aenv sh e. (Shape sh, Elt e) + => ExecutableR Native + -> Gamma aenv + -> Aval aenv + -> Stream + -> sh :. Int + -> LLVM Native (Array (sh:.Int) e, Array sh e) +scan'Core NativeR{..} gamma aenv () sh@(sz :. n) = do + Native{..} <- gets llvmTarget + let + ncpu = gangSize + stride = defaultLargePPT `min` ((n + ncpu - 1) `quot` ncpu) + steps = (n + stride - 1) `quot` stride + steps' = steps - 1 + -- + if ncpu == 1 || rank sz > 0 || n <= 2 * defaultLargePPT + then liftIO $ do + out <- allocateArray sh + sum <- allocateArray sz + execute executableR "scanS" $ \f -> + executeOp 1 fillP f gamma aenv (IE 0 (size sz)) (out,sum) + return (out,sum) + + else liftIO $ do + tmp <- allocateArray (Z :. steps) :: IO (Vector e) + out <- allocateArray sh + sum <- allocateArray sz + + execute executableR "scanP1" $ \f1 -> do + execute executableR "scanP2" $ \f2 -> do + execute executableR "scanP3" $ \f3 -> do + executeOp 1 fillP f1 gamma aenv (IE 0 steps) (stride, steps', out, tmp) + executeOp 1 fillS f2 gamma aenv (IE 0 steps) (sum, tmp) + executeOp 1 fillP f3 gamma aenv (IE 0 steps') (stride, out, tmp) + + return (out,sum) + + +-- Forward permutation, specified by an indexing mapping into an array and a +-- combination function to combine elements. +-- +permuteOp + :: (Shape sh, Shape sh', Elt e) + => ExecutableR Native + -> Gamma aenv + -> Aval aenv + -> Stream + -> Bool + -> sh + -> Array sh' e + -> LLVM Native (Array sh' e) +permuteOp NativeR{..} gamma aenv () inplace shIn dfs = do + Native{..} <- gets llvmTarget + out <- if inplace + then return dfs + else cloneArray dfs + let + ncpu = gangSize + n = size shIn + m = size (shape out) + -- + if ncpu == 1 || n <= defaultLargePPT + then liftIO $ do + -- sequential permutation + execute executableR "permuteS" $ \f -> + executeOp 1 fillS f gamma aenv (IE 0 n) out + + else liftIO $ do + -- parallel permutation + symbols <- nm executableR + if "permuteP_rmw" `elem` symbols + then do + execute executableR "permuteP_rmw" $ \f -> + executeOp defaultLargePPT fillP f gamma aenv (IE 0 n) out + + else do + barrier@(Array _ adb) <- allocateArray (Z :. m) :: IO (Vector Word8) + memset (ptrsOfArrayData adb) 0 m + execute executableR "permuteP_mutex" $ \f -> + executeOp defaultLargePPT fillP f gamma aenv (IE 0 n) (out, barrier) + + return out + + +stencil1Op + :: (Shape sh, Elt b) + => ExecutableR Native + -> Gamma aenv + -> Aval aenv + -> Stream + -> Array sh a + -> LLVM Native (Array sh b) +stencil1Op kernel gamma aenv stream arr = + simpleOp kernel gamma aenv stream (shape arr) + +stencil2Op + :: (Shape sh, Elt c) + => ExecutableR Native + -> Gamma aenv + -> Aval aenv + -> Stream + -> Array sh a + -> Array sh b + -> LLVM Native (Array sh c) +stencil2Op kernel gamma aenv stream arr brr = + simpleOp kernel gamma aenv stream (shape arr `intersect` shape brr) + + +-- Skeleton execution +-- ------------------ + +-- Execute the given function distributed over the available threads. +-- +executeOp + :: Marshalable args + => Int + -> Executable + -> (String, [Arg] -> IO ()) + -> Gamma aenv + -> Aval aenv + -> Range + -> args + -> IO () +executeOp ppt exe (name, f) gamma aenv r args = + runExecutable exe name ppt r $ \start end _tid -> + monitorProcTime $ + f =<< marshal (undefined::Native) () (start, end, args, (gamma, aenv)) + + +-- Standard C functions +-- -------------------- + +memset :: Ptr Word8 -> Word8 -> Int -> IO () +memset p w s = c_memset p (fromIntegral w) (fromIntegral s) >> return () + +foreign import ccall unsafe "string.h memset" c_memset + :: Ptr Word8 -> CInt -> CSize -> IO (Ptr Word8) + + +-- Debugging +-- --------- + +monitorProcTime :: IO a -> IO a +monitorProcTime = Debug.withProcessor Debug.Native + diff --git a/Data/Array/Accelerate/LLVM/Native/Execute/Async.hs b/Data/Array/Accelerate/LLVM/Native/Execute/Async.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/LLVM/Native/Execute/Async.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- | +-- Module : Data.Array.Accelerate.LLVM.Native.Execute.Async +-- Copyright : [2014..2017] Trevor L. McDonell +-- [2014..2014] Vinod Grover (NVIDIA Corporation) +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.LLVM.Native.Execute.Async ( + + Async, Stream, Event, + module Data.Array.Accelerate.LLVM.Execute.Async, + +) where + +-- accelerate +import Data.Array.Accelerate.LLVM.Execute.Async hiding ( Async ) +import qualified Data.Array.Accelerate.LLVM.Execute.Async as A + +import Data.Array.Accelerate.LLVM.Native.Target + + +type Async a = A.AsyncR Native a +type Stream = A.StreamR Native +type Event = A.EventR Native + +-- The native backend does everything synchronously. +-- +instance A.Async Native where + type StreamR Native = () + type EventR Native = () + + {-# INLINE fork #-} + fork = return () + + {-# INLINE join #-} + join () = return () + + {-# INLINE checkpoint #-} + checkpoint () = return () + + {-# INLINE after #-} + after () () = return () + + {-# INLINE block #-} + block () = return () + diff --git a/Data/Array/Accelerate/LLVM/Native/Execute/Environment.hs b/Data/Array/Accelerate/LLVM/Native/Execute/Environment.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/LLVM/Native/Execute/Environment.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} +-- | +-- Module : Data.Array.Accelerate.LLVM.Native.Execute.Environment +-- Copyright : [2014..2017] Trevor L. McDonell +-- [2014..2014] Vinod Grover (NVIDIA Corporation) +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.LLVM.Native.Execute.Environment ( + + Aval, aprj + +) where + +-- accelerate +import Data.Array.Accelerate.LLVM.Native.Target +import Data.Array.Accelerate.LLVM.Execute.Environment + +type Aval = AvalR Native + diff --git a/Data/Array/Accelerate/LLVM/Native/Execute/LBS.hs b/Data/Array/Accelerate/LLVM/Native/Execute/LBS.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/LLVM/Native/Execute/LBS.hs @@ -0,0 +1,34 @@ +-- | +-- Module : Data.Array.Accelerate.LLVM.Native.Execute.LBS +-- Copyright : [2014..2017] Trevor L. McDonell +-- [2014..2014] Vinod Grover (NVIDIA Corporation) +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.LLVM.Native.Execute.LBS + where + +-- Some default values for the profitable parallelism threshold (PPT). These are +-- chosen as to reduce the frequency of deque checks. Since a deque check also +-- requires returning from the foreign LLVM function back to the scheduler code, +-- it is important to combine fine-grained iterations via the PPT. +-- +-- The large PPT is meant for operations such as @map@ and @generate@, where the +-- input length equates the total number of elements to process. The small PPT +-- is meant for operations such as multidimensional reduction, where each input +-- index corresponds to a non-unit amount of work. +-- +-- These should really be dynamic values based on how long it took to execute +-- the last chunk, increase or decrease the chunk size to ensure quick +-- turnaround and also low scheduler overhead. +-- +defaultLargePPT :: Int +defaultLargePPT = 4096 + +defaultSmallPPT :: Int +defaultSmallPPT = 64 + diff --git a/Data/Array/Accelerate/LLVM/Native/Execute/Marshal.hs b/Data/Array/Accelerate/LLVM/Native/Execute/Marshal.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/LLVM/Native/Execute/Marshal.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +#if __GLASGOW_HASKELL__ <= 708 +{-# LANGUAGE OverlappingInstances #-} +{-# OPTIONS_GHC -fno-warn-unrecognised-pragmas #-} +#endif +-- | +-- Module : Data.Array.Accelerate.LLVM.Native.Execute.Marshal +-- Copyright : [2014..2017] Trevor L. McDonell +-- [2014..2014] Vinod Grover (NVIDIA Corporation) +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.LLVM.Native.Execute.Marshal ( + + Marshalable, M.marshal + +) where + +-- accelerate +import Data.Array.Accelerate.LLVM.CodeGen.Environment ( Gamma, Idx'(..) ) +import qualified Data.Array.Accelerate.LLVM.Execute.Marshal as M + +import Data.Array.Accelerate.LLVM.Native.Array.Data +import Data.Array.Accelerate.LLVM.Native.Execute.Async +import Data.Array.Accelerate.LLVM.Native.Execute.Environment +import Data.Array.Accelerate.LLVM.Native.Target + +-- libraries +import Data.DList ( DList ) +import qualified Data.DList as DL +import qualified Data.IntMap as IM +import qualified Foreign.LibFFI as FFI + + +-- Instances for the Native backend +-- +type Marshalable args = M.Marshalable Native args +type instance M.ArgR Native = FFI.Arg + + +-- Instances for handling concrete types in this backend, namely shapes and +-- array data. +-- +instance M.Marshalable Native Int where + marshal' _ _ x = return $ DL.singleton (FFI.argInt x) + +instance {-# OVERLAPS #-} M.Marshalable Native (Gamma aenv, Aval aenv) where + marshal' t s (gamma, aenv) + = fmap DL.concat + $ mapM (\(_, Idx' idx) -> M.marshal' t s (sync (aprj idx aenv))) (IM.elems gamma) + where + sync (AsyncR () a) = a + +instance ArrayElt e => M.Marshalable Native (ArrayData e) where + marshal' _ _ adata = return $ marshalR arrayElt adata + where + marshalR :: ArrayEltR e' -> ArrayData e' -> DList FFI.Arg + marshalR ArrayEltRunit _ = DL.empty + marshalR (ArrayEltRpair aeR1 aeR2) ad = + marshalR aeR1 (fstArrayData ad) `DL.append` + marshalR aeR2 (sndArrayData ad) + -- + marshalR ArrayEltRint ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad) + marshalR ArrayEltRint8 ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad) + marshalR ArrayEltRint16 ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad) + marshalR ArrayEltRint32 ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad) + marshalR ArrayEltRint64 ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad) + marshalR ArrayEltRword ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad) + marshalR ArrayEltRword8 ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad) + marshalR ArrayEltRword16 ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad) + marshalR ArrayEltRword32 ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad) + marshalR ArrayEltRword64 ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad) + marshalR ArrayEltRfloat ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad) + marshalR ArrayEltRdouble ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad) + marshalR ArrayEltRchar ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad) + marshalR ArrayEltRcshort ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad) + marshalR ArrayEltRcushort ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad) + marshalR ArrayEltRcint ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad) + marshalR ArrayEltRcuint ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad) + marshalR ArrayEltRclong ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad) + marshalR ArrayEltRculong ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad) + marshalR ArrayEltRcllong ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad) + marshalR ArrayEltRcullong ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad) + marshalR ArrayEltRcchar ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad) + marshalR ArrayEltRcschar ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad) + marshalR ArrayEltRcuchar ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad) + marshalR ArrayEltRcfloat ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad) + marshalR ArrayEltRcdouble ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad) + marshalR ArrayEltRbool ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad) + diff --git a/Data/Array/Accelerate/LLVM/Native/Foreign.hs b/Data/Array/Accelerate/LLVM/Native/Foreign.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/LLVM/Native/Foreign.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- | +-- Module : Data.Array.Accelerate.LLVM.Native.Foreign +-- Copyright : [2016..2017] Trevor L. McDonell +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.LLVM.Native.Foreign ( + + -- Foreign functions + ForeignAcc(..), + ForeignExp(..), + + -- useful re-exports + LLVM, + Native, + liftIO, + module Data.Array.Accelerate.LLVM.Native.Array.Data, + +) where + +import qualified Data.Array.Accelerate.Array.Sugar as S + +import Data.Array.Accelerate.LLVM.State +import Data.Array.Accelerate.LLVM.CodeGen.Sugar + +import Data.Array.Accelerate.LLVM.Foreign +import Data.Array.Accelerate.LLVM.Native.Array.Data +import Data.Array.Accelerate.LLVM.Native.Target + +import Control.Monad.State +import Data.Typeable + + +instance Foreign Native where + foreignAcc _ (ff :: asm (a -> b)) + | Just (ForeignAcc _ asm :: ForeignAcc (a -> b)) <- cast ff = Just (const asm) + | otherwise = Nothing + + foreignExp _ (ff :: asm (x -> y)) + | Just (ForeignExp _ asm :: ForeignExp (x -> y)) <- cast ff = Just asm + | otherwise = Nothing + + +instance S.Foreign ForeignAcc where + strForeign (ForeignAcc s _) = s + +instance S.Foreign ForeignExp where + strForeign (ForeignExp s _) = s + + +-- Foreign functions in the Native backend. +-- +-- This is just some arbitrary monadic computation. +-- +data ForeignAcc f where + ForeignAcc :: String + -> (a -> LLVM Native b) + -> ForeignAcc (a -> b) + +-- Foreign expressions in the Native backend. +-- +-- I'm not sure how useful this is; perhaps we want a way to splice in an +-- arbitrary llvm-general term, which would give us access to instructions not +-- currently encoded in Accelerate (i.e. SIMD operations, struct types, etc.) +-- +data ForeignExp f where + ForeignExp :: String + -> IRFun1 Native () (x -> y) + -> ForeignExp (x -> y) + +deriving instance Typeable ForeignAcc +deriving instance Typeable ForeignExp + diff --git a/Data/Array/Accelerate/LLVM/Native/State.hs b/Data/Array/Accelerate/LLVM/Native/State.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/LLVM/Native/State.hs @@ -0,0 +1,140 @@ +{-# LANGUAGE CPP #-} +-- | +-- Module : Data.Array.Accelerate.LLVM.Native.State +-- Copyright : [2014..2017] Trevor L. McDonell +-- [2014..2014] Vinod Grover (NVIDIA Corporation) +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.LLVM.Native.State ( + + evalNative, + createTarget, defaultTarget, + + Strategy, + balancedParIO, unbalancedParIO, + +) where + +-- accelerate +import Control.Parallel.Meta +import Control.Parallel.Meta.Worker +import qualified Control.Parallel.Meta.Trans.LBS as LBS +import qualified Control.Parallel.Meta.Resource.SMP as SMP +import qualified Control.Parallel.Meta.Resource.Single as Single +import qualified Control.Parallel.Meta.Resource.Backoff as Backoff + +import Data.Array.Accelerate.LLVM.State +import Data.Array.Accelerate.LLVM.Native.Target + +import qualified Data.Array.Accelerate.LLVM.Native.Debug as Debug + +-- library +import Data.Monoid +import System.IO.Unsafe +import Text.Printf + +import GHC.Conc + + +-- | Execute a computation in the Native backend +-- +evalNative :: Native -> LLVM Native a -> IO a +evalNative = evalLLVM + + +-- | Create a Native execution target by spawning a worker thread on each of the +-- given capabilities, and using the given strategy to load balance the workers +-- when executing parallel operations. +-- +createTarget + :: [Int] -- ^ CPU IDs to launch worker threads on + -> Strategy -- ^ Strategy to balance parallel workloads + -> IO Native +createTarget caps parallelIO = do + gang <- forkGangOn caps + return $! Native (length caps) (sequentialIO gang) (parallelIO gang) + + +-- | The strategy for balancing work amongst the available worker threads. +-- +type Strategy = Gang -> Executable + + +-- | Execute an operation sequentially on a single thread +-- +sequentialIO :: Strategy +sequentialIO gang = + Executable $ \name _ppt range fill -> + timed name $ runSeqIO gang range fill + + +-- | Execute a computation without load balancing. Each thread computes an +-- equally sized chunk of the input. No work stealing occurs. +-- +unbalancedParIO :: Strategy +unbalancedParIO gang = + Executable $ \name _ppt range fill -> + timed name $ runParIO Single.mkResource gang range fill + + +-- | Execute a computation where threads use work stealing (based on lazy +-- splitting of work stealing queues and exponential backoff) in order to +-- automatically balance the workload amongst themselves. +-- +balancedParIO + :: Int -- ^ number of steal attempts before backing off + -> Strategy +balancedParIO retries gang = + Executable $ \name ppt range fill -> + -- TLM: A suitable PPT should be chosen when invoking the continuation in + -- order to balance scheduler overhead with fine-grained function calls + -- + let resource = LBS.mkResource ppt (SMP.mkResource retries <> Backoff.mkResource) + in timed name $ runParIO resource gang range fill + + +-- Top-level mutable state +-- ----------------------- +-- +-- It is important to keep some information alive for the entire run of the +-- program, not just a single execution. These tokens use 'unsafePerformIO' to +-- ensure they are executed only once, and reused for subsequent invocations. +-- + +-- | Initialise the gang of threads that will be used to execute computations. +-- This spawns one worker on each capability, which can be set via +RTS -Nn. +-- +-- This globally shared thread gang is auto-initialised on startup and shared by +-- all computations (unless the user chooses to 'run' with a different gang). +-- +-- In a data parallel setting, it does not help to have multiple gangs running +-- at the same time. This is because a single data parallel computation should +-- already be able to keep all threads busy. If we had multiple gangs running at +-- the same time, then the system as a whole would run slower as the gangs +-- contend for cache and thrash the scheduler. +-- +{-# NOINLINE defaultTarget #-} +defaultTarget :: Native +defaultTarget = unsafePerformIO $ do + Debug.traceIO Debug.dump_gc (printf "gc: initialise native target with %d CPUs" numCapabilities) + case numCapabilities of + 1 -> createTarget [0] sequentialIO + n -> createTarget [0 .. n-1] (balancedParIO n) + + +-- Debugging +-- --------- + +{-# INLINE timed #-} +timed :: String -> IO a -> IO a +timed name f = Debug.timed Debug.dump_exec (elapsed name) f + +{-# INLINE elapsed #-} +elapsed :: String -> Double -> Double -> String +elapsed name x y = printf "exec: %s %s" name (Debug.elapsedP x y) + diff --git a/Data/Array/Accelerate/LLVM/Native/Target.hs b/Data/Array/Accelerate/LLVM/Native/Target.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/LLVM/Native/Target.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +-- | +-- Module : Data.Array.Accelerate.LLVM.Native.Target +-- Copyright : [2014..2017] Trevor L. McDonell +-- [2014..2014] Vinod Grover (NVIDIA Corporation) +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.LLVM.Native.Target ( + + module Data.Array.Accelerate.LLVM.Target, + module Data.Array.Accelerate.LLVM.Native.Target + +) where + +-- llvm-general +import LLVM.Target hiding ( Target ) +import LLVM.AST.DataLayout ( DataLayout ) + +-- accelerate +import Data.Array.Accelerate.Error ( internalError ) + +import Data.Array.Accelerate.LLVM.Target ( Target(..) ) +import Control.Parallel.Meta ( Executable ) + +-- standard library +import Control.Monad.Except +import System.IO.Unsafe + + +-- | Native machine code JIT execution target +-- +data Native = Native { + gangSize :: {-# UNPACK #-} !Int + , fillS :: {-# UNPACK #-} !Executable + , fillP :: {-# UNPACK #-} !Executable + } + +instance Target Native where + targetTriple _ = Just nativeTargetTriple + targetDataLayout _ = Just nativeDataLayout + + +-- | String that describes the native target +-- +{-# NOINLINE nativeTargetTriple #-} +nativeTargetTriple :: String +nativeTargetTriple = unsafePerformIO $ + -- A target triple suitable for loading code into the current process + getProcessTargetTriple + +-- | A description of the various data layout properties that may be used during +-- optimisation. +-- +{-# NOINLINE nativeDataLayout #-} +nativeDataLayout :: DataLayout +nativeDataLayout + = unsafePerformIO + $ fmap (either ($internalError "nativeDataLayout") id) + $ runExceptT (withNativeTargetMachine getTargetMachineDataLayout) + + +-- | Bracket the creation and destruction of a target machine for the native +-- backend running on this host. +-- +withNativeTargetMachine + :: (TargetMachine -> IO a) + -> ExceptT String IO a +withNativeTargetMachine = withHostTargetMachine + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,23 @@ +Copyright (c) [2014..2017] The Accelerate Team. All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the names of the contributors nor of their affiliations may + be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS ''AS IS'' AND ANY +EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL COPYRIGHT HOLDERS BE LIABLE FOR ANY +DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 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/accelerate-llvm-native.cabal b/accelerate-llvm-native.cabal new file mode 100644 --- /dev/null +++ b/accelerate-llvm-native.cabal @@ -0,0 +1,124 @@ +name: accelerate-llvm-native +version: 1.0.0.0 +cabal-version: >= 1.10 +tested-with: GHC == 7.8.* +build-type: Simple + +synopsis: Accelerate backend generating LLVM +description: + This library implements a backend for the /Accelerate/ language which + generates LLVM-IR targeting multicore CPUs. For further information, refer + to the main /Accelerate/ package: + + +license: BSD3 +license-file: LICENSE +author: Trevor L. McDonell +maintainer: Trevor L. McDonell +bug-reports: https://github.com/AccelerateHS/accelerate/issues +category: Compilers/Interpreters, Concurrency, Data, Parallelism + + +-- Configuration flags +-- ------------------- + +Flag debug + Default: True + Description: + Enable debug tracing message flags. Note that 'debug' must be enabled in the + base 'accelerate' package as well. See the 'accelerate' package for usage + and available options. + +Flag bounds-checks + Default: True + Description: Enable bounds checking + +Flag unsafe-checks + Default: True + Description: Enable bounds checking in unsafe operations + +Flag internal-checks + Default: True + Description: Enable internal consistency checks + + +-- Build configuration +-- ------------------- + +Library + exposed-modules: + Data.Array.Accelerate.LLVM.Native + Data.Array.Accelerate.LLVM.Native.Foreign + + other-modules: + Data.Array.Accelerate.LLVM.Native.Array.Data + Data.Array.Accelerate.LLVM.Native.Debug + Data.Array.Accelerate.LLVM.Native.Execute + Data.Array.Accelerate.LLVM.Native.State + Data.Array.Accelerate.LLVM.Native.Target + + Data.Array.Accelerate.LLVM.Native.Compile + Data.Array.Accelerate.LLVM.Native.Compile.Module + Data.Array.Accelerate.LLVM.Native.Compile.Link + Data.Array.Accelerate.LLVM.Native.Compile.Optimise + + Data.Array.Accelerate.LLVM.Native.CodeGen + Data.Array.Accelerate.LLVM.Native.CodeGen.Base + Data.Array.Accelerate.LLVM.Native.CodeGen.Fold + Data.Array.Accelerate.LLVM.Native.CodeGen.FoldSeg + Data.Array.Accelerate.LLVM.Native.CodeGen.Generate + Data.Array.Accelerate.LLVM.Native.CodeGen.Loop + Data.Array.Accelerate.LLVM.Native.CodeGen.Map + Data.Array.Accelerate.LLVM.Native.CodeGen.Permute + Data.Array.Accelerate.LLVM.Native.CodeGen.Scan + + Data.Array.Accelerate.LLVM.Native.Execute.Async + Data.Array.Accelerate.LLVM.Native.Execute.Environment + Data.Array.Accelerate.LLVM.Native.Execute.LBS + Data.Array.Accelerate.LLVM.Native.Execute.Marshal + + build-depends: + base >= 4.7 && < 4.10 + , accelerate == 1.0.* + , accelerate-llvm == 1.0.* + , containers >= 0.5 && < 0.6 + , directory >= 1.0 + , dlist >= 0.6 + , fclabels >= 2.0 + , libffi >= 0.1 + , llvm-hs >= 3.9 + , llvm-hs-pure >= 3.9 + , mtl >= 2.2.1 + , time >= 1.4 + + default-language: + Haskell2010 + + ghc-options: -O2 -Wall -fwarn-tabs + + if impl(ghc >= 8.0) + ghc-options: -Wmissed-specialisations + + if flag(debug) + cpp-options: -DACCELERATE_DEBUG + + if flag(bounds-checks) + cpp-options: -DACCELERATE_BOUNDS_CHECKS + + if flag(unsafe-checks) + cpp-options: -DACCELERATE_UNSAFE_CHECKS + + if flag(internal-checks) + cpp-options: -DACCELERATE_INTERNAL_CHECKS + + +source-repository head + type: git + location: https://github.com/AccelerateHS/accelerate-llvm.git + +source-repository this + type: git + tag: 1.0.0.0 + location: https://github.com/AccelerateHS/accelerate-llvm.git + +-- vim: nospell