diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml index 6b2372d5..966744eb 100644 --- a/.github/workflows/haskell-ci.yml +++ b/.github/workflows/haskell-ci.yml @@ -8,9 +8,9 @@ # # For more information, see https://github.com/andreasabel/haskell-ci # -# version: 0.17.20230928 +# version: 0.17.20240110 # -# REGENDATA ("0.17.20230928",["github","parallel.cabal"]) +# REGENDATA ("0.17.20240110",["github","parallel.cabal"]) # name: Haskell-CI on: @@ -32,19 +32,19 @@ jobs: strategy: matrix: include: - - compiler: ghc-9.8.0.20230919 + - compiler: ghc-9.8.1 compilerKind: ghc - compilerVersion: 9.8.0.20230919 + compilerVersion: 9.8.1 setup-method: ghcup - allow-failure: true - - compiler: ghc-9.6.3 + allow-failure: false + - compiler: ghc-9.6.4 compilerKind: ghc - compilerVersion: 9.6.3 + compilerVersion: 9.6.4 setup-method: ghcup allow-failure: false - - compiler: ghc-9.4.7 + - compiler: ghc-9.4.8 compilerKind: ghc - compilerVersion: 9.4.7 + compilerVersion: 9.4.8 setup-method: ghcup allow-failure: false - compiler: ghc-9.2.8 @@ -65,32 +65,12 @@ jobs: - compiler: ghc-8.8.4 compilerKind: ghc compilerVersion: 8.8.4 - setup-method: hvr-ppa + setup-method: ghcup allow-failure: false - compiler: ghc-8.6.5 compilerKind: ghc compilerVersion: 8.6.5 - setup-method: hvr-ppa - allow-failure: false - - compiler: ghc-8.4.4 - compilerKind: ghc - compilerVersion: 8.4.4 - setup-method: hvr-ppa - allow-failure: false - - compiler: ghc-8.2.2 - compilerKind: ghc - compilerVersion: 8.2.2 - setup-method: hvr-ppa - allow-failure: false - - compiler: ghc-8.0.2 - compilerKind: ghc - compilerVersion: 8.0.2 - setup-method: hvr-ppa - allow-failure: false - - compiler: ghc-7.10.3 - compilerKind: ghc - compilerVersion: 7.10.3 - setup-method: hvr-ppa + setup-method: ghcup allow-failure: false fail-fast: false steps: @@ -98,23 +78,11 @@ jobs: run: | apt-get update apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5 - if [ "${{ matrix.setup-method }}" = ghcup ]; then - mkdir -p "$HOME/.ghcup/bin" - curl -sL https://downloads.haskell.org/ghcup/0.1.19.5/x86_64-linux-ghcup-0.1.19.5 > "$HOME/.ghcup/bin/ghcup" - chmod a+x "$HOME/.ghcup/bin/ghcup" - "$HOME/.ghcup/bin/ghcup" config add-release-channel https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-prereleases-0.0.7.yaml; - "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false) - "$HOME/.ghcup/bin/ghcup" install cabal 3.10.1.0 || (cat "$HOME"/.ghcup/logs/*.* && false) - else - apt-add-repository -y 'ppa:hvr/ghc' - apt-get update - apt-get install -y "$HCNAME" - mkdir -p "$HOME/.ghcup/bin" - curl -sL https://downloads.haskell.org/ghcup/0.1.19.5/x86_64-linux-ghcup-0.1.19.5 > "$HOME/.ghcup/bin/ghcup" - chmod a+x "$HOME/.ghcup/bin/ghcup" - "$HOME/.ghcup/bin/ghcup" config add-release-channel https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-prereleases-0.0.7.yaml; - "$HOME/.ghcup/bin/ghcup" install cabal 3.10.1.0 || (cat "$HOME"/.ghcup/logs/*.* && false) - fi + mkdir -p "$HOME/.ghcup/bin" + curl -sL https://downloads.haskell.org/ghcup/0.1.20.0/x86_64-linux-ghcup-0.1.20.0 > "$HOME/.ghcup/bin/ghcup" + chmod a+x "$HOME/.ghcup/bin/ghcup" + "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false) + "$HOME/.ghcup/bin/ghcup" install cabal 3.10.2.0 || (cat "$HOME"/.ghcup/logs/*.* && false) env: HCKIND: ${{ matrix.compilerKind }} HCNAME: ${{ matrix.compiler }} @@ -126,27 +94,18 @@ jobs: echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV" echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV" HCDIR=/opt/$HCKIND/$HCVER - if [ "${{ matrix.setup-method }}" = ghcup ]; then - HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER") - HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#') - HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#') - echo "HC=$HC" >> "$GITHUB_ENV" - echo "HCPKG=$HCPKG" >> "$GITHUB_ENV" - echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV" - echo "CABAL=$HOME/.ghcup/bin/cabal-3.10.1.0 -vnormal+nowrap" >> "$GITHUB_ENV" - else - HC=$HCDIR/bin/$HCKIND - echo "HC=$HC" >> "$GITHUB_ENV" - echo "HCPKG=$HCDIR/bin/$HCKIND-pkg" >> "$GITHUB_ENV" - echo "HADDOCK=$HCDIR/bin/haddock" >> "$GITHUB_ENV" - echo "CABAL=$HOME/.ghcup/bin/cabal-3.10.1.0 -vnormal+nowrap" >> "$GITHUB_ENV" - fi - + HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER") + HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#') + HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#') + echo "HC=$HC" >> "$GITHUB_ENV" + echo "HCPKG=$HCPKG" >> "$GITHUB_ENV" + echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV" + echo "CABAL=$HOME/.ghcup/bin/cabal-3.10.2.0 -vnormal+nowrap" >> "$GITHUB_ENV" HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))') echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV" echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV" echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV" - if [ $((HCNUMVER >= 90800)) -ne 0 ] ; then echo "HEADHACKAGE=true" >> "$GITHUB_ENV" ; else echo "HEADHACKAGE=false" >> "$GITHUB_ENV" ; fi + echo "HEADHACKAGE=false" >> "$GITHUB_ENV" echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV" echo "GHCJSARITH=0" >> "$GITHUB_ENV" env: @@ -175,18 +134,6 @@ jobs: repository hackage.haskell.org url: http://hackage.haskell.org/ EOF - if $HEADHACKAGE; then - cat >> $CABAL_CONFIG <> $CABAL_CONFIG <> cabal.project - if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo "package parallel" >> cabal.project ; fi - if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo " ghc-options: -Werror=missing-methods" >> cabal.project ; fi + echo "package parallel" >> cabal.project + echo " ghc-options: -Werror=missing-methods" >> cabal.project cat >> cabal.project <> cabal.project - fi $HCPKG list --simple-output --names-only | perl -ne 'for (split /\s+/) { print "constraints: $_ installed\n" unless /^(parallel)$/; }' >> cabal.project.local cat cabal.project cat cabal.project.local @@ -264,6 +208,9 @@ jobs: - name: build run: | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --write-ghc-environment-files=always + - name: tests + run: | + $CABAL v2-test $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --test-show-details=direct - name: cabal check run: | cd ${PKGDIR_parallel} || false @@ -280,10 +227,10 @@ jobs: rm -f cabal.project.local - name: constraint set containers-0.7 run: | - if [ $((HCNUMVER >= 80200 && HCNUMVER < 90800)) -ne 0 ] ; then $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --constraint='containers ^>= 0.7' all --dry-run ; fi - if [ $((HCNUMVER >= 80200 && HCNUMVER < 90800)) -ne 0 ] ; then cabal-plan topo | sort ; fi - if [ $((HCNUMVER >= 80200 && HCNUMVER < 90800)) -ne 0 ] ; then $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --constraint='containers ^>= 0.7' --dependencies-only -j2 all ; fi - if [ $((HCNUMVER >= 80200 && HCNUMVER < 90800)) -ne 0 ] ; then $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --constraint='containers ^>= 0.7' all ; fi + if [ $((HCNUMVER < 90800)) -ne 0 ] ; then $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --constraint='containers ^>= 0.7' all --dry-run ; fi + if [ $((HCNUMVER < 90800)) -ne 0 ] ; then cabal-plan topo | sort ; fi + if [ $((HCNUMVER < 90800)) -ne 0 ] ; then $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --constraint='containers ^>= 0.7' --dependencies-only -j2 all ; fi + if [ $((HCNUMVER < 90800)) -ne 0 ] ; then $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --constraint='containers ^>= 0.7' all ; fi - name: save cache uses: actions/cache/save@v3 if: always() diff --git a/Control/Parallel/Strategies.hs b/Control/Parallel/Strategies.hs index 3c699ac6..79f2e496 100644 --- a/Control/Parallel/Strategies.hs +++ b/Control/Parallel/Strategies.hs @@ -216,11 +216,11 @@ newtype Eval a = Eval {unEval_ :: IO a} -- | Run the evaluation. runEval :: Eval a -> a -# if MIN_VERSION_base(4,4,0) +#if MIN_VERSION_base(4,4,0) runEval = unsafeDupablePerformIO . unEval_ -# else +#else runEval = unsafePerformIO . unEval_ -# endif +#endif -- | Run the evaluation in the 'IO' monad. This allows sequencing of -- evaluations relative to 'IO' actions. @@ -530,6 +530,8 @@ evalTraversable = traverse {-# INLINE evalTraversable #-} -- | Like 'evalTraversable', but evaluates all elements in parallel. +-- +-- > parTraversable = evalTraversable . rparWith parTraversable :: Traversable t => Strategy a -> Strategy (t a) parTraversable strat = evalTraversable (rparWith strat) {-# INLINE parTraversable #-} @@ -549,6 +551,8 @@ evalList = evalTraversable -- | Evaluate each element of a list in parallel according to given strategy. -- Equivalent to 'parTraversable' at the list type. +-- +-- > parList = evalList . rparWith parList :: Strategy a -> Strategy [a] parList = parTraversable -- Alternative definition via evalList: @@ -652,7 +656,7 @@ evalBufferWHNF n0 xs0 = return (ret xs0 (start n0 xs0)) -- > evalBuffer n r0 == evalBuffer n rseq -- evalBuffer :: Int -> Strategy a -> Strategy [a] -evalBuffer n strat = evalBufferWHNF n . map (withStrategy strat) +evalBuffer n strat = evalBufferWHNF n . map (withStrategy strat) -- Like evalBufferWHNF, but sparks the list elements when pushing them -- into the buffer. diff --git a/Control/Seq.hs b/Control/Seq.hs index 04e14876..b49a7b82 100644 --- a/Control/Seq.hs +++ b/Control/Seq.hs @@ -164,6 +164,8 @@ seqArrayBounds :: Ix i => Strategy i -> Strategy (Array i a) seqArrayBounds strat = seqTuple2 strat strat . Data.Array.bounds -- | Evaluate the keys and values of a map according to the given strategies. +-- +-- Note: A 'Map' is strict in its keys, so the keys will always be at least in WHNF. seqMap :: Strategy k -> Strategy v -> Strategy (Map k v) seqMap stratK stratV = seqList (seqTuple2 stratK stratV) . Data.Map.toList diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 index 6fa548ca..00000000 --- a/Setup.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Main (main) where - -import Distribution.Simple - -main :: IO () -main = defaultMain diff --git a/cabal.project b/cabal.project deleted file mode 100644 index e6fdbadb..00000000 --- a/cabal.project +++ /dev/null @@ -1 +0,0 @@ -packages: . diff --git a/parallel.cabal b/parallel.cabal index 270f53d9..714a71b3 100644 --- a/parallel.cabal +++ b/parallel.cabal @@ -12,24 +12,14 @@ category: Control, Parallelism build-type: Simple tested-with: - GHC == 9.8.0 - GHC == 9.6.3 - GHC == 9.4.7 + GHC == 9.8.1 + GHC == 9.6.4 + GHC == 9.4.8 GHC == 9.2.8 GHC == 9.0.2 GHC == 8.10.7 GHC == 8.8.4 GHC == 8.6.5 - GHC == 8.4.4 - GHC == 8.2.2 - GHC == 8.0.2 - GHC == 7.10.3 - -- Drop these old GHCs from CI: - -- GHC == 7.8.4 - -- GHC == 7.6.3 - -- GHC == 7.4.2 - -- GHC == 7.2.2 - -- GHC == 7.0.4 description: This package provides a library for parallel programming. @@ -68,11 +58,24 @@ library containers >= 0.4 && < 0.8, deepseq >= 1.1 && < 1.6 - ghc-options: -Wall - - if impl(ghc >= 6.11) + ghc-options: + -Wall -- To improve parallel performance: - ghc-options: -feager-blackholing + -feager-blackholing if impl(ghc >= 7.2.1) build-depends: ghc-prim + +test-suite tests + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: Main.hs + other-modules: + Par + Seq + Util + + build-depends: array, base, containers, nothunks, parallel, tasty, tasty-hunit + + ghc-options: -Wall -threaded diff --git a/prologue.txt b/prologue.txt deleted file mode 100644 index 50a0fc4f..00000000 --- a/prologue.txt +++ /dev/null @@ -1 +0,0 @@ -This package provides a library for parallel programming. diff --git a/tests/.gitignore b/tests/.gitignore deleted file mode 100644 index 0f6f0c44..00000000 --- a/tests/.gitignore +++ /dev/null @@ -1,14 +0,0 @@ -.hpc*/ -*.o -*.hi -*.comp.std* -*.run.std* -*.eventlog -*.genscript -*.exe - -# specific files -/T2185 -/par001 -/par002 -/par003 diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 index 00000000..180bda44 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,24 @@ +import Test.Tasty +import Test.Tasty.HUnit + +import Control.Parallel + +import qualified Par +import qualified Seq + +parnofib :: Int -> Int +parnofib 0 = 1 +parnofib 1 = 1 +parnofib n = + let n1 = parnofib (n - 1) + n2 = parnofib (n - 2) + in n1 `par` n2 `pseq` n1 + n2 + 1 + +main :: IO () +main = defaultMain $ testGroup "parallel" + [ testGroup "Control.Parallel" + [ testCase "parnofib" $ parnofib 30 @?= 2692537 + ] + , Par.tests + , Seq.tests + ] diff --git a/tests/Makefile b/tests/Makefile deleted file mode 100644 index c3edbed4..00000000 --- a/tests/Makefile +++ /dev/null @@ -1,25 +0,0 @@ -# This Makefile runs the tests using GHC's testsuite framework. It -# assumes the package is part of a GHC build tree with the testsuite -# installed in ../../../testsuite. - -TOP=../../../testsuite -include $(TOP)/mk/boilerplate.mk -include $(TOP)/mk/test.mk - - -.PHONY: par003 -par003 : - @echo Compiling - "$(TEST_HC)" -v0 -fforce-recomp --make par003.hs -o par003 -threaded -rtsopts - @echo Running - yes abqszzzq 2>/dev/null | head -n 11111 | ./par003 +RTS -N2 - @echo Done - - -.PHONY: par004 -par004 : - @echo Compiling - "$(TEST_HC)" -v0 -fforce-recomp --make par004.hs -o par004 -threaded -rtsopts - @echo Running - ./par004 +RTS -N2 - @echo Done diff --git a/tests/Par.hs b/tests/Par.hs new file mode 100644 index 00000000..c7ad8334 --- /dev/null +++ b/tests/Par.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE CPP, ExistentialQuantification, RankNTypes #-} + +module Par (tests) where + +#if !MIN_VERSION_base(4,18,0) +import Control.Applicative (liftA2) +#endif +import Control.Concurrent (threadDelay) +import Data.Coerce (coerce) +import Data.Foldable (traverse_) +import Data.Functor.Identity +import Test.Tasty +import Test.Tasty.HUnit + +import Control.Parallel.Strategies + +import Util + +data TestStrategy = forall a. TestStrategy + { name :: TestName + , value :: () -> a + , strat :: Strategy a + , assertEval :: a -> Assertion + } + +testEval :: TestStrategy -> TestTree +testEval (TestStrategy name value strat assertEval) = testCase name $ do + let a = value () + x <- withStrategyIO strat a + assertEval x + +mapTestStrategy + :: (forall a. (() -> a) -> () -> f a) + -> (forall a. Strategy a -> Strategy (f a)) + -> (forall a. (a -> Assertion) -> f a -> Assertion) + -> TestStrategy + -> TestStrategy +mapTestStrategy f g h (TestStrategy name value strat assertSeq) = TestStrategy name (f value) (g strat) (h assertSeq) + +map2TestStrategy + :: (forall a b. (() -> a) -> (() -> b) -> () -> f a b) + -> (forall a b. Strategy a -> Strategy b -> Strategy (f a b)) + -> (forall a b. (a -> Assertion) -> (b -> Assertion) -> f a b -> Assertion) + -> TestStrategy + -> TestStrategy + -> TestStrategy +map2TestStrategy f g h (TestStrategy name1 value1 strat1 assertSeq1) (TestStrategy name2 value2 strat2 assertSeq2) = + TestStrategy (name1 ++ " " ++ name2) (f value1 value2) (g strat1 strat2) (h assertSeq1 assertSeq2) + +test_r0 :: TestStrategy +test_r0 = TestStrategy { name = "r0", value = const undefined, strat = r0, assertEval = discard } + +test_rseq :: TestStrategy +test_rseq = TestStrategy { name = "rseq", value = const (just undefined :: Maybe ()), strat = rseq, assertEval = assertWHNF } + +test_rpar :: TestStrategy +test_rpar = TestStrategy { name = "rpar", value = const (undefined :: Maybe ()), strat = rpar, assertEval = \x -> threadDelay 10000 >> assertWHNF x } + +test_rdeepseq :: TestStrategy +test_rdeepseq = TestStrategy { name = "rdeepseq", value = const (just (just ())), strat = rdeepseq, assertEval = assertNF } + +basicStrategies :: [TestStrategy] +basicStrategies = [test_r0, test_rseq, test_rpar, test_rdeepseq] + +testStrategies + :: (forall a. (() -> a) -> () -> f a) + -> (forall a. Strategy a -> Strategy (f a)) + -> (forall a. (a -> Assertion) -> f a -> Assertion) + -> [TestTree] +testStrategies f g h = map (testEval . mapTestStrategy f g h) basicStrategies + +testStrategies2 + :: (forall a b. (() -> a) -> (() -> b) -> () -> f a b) + -> (forall a b. Strategy a -> Strategy b -> Strategy (f a b)) + -> (forall a b. (a -> Assertion) -> (b -> Assertion) -> f a b -> Assertion) + -> [TestTree] +testStrategies2 f g h = liftA2 (testEval .: map2TestStrategy f g h) basicStrategies basicStrategies + where + (.:) = (.) . (.) + +tests :: TestTree +tests = testGroup "Control.Parallel.Strategies" + [ testEval test_r0 + , testEval test_rseq + , testEval test_rpar + , testEval test_rdeepseq + -- FIXME + --, testGroup "rparWith" $ + -- testStrategies (Identity .) (coerce . rparWith) (\assert -> \x -> threadDelay 10000 >> assert (runIdentity x)) + , testGroup "evalTraversable" $ + testStrategies (\v -> \_ -> [v (), v ()]) evalTraversable traverse_ + , testGroup "evalTuple2" $ + testStrategies2 (\v1 v2 -> \_ -> (v1 (), v2 ())) evalTuple2 (\assert1 assert2 -> \(x, y) -> assert1 x >> assert2 y) + ] diff --git a/tests/Seq.hs b/tests/Seq.hs new file mode 100644 index 00000000..7b24557e --- /dev/null +++ b/tests/Seq.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE CPP, ExistentialQuantification, RankNTypes #-} + +module Seq (tests) where + +#if !MIN_VERSION_base(4,18,0) +import Control.Applicative (liftA2) +#endif +import qualified Data.Array as A +import Data.Foldable (traverse_) +import qualified Data.Map as Map + +import Test.Tasty +import Test.Tasty.HUnit + +import Control.Seq + +import Util + +data TestStrategy = forall a. TestStrategy + { name :: TestName + , value :: () -> a + , strat :: Strategy a + , assertSeq :: a -> Assertion + } + +testSeq :: TestStrategy -> TestTree +testSeq (TestStrategy name value strat assertSeq) = testCase name $ do + let a = value () + strat a @?= () + assertSeq a + +mapTestStrategy + :: (forall a. (() -> a) -> () -> f a) + -> (forall a. Strategy a -> Strategy (f a)) + -> (forall a. (a -> Assertion) -> f a -> Assertion) + -> TestStrategy + -> TestStrategy +mapTestStrategy f g h (TestStrategy name value strat assertSeq) = TestStrategy name (f value) (g strat) (h assertSeq) + +map2TestStrategy + :: (forall a b. (() -> a) -> (() -> b) -> () -> f a b) + -> (forall a b. Strategy a -> Strategy b -> Strategy (f a b)) + -> (forall a b. (a -> Assertion) -> (b -> Assertion) -> f a b -> Assertion) + -> TestStrategy + -> TestStrategy + -> TestStrategy +map2TestStrategy f g h (TestStrategy name1 value1 strat1 assertSeq1) (TestStrategy name2 value2 strat2 assertSeq2) = + TestStrategy (name1 ++ " " ++ name2) (f value1 value2) (g strat1 strat2) (h assertSeq1 assertSeq2) + +test_r0 :: TestStrategy +test_r0 = TestStrategy { name = "r0", value = const undefined, strat = r0, assertSeq = discard } + +test_rseq :: TestStrategy +test_rseq = TestStrategy { name = "rseq", value = const (just undefined :: Maybe ()), strat = rseq, assertSeq = assertWHNF } + +test_rdeepseq :: TestStrategy +test_rdeepseq = TestStrategy { name = "rdeepseq", value = const (just (just ())), strat = rdeepseq, assertSeq = assertNF } + +basicStrategies :: [TestStrategy] +basicStrategies = [test_r0, test_rseq, test_rdeepseq] + +testStrategies + :: (forall a. (() -> a) -> () -> f a) + -> (forall a. Strategy a -> Strategy (f a)) + -> (forall a. (a -> Assertion) -> f a -> Assertion) + -> [TestTree] +testStrategies f g h = map (testSeq . mapTestStrategy f g h) basicStrategies + +testStrategies2 + :: (forall a b. (() -> a) -> (() -> b) -> () -> f a b) + -> (forall a b. Strategy a -> Strategy b -> Strategy (f a b)) + -> (forall a b. (a -> Assertion) -> (b -> Assertion) -> f a b -> Assertion) + -> [TestTree] +testStrategies2 f g h = liftA2 (testSeq .: map2TestStrategy f g h) basicStrategies basicStrategies + where + (.:) = (.) . (.) + +tests :: TestTree +tests = testGroup "Control.Seq" $ + [ testSeq test_r0 + , testSeq test_rseq + , testSeq test_rdeepseq + , testGroup "seqList" $ + testStrategies (\v -> \_ -> [v (), v ()]) seqList traverse_ + , testGroup "seqFoldable" $ + testStrategies (\v -> \_ -> Just (v ())) seqFoldable traverse_ + , testGroup "seqMap" $ + -- keys are ignored, since a Map is strict in its keys anyway + testStrategies (\v -> \_ -> Map.fromList [(1 :: Int, v ()), (2, v ())]) (seqMap r0) (\assertSeq -> traverse_ (\(_k, v) -> assertSeq v) . Map.toList) + , testGroup "seqArray" $ + testStrategies (\v -> \_ -> A.listArray (0 :: Int, 1) [v (), v ()]) seqArray traverse_ + , testGroup "seqTuple2" $ + testStrategies2 (\v1 v2 -> \_ -> (v1 (), v2 ())) seqTuple2 (\assert1 assert2 -> \(x, y) -> assert1 x >> assert2 y) + ] diff --git a/tests/Util.hs b/tests/Util.hs new file mode 100644 index 00000000..8d679113 --- /dev/null +++ b/tests/Util.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE ExistentialQuantification, RankNTypes #-} + +module Util + ( isNF + , isWHNF + , discard + , assertNF + , assertWHNF + , just + ) where + +import Data.Maybe (isNothing) +import Data.Typeable (Typeable) +import NoThunks.Class + +import Test.Tasty.HUnit + +isNF :: (NoThunks a) => a -> IO Bool +isNF x = isNothing <$> noThunks [] x + +isWHNF :: (Typeable a) => a -> IO Bool +isWHNF x = isNothing <$> noThunks [] (OnlyCheckWhnf x) + +discard :: a -> Assertion +discard _ = pure () + +assertNF :: (NoThunks a) => a -> Assertion +assertNF x = isNF x @? "value is not in NF" + +assertWHNF :: (Typeable a) => a -> Assertion +assertWHNF x = isWHNF x @? "value is not in WHNF" + +-- used to create a thunk +just :: a -> Maybe a +just = Just +{-# NOINLINE just #-} diff --git a/tests/all.T b/tests/all.T deleted file mode 100644 index bf46e633..00000000 --- a/tests/all.T +++ /dev/null @@ -1,20 +0,0 @@ -test('par001', only_ways(['threaded1', 'threaded2']), - compile_and_run, ['-package parallel']) - -test('par002', only_ways(['threaded2']), - compile_and_run, ['-O0 -package parallel']) - - -test('par003', req_smp, run_command, ['$MAKE -s --no-print-directory par003']) - -test('T2185', [when(fast(), skip), reqlib('parallel'), - extra_run_opts('+RTS -M16m -RTS'), - only_ways(['threaded1','threaded2'])], - # threaded1 demonstrates the bug: sparks were treated as roots by GC - multimod_compile_and_run, ['T2185','']) - -test('rparWith_r0', only_ways(['threaded1', 'threaded2']), - compile_and_run, ['-package parallel']) - -test('pareval', only_ways(['threaded1', 'threaded2']), - compile_and_run, ['-package parallel']) diff --git a/tests/par001.hs b/tests/par001.hs deleted file mode 100644 index 4f25c36a..00000000 --- a/tests/par001.hs +++ /dev/null @@ -1,11 +0,0 @@ -import Control.Parallel - -parfib 0 = return 1 -parfib 1 = return 1 -parfib n = do - n1 <- parfib (n - 1) - n2 <- parfib (n - 2) - n3 <- (n1 `par` (n2 `seq` (return (n1 + n2 + 1)))) - return n3 - -main = do x <- parfib 30; print x diff --git a/tests/par001.stdout b/tests/par001.stdout deleted file mode 100644 index f108de6a..00000000 --- a/tests/par001.stdout +++ /dev/null @@ -1 +0,0 @@ -2692537 diff --git a/tests/par002.hs b/tests/par002.hs deleted file mode 100644 index 0b14a72a..00000000 --- a/tests/par002.hs +++ /dev/null @@ -1,24 +0,0 @@ --- test for a bug in blackhole handling in the garbage collector, --- fixed on 7/4/2006. The symptom is that stdout gets finalized too --- early, and the main thread fails when writing to it. Only happens --- with +RTS -N2, and must be compiled without optimisation. - -module Main (main) where - -import Control.Parallel.Strategies -import Control.Exception - -f x 0 = x -f x y = f ((x+y)-y) (y-1) - -bigcomputation :: Int -> Int -bigcomputation x = f x 50000 - -main = do - let seeds = [1..12] - let seeds2 = map bigcomputation seeds - mapM (\v -> putStr ((show v) ++ " " )) seeds - putStr "\n" - evaluate (seeds2 `using` parList rwhnf) - mapM (\v -> putStr ((show v) ++ " " )) seeds2 - putStr "\n" diff --git a/tests/par002.stdout b/tests/par002.stdout deleted file mode 100644 index 83a08437..00000000 --- a/tests/par002.stdout +++ /dev/null @@ -1,2 +0,0 @@ -1 2 3 4 5 6 7 8 9 10 11 12 -1 2 3 4 5 6 7 8 9 10 11 12 diff --git a/tests/par003.hs b/tests/par003.hs deleted file mode 100644 index 4dcd2825..00000000 --- a/tests/par003.hs +++ /dev/null @@ -1,22 +0,0 @@ -import Data.List -import Data.Char -import Control.Parallel -import System.IO - -{-# NOINLINE fool #-} --- 'fool' just makes sure CSE doesn't meddle with the code below -fool :: [a] -> [a] -fool (x:xs) = xs - -main = do - hSetBuffering stdin NoBuffering - hs <- getContents - let -- create copies of the input - ts = map (:hs) ['a'..'z'] - -- sum the characters of each copy - qs = map (foldl' (+) 0 . map ord . fool) ts - -- in parallel - rs = foldr (\x y -> x `par` y `par` (x:y)) [] qs - -- compare the results and print 'True' if they are all equal. - -- This should never print 'False' - print $ all (uncurry (==)) $ zip rs (tail rs) diff --git a/tests/par003.stdout b/tests/par003.stdout deleted file mode 100644 index e81ece6b..00000000 --- a/tests/par003.stdout +++ /dev/null @@ -1,4 +0,0 @@ -Compiling -Running -True -Done diff --git a/tests/par004.hs b/tests/par004.hs deleted file mode 100644 index dd3d8670..00000000 --- a/tests/par004.hs +++ /dev/null @@ -1,34 +0,0 @@ --- Checks if runEvalIO sequence the evaluation with the IO actions as expected. - -import Control.Parallel.Strategies -import Control.Concurrent -import System.IO.Unsafe - -longrunning :: Int -> IO () -longrunning decisecs = do - threadDelay $ 10^(5::Int) * decisecs - putStr ("Thread has been delayed by " ++ shows decisecs "/10 seconds.\n") - -interleavedPrint :: String -> () -interleavedPrint = unsafePerformIO . putStrLn - -main :: IO () -main = do - -- check runEvalIO . r0 - lastused <- runEvalIO . r0 - $ interleavedPrint "Should be printed at the end." - _ <- runEvalIO . r0 $ interleavedPrint "Should never be printed." - - -- check runEvalIO . rseq - _ <- runEvalIO . rseq $ interleavedPrint "Should be printed first." - - -- check runEvalIO . rpar - -- - -- When using the threaded runtime the spark should print its text before - -- the main thread. If the unthreaded runtime is used it should never be - -- printed. - unit <- runEvalIO . rpar . unsafePerformIO $ longrunning 1 - longrunning 2 - return unit -- make sure unit is not garbage collected - - return $! lastused -- force printing now diff --git a/tests/par004.stdout b/tests/par004.stdout deleted file mode 100644 index 67d4ee44..00000000 --- a/tests/par004.stdout +++ /dev/null @@ -1,7 +0,0 @@ -Compiling -Running -Should be printed first. -Thread has been delayed by 1/10 seconds. -Thread has been delayed by 2/10 seconds. -Should be printed at the end. -Done