1. Jean-Marie Gaillourdet
  2. global-variables

Commits

Jean-Marie Gaillourdet  committed ccd3ac3

this version is suitable to show the strange concurrency, simply compile Test.hs and execute it repeatedly

  • Participants
  • Parent commits 0b010b6
  • Branches strange-concurrency

Comments (0)

Files changed (7)

File Test.hs

View file
+import Control.Monad
+import Control.Concurrent
+import Data.Global.Registry
+import System.Exit
+
+main = do
+    -- let x = declareIORef "bar" (0 :: Int)
+    -- print $ x == x
+    putStrLn "run"
+    forM [1..100] $ \_ -> forkIO $ do
+        x <- return $ declareIORef "foo" (1 :: Int)
+        y <- return $ declareIORef "foo" (1 :: Int)
+        x <- return $ declareMVar "foo" (1 :: Int)
+        y <- return $ declareMVar "foo" (1 :: Int)
+        if x == y
+            then return ()
+            else exitWith (ExitFailure 255)
+

File global-variables.cabal

View file
 
 Library
   Exposed-modules:    Data.Global
-                    , Data.Global.IORef
-                    , Data.Global.TVar
+--                    , Data.Global.IORef
+--                    , Data.Global.TVar
   Hs-Source-Dirs:   src
   
   Build-depends:      base >= 4
   
   Other-modules:    Data.Global.Registry
 
-  Ghc-Options:      -threaded -Wall
+  Ghc-Options:      -Wall -O2
   
 Executable          runtests
   if flag(test)
                     , QuickCheck == 2.4.*
                     , test-framework == 0.4.*
                     , test-framework-quickcheck2 == 0.2.*
-  Ghc-Options:      -threaded -Wall
+  Ghc-Options:      -threaded -Wall -O2
   if impl(ghc >= 7.0)
     Ghc-Options:    -rtsopts
 

File runtests.sh

View file
-while dist/build/runtests/runtests  -j 4 +RTS -N ; do echo; done
+while dist/build/runtests/runtests -t forward -a 1 -j 4 +RTS -N ; do echo; done

File src/Data/Global.hs

View file
 module Data.Global (
-    module Data.Global.IORef
+    module Data.Global.Registry
 ) where
 
-import Data.Global.IORef
+import Data.Global.Registry
 
 
 

File src/Data/Global/Registry.hs

