On Sat, Dec 03, 2005 at 10:35:54PM +0100, Tomasz Zielonka wrote:
> so I could export a waitUntil function with type
>
> waitUntil :: Time -> STM ()
>
> but I tripped on something that was reported before, namely that STM
> transactions can't be nested (as a result of unsafePerformIO or
> unsafeInterleaveIO). Is there a plan to support such scenario?
OK, it can be worked around by running the atomically block in a new
transaction. But still it would be nice if the program didn't segfault,
but cause an exception for example.
Updated modules attached.
Best regards
Tomasz
--
I am searching for a programmer who is good at least in some of
[Haskell, ML, C++, Linux, FreeBSD, math] for work in Warsaw, Poland
module Main where
import Debug.Trace
import Control.Concurrent.STM
import Control.Concurrent
import Control.Monad
import TimeVar
import Random
import Control.Exception (finally)
main = do
runTests
[ test 1
, testMany
, test 5
, test 10
]
runTests fs = do
mapM_ (\t -> t >> putStrLn "") fs
test secs = do
putStrLn ("Testing waiting for " ++ show secs ++ " seconds")
-- waitUntil <- liftM waitOnTimeVar initTimeVar
time1 <- getTime
atomically $ do
stmTrace "try"
waitUntil (time1 + secs)
time2 <- getTime
putStrLn $ concat $
[ show time2
, " - "
, show time1
, " = "
, show (time2 - time1)
]
testMany = do
putStrLn "Testing with many threads"
messages <- atomically newTChan
threadCount <- atomically (newTVar 0)
let forkIO' t = do
atomically (modifyTVar threadCount succ)
forkIO (t `finally` atomically (modifyTVar threadCount pred))
replicateM 30 $ forkIO' $ do
secs <- liftM fromIntegral (randomRIO (1 :: Int, 10))
time1 <- getTime
atomically $ do
waitUntil (time1 + secs)
time2 <- getTime
atomically $ writeTChan messages $ concat $
[ "waited for "
, show (time2 - time1)
, " seconds, difference from requested: "
, show ((time2 - time1) - secs)
]
let loop = do
join $ atomically $
(do msg <- readTChan messages
return (putStrLn msg >> loop))
`orElse`
(do n <- readTVar threadCount
guard (n == 0)
return (return ()))
loop
--------------------------------------------------------------------------------
stmTrace s = do
v <- newTVar ()
trace s v `seq` return ()
modifyTVar v f = readTVar v >>= writeTVar v . f
module TimeVar
( Time
, getTime
, waitUntil
, timeVar
) where
import Control.Concurrent.STM
import Control.Concurrent
import Control.Monad
import System.Time (getClockTime, ClockTime(..))
import Data.Bits
import Data.Int
import System.IO.Unsafe (unsafePerformIO)
newtype TimeVar = TimeVar [TVar Bool]
{-# NOINLINE timeVar #-}
timeVar :: TimeVar
timeVar = unsafePerformIO $ do
var <- newEmptyMVar
forkIO $ do
tv <- initTimeVar
putMVar var tv
takeMVar var
waitUntil :: Time -> STM ()
waitUntil = waitOnTimeVar timeVar
type Time = Int32
getTime :: IO Time
getTime = do
TOD secs _ <- getClockTime
return (fromIntegral secs)
initTimeVar :: IO TimeVar
initTimeVar = do
t0 <- liftM toBitsFromMSB getTime
vars <- atomically $ do
sequence
[ do
v <- newTVar b
return v
| b <- t0 ]
forkIO $ do
sequence_ $ repeat $ do
threadDelay 100000
t <- liftM toBitsFromMSB getTime
atomically $ do
sequence_
[ do
old <- readTVar var
when (old /= new) (writeTVar var new)
| (var, new) <- zip vars t ]
return (TimeVar vars)
waitOnTimeVar :: TimeVar -> Time -> STM ()
waitOnTimeVar (TimeVar vars) t = do
let tBits = toBitsFromMSB t
cmp vars tBits
where
cmp (v:vs) (b:bs) = do
vVal <- readTVar v
case compare vVal b of
LT -> retry
EQ -> cmp vs bs
GT -> return ()
cmp [] [] = return ()
toBitsFromMSB :: Bits b => b -> [Bool]
toBitsFromMSB x = [ testBit x i | i <- [nBits-1, nBits-2 .. 0] ]
where
nBits = bitSize x
_______________________________________________
Haskell-Cafe mailing list
Haskell-Cafe@haskell.org
http://www.haskell.org/mailman/listinfo/haskell-cafe
