diff --git a/LICENSE.md b/LICENSE.md new file mode 100644 --- /dev/null +++ b/LICENSE.md @@ -0,0 +1,23 @@ +[The MIT License (MIT)][] + +Copyright (c) 2017 Martin Braun + +Permission is hereby granted, free of charge, to any person obtaining a copy of +this software and associated documentation files (the "Software"), to deal in +the Software without restriction, including without limitation the rights to +use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies +of the Software, and to permit persons to whom the Software is furnished to do +so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. + +[The MIT License (MIT)]: https://opensource.org/licenses/MIT diff --git a/Parallel-Arrows-BaseSpec.cabal b/Parallel-Arrows-BaseSpec.cabal new file mode 100644 --- /dev/null +++ b/Parallel-Arrows-BaseSpec.cabal @@ -0,0 +1,62 @@ +-- This file has been generated from package.yaml by hpack version 0.20.0. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 2e1eaee8b7234a112a27864df9c9c2b2880c16f1768a7e233a90748284b60fa3 + +name: Parallel-Arrows-BaseSpec +version: 0.1.1.0 +synopsis: BaseSpecs used for @Parallel-Arrows-Definition@ and Co. +description: BaseSpecs used for @Parallel-Arrows-Definition@ and Co. This package contains tests for basic features and even skeletons. See the tests for the dummy backend (from @Parallel-Arrows-Definition@) in @src/test@ or one of the backends (e.g. @Parallel-Arrows-Multicore@) for actual implementations. +category: Parallelism,Arrows +homepage: https://github.com/s4ke/Parrows#readme +bug-reports: https://github.com/s4ke/Parrows/issues +maintainer: Martin Braun +license: MIT +license-file: LICENSE.md +build-type: Simple +cabal-version: >= 1.10 + +extra-source-files: + package.yaml + stack.yaml + +source-repository head + type: git + location: https://github.com/s4ke/Parrows + +library + hs-source-dirs: + src/main + ghc-options: -Wall + build-depends: + Parallel-Arrows-Definition ==0.1.1.0 + , base >=4.7 && <5.0 + , deepseq + , hspec ==2.* + , split + exposed-modules: + BaseSpec.BasicSpecBase + BaseSpec.CompleteSpecBase + BaseSpec.SkeletonCheckBase + BaseSpec.TorusSpecBase + other-modules: + Paths_Parallel_Arrows_BaseSpec + default-language: Haskell2010 + +test-suite spec + type: exitcode-stdio-1.0 + main-is: DefinitionSpec.hs + hs-source-dirs: + src/test + ghc-options: -Wall + build-depends: + Parallel-Arrows-BaseSpec + , Parallel-Arrows-Definition ==0.1.1.0 + , base + , hspec ==2.* + , split + other-modules: + DummySpec + Paths_Parallel_Arrows_BaseSpec + default-language: Haskell2010 diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,7 @@ +-- This script is used to build and install your package. Typically you don't +-- need to change it. The Cabal documentation has more information about this +-- file: . +import qualified Distribution.Simple + +main :: IO () +main = Distribution.Simple.defaultMain diff --git a/package.yaml b/package.yaml new file mode 100644 --- /dev/null +++ b/package.yaml @@ -0,0 +1,38 @@ +# This YAML file describes your package. Stack will automatically generate a +# Cabal file when you run `stack build`. See the hpack website for help with +# this file: . +category: Parallelism,Arrows +description: BaseSpecs used for @Parallel-Arrows-Definition@ and Co. + This package contains tests for basic features and even skeletons. + See the tests for the dummy backend (from @Parallel-Arrows-Definition@) in @src/test@ + or one of the backends (e.g. @Parallel-Arrows-Multicore@) for actual implementations. +extra-source-files: +- package.yaml +- stack.yaml +ghc-options: -Wall +github: s4ke/Parrows +library: + dependencies: + - base >= 4.7 && < 5.0 + - hspec == 2.* + - deepseq + - split + - Parallel-Arrows-Definition == 0.1.1.0 + source-dirs: src/main +tests: + spec: + source-dirs: src/test + main: DefinitionSpec.hs + dependencies: + - hspec == 2.* + - base + - Parallel-Arrows-BaseSpec + - Parallel-Arrows-Definition == 0.1.1.0 + - split +license: MIT +license-file: LICENSE.md +maintainer: Martin Braun +name: Parallel-Arrows-BaseSpec +synopsis: BaseSpecs used for @Parallel-Arrows-Definition@ and Co. + +version: '0.1.1.0' diff --git a/src/main/BaseSpec/BasicSpecBase.hs b/src/main/BaseSpec/BasicSpecBase.hs new file mode 100644 --- /dev/null +++ b/src/main/BaseSpec/BasicSpecBase.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +module BaseSpec.BasicSpecBase (basicSpec) where + +import Parrows.Definition +import Parrows.Future + +import Control.Arrow() + +import Test.Hspec +import Test.Hspec.QuickCheck + +basicSpec :: (ArrowParallel (->) Int Int (), + Future fut Int (), ArrowParallel (->) (fut Int) (fut Int) (), + ArrowParallel (->) (Either Int Int) (Either Int Int) ()) => Spec +basicSpec = describe "Basic Functionality Check" $ do + prop "Basic parEvalN" $ basicParEvalN + prop "parEvalNLazy" $ parEvalNLazyInt + prop "parEvalNFut" $ parEvalNFutInt + prop "parEval2" $ parEval2Int + where + basicParEvalN :: [Int] -> Bool + basicParEvalN xs = parEvalN () (repeat (+1)) xs == map (+1) xs + + parEvalNLazyInt :: [Int] -> Bool + parEvalNLazyInt xs = parEvalNLazy () 4 (repeat (+1)) xs == map (+1) xs + + parEvalNFutInt :: [Int] -> Bool + parEvalNFutInt xs = (map (get ()) (parEvalNFut () (repeat (+1)) (map (put ()) xs))) == map (+1) xs + + parEval2Int :: (Int, Int) -> Bool + parEval2Int (x, y) = (parEval2 () (+1) (*2) (x, y)) == (x+1,y*2) diff --git a/src/main/BaseSpec/CompleteSpecBase.hs b/src/main/BaseSpec/CompleteSpecBase.hs new file mode 100644 --- /dev/null +++ b/src/main/BaseSpec/CompleteSpecBase.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +module BaseSpec.CompleteSpecBase(specBase) where + +import BaseSpec.BasicSpecBase +import BaseSpec.SkeletonCheckBase +import BaseSpec.TorusSpecBase + +import Parrows.Definition +import Parrows.Future + +import Test.Hspec + +specBase :: ( + Future fut Int (), + Future fut [Matrix] (), + Future fut (([Int], [Int]), [Int]) (), + ArrowParallel (->) [Int] [Int] (), + ArrowParallel (->) (Int, [Int]) Int (), + ArrowParallel (->) (Either Int Int) (Either Int Int) (), + ArrowLoopParallel (->) Int Int (), + ArrowLoopParallel (->) [Matrix] [Matrix] (), + ArrowLoopParallel (->) (fut Int) (fut Int) (), + ArrowLoopParallel (->) (Int, fut Int) (Int, fut Int) (), + ArrowLoopParallel (->) (fut (([Int], [Int]), [Int])) (fut (([Int], [Int]), [Int])) (), + ArrowLoopParallel (->) ((Matrix, Matrix), fut [Matrix], fut [Matrix]) (Matrix, fut [Matrix], fut [Matrix]) ()) => + Spec +specBase = describe "Dummy Parrow Check" $ do + basicSpec + pipeSpec + ringSpec + mapSpec + mapReduceSpec + torusSpec diff --git a/src/main/BaseSpec/SkeletonCheckBase.hs b/src/main/BaseSpec/SkeletonCheckBase.hs new file mode 100644 --- /dev/null +++ b/src/main/BaseSpec/SkeletonCheckBase.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +module BaseSpec.SkeletonCheckBase where + +import Parrows.Definition +import Parrows.Skeletons.Topology +import Parrows.Skeletons.Map + +import Parrows.Future + +import Control.Arrow + +import Test.Hspec +import Test.Hspec.QuickCheck + +pipeSpec :: (ArrowLoopParallel (->) Int Int (), + Future fut Int (), ArrowLoopParallel (->) (fut Int) (fut Int) (), + Future fut (([Int], [Int]) ,[Int]) (), ArrowLoopParallel (->) (fut (([Int], [Int]), [Int])) (fut (([Int], [Int]), [Int])) ()) => Spec +pipeSpec = describe "Pipe Test" $ do + prop "Pipe 4 times (+1)" $ pipeTest + prop "Pipe (Future) 4 times (+1)" $ pipeSimpleTest + where + replicated :: [Int -> Int] + replicated = map (+) [1..4] + + expectedValue :: Int -> Int + expectedValue x = foldl (flip ($)) x replicated + + pipeTest :: Int -> Bool + pipeTest x = pipe () replicated x == expectedValue x + + pipeSimpleTest :: Int -> Bool + pipeSimpleTest x = pipeSimple () replicated x == expectedValue x + + pipeCombinatorTest :: Int -> Bool + pipeCombinatorTest x = (((+1) |>>>| (*2)) x) == (((+1) >>> (*2)) x) + +ringSpec :: (Future fut Int (), ArrowLoopParallel (->) (Int, fut Int) (Int, fut Int) (), + ArrowLoopParallel (->) Int Int ()) => Spec +ringSpec = describe "Ring Test" $ do + prop "" $ ringTest + where + values :: Int -> [Int] + values cnt = take cnt $ [1..] + + ringTest :: Int -> Bool + ringTest cnt = (ring () (\(x,y) -> (y, x+1)) (values cnt) ) == (rightRotate $ map (+1) (values cnt)) + + rightRotate :: [a] -> [a] + rightRotate [] = [] + rightRotate xs = last xs : init xs + +mapSpec :: (ArrowParallel (->) Int Int (), ArrowParallel (->) [Int] [Int] ()) => Spec +mapSpec = describe "mapTest" $ do + prop "parMap" $ parMapTest $ parMap () + prop "parMapStream" $ parMapTest $ parMapStream () 4 + prop "farm" $ parMapTest $ farm () 2 + prop "farmChunk" $ parMapTest $ farmChunk () 2 4 + where + parMapTest :: ((Int -> Int) -> ([Int] -> [Int])) -> [Int] -> Bool + parMapTest skel xs = skel (+1) xs == map (+1) xs + +mapReduceSpec :: (ArrowParallel (->) (Int, [Int]) Int ()) => Spec +mapReduceSpec = describe "parMapReduceDirect Test" $ + prop "Basic parMapReduceDirect Test" $ parMapReduceDirectTest + where + parMapReduceDirectTest :: [Int] -> Bool + parMapReduceDirectTest xs = (parMapReduceDirect () 4 (+1) (uncurry (*)) (0, xs)) == (foldl (*) 0 $ map (+1) xs) diff --git a/src/main/BaseSpec/TorusSpecBase.hs b/src/main/BaseSpec/TorusSpecBase.hs new file mode 100644 --- /dev/null +++ b/src/main/BaseSpec/TorusSpecBase.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +module BaseSpec.TorusSpecBase (torusSpec, Matrix) where + +import Test.Hspec +import Test.Hspec.QuickCheck + +import Parrows.Skeletons.Topology as P + +import Parrows.Definition +import Parrows.Future + +import Data.List +import Data.List.Split + +torusSpec :: (Future fut [Matrix] (), + ArrowLoopParallel (->) [Matrix] [Matrix] (), + ArrowLoopParallel (->) ((Matrix, Matrix), fut [Matrix], fut [Matrix]) (Matrix, fut [Matrix], fut [Matrix]) ()) + => Spec +torusSpec = describe "torus Test" $ do + prop "Basic Torus Test" $ torusTest + prop "Identity Torus Test" $ torusTestIdentity + where + vals = [1..256] + matrixA = toMatrix 256 (cycle vals) + matrixB = toMatrix 256 (cycle (tail vals)) + + torusTest :: Bool + torusTest = (prMM_torus noPe 256 matrixA matrixB) == (prMM matrixA matrixB) + + torusTestIdentity :: Bool + torusTestIdentity = (prMM_torus noPe 256 matrixA (identity 256)) == matrixA + +noPe :: Int +noPe = 4 + +type Vector = [Int] +type Matrix = [Vector] + +dimX :: Matrix -> Int +dimX = length + +dimY :: Matrix -> Int +dimY = length . head + +matAdd :: Matrix -> Matrix -> Matrix +matAdd x y + | dimX x /= dimX y = error "dimX x not equal to dimX y" + | dimY x /= dimY y = error "dimY x not equal to dimY y" + | otherwise = chunksOf (dimX x) $ zipWith (+) (concat x) (concat y) + +toMatrix :: Int -> [Int] -> Matrix +toMatrix cnt randoms = chunksOf n $ take (matrixIntSize n) randoms + where n = cnt + +identity :: Int -> Matrix +identity size = [((replicate (shift) 0) ++ [1] ++ (replicate (size-1-shift) 0)) | shift <- [0..size-1]] + +matrixIntSize :: Int -> Int +matrixIntSize n = n * n + +splitMatrix :: Int -> Matrix -> [[Matrix]] +splitMatrix size matrix = (map (transpose . map (chunksOf size)) $ chunksOf size $ matrix) + +prMM :: Matrix -> Matrix -> Matrix +prMM m1 m2 = prMMTr m1 (transpose m2) + where + prMMTr m1' m2' = [[sum (zipWith (*) row col) | col <- m2' ] | row <- m1'] + +-- 1 2 3 4 +-- 5 6 7 8 +-- 9 10 11 12 +-- 13 14 15 16 + +--let x = [[[[1,2],[5,6]],[[3,4],[7,8]]],[[[9,10],[13,14]],[[11,12],[15,16]]]] + +numCoreCalc :: Int -> Int +numCoreCalc num + | num <= 4 = 4 + | num <= 16 = 16 + | num <= 64 = 64 + | num <= 256 = 256 + | num <= 512 = 512 + | otherwise = error "too many cores!" + +prMM_torus :: (Future fut [Matrix] (), + ArrowLoopParallel (->) [Matrix] [Matrix] (), + ArrowLoopParallel (->) ((Matrix, Matrix), fut [Matrix], fut [Matrix]) (Matrix, fut [Matrix], fut [Matrix]) ()) + => Int -> Int -> Matrix -> Matrix -> Matrix +prMM_torus numCores problemSizeVal m1 m2 = combine $ torus () (mult torusSize) $ zipWith zip (split1 m1) (split2 m2) + where torusSize = (floor . sqrt) $ fromIntegral $ numCoreCalc numCores + combine x = concat (map ((map (concat)) . transpose) x) + split1 x = staggerHorizontally (splitMatrix (problemSizeVal `div` torusSize) x) + split2 x = staggerVertically (splitMatrix (problemSizeVal `div` torusSize) x) + + +--https://books.google.de/books?id=Hfnj5WmFVNUC&pg=PA499&lpg=PA499&dq=matrix+blockwise+multiplication+torus&source=bl&ots=H_jKeqVBJk&sig=GFIllvD9DKTXJaBMetoJyaLE-4A&hl=de&sa=X&ved=0ahUKEwjorcaTu9LYAhXEtBQKHQCVDSQQ6AEILjAB#v=onepage&q=matrix%20blockwise%20multiplication%20torus&f=false + +staggerHorizontally :: [[a]] -> [[a]] +staggerHorizontally matrix = zipWith leftRotate [0..] matrix + +staggerVertically :: [[a]] -> [[a]] +staggerVertically matrix = transpose $ zipWith leftRotate [0..] (transpose matrix) + +leftRotate :: Int -> [a] -> [a] +leftRotate i xs = xs2 ++ xs1 where + (xs1,xs2) = splitAt i xs + +mult :: Int -> ((Matrix,Matrix),[Matrix],[Matrix]) -> (Matrix,[Matrix],[Matrix]) +mult size ((sm1,sm2),sm1s,sm2s) = (result,toRight,toBottom) + where toRight = take (size-1) (sm1:sm1s) + toBottom = take (size-1) (sm2:sm2s) + sms = zipWith prMM (sm1:sm1s) (sm2:sm2s) + result = foldl1' matAdd sms diff --git a/src/test/DefinitionSpec.hs b/src/test/DefinitionSpec.hs new file mode 100644 --- /dev/null +++ b/src/test/DefinitionSpec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/src/test/DummySpec.hs b/src/test/DummySpec.hs new file mode 100644 --- /dev/null +++ b/src/test/DummySpec.hs @@ -0,0 +1,11 @@ +module DummySpec(spec) where + +import Parrows.Dummy.Simple() + +import BaseSpec.CompleteSpecBase + +import Test.Hspec + +spec :: Spec +spec = describe "Dummy PArrows Check" $ do + specBase diff --git a/stack.yaml b/stack.yaml new file mode 100644 --- /dev/null +++ b/stack.yaml @@ -0,0 +1,67 @@ +# This file was automatically generated by 'stack init' +# +# Some commonly used options have been documented as comments in this file. +# For advanced use and comprehensive documentation of the format, please see: +# http://docs.haskellstack.org/en/stable/yaml_configuration/ + +# Resolver to choose a 'specific' stackage snapshot or a compiler version. +# A snapshot resolver dictates the compiler version and the set of packages +# to be used for project dependencies. For example: +# +# resolver: lts-3.5 +# resolver: nightly-2015-09-21 +# resolver: ghc-7.10.2 +# resolver: ghcjs-0.1.0_ghc-7.10.2 +# resolver: +# name: custom-snapshot +# location: "./custom-snapshot.yaml" +resolver: lts-7.1 + +# User packages to be built. +# Various formats can be used as shown in the example below. +# +# packages: +# - some-directory +# - https://example.com/foo/bar/baz-0.0.2.tar.gz +# - location: +# git: https://github.com/commercialhaskell/stack.git +# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a +# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a +# extra-dep: true +# subdirs: +# - auto-update +# - wai +# +# A package marked 'extra-dep: true' will only be built if demanded by a +# non-dependency (i.e. a user package), and its test suites and benchmarks +# will not be run. This is useful for tweaking upstream packages. +packages: +- ../Definition +- '.' +# Dependency packages to be pulled from upstream that are not in the resolver +# (e.g., acme-missiles-0.3) +extra-deps: [] + +# Override default flag values for local packages and extra-deps +flags: {} + +# Extra package databases containing global packages +extra-package-dbs: [] + +# Control whether we use the GHC we find on the path +# system-ghc: true +# +# Require a specific version of stack, using version ranges +# require-stack-version: -any # Default +# require-stack-version: ">=1.1" +# +# Override the architecture used by stack, especially useful on Windows +# arch: i386 +# arch: x86_64 +# +# Extra directories used by stack for building +# extra-include-dirs: [/path/to/dir] +# extra-lib-dirs: [/path/to/dir] +# +# Allow a newer minor version of GHC than the snapshot specifies +# compiler-check: newer-minor