mirror of
https://github.com/ekmett/speculation.git
synced 2024-08-17 01:10:25 +03:00
added code coverage
This commit is contained in:
parent
f259a600a4
commit
93172c93d6
1
.gitignore
vendored
1
.gitignore
vendored
@ -1 +1,2 @@
|
||||
dist
|
||||
.hpc
|
||||
|
5
Benchmark.hs
Normal file
5
Benchmark.hs
Normal file
@ -0,0 +1,5 @@
|
||||
module Main where
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
return ()
|
@ -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
|
||||
|
@ -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)
|
||||
|
56
Setup.lhs
56
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}
|
||||
|
24
Test.hs
Normal file
24
Test.hs
Normal 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) ]
|
||||
]
|
@ -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
|
||||
|
Loading…
Reference in New Issue
Block a user