added code coverage

This commit is contained in:
ekmett 2010-06-27 22:25:18 -07:00
parent f259a600a4
commit 93172c93d6
7 changed files with 177 additions and 24 deletions

1
.gitignore vendored
View File

@ -1 +1,2 @@
dist
.hpc

5
Benchmark.hs Normal file
View File

@ -0,0 +1,5 @@
module Main where
main :: IO ()
main = do
return ()

View File

@ -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

View File

@ -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)

View File

@ -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}

24
Test.hs Normal file
View File

@ -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) ]
]

View File

@ -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 <ekmett@gmail.com>
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