Skip to content

Commit

Permalink
added code coverage
Browse files Browse the repository at this point in the history
  • Loading branch information
ekmett committed Jun 28, 2010
1 parent f259a60 commit 93172c9
Show file tree
Hide file tree
Showing 7 changed files with 177 additions and 24 deletions.
1 change: 1 addition & 0 deletions .gitignore
@@ -1 +1,2 @@
dist dist
.hpc
5 changes: 5 additions & 0 deletions Benchmark.hs
@@ -0,0 +1,5 @@
module Main where

main :: IO ()
main = do
return ()
17 changes: 13 additions & 4 deletions Control/Concurrent/Speculation.hs
@@ -1,4 +1,4 @@
{-# LANGUAGE BangPatterns, DeriveDataTypeable #-} {-# LANGUAGE CPP, BangPatterns, DeriveDataTypeable #-}
module Control.Concurrent.Speculation module Control.Concurrent.Speculation
( (
-- * Speculative application -- * Speculative application
Expand All @@ -24,9 +24,14 @@ import Control.Concurrent.STM
import Control.Parallel (par) import Control.Parallel (par)
import Control.Monad (liftM2, unless) import Control.Monad (liftM2, unless)
import Data.Function (on) import Data.Function (on)

#if __GLASGOW_HASKELL__ >= 608
import Data.Bits ((.&.)) import Data.Bits ((.&.))
import Foreign (sizeOf) import Foreign (sizeOf)
import Unsafe.Coerce (unsafeCoerce) import Unsafe.Coerce (unsafeCoerce)
-- dynamic pointer tagging is present on this platform
#define TAGGED
#endif


-- * Basic speculation -- * Basic speculation


Expand Down Expand Up @@ -171,13 +176,17 @@ specOnSTM' :: Eq c => (a -> STM c) -> STM a -> (a -> STM b) -> a -> STM b
specOnSTM' = specBySTM' . on (liftM2 (==)) specOnSTM' = specBySTM' . on (liftM2 (==))
{-# INLINE specOnSTM' #-} {-# 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. -- | 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 -> Int
unsafeGetTagBits a = unsafeCoerce (Box a) .&. (sizeOf (undefined :: Int) - 1)
{-# INLINE unsafeGetTagBits #-} {-# 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! -- | 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 unsafeIsEvaluated :: a -> Bool
Expand Down
3 changes: 2 additions & 1 deletion Data/Foldable/Speculation.hs
@@ -1,4 +1,4 @@
{-# LANGUAGE BangPatterns, ScopedTypeVariables #-} {-# LANGUAGE BangPatterns #-}
module Data.Foldable.Speculation module Data.Foldable.Speculation
( (
-- * Speculative folds -- * Speculative folds
Expand Down Expand Up @@ -48,6 +48,7 @@ import Prelude hiding
, elem, notElem, sum, product , elem, notElem, sum, product
, minimum, maximum, concat, concatMap , minimum, maximum, concat, concatMap
) )

import Data.Monoid import Data.Monoid
import Data.Ix () import Data.Ix ()
import Data.Function (on) import Data.Function (on)
Expand Down
56 changes: 54 additions & 2 deletions Setup.lhs
@@ -1,3 +1,55 @@
#!/usr/bin/env runhaskell #!/usr/bin/env runhaskell
> import Distribution.Simple \begin{code}
> main = defaultMainWithHooks simpleUserHooks {-# 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 changes: 24 additions & 0 deletions 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) ]
]
95 changes: 78 additions & 17 deletions speculation.cabal
@@ -1,12 +1,16 @@
name: speculation name: speculation
version: 0.7.0 version: 0.8.0
license: BSD3 license: BSD3
license-file: LICENSE license-file: LICENSE
author: Edward A. Kmett author: Edward A. Kmett
maintainer: Edward A. Kmett <ekmett@gmail.com> maintainer: Edward A. Kmett <ekmett@gmail.com>
stability: experimental stability: experimental
homepage: http://github.com/ekmett/speculation homepage: http://github.com/ekmett/speculation
category: Concurrency 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 synopsis: A framework for safe, programmable, speculative parallelism
description: description:
A framework for safe, programmable, speculative parallelism, loosely based on: A framework for safe, programmable, speculative parallelism, loosely based on:
Expand Down Expand Up @@ -42,28 +46,47 @@ description:
. .
'specSTM' provides a similar time table for STM actions, but also rolls back side-effects. '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' * Test suite, code coverage, and benchmark suite added
* Removed 'SpeculationException'
. extra-source-files:
/Changes in 0.6.0:/ README.markdown
.
* Upgraded the comparisons used by the STM combinators to STM actions, so they can check other STM state source-repository head
. type: git
/Changes in 0.5.1:/ location: http://github.com/ekmett/speculation.git
. branch: master
* Exposed 'unsafeGetTagBits' and 'unsafeIsEvaluated'
flag optimize
description: Enable optimizations
default: True


copyright: (c) 2010 Edward A. Kmett flag tests
build-type: Simple description: Build the tests
cabal-version: >=1.2 default: True
tested-with: GHC==6.12.1
extra-source-files: README.markdown 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 library
ghc-options: -Wall ghc-options: -Wall


if flag(optimize)
ghc-options: -funbox-strict-fields -O2 -fspec-constr -fdicts-cheap

if flag(nolib)
buildable: False

build-depends: build-depends:
base >= 4 && < 6, base >= 4 && < 6,
parallel >= 2.2 && < 2.3, parallel >= 2.2 && < 2.3,
Expand All @@ -72,3 +95,41 @@ library
exposed-modules: exposed-modules:
Control.Concurrent.Speculation Control.Concurrent.Speculation
Data.Foldable.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

0 comments on commit 93172c9

Please sign in to comment.