diff --git a/System/Clock.hsc b/System/Clock.hsc --- a/System/Clock.hsc +++ b/System/Clock.hsc @@ -41,7 +41,9 @@ # endif #endif -#let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__) +#if __GLASGOW_HASKELL__ < 800 +# let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__) +#endif -- | Clock types. A clock may be system-wide (that is, visible to all processes) -- or per-process (measuring time that is meaningful only within a process). @@ -126,12 +128,12 @@ foreign import ccall hs_clock_darwin_gettime :: #{type clock_id_t} -> Ptr TimeSpec -> IO () foreign import ccall hs_clock_darwin_getres :: #{type clock_id_t} -> Ptr TimeSpec -> IO () #else -foreign import ccall clock_gettime :: #{type clockid_t} -> Ptr TimeSpec -> IO () -foreign import ccall clock_getres :: #{type clockid_t} -> Ptr TimeSpec -> IO () +foreign import ccall unsafe clock_gettime :: #{type clockid_t} -> Ptr TimeSpec -> IO () +foreign import ccall unsafe clock_getres :: #{type clockid_t} -> Ptr TimeSpec -> IO () #endif -#if defined(_WIN32) -#elif defined(__MACH__) && defined(__APPLE__) +#if !defined(_WIN32) +#if defined(__MACH__) && defined(__APPLE__) clockToConst :: Clock -> #{type clock_id_t} clockToConst Monotonic = #const SYSTEM_CLOCK clockToConst Realtime = #const CALENDAR_CLOCK @@ -143,23 +145,20 @@ clockToConst Realtime = #const CLOCK_REALTIME clockToConst ProcessCPUTime = #const CLOCK_PROCESS_CPUTIME_ID clockToConst ThreadCPUTime = #const CLOCK_THREAD_CPUTIME_ID +#endif #if defined (CLOCK_MONOTONIC_RAW) clockToConst MonotonicRaw = #const CLOCK_MONOTONIC_RAW #endif - #if defined (CLOCK_BOOTTIME) clockToConst Boottime = #const CLOCK_BOOTTIME #endif - #if defined (CLOCK_MONOTONIC_COARSE) clockToConst MonotonicCoarse = #const CLOCK_MONOTONIC_COARSE #endif - #if defined (CLOCK_REALTIME_COARSE) clockToConst RealtimeCoarse = #const CLOCK_REALTIME_COARSE #endif - #endif allocaAndPeek :: Storable a => (Ptr a -> IO ()) -> IO a diff --git a/bench/benchmarks.hs b/bench/benchmarks.hs new file mode 100644 --- /dev/null +++ b/bench/benchmarks.hs @@ -0,0 +1,26 @@ +{-# language CPP #-} +module Main (main) where + +import Criterion.Main +import System.Clock + +#if MIN_VERSION_base(4,11,0) +import GHC.Clock +#endif + +main :: IO () +main = defaultMain [ + bgroup "getTime" [ + bench "Monotonic" $ whnfIO (getTime Monotonic) + , bench "Realtime" $ whnfIO (getTime Realtime) + , bench "ProcessCPUTime" $ whnfIO (getTime ProcessCPUTime) + , bench "ThreadCPUTime" $ whnfIO (getTime ThreadCPUTime) + , bench "MonotonicRaw" $ whnfIO (getTime MonotonicRaw) + , bench "Boottime" $ whnfIO (getTime Boottime) + , bench "MonotonicCoarse" $ whnfIO (getTime MonotonicCoarse) + , bench "RealtimeCoarse" $ whnfIO (getTime RealtimeCoarse) + ] +#if MIN_VERSION_base(4,11,0) + , bench "GHC.Clock.getMonotonicTimeNSec" $ whnfIO getMonotonicTimeNSec +#endif + ] diff --git a/cbits/hs_clock_win32.c b/cbits/hs_clock_win32.c --- a/cbits/hs_clock_win32.c +++ b/cbits/hs_clock_win32.c @@ -28,12 +28,22 @@ t[1] = 100*(long)(t_100ns % 10000000UL); } +/* See https://ghc.haskell.org/trac/ghc/ticket/15094 */ +#if defined(_WIN32) && !defined(_WIN64) +__attribute__((optimize("-fno-expensive-optimizations"))) +#endif void hs_clock_win32_gettime_monotonic(long long* t) { LARGE_INTEGER time; - LARGE_INTEGER frequency; + static LARGE_INTEGER frequency; + static int hasFreq = 0; + QueryPerformanceCounter(&time); - QueryPerformanceFrequency(&frequency); + if (!hasFreq) + { + hasFreq = 1; + QueryPerformanceFrequency(&frequency); + } // seconds t[0] = time.QuadPart / frequency.QuadPart; // nanos = diff --git a/clock.cabal b/clock.cabal --- a/clock.cabal +++ b/clock.cabal @@ -1,5 +1,5 @@ name: clock -version: 0.7.2 +version: 0.8 stability: stable synopsis: High-resolution clock functions: monotonic, realtime, cputime. description: A package for convenient access to high-resolution clock and @@ -33,6 +33,8 @@ . Fixes for older Linux build failures introduced by new Linux-specific clocks by Mario Longobardi on 2016-04-18. . + Refreshment release in 2019-04 after numerous contributions. + . [Version Scheme] Major-@/R/@-ewrite . New-@/F/@-unctionality . @/I/@-mprovementAndBugFixes . @/P/@-ackagingOnly . @@ -41,8 +43,8 @@ copyright: Copyright © Cetin Sert 2009-2016, Eugene Kirpichov 2010, Finn Espen Gundersen 2013, Gerolf Seitz 2013, Mathieu Boespflug 2014 2015, Chris Done 2015, Dimitri Sabadie 2015, Christian Burger 2015, Mario Longobardi 2016 license: BSD3 license-file: LICENSE -author: Cetin Sert , Corsis Research -maintainer: Cetin Sert , Corsis Research +author: Cetin Sert , Corsis Research +maintainer: Cetin Sert , Corsis Research homepage: https://github.com/corsis/clock bug-reports: https://github.com/corsis/clock/issues category: System @@ -94,4 +96,16 @@ base >= 4 && < 5 , tasty >= 0.10 , tasty-quickcheck + , clock + +benchmark benchmarks + type: + exitcode-stdio-1.0 + hs-source-dirs: + bench + main-is: + benchmarks.hs + build-depends: + base >= 4 && < 5 + , criterion , clock diff --git a/tests/test.hs b/tests/test.hs --- a/tests/test.hs +++ b/tests/test.hs @@ -14,46 +14,25 @@ main = defaultMain (adjustOption (QuickCheckTests 100000 +) $ tests) tests :: TestTree -tests = testGroup "All tests" [numInstanceTests, eqOrdInstancesTests] - -numInstanceTests = testGroup "Num class tests" [ - -- let's make at least 100,000 tests - qcNumInstance - ] +tests = testGroup "All tests" [numInstanceTests, ordInstanceTests] -eqOrdInstancesTests = testGroup "Eq and Ord instance tests" [ - -- let's make at least 100,000 tests - qcEqOrdInstance - ] +numInstanceTests = testGroup "Num instance tests" [qcNumInstance] +ordInstanceTests = testGroup "Ord instance tests" [qcOrdInstance] qcNumInstance = testGroup "QuickCheck" [ - QuickCheck.testProperty "x = abs(x) * signum(x)" $ - \ x -> (x :: TimeSpec) == (abs x) * (signum x) - , QuickCheck.testProperty "integer addition equals TimeSpec addition" $ - \ x y -> x + y == timeSpecAsNanoSecs (fromInteger x + fromInteger y) - , QuickCheck.testProperty "integer substraction equals TimeSpec addition" $ - \ x y -> x - y == timeSpecAsNanoSecs (fromInteger x - fromInteger y) - , QuickCheck.testProperty - "rational multiplication equals TimeSpec multiplication" $ + QuickCheck.testProperty "x = abs(x) * signum(x)" $ \ x -> (x :: TimeSpec) == (abs x) * (signum x) + , QuickCheck.testProperty "integer addition equals TimeSpec addition" $ \ x y -> x + y == toNanoSecs (fromInteger x + fromInteger y) + , QuickCheck.testProperty "integer subtraction equals TimeSpec subtracttion" $ \ x y -> x - y == toNanoSecs (fromInteger x - fromInteger y) + , QuickCheck.testProperty "rational multiplication equals TimeSpec multiplication" $ \ x y -> - let - rationalMul = truncate ((x :: Nano) * (y :: Nano) * (10^9)) - timespecMul = timeSpecAsNanoSecs ( - fromInteger (truncate (x * 10^9)) - * fromInteger (truncate (y * 10^9))) - in - rationalMul == timespecMul - , QuickCheck.testProperty "neg(neg(x)) = x" $ - \ x -> negate (negate x :: TimeSpec) == x + let rationalMul = truncate ((x :: Nano) * (y :: Nano) * (10^9)) + timespecMul = toNanoSecs (fromInteger (truncate (x * 10^9)) * fromInteger (truncate (y * 10^9))) + in rationalMul == timespecMul + , QuickCheck.testProperty "neg(neg(x)) = x" $ \ x -> negate (negate x :: TimeSpec) == x ] -qcEqOrdInstance = testGroup "QuickCheck" +qcOrdInstance = testGroup "QuickCheck" [ - QuickCheck.testProperty - "random list of TimeSpecs is sorted like equivalent list of integers" $ - \ x -> - sort (x :: [TimeSpec]) - == - map (fromInteger) (sort (map timeSpecAsNanoSecs x)) + QuickCheck.testProperty "random list of TimeSpecs is sorted like equivalent list of integers" $ \ x -> sort (x :: [TimeSpec]) == map (fromInteger) (sort (map toNanoSecs x)) ]