Skip to content
Browse files

Commit failing testcase for #1

  • Loading branch information...
1 parent d6928ba commit 8d899d3b75139b7c71e2e4d36e8a61881cf4b6a4 @gregorycollins committed Nov 23, 2011
Showing with 129 additions and 8 deletions.
  1. +13 −1 cbits/cfuncs.c
  2. +1 −1 hashtables.cabal
  3. +7 −3 test/hashtables-test.cabal
  4. +108 −3 test/suite/Data/HashTable/Test/Common.hs
View
14 cbits/cfuncs.c
@@ -1,5 +1,7 @@
+#include <signal.h>
#include <stdint.h>
-
+#include <stdio.h>
+#include <unistd.h>
#if defined(USE_SSE_4_1)
#include <smmintrin.h>
@@ -469,3 +471,13 @@ int lineSearch64_3(uint64_t* array, int start,
return lineResult64((int)m, start);
}
+void suicide(volatile int* check, int t) {
+ int secs = (3*t + 999999) / 1000000;
+ if (secs < 1) secs = 1;
+
+ sleep(secs);
+ if (*check) {
+ printf("timeout expired, dying!!\n");
+ raise(SIGKILL);
+ }
+}
View
2 hashtables.cabal
@@ -165,7 +165,7 @@ Library
if flag(portable)
- cpp-options: -DNO_C_SEARCH
+ cpp-options: -DNO_C_SEARCH -DPORTABLE
if !flag(portable) && flag(unsafe-tricks) && impl(ghc)
build-depends: ghc-prim
View
10 test/hashtables-test.cabal
@@ -47,8 +47,10 @@ Executable testsuite
ghc-options: -fhpc
if flag(portable)
- cpp-options: -DNO_C_SEARCH
-
+ cpp-options: -DNO_C_SEARCH -DPORTABLE
+ else
+ build-depends: unix >= 2.3 && <3
+
if !flag(portable) && flag(unsafe-tricks) && impl(ghc)
cpp-options: -DUNSAFETRICKS
build-depends: ghc-prim
@@ -92,7 +94,9 @@ Executable compute-overhead
ghc-prof-options: -prof -auto-all
if flag(portable)
- cpp-options: -DNO_C_SEARCH
+ cpp-options: -DNO_C_SEARCH -DPORTABLE
+ else
+ build-depends: unix >= 2.3 && <3
if !flag(portable) && flag(unsafe-tricks) && impl(ghc)
cpp-options: -DUNSAFETRICKS
View
111 test/suite/Data/HashTable/Test/Common.hs
@@ -1,5 +1,7 @@
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE RankNTypes #-}
module Data.HashTable.Test.Common
( FixedTableType
@@ -9,7 +11,7 @@ module Data.HashTable.Test.Common
) where
------------------------------------------------------------------------------
-import Control.Monad (liftM, when)
+import Control.Monad (foldM_, liftM, when)
import Control.Monad.ST (unsafeIOToST)
import Data.IORef
import Data.List hiding ( insert
@@ -20,6 +22,7 @@ import qualified Data.Vector as V
import qualified Data.Vector.Mutable as MV
import Prelude hiding (lookup, mapM_)
import System.Random.MWC
+import System.Timeout
import Test.Framework
import Test.Framework.Providers.QuickCheck2
import Test.QuickCheck
@@ -28,6 +31,11 @@ import Test.QuickCheck.Monadic
import qualified Data.HashTable.Class as C
import Data.HashTable.IO
+#ifndef PORTABLE
+import Control.Concurrent
+import Foreign (malloc, free, poke, Ptr)
+import Foreign.C.Types (CInt)
+#endif
------------------------------------------------------------------------------
type FixedTableType h = forall k v . IOHashTable h k v
@@ -67,6 +75,7 @@ tests prefix dummyArg = testGroup prefix $ map f ts
, SomeTest testNewAndInsert
, SomeTest testGrowTable
, SomeTest testDelete
+ , SomeTest testNastyFullLookup
]
@@ -253,6 +262,102 @@ testDelete prefix dummyArg =
------------------------------------------------------------------------------
+data Action = Lookup Int
+ | Insert Int
+ | Delete Int
+ deriving Show
+
+
+timeout_ :: Int -> IO a -> IO (Maybe a)
+#ifdef PORTABLE
+timeout_ = timeout
+#else
+
+foreign import ccall safe "suicide"
+ c_suicide :: Ptr CInt -> CInt -> IO ()
+
+
+-- Foreign thread can get blocked here, stalling progress. We'll make damned
+-- sure we bomb out.
+timeout_ t m = do
+ ptr <- malloc
+ poke ptr 1
+ forkOS $ suicide ptr
+ threadDelay 1000
+ r <- timeout t m
+ poke ptr 0
+ return r
+ where
+ suicide ptr = do
+ c_suicide ptr $ toEnum t
+ free ptr
+#endif
+
+
+testNastyFullLookup :: HashTest
+testNastyFullLookup prefix dummyArg =
+ testProperty (prefix ++ "/nastyFullLookup") $ monadicIO $ run go
+ where
+ apply :: forall h . C.HashTable h =>
+ IOHashTable h Int () -> Action -> IO ()
+ apply tbl (Lookup key) = lookup tbl key >> return ()
+ apply tbl (Insert key) = insert tbl key ()
+ apply tbl (Delete key) = delete tbl key
+
+ go = do
+ tbl <- new
+ forceType tbl dummyArg
+ timeout_ 1000000 $ foldM_ (\t k -> apply t k >> return t) tbl testData
+
+ testData =
+ [ Insert 28
+ , Insert 27
+ , Insert 30
+ , Insert 31
+ , Insert 32
+ , Insert 33
+ , Insert 34
+ , Insert 29
+ , Insert 36
+ , Insert 37
+ , Delete 34
+ , Delete 29
+ , Insert 38
+ , Insert 39
+ , Insert 40
+ , Insert 35
+ , Delete 39
+ , Insert 42
+ , Insert 43
+ , Delete 40
+ , Delete 35
+ , Insert 44
+ , Insert 45
+ , Insert 41
+ , Insert 48
+ , Insert 47
+ , Insert 50
+ , Insert 51
+ , Insert 52
+ , Insert 49
+ , Insert 54
+ , Insert 53
+ , Insert 56
+ , Insert 55
+ , Insert 58
+ , Insert 57
+ , Insert 60
+ , Insert 59
+ , Delete 60
+ , Insert 62
+ , Insert 61
+ , Insert 63
+ , Insert 46
+ , Lookup 66
+ ]
+
+
+------------------------------------------------------------------------------
initializeRNG :: PropertyM IO GenIO
initializeRNG = run $ withSystemRandom (return :: GenIO -> IO GenIO)

0 comments on commit 8d899d3

Please sign in to comment.
Something went wrong with that request. Please try again.