Haskell STM : How to store ThreadID as per their execution sequence - haskell

In the following program Fibonacci number is generated from a given integer (generated randomly) and that value is stored into a TVar. As the execution time for generating the Fibonacci is different for different number, thus threads will not run sequentially. I want to store theadID, may be in a list, to check their execution pattern.
Please help me. Thanks in advance.
module Main
where
import Control.Parallel
import Control.Concurrent.STM
import Control.Concurrent
import System.Random
import Control.Monad
import Data.IORef
import System.IO
nfib :: Int -> Int
nfib n | n <= 2 = 1
| otherwise = par n1 (pseq n2 (n1 + n2 ))
where n1 = nfib (n-1)
n2 = nfib (n-2)
type TInt = TVar Int
updateNum :: TInt -> Int -> STM()
updateNum n v = do x1 <- readTVar n
let y = nfib v
x2 <- readTVar n
if x1 == x2
then writeTVar n y
else retry
updateTransaction :: TInt -> Int -> IO ()
updateTransaction n v = do atomically $ updateNum n v
incR :: IORef Int -> Int -> IO ()
incR r x = do { v <- readIORef r;
writeIORef r (v - x) }
main :: IO ()
main = do
n <- newTVarIO 10
r <- newIORef 40;
forM_ [1..10] (\i -> do
incR r i
;v <- readIORef r
;forkIO (updateTransaction n v)
)
I want to store [TreadID,FibNo] into a List for all the threads as per their execution. Suppose T1 has executed Fib30, T2 Fib35, T3->32 and T4->40. And if the commit sequence of threads like T1,T3, T2 and T4 then I want to store T1-35,T3-32,t2-35,t4-40 in a list.
Edit:
As suggested by #MathematicalOrchid, I have modified updateTrasaction as follows:-
updateTransaction :: MVar [(ThreadId, Int)] -> TInt -> Int -> IO ()
updateTransaction mvar n v = do
tid <- myThreadId
atomically $ updateNum n v
list <- takeMVar mvar
putMVar mvar $ list ++ [(tid, v)]
Now I am trying to print the values from that list in main
main :: IO ()
main = do
...
...
m <- newEmptyMVar
...
...
mv <- readMVar m
putStrLn ("ThreadId, FibVal : " ++ " = " ++ (show mv))
At the time of execution. MVar values couldn't be read and generates error
Exception: thread blocked indefinitely in an MVar operation
What to do? Thank in advance.

Did you want something like
updateTransaction :: TInt -> Int -> IO ()
updateTransaction n v = do
tid <- myThreadId
putStrLn $ "Start " ++ show tid
atomically $ updateNum n v
putStrLn $ "End " ++ show tid
Or perhaps something like
updateTransaction :: TInt -> Int -> IO ThreadId
updateTransaction n v = do
atomically $ updateNum n v
myThreadId
and change forM_ to forM?
Also, this part:
do
x1 <- readTVar n
...
x2 <- readTVar n
if x1 == x2 ...
If x1 /= x2 then GHC will automatically abort and restart your transaction. You do not need to manually check this yourself. Indeed, the else-branch can never execute. That's kind of the point of STM; it will appear to your transaction that nobody else changes the data you're looking at, so you don't ever have to worry about concurrent writes.
Edit: If you want to record the actual order in which the transactions committed, you're going to need some more inter-thread communication. Obviously you could do that with STM, but just for a list of stuff, maybe this could work?
updateTransaction :: MVar [(ThreadId, Int)] -> TInt -> Int -> IO ()
updateTransaction mvar n v = do
tid <- myThreadId
fib <- atomically $ updateNum n v
list <- takeMVar mvar
putMVar mvar $ list ++ [(tid, fib)]
(Obviously you have to make updateNum return the number it calculated.)

Related

Self-Mutating `IO a` in Haskell

