diff --git a/AccelerateSVM.hs b/AccelerateSVM.hs new file mode 100644 --- /dev/null +++ b/AccelerateSVM.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE TypeFamilies, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts #-} + +-- +-- | An instance demonstrating that the @Data.Array.Accelerate@ +-- library for GPU computation is able to support the SVM operations +-- + +module AccelerateSVM where +import qualified Data.Array.Accelerate as Accelerate +import ScanVectorMachine as SVM + +instance Accelerate.IsScalar s => SVM.ScanVectorMachine (Accelerate.Array Accelerate.DIM1) s where + neg a = error "FIXME: not implemented" + leq a b = error "FIXME: not implemented" + op o a b = error "FIXME: not implemented" + select b x y = error "FIXME: not implemented" + permute a i = error "FIXME: not implemented" + insert a pos s = error "FIXME: not implemented" + extract a pos = error "FIXME: not implemented" + distribute s len = error "FIXME: not implemented" + length a = error "FIXME: not implemented" + scan o a = error "FIXME: not implemented" diff --git a/DataParallelHaskellSVM.hs b/DataParallelHaskellSVM.hs new file mode 100644 --- /dev/null +++ b/DataParallelHaskellSVM.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE TypeFamilies, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts, ParallelArrays #-} + +-- +-- | An instance demonstrating that the parallel arrays @[:s:]@ of +-- Data Parallel Haskell support the SVM operations. In truth this +-- is a bit backward: DPH is a high-level nested data parallel +-- language which ought to /compile down to/ something like SVM. +-- Unfortunately DPH's @mapP@ allows closures and uncontained +-- recursion into the parallel context, so this isn't possible. +-- +module DataParallelHaskellSVM where +import ScanVectorMachine as SVM + +instance Num s => SVM.ScanVectorMachine ([::]) s where + neg a = error "FIXME: not implemented" + leq a b = error "FIXME: not implemented" + op o a b = error "FIXME: not implemented" + select b x y = error "FIXME: not implemented" + permute a i = error "FIXME: not implemented" + insert a pos s = error "FIXME: not implemented" + extract a pos = error "FIXME: not implemented" + distribute s len = error "FIXME: not implemented" + length a = error "FIXME: not implemented" + scan o a = error "FIXME: not implemented" diff --git a/NestedVectors.hs b/NestedVectors.hs new file mode 100644 --- /dev/null +++ b/NestedVectors.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE TypeFamilies, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts #-} + +-- +-- | Given an instance of @ScanVectorMachine V' (V S)@, we can produce +-- a type @V''@ and instance @ScanVectorMachine V'' (V' (V S))@. In +-- other words, given an implementation of vectors with some nonzero +-- nesting depth, this will produce an implementation with nesting +-- depth /one level deeper/. +-- +-- This is different from @SegmentedVectors@, which uses flat +-- vectors (0-deep nesting) to emulate segmented vectors (1-deep +-- nesting) by cutting the size of the scalars in half. Here, there +-- is no need to assume that the flat-vector scalars are twice as +-- wide (in terms of bits) as the segmented scalars, so arbitrarily +-- deep nesting may be achieved without sacrificing any additional +-- bit-width. In addition, @NestedVectors@ introduces less overhead +-- than @SegmentedVectors@. For this reason, many hardware/platform +-- providers choose to implement @ScanVectorMachine V' (V S)@ +-- instead of @ScanVectorMachine (V S)@; this requires more work +-- (more methods to implement), but eliminates the overhead of +-- @SegmentedVectors@. +-- + +module NestedVectors where +import ScanVectorMachine as SVM + +-- private; isomorphic to (,) +data VecPair v = VecPair v v + +-- sanity check that the two vectors have identical segment descriptors; if not, raise an error +check_eq a b = a -- FIXME: implement; for now we just trust the user + +instance (SVM.ScanVectorMachine v s, + SVM.ScanVectorMachine v' (v s)) => + SVM.ScanVectorMachine VecPair (v' (v s)) where + neg (VecPair a alens) = undefined + leq (VecPair a alens) (VecPair b blens) = undefined + op o (VecPair a alens) (VecPair b blens) = undefined + select (VecPair b blens) (VecPair x xlens) (VecPair y ylens) = undefined + permute (VecPair a alens) (VecPair i ilens) = undefined + insert (VecPair a alens) pos v = undefined + extract (VecPair a alens) pos = undefined + distribute v len = undefined + length (VecPair a alens) = undefined + scan o (VecPair a alens) = undefined diff --git a/ScanVectorMachine.hs b/ScanVectorMachine.hs --- a/ScanVectorMachine.hs +++ b/ScanVectorMachine.hs @@ -1,2 +1,83 @@ --- Placeholder +{-# LANGUAGE TypeFamilies, MultiParamTypeClasses #-} module ScanVectorMachine where + +-- | Scalar operations which may be performed on the elements of a +-- vector, either elementwise or in prefix-scan form. +data Op = And | Or | Min | Max | Plus | Times + +-- +-- | An instance of @ScanVectorMachine@ provides a scalar type @s@, +-- vectors of type @v s@ over that scalar of type, and the full +-- suite of Scan Vector Machine (SVM) operations (Blelloch'90, +-- page 60) on those vectors. The SVM instruction set is sometimes +-- referred to as /VCODE/ (CMU tech report CMU-CS-90-146-R). +-- +-- Only two changes have been made: (1) booleans are encoded as +-- scalars (zero is false, nonzero is true) and (2) Belloch's +-- elementwise subtraction has been replaced with a unary @neg@ +-- operation; this way the set of elementwise and scan operations are +-- the same (subtraction is not associative). +-- +-- Many of the names below overlap with those in the Prelude; we +-- recommend @import qualified ScanVectorMachine as SVM@ so that these +-- may be referred to as, for example, @SVM.length@. +-- +-- Notice that there is no @map :: (s -> s) -> v s -> v s@; this is +-- essential to keeping /closures/ and /uncontained recursion/ out of the +-- parallel context. See Blelloch 10.6.2 for the definition of +-- contained recursion. +-- +-- Also notice that only three operations involve communication +-- between different parts of the paralell context: @distribute@, +-- @scan@, and @permute@. The @distribute@ operation performs +-- broadcast communication from the serial context to the parallel +-- context. The @scan@ operation performs prefix scans, which have +-- very efficient communication patterns (do a local scan, then a +-- global tree reduction, then a local distribution, then an +-- elementwise operation). Only the @permute@ operation involves +-- complicated communication patterns. This is mitigated to some +-- extent by the requirement that @permute@ must be a /permutation/ of +-- the vector; it is an error to send two elements to the same +-- destination index, or to have a destination index to which no +-- element is sent. +-- +class ScanVectorMachine v s where + + -- | Scalar negation all of the elements of the vector. + neg :: v s -> v s + + -- | Elementwise less-than-or-equal-to comparison. Both vectors must be the same length. + leq :: v s -> v s -> v s + + -- | Elementwise operations (see @Op@). Both vectors must be the same length. + op :: Op -> v s -> v s -> v s + + -- | Prefix scan operations (see @Op@). + scan :: Op -> v s -> v s + + -- | If-then-else; @select b x y@ returns a vector whose @i@^th element is @if b[i] then x[i] else y[i]@. + -- All three vectors must be the same length. + select :: v s -> v s -> v s -> v s + + -- | Permutation: @permute v1 v2@ returns a vector @v3@ where @v3[v2[i]] = v1[i]@ for all @i@. Both vectors + -- must be the same length and the elements of @v2@ must all be distinct, non-negative, and + -- less than the lengths of the vectors. + permute :: v s -> v s -> v s + + -- | Replaces an element of a vector; @insert v s i e@ sets @i@^th element of the vector to @s@. The scalar @i@ must be + -- nonnegative and less than the length of the vector. This instruction implements unicast communication from the + -- serial context to the parallel context. + insert :: v s -> s -> s -> v s + + -- | Extracts an element of a vector; @extract v i@ yields @v[i]@. The scalar @i@ must be nonnegative and less than + -- the length of the vector. This instruction implements communication from the parallel context to the serial context. + extract :: v s -> s -> s + + -- | Creates a new vector; @distribute s n@ creates a vector of length @n@ whose elements are all @s@. + -- This instruction implements communication from the parallel context to the serial context. + distribute :: s -> s -> v s + + -- | Returns the length of a parallel vector. These can be cached in the serial context since the length of a vector + -- never depends on data from the paralell context; as a result @length@ does not actually involve communication. + length :: v s -> s + diff --git a/SegmentedScanVectorMachine.hs b/SegmentedScanVectorMachine.hs new file mode 100644 --- /dev/null +++ b/SegmentedScanVectorMachine.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE TypeFamilies, FlexibleInstances, MultiParamTypeClasses #-} + +-- | An instance of @SegmentedScanVectorMachine@ provides a scalar +-- type @s@, a vector type @v@, and a segmented vector +-- (vector-of-vectors) type @v'@ such that @v@ implements the SVM +-- operations over @s@ /and/ @v'@ implements the SVM operations over +-- @v s@. +-- +-- This file contains a default instance for @ScanVectorMachine V' (V S)@, +-- given an instance @ScanVectorMachine V S@. In other words, given an +-- implementation of vectors-of-scalars, this will produce an +-- implementation of vectors-of-vectors-of-scalars. +-- +-- This new type @V'@ provides SVM operations over +-- vectors-of-vectors-of-scalars; from the perspective of @V'@, the +-- vectors-of-scalars are called /segments/. Notice that @V'@ uses +-- vectors-of-scalars wherever ordinary scalars were previously +-- used. For example, when the /length/ operation is applied to a +-- vector-of-vectors the result is not a scalar, but rather a +-- vector-of-scalars giving the lengths of each of the segments. +-- This phenomenon is crucial to the replication theorem and +-- flattening transformation. +-- +-- It turns out that @V'@ is basically @(,)@ -- but this is not +-- exposed to the user. Blelloch outlines three encodings (figure +-- 4.2): head-flags, length, and head-pointer. The implementation +-- below uses the /length/ style since it can represent zero-length +-- vectors efficiently. +-- +-- It is sometimes advantageous for hardware/platform providers to +-- implement vectors-of-vectors-of-scalars directly (see +-- @NestedVectors.hs@ for the reasoning). To do this, implement the +-- class @SegmentedScanVectorMachine@ below. + +module SegmentedScanVectorMachine(SegmentedScanVectorMachine) where +import ScanVectorMachine as SVM + +-- sanity check that the two vectors have identical segment descriptors; if not, raise an error +check_eq a b = a -- FIXME: implement; for now we just trust the user + +class (SVM.ScanVectorMachine v s, + SVM.ScanVectorMachine v' (v' (v s))) => + SegmentedScanVectorMachine v' v s + +-- private; isomorphic to (,) +data SegVec v = SegVec v v + +-- | Default implementation of segments using an auxiliary segment-length vector +instance SVM.ScanVectorMachine v s => SVM.ScanVectorMachine SegVec (v s) where + neg (SegVec a alens) = SegVec (neg a) alens + leq (SegVec a alens) (SegVec b blens) = SegVec (leq a b) (check_eq alens blens) + op o (SegVec a alens) (SegVec b blens) = SegVec (op o a b) (check_eq alens blens) + select (SegVec b blens) (SegVec x xlens) (SegVec y ylens) = SegVec (select b x y) (check_eq blens (check_eq xlens ylens)) + permute (SegVec a alens) (SegVec i ilens) = undefined + insert (SegVec a alens) pos v = undefined + extract (SegVec a alens) pos = undefined + distribute v len = undefined + length (SegVec a alens) = undefined + scan o (SegVec a alens) = undefined diff --git a/SerialScanVectorMachine.hs b/SerialScanVectorMachine.hs new file mode 100644 --- /dev/null +++ b/SerialScanVectorMachine.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE TypeFamilies, FlexibleInstances, MultiParamTypeClasses #-} + +-- | A crude implementation of the ScanVectorMachine class using +-- Data.Array.IArray; no parallelism. Warning: outrageously +-- inefficient code ahead! + +module SerialScanVectorMachine(SSVM) where +import Data.Array.IArray +import ScanVectorMachine as SVM + +newtype SSVM e = SSVM { unSSVM :: Array e e } + +-- Array zip +azip :: Ix idx => Array idx e1 -> Array idx e2 -> Array idx (e1,e2) +azip x y = array (start, end) $ map (\i -> (i,((x!i),(y!i)))) (range (start,end)) + where + (xmin,xmax) = bounds x + (ymin,ymax) = bounds y + start = max xmin ymin + end = min xmax ymax + +op2func :: (Ix e, Ord e, Num e) => SVM.Op -> (e -> e -> e) +op2func And x y = if x/=0 && y/=0 then 1 else 0 +op2func Or x y = if x/=0 || y/=0 then 1 else 0 +op2func Min x y = if x < y then x else y +op2func Max x y = if x > y then x else y +op2func Plus x y = x+y +op2func Times x y = x*y + +instance (Ix e, Show e) => Show (SSVM e) where + show (SSVM a) = show $ elems a + +instance (Enum e, Ix e, Ord e, Num e) => SVM.ScanVectorMachine SSVM e where + neg (SSVM a) = SSVM $ amap (\x -> if x==0 then 1 else 0) a + leq (SSVM a) (SSVM b) = SSVM $ amap (\(x,y) -> if x <= y then 1 else 0) $ azip a b + op op (SSVM a) (SSVM b) = SSVM $ amap (uncurry $ op2func op) $ azip a b + select (SSVM b) (SSVM x) (SSVM y) = SSVM $ amap (\(b,(x,y)) -> if b/=0 then x else y) $ azip b (azip x y) + permute (SSVM a) (SSVM i) = SSVM $ array (bounds a) $ zip (elems i) (elems a) + insert (SSVM a) pos v = SSVM $ a // [(pos,v)] + extract (SSVM a) pos = a ! pos + distribute v len = SSVM $ array (0,(len-1)) [ (i,v) | i <- [0..(len-1)] ] + length (SSVM a) = max 0 (end-start+fromInteger 1) where (start,end) = bounds a + scan op (SSVM a) = SSVM $ array (bounds a) $ (0,0):(drop 1 result) + where + result = fst $ foldl mapfunc ([],0) (assocs a) + mapfunc (ret,acc) (i,e) = let acc' = op2func op e acc in (((i+1,acc'):ret),acc') diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs diff --git a/Setup.lhs b/Setup.lhs deleted file mode 100644 --- a/Setup.lhs +++ /dev/null diff --git a/Tests.hs b/Tests.hs new file mode 100644 --- /dev/null +++ b/Tests.hs @@ -0,0 +1,67 @@ +module Main(main) where +import Test.HUnit +import qualified ScanVectorMachine as SVM +import SerialScanVectorMachine +import System.Exit + +ones :: SSVM Int +ones = SVM.distribute 1 20 + +count :: SSVM Int +count = SVM.scan SVM.Plus ones + +mkLiteral :: [Int] -> SSVM Int +mkLiteral vals = let zeroes = SVM.distribute 0 (length vals) + in foldl (\vec -> \(i,e) -> SVM.insert vec i e) zeroes $ zip [0..(length vals-1)] vals + + +example_a = mkLiteral [5,1,3,4,3,9,2,6] +example_b = mkLiteral [2,5,3,8,1,3,6,2] +example_f = mkLiteral [1,0,0,0,1,1,0,1] +example_i = mkLiteral [2,5,4,3,1,6,0,7] + +main = do result <- + runTestTT $ TestList + -- section 4.1.2 of Blelloch's book + [ TestCase $ assertEqual "Ble90 4.1.2: A+B" + "[7,6,6,12,4,12,8,8]" + $ show $ SVM.op SVM.Plus example_a example_b + , TestCase $ assertEqual "Ble90 4.1.2: A*B" + "[10,5,9,32,3,27,12,12]" + $ show $ SVM.op SVM.Times example_a example_b + , TestCase $ assertEqual "Ble90 4.1.2: select(F,A,B)" + "[5,5,3,8,3,9,6,6]" + $ show $ SVM.select example_f example_a example_b + + -- section 4.1.3 of Blelloch's book + , TestCase $ assertEqual "Ble90 4.1.3: permute(A,I)" + "[-6,-4,0,-3,-2,-1,-5,-7]" + $ show $ SVM.permute (mkLiteral [0,-1,-2,-3,-4,-5,-6,-7]) example_i + + -- section 4.1.4 of Blelloch's book + , TestCase $ assertEqual "Ble90 4.1.4: A" + "[5,1,3,4,3,9,2,6]" + $ show example_a + , TestCase $ assertEqual "Ble90 4.1.4: +-scan(A)" + "[0,5,6,9,13,16,25,27]" + $ show $ SVM.scan SVM.Plus example_a + , TestCase $ assertEqual "Ble90 4.1.4: max-scan(A)" + "[0,5,5,5,5,5,9,9]" + $ show $ SVM.scan SVM.Max example_a + + -- section 4.1.5 of Blelloch's book + , TestCase $ assertEqual "Ble90 4.1.5: insert(A,3,999)" + "[5,1,3,999,3,9,2,6]" + $ show $ SVM.insert example_a 3 999 + , TestCase $ assertEqual "Ble90 4.1.5: extract(A,3)" + "4" + $ show $ SVM.extract example_a 3 + , TestCase $ assertEqual "Ble90 4.1.5: distribute(999,5)" + "[999,999,999,999,999]" + $ show $ (SVM.distribute 999 5 :: SSVM Int) + , TestCase $ assertEqual "Ble90 4.1.5: length(A)" + "8" + $ show $ SVM.length example_a + ] + let bad = errors result + failures result + System.Exit.exitWith $ if bad == 0 then ExitSuccess else ExitFailure bad diff --git a/scan-vector-machine.cabal b/scan-vector-machine.cabal --- a/scan-vector-machine.cabal +++ b/scan-vector-machine.cabal @@ -1,6 +1,6 @@ name: scan-vector-machine -version: 0.0.1 -Cabal-Version: >= 1.2 +version: 0.2 +Cabal-Version: >= 1.8 build-type: Simple synopsis: An implementation of the Scan Vector Machine instruction set in Haskell license: BSD3 @@ -11,3 +11,14 @@ library exposed-modules: ScanVectorMachine + , SerialScanVectorMachine + , SegmentedScanVectorMachine + , NestedVectors + , DataParallelHaskellSVM + , AccelerateSVM + build-depends: haskell2010, HUnit >=1.0, array, dph-par, accelerate + +Test-Suite Test + type: exitcode-stdio-1.0 + main-is: Tests.hs + build-depends: haskell2010, HUnit >=1.0, array