27.04.2017, JetBrains
by Дмитрий Коваников
by Simon Marlow
перевод Виталия Брагилевского
typedef struct StgTSO_ {
StgHeader header;
struct StgTSO_* _link;
struct StgTSO_* global_link;
struct StgStack_ *stackobj;
StgWord16 what_next;
StgWord16 why_blocked;
StgWord32 flags;
StgTSOBlockInfo block_info;
StgThreadID id;
StgWord32 saved_errno;
StgWord32 dirty;
struct InCall_* bound;
struct Capability_* cap;
...
} *StgTSOPtr;
// StgTSO defined in rts/Types.h
-- главная функция
main :: IO () -- IO — функция работает с реальным миром, () — типа Unit, void
main = do
s <- getLine -- считать строку из консоли в переменную s
putStrLn s -- напечатать строку s в консоль
-- возвращает не просто строку, а показывает, что строка пришла из реального мира
getReversedLine :: IO String
getReversedLine = do
s <- getLine
return (reverse s)
main :: IO ()
main = do
rs <- getReversedLine
putStrLn rs
forkIO :: IO () -> IO ThreadId -- creates lightweight thread
module Main where
import System.Random (randomRIO)
import Control.Concurrent (forkIO, threadDelay)
main :: IO ()
main = do
forkIO delayAndPrint
threadDelay (2 * 10^6)
putStrLn "Main thread!"
delayAndPrint :: IO ()
delayAndPrint = do
randomTime <- randomRIO (1, 3)
threadDelay (randomTime * 10^6) -- подождать указанное число микросекунд
putStrLn "Forked thread!"
Ожидаемый результат?
-- коробочка для данных; может быть в одном из двух состояний
-- 1. Пустая
-- 2. Хранит данные типа `a`
data MVar a
newEmptyMVar :: IO (MVar a) -- создаёт новую пустую коробочку
newMVar :: a -> IO (MVar a) -- создаёт непустую коробочку с данными
putMVar :: MVar a -> a -> IO () -- кладёт данные в коробочку
takeMVar :: MVar a -> IO a -- забирает данные из коробочки
readMVar :: MVar a -> IO a -- атомарно читает из коробочки, не забирая
Семантика take и put
Неблокирующие версии функций try*
-- аргументы функции: две коробочки строк
slowPut :: MVar String -> MVar String -> IO ()
slowPut mv1 mv2 = do
threadDelay (2 * 10^6) -- ждём две секунды
putStrLn "Put val 1"
putMVar mv1 "mv1 smth" -- кладём в первую коробочку
threadDelay (2 * 10^6) -- ждём ещё две секунды
putStrLn "Put val 2"
putMVar mv2 "mv2 smth" -- кладём во вторую коробочку
main :: IO ()
main = do
mv1 <- newEmptyMVar -- создаём две пустые коробочки
mv2 <- newEmptyMVar
forkIO $ do -- выполняем в отдельном форке действия
putStrLn "Start slowput"
slowPut mv1 mv2
r1 <- takeMVar mv1 -- ждём, пока положат в первую коробочку
putStrLn ("Take first: " ++ r1)
r2 <- takeMVar mv2 -- ждём, пока положат во вторую коробочку
putStrLn ("Take second: " ++ r2)
1. Глобальные изменяемые переменные
с разделяемым доступом
2. join тредов
3. Доступ к критичекой секции
Обычно работать с MVar проще, чем с мьютексами
module Main where -- название файла: MVTest.hs
import Control.Concurrent.MVar (newEmptyMVar, takeMVar)
main :: IO ()
main = do
m <- newEmptyMVar
takeMVar m
$ stack ghc -- MVTest.hs
[1 of 1] Compiling Main ( MVTest.hs, MVTest.o )
Linking MVTest ...
$ ./MVTest
MVTest: thread blocked indefinitely in an MVar operation
Решение:
endlessPain :: IO ()
endlessPain = do
v <- newEmptyMVar -- создаём пустую коробочку
forkIO $ forever $ do -- в отдельном треде выполняем действие бесконечно
x <- takeMVar v
putStrLn x
putMVar v "Haskell" -- кладём в коробочку всего два раза
putMVar v "42"
main :: IO ()
main = do
endlessPain -- вызываем определённую ранее функцию
threadDelay (5 * 10^6) -- ждём 5 секунд
putStrLn "After eternity"
data ChItem a = ChItem a (Stream a)
type Stream a = MVar (ChItem a)
data Chan a = Chan (MVar (Stream a))
(MVar (Stream a)) -- Invariant: the `Stream a`
-- is always an empty MVar
forkFinally :: IO a -> (Either SomeException a -> IO ()) -> IO ThreadId
^ ^
| |----- finalizer
|
|------ действие, которое выполняется в отдельном потоке
Исключение во время выполнения finalizer?
throwTo :: Exception e => ThreadId -> e -> IO ()
Может бросить асинхронное исключение любому треду
Используем forkFinally для ловли исключений
problem :: MVar a -> (a -> IO a) -> IO ()
problem m f = do
a <- takeMVar m -- 1
r <- f a `catch` \e -> do putMVar m a; throw e -- 2
putMVar m r -- 3
Комбинатор маски
mask :: ((IO a -> IO a) -> IO b) -> IO b
problem :: MVar a -> (a -> IO a) -> IO ()
problem m f = mask $ \unmasked -> do
a <- takeMVar m
r <- unmasked (f a) `catch` \e -> do putMVar m a; throw e
putMVar m r
finally :: IO a -> IO b -> IO a
finally action finalizer = mask $ \unmasked -> do
result <- unmasked action `catch` \e -> do
finalizer
throwM (e :: SomeException)
finalizer
return result
Можно посмотреть на код и подумать
data Async a -- асинхронное вычисление, возвращающее объект типа `a`
async :: IO a -> IO (Async a) -- создать асинхронное вычисление
wait :: Async a -> IO a -- подождать выполнения
cancel :: Async a -> IO () -- отменить вычисление
concurrently :: IO a -> IO b -> IO (a, b) -- оба параллельно
race :: IO a -> IO b -> IO (Either a b) -- какое раньше
dummyWorker :: Int -> IO Int -- делаем бесполезную работу (программируем)
dummyWorker n = do
threadDelay (10^2 * n)
return (n * n)
-- Запускаем два потока, делаем ставки на самый быстрый и ждём
raceTest :: IO (Either Int Int)
raceTest = race (worker 1000) (worker 2000)
-- Запускаем два треда и ждём выполнения обоих
test1 :: IO (Int, Int)
test1 = do val1 <- async $ worker 1000
val2 <- async $ worker 2000
res1 <- wait val1
res2 <- wait val2
return (res1, res2)
type Account = MVar Integer
credit :: Integer -> Account -> IO ()
credit amount account = do
current <- takeMVar account
putMVar account (current + amount)
debit :: Integer -> Account -> IO ()
debit amount account = do
current <- takeMVar account
putMVar account (current - amount)
transfer :: Integer
-> Account
-> Account
-> IO ()
transfer amount from to = do
debit amount from
credit amount to
type Account = TVar Integer
credit :: Integer -> Account -> STM ()
credit amount account = do
current <- readTVar account
writeTVar account (current + amount)
debit :: Integer -> Account -> STM ()
debit amount account = do
current <- readTVar account
writeTVar account (current - amount)
transfer :: Integer
-> Account
-> Account
-> STM ()
transfer amount from to = do
debit amount from
credit amount to