I would like to use IO Int to represent a stream of integers by hiding an IORef in its definition:
tickrate :: Int
tickrate = 20000
ioIntTest :: Int -> IO Int
ioIntTest i0 = do
intRef <- newIORef i0
f intRef
where
f :: IORef Int -> IO Int
f ref = do
i <- readIORef ref
modifyIORef ref (+1)
return i
ioTest :: Int -> IO ()
ioTest n = do
let intStream = ioIntTest n
intStreamToPrint intStream
where
intStreamToPrint is = do
threadDelay tickrate
c <- is
putStrLn (show c)
intStreamToPrint is
However, if I call ioTest n, rather than seeing an increasing list of numbers printed to the screen, I see only the starting number, n, repeating indefinitely.
While I could refactor this code so that incrementing and reading the value of ioIntTest i0 are done separately, I would like to know if/why the following is impossible:
Can I make an IO Int such that each time it is used in (>>=) (either explicitly or implicitly in do notation) the returned Int mutates?
While such an IO Int is perhaps not referentially transparent, I thought that was the point of wrapping computations in the IO monad.
Such a refactoring could be:
tickrate :: Int
tickrate = 20000
ioIntMutate :: IORef Int -> IO Int
ioIntMutate ref = do
i <- readIORef ref
modifyIORef ref (+1)
return i
ioTest :: Int -> IO ()
ioTest n = do
intStream <- newIORef n
intStreamToPrint intStream
where
intStreamToPrint is = do
threadDelay tickrate
c <- ioIntMutate is
putStrLn (show c)
intStreamToPrint is
In other words, is there any way to replace the line ioIntMutate is in the third-to-last line with an IO Int?
You can use IO (IO Int) for that. Like this:
ioIntTest :: Int -> IO (IO Int)
ioIntTest n = do
ref <- newIORef n
pure $ do
i <- readIORef ref
writeIORef ref (i+1)
pure i
ioTest :: Int -> IO ()
ioTest n = do
intStream <- ioIntTest n
intStreamToPrint intStream
where
intStreamToPrint is = do
threadDelay tickrate
c <- is
putStrLn (show c)
intStreamToPrint is
Note that the only difference between my ioTest and your ioTest is this line:
let intStream = ioIntTest n -- yours
intStream <- ioIntTest n -- mine
And, by the way, this solution is not so contrived. I have used a trick like this before to hide internal implementation details of an async RPC channel; or for another example on Hackage, check out once. You don't need to know whether that's implemented with IORefs or some other trick, and the author can switch tricks as they find better ones.
As a stylistic note, I'd write ioTest a little differently. One of these two:
ioTest :: Int -> IO ()
ioTest n = do
intStream <- ioIntTest n
forever (intStream >>= print >> threadDelay tickrate)
-- OR
forever $ do
intStream >>= print
threadDelay tickrate

Factorial using imperative-style programming

