public
Created

Alternative STM implementation for Haskell

  • Download Gist
STM.hs
Haskell
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140
{-# LANGUAGE ExistentialQuantification #-}
 
{-
The idea is that each variable is an IORef that is either in a stable state
or is being transformed. If it is being transformed then the IORef contains a
MidChange value. The first argument of the constructor is the state before
the modification, the second argument is the state afterwards and the third
argument is an IORef that says whether the transaction has completed.
-}
 
module STM where
 
import Control.Concurrent (yield)
import Data.IORef
 
data STMState a =
At a |
MidChange a a (IORef Bool)
 
type TVar a = IORef (STMState a)
 
data STM a =
Done a |
forall x. NewTVar x (TVar x -> STM a) |
forall x. ReadTVar (TVar x) (x -> STM a) |
forall x. WriteTVar (TVar x) x (STM a)
 
instance Monad STM where
return = Done
m >>= f =
case m of
Done x -> f x
NewTVar x c -> NewTVar x (\i -> c i >>= f)
ReadTVar x c -> ReadTVar x (\i -> c i >>= f)
WriteTVar v x c -> WriteTVar v x (c >>= f)
 
newTVar = flip NewTVar return
readTVar = flip ReadTVar return
writeTVar v x = WriteTVar v x $ return ()
 
newTVarIO :: a -> IO (TVar a)
newTVarIO x =
newIORef (At x)
 
reduce :: IORef Bool -> TVar a -> IO ()
reduce t var = do
atomicModifyIORef var (\v ->
case v of
MidChange a b t' ->
if t == t' then
(At b, ())
else
(v, ())
_ -> (v, ()))
 
readTVarIO :: TVar a -> IO a
readTVarIO var = do
var' <- readIORef var
case var' of
At x -> return x
MidChange before after switch -> do
x <- readIORef switch
if x then do
reduce switch var
return after
else
return before
 
atomicModifyTVar :: TVar a -> (a -> (a, b)) -> IO b
atomicModifyTVar var op = do
undefined
 
atomically :: STM a -> IO a
atomically op = do
t <- newIORef False
out <- retry $ trans t op
writeIORef t True
return out
where
retry :: IO (Maybe a) -> IO a
retry op = do
v <- op
case v of
Just v' -> return v'
Nothing -> do
yield
retry op
continue :: IORef Bool -> STM a -> TVar x -> IO (Maybe a)
continue t c v = do
out <- trans t c
case out of
Nothing ->
-- transaction failed, rollback.
atomicModifyIORef v (\v' ->
case v' of
At _ ->
error "Clobbered transaction"
MidChange x _ t' ->
if t /= t' then
error "Clobbered transaction"
else
(At x, ()))
Just _ ->
return ()
return out
transVar :: (IORef Bool) -> TVar a -> (a -> a) -> IO (Maybe a)
transVar t x fn = do
v <- atomicModifyIORef x (\v ->
case v of
At v' ->
(MidChange v' (fn v') t, Left v')
MidChange a b t' ->
if t' == t then
(MidChange a (fn b) t, Left b)
else
(v, Right t'))
case v of
Left v' -> return $ Just v'
Right t' -> do
s <- readIORef t'
if s then do
reduce t' x
transVar t x fn
else
return Nothing
trans _ (Done x) =
return $ Just x
trans t (NewTVar x c) = do
var <- newTVarIO x
trans t $ c var
trans t (ReadTVar x c) = do
v <- transVar t x id
case v of
Just v' -> continue t (c v') x
Nothing -> return Nothing
trans t (WriteTVar v x c) = do
v' <- transVar t v (const x)
case v' of
Just _ -> continue t c v
Nothing -> return Nothing
main.hs
Haskell
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34
{-
This is a simple consistency test.
-}
 
import Control.Concurrent
--import Control.Concurrent.STM
import STM
import Control.Monad
 
main = do
a <- newTVarIO ""
b <- newTVarIO True
forkIO $ forever $ atomically $ do
a' <- readTVar a
b' <- readTVar b
if b' then do
writeTVar a $ "%" ++ a'
writeTVar b $ not b'
else
return ()
forkIO $ forever $ atomically $ do
a' <- readTVar a
b' <- readTVar b
if not b' then do
writeTVar a $ "^" ++ a'
writeTVar b $ not b'
else
return ()
threadDelay 1000000
v <- atomically $ do
a' <- readTVar a
b' <- readTVar b
return (a', b')
print v

Some comments on the functions appreciated .. I am not able to understand whats going on after atomically

@satvikc, I completely agree, looking back at this, it's difficult to tell exactly what's going on. I'll add comments at some point when I get the time.

Please sign in to comment on this gist.

Something went wrong with that request. Please try again.