Многопоточное программирование на Haskell

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

Парадигмы ФП на помощь

1. Чистые функции

2. Иммутабельность

Краткое введение в реальный мир для не-хаскеллистов

-- главная функция
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

fork

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!"

Ожидаемый результат?

MVar

-- коробочка для данных; может быть в одном из двух состояний 
--   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*

Пример MVar

-- аргументы функции: две коробочки строк
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)

Использование MVar

1. Глобальные изменяемые переменные

    с разделяемым доступом

2. join тредов

3. Доступ к критичекой секции

Обычно работать с MVar проще, чем с мьютексами

Deadlocks (1 / 2)

Deadlocks (2 / 2)

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

Как там с утечками памяти?

Обычно не так сложно внести в программу утечку памяти даже при наличии GC

Решение:

Вдохновляющий пример

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"         

MVar как Lego

data ChItem a = ChItem a (Stream a)

type Stream a = MVar (ChItem a)

Unbounded Channels

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

Можно посмотреть на код и подумать

Ещё?

Async

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

Благодарю за внимание! Вопросы?

Многопоточное программирование на Haskell

By Dmitrii Kovanikov

Многопоточное программирование на Haskell

Презентация-обзор возможностей многопоточного программирования на Haskell

  • 1,537