I have the following code:
while :: IO Bool -> IO () -> IO ()
while test body =
do b <- test
if b
then do {body ; while test body} -- same-line syntax for do
else return ()
I need to implement the factorial function using imperative-style programming. what I have to do is to create and initialize variables using newIORef, modify their values using a while loop with readIORef and writeIORef, then have the IO action return a pair consisting of the input n and the final result.
This is what I have done so far:
fact :: Integer -> IO (Integer, Integer)
fact n = do r <- newIORef n --initialize variable
while
(do {v <- readIORef n; n})
(do {v <- readIORef r; writeIORef (...)) --modify the value (?)
readIORef r
This is my attempt to write the factorial function. This is obviously does not work. Any help would be appreciated.
I think maybe it's time to give you some working version:
fact :: Integer -> IO (Integer, Integer)
fact n = do
i <- newIORef 1
acc <- newIORef 1
while (lessOrEqualN i) (step i acc)
acc' <- readIORef acc
return $ (n, acc')
where
lessOrEqualN iRef = do
i' <- readIORef iRef
return $ i' <= n
step iRef accRef = do
i' <- readIORef iRef
acc' <- readIORef accRef
writeIORef accRef (acc' * i')
writeIORef iRef (i'+1)
as you can see I used an loop reference i and an accumulator reference acc always reading, writing the changing values.
To make this (hopefully) a bit more readable I extracted the test and the body of the while into lessOrEqualN and step.
Of course there are easier ways to do this (modifyIORef) but I guess you have to use those.
PS: you play with it a bit - maybe you want to handle negative values differently or whatever
this might be a bit cleaner (putting both mutables into the same ref):
fact :: Integer -> IO (Integer, Integer)
fact n = do
ref <- newIORef (1,1)
while (lessOrEqualN ref) (step ref)
(_,acc) <- readIORef ref
return $ (n, acc)
where
lessOrEqualN ref = do
(i,_) <- readIORef ref
return $ i <= n
step ref = do
(i,acc) <- readIORef ref
writeIORef ref (i+1, acc * i)
I think Carsten's answer can be made a bit cleaner like this:
{-# LANGUAGE TupleSections #-}
import Control.Monad
import Data.IORef
fact :: Integer -> IO (Integer, Integer)
fact n = do
counter <- newIORef 1
result <- newIORef 1
while (fmap (<=n) (readIORef counter)) $ do
i <- postIncrement counter
modifyIORef result (*i)
fmap (n,) (readIORef result)
while :: IO Bool -> IO () -> IO ()
while test body =
do b <- test
if b
then do {body ; while test body} -- same-line syntax for do
else return ()
postIncrement :: Enum a => IORef a -> IO a
postIncrement ref = do
result <- readIORef ref
modifyIORef ref succ
return result
What I'm doing here is:
Using modifyIORef to cut down on the number of paired readIORef/writeIORef calls.
Using fmap to reduce the need for auxiliary functions to test the contents of an IORef.
Write a generic, reusable postIncrement function and use that to shorten fact further.
But frankly, I think your instructor's insistence that you use this while function is a bit silly. It doesn't make for clean code. If I was told to write an imperative factorial with IORef I'd first write this, just using the forM_ loop from the library:
factorial :: Integer -> IO (Integer, Integer)
factorial n = do
result <- newIORef 1
forM_ [2..n] $ \i -> do
modifyIORef result (*i)
fmap (n,) (readIORef result)
And that's because I was too dumb to remember replicateM_ :: Monad m => Int -> m a -> m () right away...

Difference in GHC versions - compile error

I was practicing my Haskell and I came across a weird problem which I was unable to find a solution to on the Internet. I decided to solve this problem:
https://www.hackerrank.com/challenges/fibonacci-fp
In as many ways I can think of. One way is to perform recursion with memoization where I want to use State monad as a cache. I have GHC 7.10.2 on my Windows 10 and GHC 7.6.2 on my Ubuntu 14.04. This code below compiles (and runs very well) on 7.6.2 and doesn't compile on 7.10.2 giving error wherever I type 'Map', for example:
Not in scope: type constructor or class: 'Map.Map'
Not in scope: 'Map.lookup'
module Main (
main
) where
import qualified Data.Map as Map
import Control.Monad.State
type CacheState = Map.Map Int Int
type IOState a = StateT CacheState IO a
modNum :: Int
modNum = 100000007
fibsMod :: [Int]
fibsMod = 0 : 1 : zipWith (\x y -> (x + y) mod modNum ) fibsMod (tail fibsMod)
-- | calculate Fibs with memoization in map
memoizedFib :: Int -> IOState Int
memoizedFib n = do
state <- get
let x = Map.lookup n state
case x of
Just y ->
return y
Nothing -> do
n1 <- memoizedFib (n - 1)
n2 <- memoizedFib (n - 2)
let n3 = mod (n1 + n2) modNum
put (Map.insert n n3 state)
return n3
query :: [Int] -> IOState ()
query [] = return ()
query (n:ns) = do
fibNum <- memoizedFib n
liftIO $ print fibNum
query ns
main :: IO ()
main = do
inputdata <- getContents
let intList = (map (read :: String -> Int) . tail . words) inputdata
evalIOState $ query intList
where
initState :: Int -> Map.Map Int Int
initState upTo = Map.fromList $ zip [0 .. upTo] $ take upTo fibsMod
--initState upTo = Map.fromList $ [(0, 0), (1, 1)]
evalIOState :: IOState a -> IO a
evalIOState m = evalStateT m (initState 10001)
Does anybody know why am I facing this problem? It's very disturbing.
Additional question
As you can see I didn't perform exactly recursion with memoization. However leaving one of those lines uncommented can change approach:
initState upTo = Map.fromList $ zip [0 .. upTo] $ take upTo fibsMod
--initState upTo = Map.fromList $ [(0, 0), (1, 1)]
The problem is that using the second line performs terrible. I don't know where I made a mistake, but I think it should run in linear time with memoization. However with this line my algorithm is clearly exponential (I couldn't even get the answer for 50-th Fib number - that long). What did I do wrong in this case?
UPDATE
Thanks to your comments I fixed my code. Obviously there was a problem with mod function (I completely don't know how did this compile on GHC 7.6.2). Also I changed:
import qualified Data.Map as Map
to:
import qualified Data.Map.Strict as Map
and now this code below works as intended:
module Main (
main
) where
import qualified Data.Map.Strict as Map
import Control.Monad.State
type CacheState = Map.Map Int Int
type IOState a = StateT CacheState IO a
modNum :: Int
modNum = 100000007
fibsMod :: [Int]
fibsMod = 0 : 1 : zipWith (\x y -> (x + y) `mod` modNum) fibsMod (tail fibsMod)
-- | calculate Fibs with memoization in map
memoizedFib :: Int -> IOState Int
memoizedFib n = do
state <- get
let x = Map.lookup n state
case x of
Just y ->
return y
Nothing -> do
n1 <- memoizedFib (n - 1)
n2 <- memoizedFib (n - 2)
state <- get
let n3 = mod (n1 + n2) modNum
put (Map.insert n n3 state)
return n3
query :: [Int] -> IOState ()
query [] = return ()
query (n:ns) = do
fibNum <- memoizedFib n
liftIO $ print fibNum
query ns
main :: IO ()
main = do
inputdata <- getContents
let intList = (map (read :: String -> Int) . tail . words) inputdata
evalIOState $ query intList
where
initState :: Int -> Map.Map Int Int
--initState upTo = Map.fromList $ zip [0 .. upTo] $ take upTo fibsMod
initState upTo = Map.fromList [(0, 0), (1, 1)]
evalIOState :: IOState a -> IO a
evalIOState m = evalStateT m (initState 10001)
So now the question comes down to: Why did I need to use Data.Map.Strict, how is it different and why GHC 7.6.2 didn't need it?

Haskell STM : Main thread will not exit until child thread completes execution

In the following program, I want that main thread will not exit until all its child threads complete execution. Please note that I have used bang patterns to evaluate the Fibonacci call so that it returns an evaluated thunk to main thread.
{-# LANGUAGE BangPatterns #-}
module Main
where
import Control.Concurrent.STM
import Control.Concurrent
import System.IO
nfib :: Int -> Int
nfib n | n <= 2 = 1
| otherwise = (n1 + n2 )
where n1 = nfib (n-1)
n2 = nfib (n-2)
type TInt = TVar Int
updateNum :: TInt -> Int -> STM()
updateNum n v = do writeTVar n v
updateTransaction :: TInt -> Int -> IO ()
updateTransaction n v = do
atomically $ do
updateNum n v
main :: IO ()
main = do
n <- newTVarIO 10
forkIO $ do
let v = 30
let !x = nfib v
updateTransaction n x
forkIO $ do
let v = 15
let !x = nfib v
updateTransaction n x
forkIO $ do
let v = 25
let !x = nfib v
updateTransaction n x
nv <- readTVarIO n
putStrLn ("Fib number of " ++ " = " ++ (show nv))
nv <- readTVarIO n
putStrLn ("Fib number of " ++ " = " ++ (show nv))
nv <- readTVarIO n
putStrLn ("Fib number of " ++ " = " ++ (show nv))
I have tired to solve this problem as per [link] (Haskell MVar : How to execute shortest job first?). I don't know whether approach is correct not not and also getting an error when try to print the value of TMVar.
Here is the code :- (nfib is same as above)
type TMInt = TMVar Int
updateNum1 :: TMInt -> Int -> STM()
updateNum1 n v = do putTMVar n v
updateTransaction1 :: TMInt -> Int -> IO ()
updateTransaction1 n v = do
atomically $ do
updateNum1 n v
main1 :: IO ()
main1 = do
n <- newTMVarIO 0
forkIO $ do
let v = 30
let !x = nfib v
updateTransaction1 n x
forkIO $ do
let v = 15
let !x = nfib v
updateTransaction1 n x
forkIO $ do
let v = 25
let !x = nfib v
updateTransaction1 n x
-- t <- takeTMVar n
-- putStrLn( "result: " ++ (show t))
** Error is as follows:-
Couldn't match type `STM' with `IO'
Expected type: IO Int
Actual type: STM Int
In the return type of a call of `takeTMVar'
In a stmt of a 'do' block: t <- takeTMVar n
Please help. Thanks.
main1 is in IO but takeTMVar returns an STM Int. You need to run the transaction:
t <- atomically $ takeTMVar n
putStrLn( "result: " ++ (show t))

How GHC forces evaluation in multithreaded applications?

For example: I have a quite simple memoised implementation of fibonacci sequence,
which I request in multiple threads:
{-# LANGUAGE BangPatterns #-}
module Main where
import Control.Concurrent
import Control.DeepSeq
import System.Environment (getArgs)
import System.IO.Unsafe (unsafePerformIO)
data Tree a = Tree (Tree a) a (Tree a)
instance Functor Tree where
fmap f (Tree l m r) = Tree (fmap f l) (f m) (fmap f r)
index :: Tree a -> Int -> a
index (Tree _ m _) 0 = m
index (Tree l _ r) n = case (n - 1) `divMod` 2 of
(q,0) -> index l q
(q,_) -> index r q
nats :: Tree Int
nats = go 0 1
where go !n !s = Tree (go l s') n (go r s')
where l = n + s
r = l + s
s' = s * 2
fib :: (Int -> Integer) -> Int -> Integer
fib _ 0 = 0
fib _ 1 = 1
fib f n = f (n - 1) + f (n - 2)
fib_tree :: Tree Integer
fib_tree = fmap (fib fastfib) nats
fastfib :: Int -> Integer
fastfib = index fib_tree
writeMutex :: MVar ()
writeMutex = unsafePerformIO (newMVar ())
fibIO :: Int -> IO ()
fibIO n = let fibn = fastfib n
in deepseq fibn $ do takeMVar writeMutex
putStrLn (show n ++ " " ++ show fibn)
putMVar writeMutex ()
children :: MVar [MVar ()]
children = unsafePerformIO (newMVar [])
waitForChildren :: IO ()
waitForChildren = do
cs <- takeMVar children
case cs of
[] -> return ()
m:ms -> do
putMVar children ms
takeMVar m
waitForChildren
forkChild :: IO () -> IO ThreadId
forkChild io = do
mvar <- newEmptyMVar
childs <- takeMVar children
putMVar children (mvar:childs)
forkFinally io (\_ -> putMVar mvar ())
main' :: [Int] -> IO ()
main' = mapM_ (forkChild . fibIO)
main :: IO ()
main = do
nargs <- fmap read `fmap` getArgs :: IO [Int]
main' nargs
waitForChildren
And when compiled with -threaded I can run it:
% time ./concur 10 10 10 10 10 10 10 +RTS -N4
10 55
10 55
10 55
10 55
10 55
10 55
10 55
./concur 10 10 10 10 10 10 10 +RTS -N4 0.00s user 0.00s system 82% cpu 0.007 total
And as expected if I have single large argument, or many, the execution time is the same.
I'm interested how evaluation of thunks in memoised tree is performed, on low-level?
When one thread evaluates a thunk, the chunk is locked, and other threads block on it (aka black hole). See Haskell on a Shared-Memory Multiprocessor paper for details.

Resources