View file
+{-# LANGUAGE ScopedTypeVariables #-}
 module Data.Global.Registry where
 
 import Control.Applicative ((<$>))
 import Control.Concurrent.MVar
+import Control.Concurrent.STM
+import Data.IORef
 import Data.Dynamic
 import Data.Map as M
+import Data.Typeable
 import GHC.Conc (pseq)
 
+import System.IO.Unsafe
 
 
-type Registry cell = MVar (Map String cell)
 
+type Registry = Map (TypeRep,String) Dynamic
 
-setupRegistryIO :: IO (Registry cell)
-setupRegistryIO = m `pseq` newMVar m
+
+setupRegistry :: IO (MVar Registry)
+setupRegistry = m `pseq` newMVar m
   where
 	m = M.empty
 
 
 
+{-# NOINLINE globalRegistry #-}
+globalRegistry :: MVar Registry
+globalRegistry = m `pseq` unsafePerformIO (newMVar m)
+  where
+    m = M.empty
 
-lookupIO :: (ref Dynamic -> cell)            -- GVar 
-         -> (Dynamic -> IO (ref Dynamic))    -- newIORef
-         -> Registry cell 
-         -> String 
-         -> IO cell
-lookupIO wrapper maker registry name = modifyMVar registry lkup
- -- do { old <- takeMVar registry
- --    ; (new, res) <- lkup old
- --    -- ; evaluate res
- --    -- ; evaluate new
- --    ; putMVar registry new
- --    ; return res
- --    }
+
+-- TODO: add a proper assertion explaining the problem
+
+lookupOrInsert
+    :: forall a. forall ref. (Typeable a, Typeable1 ref)
+    => MVar Registry
+    -> (a -> IO (ref a))
+    -> String
+    -> a
+    -> IO (ref a)
+lookupOrInsert registry new name val
+    | registry `pseq` new `pseq` name `pseq` val `pseq` False = undefined
+lookupOrInsert registry new name val = modifyMVar registry lkup
   where
-    lkup reg = case M.lookup name reg of
-        Just k' -> return (reg, k')
-        Nothing -> do
-            k' <- wrapper <$> maker (toDyn ())
-            return (M.insert name k' reg, k')
+    typ = typeOf val
 
+    lkup :: Registry -> IO (Registry, ref a)
+    lkup reg = case M.lookup (typ, name) reg of
+        Just ref -> return (reg, fromDyn ref err)
+        Nothing -> 
+         do { ref <- new val
+            ; return (M.insert (typ, name) (toDyn ref) reg, ref)
+            }
+    err = error "Data.Global.Registry: Invariant violation"
+{-# INLINE lookupOrInsert #-}
 
+
+lookupOrInsertIORef
+    :: Typeable a
+    => String
+    -> a
+    -> IO (IORef a)
+lookupOrInsertIORef = lookupOrInsert globalRegistry newIORef
+{-# NOINLINE lookupOrInsertIORef #-}
+
+
+lookupOrInsertMVar
+    :: Typeable a
+    => String
+    -> a
+    -> IO (MVar a)
+lookupOrInsertMVar = lookupOrInsert globalRegistry newMVar
+
+
+
+lookupOrInsertTVar
+    :: Typeable a
+    => String
+    -> a
+    -> IO (TVar a)
+lookupOrInsertTVar = lookupOrInsert globalRegistry newTVarIO
+
+
+
+declareIORef, declareIORef', declareIORef''
+    :: Typeable a
+    => String
+    -> a
+    -> (IORef a)
+declareIORef name val
+    | res1 == res2 = res1
+    | otherwise    = declareIORef name val
+  where
+    res1 = declareIORef' name val
+    res2 = declareIORef'' name val
+
+declareIORef' name val = unsafePerformIO $ lookupOrInsertIORef name val
+{-# NOINLINE declareIORef' #-}
+
+declareIORef'' name val = unsafePerformIO $ lookupOrInsertIORef name val
+{-# NOINLINE declareIORef'' #-}
+
+
+
+declareMVar
+    :: Typeable a
+    => String
+    -> a
+    -> (MVar a)
+declareMVar name val = unsafePerformIO $ lookupOrInsertMVar name val
+{-# NOINLINE declareMVar #-}
+
+
+
+declareTVar
+    :: Typeable a
+    => String
+    -> a
+    -> (TVar a)
+declareTVar name val = unsafePerformIO $ lookupOrInsertTVar name val
+{-# NOINLINE declareTVar #-}

File test-src/Data/Global/Registry/Test.hs

View file
 module Data.Global.Registry.Test where
 
+import Control.Concurrent ( myThreadId, forkIO )
+import qualified Control.Exception as E (assert)
+import Control.Monad ( forM )
 import Data.Dynamic
 import Data.IORef   
+import System.Exit ( exitWith, ExitCode(..) )
 import Test.QuickCheck
 import Test.QuickCheck.Monadic
 import Test.Framework
 (===>) ::  Bool -> Bool -> Bool
 x ===> y = not x || y
 
+(<==>) ::  Bool -> Bool -> Bool
+x <==> y = (x && y) || (not x && not y)
 
 prop_idempotent_lookupIO :: String -> Property
 prop_idempotent_lookupIO n = monadicIO $
- do { reg <- run setupRegistryIO
-    ; c1 <- run $ lookupIO Cell newIORef reg n
-    ; c2 <- run $ lookupIO Cell newIORef reg n
+ do { reg <- run setupRegistry
+    ; c1 <- run $ lookupOrInsert reg newIORef n ()
+    ; c2 <- run $ lookupOrInsert reg newIORef n ()
     ; assert $ c1 == c2
     }
 
 
 prop_safe_lookupIO :: String -> String -> Property
 prop_safe_lookupIO n1 n2 = monadicIO $
- do { reg <- run setupRegistryIO
-    ; c1 <- run $ lookupIO Cell newIORef reg n1
-    ; c2 <- run $ lookupIO Cell newIORef reg n2
+ do { reg <- run setupRegistry
+    ; c1 <- run $ lookupOrInsert reg newIORef n1 ()
+    ; c2 <- run $ lookupOrInsert reg newIORef n2 ()
     ; assert $ (n1 == n2) ===> (c1 == c2)
     }
 
+prop_pure_declare :: String -> Bool
+prop_pure_declare n = declareIORef n () == declareIORef n ()
+
+prop_bijective_declare :: String -> String -> Bool
+prop_bijective_declare n1 n2 = (n1 == n2) <==> (declareIORef n1 () == declareIORef n2 ())
+
+prop_bijective_declare_forward :: String -> String -> Bool
+prop_bijective_declare_forward n1 n2 = (n1 == n2) ===> (declareIORef n1 () == declareIORef n2 ())
+
+prop_bijective_declare_backward :: String -> String -> Bool
+prop_bijective_declare_backward n1 n2 = (declareIORef n1 () == declareIORef n2 ()) ===> (n1 == n2) 
+
+
+prop_writeread :: String -> Integer -> Property
+prop_writeread n z = monadicIO $
+ do { let x = declareIORef n 1
+    ; run $ x `writeIORef` z
+    ; z' <- run $ readIORef x
+    ; assert $ z' == z
+    }
+
+
+prop_wwr :: String -> String -> Integer -> Integer -> Property
+prop_wwr n1' n2' z1 z2 = z1 /= z2 ==> monadicIO $
+ do { tid <- run myThreadId
+    ; let n1 = show tid ++ n1'
+    ; let n2 = show tid ++ n2'
+    ; let k1 = declareIORef n1 1
+    ; let k2 = declareIORef n2 1
+    ; run $ k1 `writeIORef` z1
+    ; run $ k2 `writeIORef` z2
+    ; z1' <- run $ readIORef k1
+    ; assert $ (n1 /= n2) <==> (z1' == z1)
+    }
+
+-- test_conc :: String -> Property
+-- test_conc _ = monadicIO $ run $
+--     forM [1..100] $ \_ -> forkIO $ do
+--         x <- return $ declareIORef "foo" (1 :: Int)
+--         y <- return $ declareIORef "foo" (1 :: Int)
+--         if x == y
+--             then return ()
+--             else exitWith (ExitFailure (-1))
+-- 
+
+test_conc :: String -> Property
+test_conc _ = monadicIO $ run $
+    forM [1..100] $ \_ -> forkIO $ do
+        x <- return $ declareIORef "foo" (1 :: Int)
+        y <- return $ declareIORef "foo" (1 :: Int)
+        E.assert (x == y) $ return ()
 
 tests ::  Test
 tests = testGroup "Data.Global.Registry"
     [ testProperty "lookupIO is idempotent" prop_idempotent_lookupIO
     , testProperty "lookupIO is safe" prop_safe_lookupIO
+    , testProperty "declareIORef is pure" prop_pure_declare
+    --   testProperty "declare is a bijective function" prop_bijective_declare
+    , testProperty "declareIORef is a bijective function" prop_bijective_declare
+      -- testProperty "declare is a bijective function (forward)" prop_bijective_declare_forward
+    , testProperty "declareIORef is a bijective function (forward)" prop_bijective_declare_forward
+    --   testProperty "declare is a bijective function (backward)" prop_bijective_declare_backward
+    , testProperty "declareIORef is a bijective function (backward)" prop_bijective_declare_backward
+    , testProperty "basic write/read test" prop_writeread
+    , testProperty "write/read with interference test" prop_wwr
+    , testProperty "conc" test_conc
+    , testProperty "conc" test_conc
     ]

File test-src/TestMain.hs

View file
 
 import Test.Framework (defaultMain)
 
-import Data.Global.IORef.Test as I
-import Data.Global.TVar.Test as T
+-- import Data.Global.IORef.Test as I
+-- import Data.Global.TVar.Test as T
+import Data.Global.Registry
 import Data.Global.Registry.Test as R
 
 main ::  IO ()
-main = defaultMain
-	[ R.tests
-	, I.tests
-	, T.tests
-	]
+main = do
+    -- let x = declareIORef "foo" (1 :: Int) 
+    -- print $ x == x
+    defaultMain $
+    	[ R.tests
+        -- , I.tests
+        -- , T.tests
+    	]