From 93172c93d67bafa8d6781f617ab6c293ee68a8c0 Mon Sep 17 00:00:00 2001 From: ekmett Date: Sun, 27 Jun 2010 22:25:18 -0700 Subject: [PATCH] added code coverage --- .gitignore | 1 + Benchmark.hs | 5 ++ Control/Concurrent/Speculation.hs | 17 ++++-- Data/Foldable/Speculation.hs | 3 +- Setup.lhs | 56 +++++++++++++++++- Test.hs | 24 ++++++++ speculation.cabal | 95 +++++++++++++++++++++++++------ 7 files changed, 177 insertions(+), 24 deletions(-) create mode 100644 Benchmark.hs create mode 100644 Test.hs diff --git a/.gitignore b/.gitignore index 1521c8b..9645a0f 100644 --- a/.gitignore +++ b/.gitignore @@ -1 +1,2 @@ dist +.hpc diff --git a/Benchmark.hs b/Benchmark.hs new file mode 100644 index 0000000..901ab2b --- /dev/null +++ b/Benchmark.hs @@ -0,0 +1,5 @@ +module Main where + +main :: IO () +main = do + return () diff --git a/Control/Concurrent/Speculation.hs b/Control/Concurrent/Speculation.hs index 462c0c3..ea0233b 100644 --- a/Control/Concurrent/Speculation.hs +++ b/Control/Concurrent/Speculation.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE BangPatterns, DeriveDataTypeable #-} +{-# LANGUAGE CPP, BangPatterns, DeriveDataTypeable #-} module Control.Concurrent.Speculation ( -- * Speculative application @@ -24,9 +24,14 @@ import Control.Concurrent.STM import Control.Parallel (par) import Control.Monad (liftM2, unless) import Data.Function (on) + +#if __GLASGOW_HASKELL__ >= 608 import Data.Bits ((.&.)) import Foreign (sizeOf) import Unsafe.Coerce (unsafeCoerce) +-- dynamic pointer tagging is present on this platform +#define TAGGED +#endif -- * Basic speculation @@ -171,13 +176,17 @@ specOnSTM' :: Eq c => (a -> STM c) -> STM a -> (a -> STM b) -> a -> STM b specOnSTM' = specBySTM' . on (liftM2 (==)) {-# INLINE specOnSTM' #-} --- | Used to inspect tag bits -data Box a = Box a -- | Inspect the dynamic pointer tagging bits of a closure. This is an impure function that relies on GHC internals and may falsely return 0, but never give the wrong tag number if it returns a non-0 value. unsafeGetTagBits :: a -> Int -unsafeGetTagBits a = unsafeCoerce (Box a) .&. (sizeOf (undefined :: Int) - 1) {-# INLINE unsafeGetTagBits #-} +#ifndef TAGGED +unsafeGetTagBits _ = 0 +#else +unsafeGetTagBits a = unsafeCoerce (Box a) .&. (sizeOf (undefined :: Int) - 1) +-- | Used to inspect tag bits +data Box a = Box a +#endif -- | Returns a guess as to whether or not a value has been evaluated. This is an impure function that relies on GHC internals and will return false negatives, but no false positives. This is unsafe as the value of this function will vary (from False to True) over the course of otherwise pure invocations! unsafeIsEvaluated :: a -> Bool diff --git a/Data/Foldable/Speculation.hs b/Data/Foldable/Speculation.hs index c757a0e..04caf48 100644 --- a/Data/Foldable/Speculation.hs +++ b/Data/Foldable/Speculation.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE BangPatterns, ScopedTypeVariables #-} +{-# LANGUAGE BangPatterns #-} module Data.Foldable.Speculation ( -- * Speculative folds @@ -48,6 +48,7 @@ import Prelude hiding , elem, notElem, sum, product , minimum, maximum, concat, concatMap ) + import Data.Monoid import Data.Ix () import Data.Function (on) diff --git a/Setup.lhs b/Setup.lhs index 4c441d1..7fc6c09 100755 --- a/Setup.lhs +++ b/Setup.lhs @@ -1,3 +1,55 @@ #!/usr/bin/env runhaskell -> import Distribution.Simple -> main = defaultMainWithHooks simpleUserHooks +\begin{code} +{-# LANGUAGE CPP #-} + +import System.Exit (ExitCode(..)) +import Control.Monad (unless, mplus) +import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..) ) +import Distribution.Simple.Program (programFindLocation, lookupKnownProgram ) +import Distribution.Verbosity (normal) +import Distribution.Simple (defaultMainWithHooks, UserHooks(..), simpleUserHooks) +import System.IO (openFile, IOMode (..)) +import System.FilePath ( (), splitDirectories, isAbsolute ) +import System.Process +import System.Directory (getCurrentDirectory, createDirectoryIfMissing, setCurrentDirectory, findExecutable, canonicalizePath) + +main = defaultMainWithHooks simpleUserHooks { runTests = testHook } + +findHPC :: LocalBuildInfo -> IO FilePath +findHPC lbi = do + Just hpcProgram <- return $ lookupKnownProgram "hpc" $ withPrograms lbi + Just hpc <- programFindLocation hpcProgram normal + return hpc + `catch` \e -> do + Just hpc <- findExecutable "hpc" + return hpc + +testHook args0 _ _ lbi = do + let args = if null args0 then [] else "-t" : args0 + -- dir <- getWorkingDirectory + let testDir = buildDir lbi "test-speculation" + baseDir <- getCurrentDirectory + canonicalBuildDir <- canonicalizePath (buildDir lbi) + setCurrentDirectory testDir + exitcode <- system $ unwords $ "test-speculation" : args + unless (exitcode == ExitSuccess) $ + fail "test failed" + hpc <- findHPC lbi + exitcode <- system $ unwords $ hpc + : "report" + : "test-speculation" + : "--srcdir=../../.." + : [] + let markupDir base = base "doc" "html" "test-speculation" + createDirectoryIfMissing True (markupDir canonicalBuildDir) + exitcode <- system $ unwords $ hpc + : "markup" + : "test-speculation" + : "--srcdir=../../.." + : ("--destdir=" ++ markupDir canonicalBuildDir) + : "--exclude=Main" + : [] + unless (exitcode == ExitSuccess) $ + fail "hpc report failed" + putStrLn $ "Code coverage created: " ++ (markupDir (buildDir lbi) "hpc_index.html") +\end{code} diff --git a/Test.hs b/Test.hs new file mode 100644 index 0000000..72619d6 --- /dev/null +++ b/Test.hs @@ -0,0 +1,24 @@ +module Main where + +import Prelude hiding ((||),(&&)) +import Test.Framework (Test) +import Test.Framework (defaultMain, testGroup) +import Test.Framework.Providers.HUnit +import Test.Framework.Providers.QuickCheck (testProperty) +import Test.QuickCheck hiding ((==>)) +-- import Test.HUnit hiding (Test) +import Control.Concurrent.Speculation + +main :: IO () +main = defaultMain tests + +ignore :: Functor f => f a -> f () +ignore = fmap (const ()) + +tests :: [Test] +tests = + [ testGroup "cases" $ zipWith (testCase . show) [1 :: Int ..] $ + [] + , testGroup "properties" $ zipWith (testProperty . show) [1 :: Int ..] $ + [ property $ \ a -> spec a (*2) a == ((*2) $! a :: Int) ] + ] diff --git a/speculation.cabal b/speculation.cabal index b982732..68e25e6 100644 --- a/speculation.cabal +++ b/speculation.cabal @@ -1,5 +1,5 @@ name: speculation -version: 0.7.0 +version: 0.8.0 license: BSD3 license-file: LICENSE author: Edward A. Kmett @@ -7,6 +7,10 @@ maintainer: Edward A. Kmett stability: experimental homepage: http://github.com/ekmett/speculation category: Concurrency +copyright: (c) 2010 Edward A. Kmett +build-type: Custom +cabal-version: >=1.6 +tested-with: GHC==6.12.1 synopsis: A framework for safe, programmable, speculative parallelism description: A framework for safe, programmable, speculative parallelism, loosely based on: @@ -42,28 +46,47 @@ description: . 'specSTM' provides a similar time table for STM actions, but also rolls back side-effects. . - /Changes in 0.7.0:/ + /Changes in 0.8.0:/ . - * Changed @'throw' 'SpeculationException'@ to 'retry' - * Removed 'SpeculationException' - . - /Changes in 0.6.0:/ - . - * Upgraded the comparisons used by the STM combinators to STM actions, so they can check other STM state - . - /Changes in 0.5.1:/ - . - * Exposed 'unsafeGetTagBits' and 'unsafeIsEvaluated' + * Test suite, code coverage, and benchmark suite added -copyright: (c) 2010 Edward A. Kmett -build-type: Simple -cabal-version: >=1.2 -tested-with: GHC==6.12.1 -extra-source-files: README.markdown +extra-source-files: + README.markdown + +source-repository head + type: git + location: http://github.com/ekmett/speculation.git + branch: master + +flag optimize + description: Enable optimizations + default: True + +flag tests + description: Build the tests + default: True + +flag benchmarks + description: Build the benchmarks + default: False + +flag hpc + description: Use HPC for tests + default: True + +flag nolib + description: Don't build the library. Useful for speeding up the modify-build-test cycle. + default: False library ghc-options: -Wall + if flag(optimize) + ghc-options: -funbox-strict-fields -O2 -fspec-constr -fdicts-cheap + + if flag(nolib) + buildable: False + build-depends: base >= 4 && < 6, parallel >= 2.2 && < 2.3, @@ -72,3 +95,41 @@ library exposed-modules: Control.Concurrent.Speculation Data.Foldable.Speculation + +executable test-speculation + main-is: Test.hs + if !flag(tests) + buildable: False + else + if flag(hpc) + ghc-options: -fhpc + ghc-options: -Wall + build-depends: + base >= 4 && < 6, + stm >= 2.1 && < 2.2, + containers >= 0.3.0 && < 0.4, + test-framework >= 0.2.4 && < 0.3, + test-framework-quickcheck >= 0.2.4 && < 0.3, + test-framework-hunit >= 0.2.4 && < 0.3, + QuickCheck >= 1.2.0.0 && < 1.3, + HUnit >= 1.2.2.1 && < 1.3 + other-modules: + Control.Concurrent.Speculation + Data.Foldable.Speculation + +executable benchmark-speculation + main-is: Benchmark.hs + if !flag(benchmarks) + buildable: False + else + ghc-options: -Wall + if flag(optimize) + ghc-options: -O2 -fspec-constr -funbox-strict-fields -fdicts-cheap + build-depends: + base >= 4 && < 6, + stm >= 2.1 && < 2.2, + containers >= 0.3.0 && < 0.4, + criterion >= 0.5 && < 0.6 + other-modules: + Control.Concurrent.Speculation + Data.Foldable.Speculation