Стековая машина на моноидах

  • Tutorial

Не так давно на Хабре появилась отличная и вдохновляющая статья про компиляторы и стековые машины. В ней показывается путь от простой реализации исполнителя байт-кода ко всё более и более эффективным версиям. Мне захотелось показать на примере разработки стековой машины, как это можно сделать Haskell-way.


На примере интерпретации языка для стековой машины мы увидим, как математическая концепция полугрупп и моноидов помогает разрабатывать и расширять архитектуру программы, как можно использовать алгебру моноидов и каким образом можно строить программы в форме набора гомоморфизмов между алгебраическими системами. В качестве рабочих примеров мы сначала построим интерпретатор, неотделимый от кода в виде EDSL, а потом научим его разным штукам: вести запись произвольной отладочной информации, отделять код программы от самой программы, проводить простой статический анализ и вычислять с различными эффектами.


Статья рассчитана на тех, кто владеет языком Haskell на среднем уровне и выше, на тех, кто его уже использует в работе или исследованиях и на всех любопытных, заглянувших поглядеть чего это функциональщики ещё понаворотили. Ну, и для тех, конечно, кого не испугал предыдущий абзац.


Материала получилось много, со множеством примеров в коде, и чтобы облегчить читателю понимание нужно ли ему в неё погружаться, приведу аннотированное содержание.


Содержание статьи
  • Языки и программы для стековых машин. Рассматриваются структурные особенности языков стековых машин, которые можно использовать для реализации интерпретатора
  • Строим машину. Более или менее подробно разбирается код интерпретатора для стековой машины с памятью, основанный на моноидах трансформации.
  • Комбинируем моноиды. С помощью алгебры моноидов добавляем в интерпретатор ведение журнала вычислений, с практически произвольными типами записей.
  • Программы и их коды. Строим изоморфизм между программой и её кодом, дающий возможность оперировать ими по-отдельности.
  • Освобождение моноида. Новые гомомофизмы из программ в другие структуры используютсях для форматированного листинга, статического анализа и оптимизации кода.
  • От моноидов к монадам и снова к моноидам. Конструируем гомоморфизмы в элементы категории Клейсли, открывающие возможности использования монад. Расширяем интерпретатор командами ввода/вывода и неоднозначными вычислениями.

Задачи трансляции и интерпретации дарят множество интересных и полезных примеров для демонстрации самых разных аспектов программирования. Они позволяют переходить на разные ступени сложности и абстракции, оставаясь при этом вполне практичными. В этой статье мы сосредоточимся на демонстрации возможностей двух важных математических структур — полугруппы и моноида. Они не так часто обсуждаются, как монады или линзы, и ими не пугают маленьких программистов, эти структуры существенно проще для понимания, но при всём том, они лежат в основе функционального программирования. Виртуозное владение моноидальными типами, которое демонстрируют профессионалы, вызывает восхищение простотой и изяществом решений.


Поиск слова "моноид" по статьям на Хабре выдаёт не более четырёх десятков статей (про те же монады, например, их три сотни). Все они концептуально начинают с чего-то вроде: моноид это такое множество... а потом, с вполне понятным восторгом, перечисляют что является моноидом — от строк до пальчиковых деревьев, от парсеров регулярных выражений до бог знает ещё чего! Но на практике мы мыслим в обратном порядке: у нас есть объект, который необходимо моделировать, мы анализируем его свойства и обнаружив, что он обладает признаками той или иной абстрактной структуры, решаем: нужны ли нам следствия из этого обстоятельства и как нам это использовать. Мы пройдём именно этим путём. А заодно добавим в коллекцию полезных моноидов ещё парочку интересных примеров.



Языки и программы для стековых машин


Стековые машины при изучении функционального программирования, обычно появляются в тот момент, когда подходят к концепции свёртки. При этом приводится крайне лаконичная реализация исполнителя простейшего стекового калькулятора, например, такая:


Простейший стековый калькулятор
calc :: String -> [Int]
calc = interpretor . lexer
  where
    lexer = words
    interpretor = foldl (flip interprete) []
    interprete c = case c of
      "add" -> binary $ \(x:y:s) -> x + y:s
      "mul" -> binary $ \(x:y:s) -> x * y:s
      "sub" -> binary $ \(x:y:s) -> y - x:s
      "div" -> binary $ \(x:y:s) -> y `div` x:s
      "pop" -> unary  $ \(x:s) -> s
      "dup" -> unary  $ \(x:s) -> x:x:s
      x -> case readMaybe x of
        Just n -> \s -> n:s
        Nothing -> error $ "Error: unknown command " ++ c
      where
        unary f s = case s of
          x:_ -> f s
          _ -> error $ "Error: " ++ c ++ " expected an argument."
        binary f s = case s of
          x:y:_ -> f s
          _ -> error $ "Error: " ++ c ++ " expected two arguments."

Здесь используется тотальный парсер readMaybe из модуля Text.Read. Можно было бы привести программу и раза в два короче, но уже без информативных сообщениях об ошибках, а это некрасиво.


Прекрасное начало для разговора! Далее, как правило, начинают навешивать эффекты: меняют свёртку foldl на foldM, обеспечивают тотальность через монаду Either String, потом добавляют логирование, оборачивая всё трасформером WriterT, внедряют с помощью StateT словарь для переменных, и так далее. Иногда, для демонстрации крутости монадических вычислений, реализуют неоднозначный калькулятор, возвращающий все возможные значения выражения $(2 \pm 3)*((4 \pm 8)\pm 5)$. Это долгий, хороший и интересный разговор. Однако, свой рассказ мы сразу поведём по-другому, хотя и закончим его тем же результатом.


Почему, вообще, речь заходит о свёртке? Потому что свёртка (катаморфизм) — это абстракция последовательной обработки индуктивных данных. Стековая машина линейно проходит по коду, выполняя последовательность инструкций и порождает одно значение — состояние стека. Мне нравится представлять себе работу свёрточной стековой машины, как трансляцию матричной РНК в живой клетке. Рибосома шаг за шагом проходит всю цепочку РНК, сопоставляет триплеты нуклеотидов с аминокислотами и создаёт первичную структуру белка.


У свёрточной машины есть ряд ограничений, основное — программа всегда прочитывается от начала до конца и один раз. Ветвление, циклы и вызовы подпрограмм требуют концептуального изменения интерпретатора. Ничего сложного, конечно, но такая машина уже не может быть описана простой свёрткой.


Согласно гипотезе лингвистической относительности, свойства используемого нами языка напрямую влияют на свойства нашего мышления. Давайте обратим внимание не на машину, а на языки и программы, которыми она управляется.


Все стеково-ориентированные языки, как относительно низкоуровневые (байт-коды виртуальных машин Java и Python или .NET), так и языки уровнем повыше (PostScript, Forth или Joy), имеют одно фундаментальное общее свойство: если записать последовательно две корректные программы, то получится корректная программа. Правда, корректная не значит "правильная", эта программа может вылетать с ошибкой на любых данных или проваливаться в бесконечные циклы и вообще не иметь смысла, но главное — такая программа сможет быть выполнена машиной. В то же время, разбивая корректную программу на части мы легко можем эти части использовать повторно, именно в силу их корректности. Наконец, в любом стековом языке можно выделить подмножество команд, оперирующих только внутренним состоянием машины (стеком или регистрами), не использующих какую-либо внешнюю память. Это подмножество будет образовывать язык, обладающий свойством конкатенативности. В таком языке любая программа имеет смысл преобразователя состояния машины, а последовательное выполнение программ эквивалентно их композиции, а значит, тоже является преобразователем состояния.


Просматривается общий паттерн: комбинация (конкатенация) корректных программ порождает корректную программу, комбинация преобразователей порождает преобразователь. Получается, что программы стековых языков замкнуты относительно операции конкатенации или образуют структуру, которая называется группоидом или магмой. Это означает, что можно, записав программу на ленту, разрезать её почти как попало и потом из полученных отрезков формировать новые программы. Причём разрезать можно вплоть до отрезков с единственной инструкцией.


При склеивании важен порядок. Например, эти две программы, несомненно, разные:

$\texttt{5 dup pop} \neq \texttt{5 pop dup}.$


Зато нам неважно где программу разрезать, если тут же её в этом месте склеить:

$(\texttt{5 dup}) + \texttt{pop} = \texttt{5} + (\texttt{dup pop}).$


Это простое обстоятельство отражает ассоциативность операции конкатенации и поднимает структуру, которую образуют стековые программы, на новый уровень, мы понимаем что это полугруппа.

И что это нам даёт, как программистам? Ассоциативность позволяет выполнять прекомпиляцию, оптимизацию и даже распараллеливание произвольных пригодных для этого отрезков программы, а потом объединять их в эквивалентную программу. Мы можем позволить себе провести статический анализ любого отрезка программы и использовать его в анализе всей программы именно потому, что нам всё равно, где ставить скобки. Это очень важные и серьёзные возможности для языка низкого уровня или промежуточного языка, на котором пишет не человек, а транслятор. А с точки зрения математика и матёрого функциональщика, это делает программы-преобразователи состояния машины полноценными эндоморфизмами. Эндоморфизмы тоже образуют полугруппу с операцией композиции. В алгебре такие эндоморфизмы называются полугруппами трансформации по отношению к какому-либо множеству. Например, конечные автоматы образуют полугруппу трансформации множества состояний.


"Полугруппа" звучит половинчато, как-то неполноценно. Может быть, стековые программы образуют группу? Э… нет, большинство программ необратимо, то есть, по результату выполнения не выйдет однозначно восстановить исходные данные. А вот нейтральный элемент у нас есть. В языках ассемблера он обозначается $\texttt{nop}$ и ничего не делает. Если в стековом языке такого оператора явно не определили, то его можно легко получить комбинируя некоторые команды, например: $\texttt{inc dec}$, $\texttt{dup pop}$ или $\texttt{swap swap}$. Такие пары можно безболезненно вырезать из программ или, напротив, вставлять куда угодно в произвольном количестве. Поскольку единица имеется, наши программы образуют полугруппу с единицей или моноид. Значит, можно программно реализовать их в виде моноидов — эндоморфизмов над состоянием стековой машины. Это позволит определить небольшой набор базовых операций для машины, а потом создавать программы с помощью их композиции, получив стековый язык в форме встроенного предметно-ориентированного языка (EDSL).


В языке Haskell полугруппы и моноиды описаны с помощью классов Semigroup и Monoid. Их определения просты и отражают только базовую структуру, требования ассоциативности и нейтральности приходится проверять программисту:


class Semigroup a where
  (<>) :: a -> a -> a

class Semigroup a => Monoid a where
  mempty :: a


Строим машину


Заголовочная часть программы
{-# LANGUAGE LambdaCase, GeneralizedNewtypeDeriving #-}

import Data.Semigroup (Max(..),stimes)
import Data.Monoid
import Data.Vector ((//),(!),Vector)
import qualified Data.Vector as V (replicate)

Мы сразу построим машину, которая располагает стеком, конечной памятью и умеет аварийно останавливаться по-хорошему, чистым образом. Всё это реализуем без использования монад, инкапсулировав необходимые данные в тип, описывающий машину. Таким образом, все базовые программы, а значит и все их комбинации будут чистыми преобразователями её состояния.


Начнём с определения типа для виртуальной машины и тривиальных функций-сеттеров.


type Stack = [Int]
type Memory = Vector Int
type Processor = VM -> VM

memSize = 4

data VM = VM { stack :: Stack
             , status :: Maybe String
             , memory :: Memory }
          deriving Show

emptyVM = VM mempty mempty (V.replicate memSize 0)

setStack :: Stack -> Processor
setStack  x (VM _ s m) = VM x s m

setStatus :: Maybe String -> Processor
setStatus x (VM s _ m) = VM s x m

setMemory :: Memory -> Processor
setMemory x (VM s st _) = VM s st x

Сеттеры нужны для того, чтобы сделать явной семантику программы. Под процессором (тип Processor) мы будем понимать преобразователь VM -> VM.


Теперь определим типы-обёртки для моноида трансформации и для программы:


instance Semigroup (Action a) where
  Action f <> Action g = Action (g . f)

instance Monoid (Action a) where
  mempty = Action id

newtype Program = Program { getProgram :: Action VM }
  deriving (Semigroup, Monoid)

Типы-обёртки определяют принцип комбинирования программ: это эндоморфизмы с обратным порядком композиции (слева направо). Использование обёрток позволяет компилятору самостоятельно определить каким образом тип Program реализует требования классов Semigroup и Monoid.


Исполнитель программ тривиален:


run :: Program -> Processor
run = runAction . getProgram

exec :: Program -> VM
exec prog = run prog emptyVM

Сообщение об ошибке будет формировать функция err:


err :: String -> Processor
err = setStatus . Just $ "Error! " ++ m

Мы используем тип Maybe не так как он используется обычно: пустое значение Nothing в статусе означает, что ничего опасного не происходит, и вычисления можно продолжать, в свою очередь, строковое значение знаменует проблемы. Для удобства, определим два умных конструктора: один — для программ, работающих только со стеком, другой — для тех, которым нужна память.


program :: (Stack -> Processor) -> Program
program f = Program . Action $
  \vm -> case status vm of
    Nothing -> f (stack vm) vm
    _ -> vm

programM :: ((Memory, Stack) -> Processor) -> Program
programM f = Program . Action $
  \vm -> case status vm of
    Nothing -> f (memory vm, stack vm) vm
    _ -> vm

Теперь можно определять базовые команды языка для работы со стеком и памятью, целочисленную арифметику, а также отношения эквивалентности и порядка.


Работа со стеком
pop = program $ 
  \case x:s -> setStack s
        _ -> err "pop expected an argument."

push x = program $ \s -> setStack (x:s)

dup = program $ 
  \case x:s -> setStack (x:x:s)
        _ -> err "dup expected an argument."

swap = program $ 
  \case x:y:s -> setStack (y:x:s)
        _ -> err "swap expected two arguments."

exch = program $ 
  \case x:y:s -> setStack (y:x:y:s)
        _ -> err "exch expected two arguments."

Работа с памятью
-- конструктор для функций с ограниченным индексом
indexed i f = programM $ if (i < 0 || i >= memSize)
                         then const $ err $ "expected index in within 0 and " ++ show memSize
                         else f

put i = indexed i $
    \case (m, x:s) -> setStack s . setMemory (m // [(i,x)])
          _ -> err "put expected an argument"

get i = indexed i $ \(m, s) -> setStack ((m ! i) : s)

Арифметические операции и отношения
unary n f = program $
  \case x:s -> setStack (f x:s)
        _ -> err $ "operation " ++ show n ++ " expected an argument"

binary n f = program $
  \case x:y:s -> setStack (f x y:s)
        _ -> err $ "operation " ++ show n ++ " expected two arguments"

add = binary "add" (+)
sub = binary "sub" (flip (-))
mul = binary "mul" (*)
frac = binary "frac" (flip div)
modulo = binary "modulo" (flip mod)
neg = unary "neg" (\x -> -x)
inc = unary "inc" (\x -> x+1)
dec = unary "dec" (\x -> x-1)
eq = binary "eq" (\x -> \y -> if (x == y) then 1 else 0)
neq = binary "neq" (\x -> \y -> if (x /= y) then 1 else 0)
lt = binary "lt" (\x -> \y -> if (x > y) then 1 else 0)
gt = binary "gt" (\x -> \y -> if (x < y) then 1 else 0)

Для полноценной работы не хватает ветвления и циклов. Вообще-то, для встроенного языка достаточно только ветвления, циклы можно организовать с помощью рекурсии во вмещающем языке (в Haskell), но мы сделаем наш язык самодостаточным. Кроме того, воспользуемся тем, что программы образуют полугруппу и определим комбинатор повторения программы указанное число раз. Количество повторений он будет брать со стека.


Ветвление и циклы
branch :: Program -> Program -> Program
branch br1 br2 = program go
   where go (x:s) = proceed (if (x /= 0) then br1 else br2) s
         go _ = err "branch expected an argument."

while :: Program -> Program -> Program
while test body = program (const go) 
  where go vm = let res = proceed test (stack vm) vm
          in case (stack res) of
               0:s -> proceed mempty s res
               _:s -> go $ proceed body s res
               _ -> err "while expected an argument." vm

rep :: Program -> Program
rep body = program go
  where go (n:s) = proceed (stimes n body) s
        go _ = err "rep expected an argument."

proceed :: Program -> Stack -> Processor
proceed prog s = run prog . setStack s

Типы функций branch и while говорят о том, что это не самостоятельные программы, а комбинаторы программ: типичный подход при создании EDSL в Haskell. Функция stimes определена для всех полугрупп, она возвращает композицию указанного числа элементов.


Наконец, напишем несколько программ, для опытов.


Примеры программ
-- рекурсивный факториал
fact = dup <> push 2 <> lt <>
       branch (push 1) (dup <> dec <> fact) <>
       mul

-- итеративный факториал
fact1 = push 1 <> swap <>
        while (dup <> push 1 <> gt) 
        (
         swap <> exch <> mul <> swap <> dec
        ) <> 
        pop

-- заполняет стек последовательностью чисел
-- в указанном диапазоне
range = exch <> sub <> rep (dup <> inc)

-- ещё один итеративный факториал,
-- записанный через свёртку списка команд
fact2 = mconcat [ dec, push 2, swap, range, push 3, sub, rep mul]

-- итеративный факториал с использованием памяти
fact3 = dup <> put 0 <> dup <> dec <>
        rep (dec <> dup <> get 0 <> mul <> put 0) <>
        get 0 <> swap <> pop

-- копирует два верхних элемента стека
copy2 = exch <> exch

-- вычисляет наибольший общий делитель 
-- по простейшему алгоритму Евклида
gcd1 = while (copy2 <> neq) 
       (
         copy2 <> lt <> branch mempty (swap) <> exch <> sub
       ) <>
       pop

-- возведение в степень методом русского крестьянина
pow = swap <> put 0 <> push 1 <> put 1 <>
      while (dup <> push 0 <> gt)
      (
        dup <> push 2 <> modulo <>
        branch (dec <> get 0 <> dup <> get 1 <> mul <> put 1) (get 0) <>
        dup <> mul <> put 0 <>
        push 2 <> frac
      ) <>
      pop <> get 1

Получилось 120 строк кода с комментариями и аннотациями типов, которые определяют машину, оперирующую 18 командами с тремя комбинаторами. Вот как наша машина работает .


λ> exec (push 6 <> fact)
VM {stack = [720], status = Nothing, memory = [0,0,0,0]}

λ> exec (push 6 <> fact3)
VM {stack = [720], status = Nothing, memory = [720,0,0,0]}

λ> exec (push 2 <> push 6 <> range)
VM {stack = [6,5,4,3,2], status = Nothing, memory = [0,0,0,0]}

λ> exec (push 6 <> push 9 <> gcd1)
VM {stack = [3], status = Nothing, memory = [0,0,0,0]}

λ> exec (push 3 <> push 15 <> pow)
VM {stack = [14348907], status = Nothing,  memory = [43046721,14348907,0,0]}

λ> exec (push 9 <> add)
VM {stack = [9], status = Just "Error! add expected two arguments", memory = [0,0,0,0]}

На самом деле, мы ничего нового не сделали — комбинируя преобразователи-эндоморфизмы, мы, по существу, вернулись к свёртке, но она стала неявной. Напомним, свёртка даёт абстракцию последовательной обработки индуктивных данных. Данные, в нашем случае, образуются индуктивным образом при склеивании программ оператором $\diamond$, и "хранятся" они в эндоморфизме в виде цепочки композиций функций-преобразователей машины до момента применения этой цепочки к исходному состоянию. В случае применения комбинаторов branch и while цепочка начинает превращаться в дерево или в цикл. В общем случае, мы получаем граф, отражающий работу автомата с магазинной памятью, то есть, стековой машины. Именно эту структуру мы "сворачиваем" при выполнении программы.


Насколько эффективна такая реализация? Композиция функций — это самое лучшее, что умеет делать компилятор языка Haskell. Он, буквально, рождён для этого! Когда речь заходит о преимуществах использования знания о моноидах, часто приводят пример разностных списков diffList — реализации связного списка в виде композиции эндоморфизмов. Разностные списки принципиально ускоряют формирование списков из множества кусочков благодаря ассоциативности композиции функций. Возня с типами-обёртками не приводит к увеличению накладных расходов, они "растворяются" на этапе компиляции. Из лишней работы остаётся только проверка состояния на каждом шаге выполнения программы.



Комбинируем моноиды


Думаю, к этому моменту скептики и случайные читатели уже нас покинули, можно позволить себе расслабиться и перейти на следующий уровень абстракции.


Концепция полугрупп и моноидов не была бы столь полезной и универсальной, если бы не ряд свойств, присущих всем полугруппам и моноидам без исключения, которые позволяют из простых структур строить сложные точно таким же образом, каким мы строим сложные программы из простых. Эти свойства относятся уже не к объектам, а к типам и их лучше записать не в математической нотации, а в виде программ на Haskell, которые в силу изоморфизма Карри-Ховарда, являются их доказательствами.


1) Моноиды и полугруппы можно "перемножать". Здесь имеется в виду произведение типов, абстракцией которого в Haskell является кортеж или пара.


instance (Semigroup a, Semigroup b) => Semigroup (a,b) where
    (a1, b1) <> (a2, b2) = (a1 <> a2, b1 <> b2)
instance (Monoid a, Monoid b) => Monoid (a,b) where
    mempty = (mempty, mempty )

2) Существует единичный моноид, он представлен единичным типом ():


instance Semigroup () where
    () <> () = ()
instance Monoid () where
    mempty = ()

С операцией перемножения полугруппы сами образуют полугруппу, а принимая во внимание единичный тип, можно сказать, что моноиды образуют моноид! Ассоциативность и нейтральность единицы при этом выполняется с точностью до изоморфизма, но это не принципиально.


3) Отображения в полугруппу или моноид образуют, соответственно, полугруппу или моноид. И тут тоже проще записать это утверждение на Haskell:


instance Semigroup a => Semigroup (r -> a) where
  f <> g = \r -> f r <> g r
instance Monoid a => Monoid (r -> a) where
  mempty = const mempty

Воспользуемся этими комбинаторами для того, чтобы расширить возможности построенного нами стекового языка. Давайте внесём серьёзное изменение и сделаем наши базовые команды функциями, возвращающими программы. Это не лишит их моноидальных свойств, зато позволит вводить в работу всех команд машины произвольную информацию извне. Вот что имеется ввиду:


(command1 <> command2) r   ==  command1 r <> command2 r

Информация может быть любой, например, внешний словарь с какими-то определениями, или способ вести журнал вычислений, нужный при отладке. Это очень похоже на действие монады Reader, которая, как раз, и является просто функцией.


Мы введём в структуру машины журнал, но не будем привязывать его к какому-то определённому типу, а выведем его в параметр типа. Писать в журнал будем с помощью обобщённой моноидальной операции.


data VM a = VM { stack :: Stack
               , status :: Maybe String
               , memory :: Memory
               , journal :: a }
            deriving Show

mkVM = VM mempty mempty (V.replicate memSize 0)

setStack  x (VM _ st m l) = VM x st m l
setStatus st (VM s _ m l) = VM s st m l
setMemory m (VM s st _ l) = VM s st m l
addRecord x (VM s st m j) = VM s st m (x<>j)

newtype Program a = Program { getProgram :: Action (VM a) }
  deriving (Semigroup, Monoid)

type Program' a = (VM a -> VM a) -> Program a

С этого момента мы позволим себе не указывать аннотации типов для всех определений, предоставляя компилятору разбираться с ними самостоятельно, они не сложные, хоть и становятся громоздкими. Сами команды менять не придётся, благодаря умным конструкторам, которые примут на себя все изменения. Совсем небольшие.


Новые конструкторы и комбинаторы.
program f p = Program . Action $
  \vm -> case status vm of
    Nothing -> p . (f (stack vm)) $ vm
    m -> vm

programM f p = Program . Action $
  \vm -> case status vm of
    Nothing -> p . (f (memory vm, stack vm)) $ vm
    m -> vm

proceed p prog s = run (prog p) . setStack s

rep body p = program go id
  where go (n:s) = proceed p (stimes n body) s
        go _ = err "rep expected an argument."

branch br1 br2 p = program go id
   where go (x:s) = proceed p (if (x /= 0) then br1 else br2) s
         go _ = err "branch expected an argument."

while test body p = program (const go) id
  where go vm = let res = proceed p test (stack vm) vm
          in case (stack res) of
               0:s -> proceed p mempty s res
               _:s -> go $ proceed p body s res
               _ -> err "while expected an argument." vm

Осталось научить вводить внешнюю информацию в исполнитель программ. Это очень просто сделать, создавая различные исполнители с различной стратегией ведения журнала. Первый исполнитель будет самым простым, молчаливым, не тратящим сил на ведение журнала:


exec prog = run (prog id) (mkVM ())

Тут нам пригодился единичный моноид () — нейтральный элемент в алгебре моноидов. Далее, можно определить функцию для исполнителя, готового записывать в журнал ту или иную информацию о состоянии машины.


execLog p prog = run (prog $ \vm -> addRecord (p vm) vm) (mkVM mempty)

Информация может быть, например, такая:


logStack vm   = [stack vm]
logStackUsed  = Max . length . stack
logSteps      = const (Sum 1)
logMemoryUsed = Max . getSum . count . memory
  where count = foldMap (\x -> if x == 0 then 0 else 1)

Проверяем работу:


λ> exec (push 4 <> fact2)
VM {stack = [24], status = Nothing, memory = [0,0,0,0], journal = ()}

λ> journal $ execLog logSteps (push 4 <> fact2)
Sum {getSum = 14}

λ> mapM_ print $ reverse $ journal $ execLog logStack (push 4 <> fact2)
[4]
[3]
[2,3]
[3,2]
[2,2]
[3,2]
[3,3,2]
[4,3,2]
[4,4,3,2]
[5,4,3,2]
[3,5,4,3,2]
[2,4,3,2]
[12,2]
[24]

Логгеры можно комбинировать, пользуясь тем обстоятельством, что моноиды перемножаются. Введём простой комбинатор для логгеров:


f &&& g = \r -> (f r, g r)

Так можно провести сравнение четырёх реализаций факториала по числу шагов и максимальной длине стека


λ> let report p = journal $ execLog (logSteps &&& logStackUsed) p

λ> report (push 8 <> fact)
(Sum {getSum = 48},Max {getMax = 10})

λ> report (push 8 <> fact1)
(Sum {getSum = 63},Max {getMax = 4})

λ> report (push 8 <> fact2)
(Sum {getSum = 26},Max {getMax = 9})

λ> report (push 8 <> fact3)
(Sum {getSum = 43},Max {getMax = 3})

Логгеры можно было бы объявить моноидом с операцией &&&, если бы они все возвращали одинаковый тип. Но так как они разные, Haskell это сделать не позволяет. Так что не всё, что комбинируется является работающим моноидом.



Программы и их коды


Полноценная отладка подразумевает информацию о выполняемых командах. Но наши команды — это настоящие функции, у них нет имени вне пространства имён Haskell. И тут мы приходим к красивому рассуждению.


Можно сопоставить каждой базовой команде уникальный код, в то же время, можно сопоставить коду — команду. Оба соответствия однозначные, а значит: множества команд и имён изоморфны. Программы (комбинации команд) образуют моноид, и тексты программ (последовательность кодов) образуют моноид. Мы и начинали разговор с того, что разрезали и склеивали именно тексты программ, записанные на лентах. Значит между программами и их кодами можно построить пару взаимно-обратных гомоморфизмов.


Давайте же построим эти отображения! Определим сначала тип для кодов нашего языка:


data Code = IF [Code] [Code]
          | REP [Code]
          | WHILE [Code] [Code]
          | PUT Int | GET Int
          | PUSH Int | POP | DUP | SWAP | EXCH
          | INC | DEC | NEG
          | ADD | MUL | SUB | DIV
          | EQL | LTH | GTH | NEQ
          deriving (Read, Show)

Теперь построим гомоморфизм код $\rightarrow$ программа:


fromCode :: [Code] -> Program' a
fromCode = hom
  where
    hom = foldMap $ \case
      IF b1 b2 -> branch (hom b1) (hom b2)
      REP p -> rep (hom p)
      WHILE t b -> while (hom t) (hom b)
      PUT i -> put i
      GET i -> get i
      PUSH i -> push i
      POP -> pop
      DUP -> dup
      SWAP -> swap
      EXCH -> exch
      INC -> inc
      DEC -> dec
      ADD -> add
      MUL -> mul
      SUB -> sub
      DIV -> frac
      EQL -> eq
      LTH -> lt
      GTH -> gt
      NEQ -> neq
      NEG -> neg

Здесь мы используем то, что программы являются моноидами. foldMap это эффективная свёртка, рассчитанная на моноиды и использующая ассоциативность моноидальных операций. Гомоморфизм fromCode является транслятором программы, записанной в кодах, он уже позволяет транслировать программы, записанные в виде кодов и даже в виде текcта:


λ> stack $ exec (fromCode [PUSH 2, PUSH 5, EXCH, SUB, REP [DUP, INC]])
[5,4,3,2]

λ> stack $ exec (fromCode $ read "[PUSH 2, PUSH 5, EXCH, SUB, REP [DUP, INC]]")
[5,4,3,2]

Обратный гомоморфизм программа $\rightarrow$ код построить таким же образом не выйдет, поскольку мы не можем перебирать в case функции. Но можно снова воспользоваться двумя замечательными обстоятельствами: тем что программы образуют моноид и тем что моноиды образуют полугруппу! Перемножим в определении типа Program код программы и соответствующий ему трансформер:


newtype Program a = Program { getProgram :: ([Code], Action (VM a)) }
  deriving (Semigroup, Monoid)

run = runAction . snd . getProgram

Наряду с исполняющей функцией run появляется возможность получить код программы и вот он второй гомоморфизм, обратный fromCode:


toCode :: Program' a -> [Code]
toCode prog = fst . getProgram $ prog id

Теперь остаётся переписать выражения для умных конструкторов так, чтобы каждой базовой программе можно было бы указать её код. Впрочем, конструкторы и определения команд языка изменятся не существенно:


type Program' a = (Code -> VM a -> VM a) -> Program a

program c f p = Program . ([c],) . Action $
  \vm -> case status vm of
    Nothing -> p c . f (stack vm) $ vm
    _ -> vm

programM c f p = Program . ([c],) . Action $
  \vm -> case status vm of
    Nothing -> p c . f (memory vm, stack vm) $ vm
    _ -> vm

Как видно, функция, которую мы передаём для ведения журнала стала бинарной, поскольку она теперь располагает кодом программы. Значит надо немного поменять логгеры, а за одно создать логгер для кода и говорливый логгер-отладчик:


Логгеры и отладчик
none = const id
exec prog = run (prog none) (mkVM ())

execLog p prog = run (prog $ \c -> \vm -> addRecord (p c vm) vm) (mkVM mempty)

logStack _ vm = [stack vm]
logStackUsed _ = Max . length . stack
logSteps _ = const (Sum 1)

-- новые логгеры
logCode c _ = [c]
logRun com vm = [pad 10 c ++ "| " ++ pad 20 s ++ "| " ++ m]
  where c = show com
        m = unwords $ show <$> toList (memory vm)
        s = unwords $ show <$> stack vm
        pad n x = take n (x ++ repeat ' ')

debug :: Program' [String] -> String
debug = unlines . reverse . journal . execLog logRun

Определения именованных базовых команд и комбинаторов
pop = program POP $ 
  \case x:s -> setStack s
        _ -> err "POP expected an argument."

push x = program (PUSH x) $ \s -> setStack (x:s)

dup = program DUP $ 
  \case x:s -> setStack (x:x:s)
        _ -> err "DUP expected an argument."

swap = program SWAP $ 
  \case x:y:s -> setStack (y:x:s)
        _ -> err "SWAP expected two arguments."

exch = program EXCH $ 
  \case x:y:s -> setStack (y:x:y:s)
        _ -> err "EXCH expected two arguments."

app1 c f = program c $
  \case x:s -> setStack (f x:s)
        _ -> err $ "operation " ++ show c ++ " expected an argument"

app2 c f = program c $
  \case x:y:s -> setStack (f x y:s)
        _ -> err $ "operation " ++ show c ++ " expected two arguments"

add = app2 ADD (+)
sub = app2 SUB (flip (-))
mul = app2 MUL (*)
frac = app2 DIV (flip div)
neg = app1 NEG (\x -> -x)
inc = app1 INC (\x -> x+1)
dec = app1 DEC (\x -> x-1)
eq = app2 EQL (\x -> \y -> if (x == y) then 1 else 0)
neq = app2 NEQ (\x -> \y -> if (x /= y) then 1 else 0)
lt = app2 LTH (\x -> \y -> if (x > y) then 1 else 0)
gt = app2 GTH (\x -> \y -> if (x < y) then 1 else 0)

proceed p prog s = run (prog p) . setStack s

rep body p = program (REP (toCode body)) go none
  where go (n:s) = if n >= 0
                   then proceed p (stimes n body) s
                   else err "REP expected positive argument."
        go _ = err "REP expected an argument."

branch br1 br2 p = program (IF (toCode br1) (toCode br2)) go none
   where go (x:s) = proceed p (if (x /= 0) then br1 else br2) s
         go _ = err "IF expected an argument."

while test body p = program (WHILE (toCode test) (toCode body)) (const go) none
  where go vm = let res = proceed p test (stack vm) vm
          in case (stack res) of
               0:s -> proceed p mempty s res
               _:s -> go $ proceed p body s res
               _ -> err "WHILE expected an argument." vm

put i = indexed (PUT i) i $
    \case (m, x:s) -> setStack s . setMemory (m // [(i,x)])
          _ -> err "PUT expected an argument"

get i = indexed (GET i) i $ \(m, s) -> setStack ((m ! i) : s)

indexed c i f = programM c $ if (i < 0 || i >= memSize)
                             then const $ err "index in [0,16]"
                             else f

Всё, изоморфизм между программами и их кодами установлен! Давайте посмотрим, как он работает.


Во-первых, мы можем получить код любой программы:


λ>  toCode fact1
[PUSH 1,SWAP,WHILE [DUP,PUSH 1,GTH] [SWAP,EXCH,MUL,SWAP,DEC],POP]

Теперь программы можно создавать с помощью EDSL, записывать их в файл и считывать из него.


Во-вторых, можем убедиться в том, что два гомоморфизма toCode и fromCode являются взаимо-обратными.


λ> toCode $ fromCode [PUSH 5, PUSH 6, ADD]
[PUSH 5, PUSH 6, ADD]

λ> exec (fromCode $ toCode (push 5 <> push 6 <> add))
VM {stack = [11], status = Nothing, memory = [0,0,0,0], journal = ()}

Правда, наш изоморфизм имеет один существенный недостаток: он не позволяет превратить в конечный код программы, определённые с помощью явной рекурсии. Попробуйте в ghci посмотреть код программы fact, только держите пальцы на готове, чтобы поскорее нажать Ctrl+C. Приходится признать, что гомоморфизм toCode существует, но вычислим частично.


Наконец, давайте запустим полноценный отладчик, причём, он-то как раз хорошо работает и с рекурсивными функциями тоже:


λ> putStrLn $ debug (push 3 <> fact)
PUSH 3    | 3                   | 0 0 0 0
DUP       | 3 3                 | 0 0 0 0
PUSH 2    | 2 3 3               | 0 0 0 0
LTH       | 0 3                 | 0 0 0 0
DUP       | 3 3                 | 0 0 0 0
DEC       | 2 3                 | 0 0 0 0
DUP       | 2 2 3               | 0 0 0 0
PUSH 2    | 2 2 2 3             | 0 0 0 0
LTH       | 0 2 3               | 0 0 0 0
DUP       | 2 2 3               | 0 0 0 0
DEC       | 1 2 3               | 0 0 0 0
DUP       | 1 1 2 3             | 0 0 0 0
PUSH 2    | 2 1 1 2 3           | 0 0 0 0
LTH       | 1 1 2 3             | 0 0 0 0
PUSH 1    | 1 1 2 3             | 0 0 0 0
MUL       | 1 2 3               | 0 0 0 0
MUL       | 2 3                 | 0 0 0 0
MUL       | 6                   | 0 0 0 0


Освобождение моноида


Код программы имеет вид дерева и он представляет собой чистую информацию о программе. Мы получили свободную алгебру программ для нашей стековой машины. Более того, и сами программы являются свободными структурами, так как мы построили изоморфизм между кодом программы и исполнителем!


Кроме возможностей сериализации и десериализации, свободные структуры предоставляют свободу интерпретации. Мы построили пока только один способ интерпретации свободной программы — в виде трансформаций состояния стековой машины. Но имея программу в свободной форме можно делать с ней что угодно, например обеспечивать форматированный вывод, проводить оптимизацию или статический анализ.


Обычно, на этом замечательном пассаже статья про свободные структуры обрывается: можно и можно, правда сложно и в одном разделе не рассказать. Но так вышло, что наш язык чрезвычайно прост и чрезвычайно моноидален, а это позволяет делать некоторые вещи очень изящно. Грех этим не воспользоваться и не поделиться!


Вот, например, как просто написать форматированный листинг программы:


listing :: Program' a -> String
listing = unlines . hom 0 . toCode
  where
    hom n = foldMap f
      where
        f = \case
          IF b1 b2 -> ouput "IF" <> indent b1 <> ouput ":" <> indent b2
          REP p -> ouput "REP" <> indent p
          WHILE t b -> ouput "WHILE" <> indent t <> indent b
          c -> ouput $ show c

        ouput x = [stimes n "  " ++ x]
        indent = hom (n+1)

И снова строится гомоморфизм: теперь командам ставятся в соответствие строки с отступом, которые, опять же, образуют моноид.


Пара симпатично напечатанных программ:
λ> putStrLn . listing $ fact2
INC
PUSH 1
SWAP
EXCH
SUB
DUP
PUSH 0
GTH
IF
  REP
    DUP
    INC
:
  NEG
  REP
    DUP
    DEC
DEC
DEC
REP
  MUL

λ> putStrLn . listing $ gcd1
WHILE
  EXCH
  EXCH
  NEQ
  EXCH
  EXCH
  LTH
  IF
  :
    SWAP
  EXCH
  SUB
POP

Не будем на этом останавливаться и попробуем провести нехитрый статический анализ программ для стековой машины. Тип данных у нас один, так что статическая типизация для языка не актуальна, зато на стеке может не хватить данных для выполнения программы. У нас есть возможность вычислить строгие требования для работы программы до её выполнения.


Введём такую характеристику программ, как валентность — это информация о максимальном количестве аргументов, которые должны быть на стеке перед её выполнением и о минимальном числе элементов которые останутся на стеке после её выполнения. Например перед выполнением операции сложения нужно иметь на стеке не менее двух элементов, а после выполнения останется как минимум один элемент. Мы запишем это обстоятельство в таком виде:

$\mathrm{arity}(\texttt{add}) = 2 \triangleright 1$


Приведём валентности некоторых других операторов:

$\mathrm{arity}(\texttt{push}) = 0 \triangleright 1\\ \mathrm{arity}(\texttt{pop}) = 1 \triangleright 0\\ \mathrm{arity}(\texttt{exch}) = 2 \triangleright 3$


Почему мы всё время оговариваемся: минимальное число, максимальные требования..? Дело в том, что все базовые операторы имеют точно определённую валентность, но при ветвлении разные ветви могут иметь разные требования и результаты. Наша задача: вычислить наиболее строгие требования, которые должны обеспечить работу всех ветвей, сколько бы их ни было.

При последовательном выполнении команд валентности комбинируются следующим нетривиальным образом:

$(i_1 \triangleright o_1) \diamond (i_2 \triangleright o_2) = (a+i_1) \triangleright (a + o_1 + o_2 - i_2),\qquad a = \max(0, i_2 - o_1).$


Эта операция ассоциативна и имеет нейтральный элемент, что не удивительно для статьи, посвящённой моноидам. Добавим этот результат в программу:
infix 7 :>
data Arity = Int :> Int 
  deriving (Show,Eq)

instance Semigroup Arity where
  (i1 :> o1) <> (i2 :> o2) = let a = 0 `max` (i2 - o1)
                             in (a + i1) :> (a + o1 + o2 - i2)
instance Monoid Arity where
  mempty = 0:>0

А после чего можно строить гомоморфизм:


arity :: Program' a -> Arity
arity = hom . toCode
  where
    hom = foldMap $
      \case
        IF b1 b2 -> let i1 :> o1 = hom b1
                        i2 :> o2 = hom b2
                    in 1:>0 <> (i1 `max` i2):>(o1 `min` o2)
        REP p -> 1:>0
        WHILE t b -> hom t <> 1:>0
        PUT _ -> 1:>0
        GET _ -> 0:>1
        PUSH _ -> 0:>1
        POP -> 1:>0
        DUP -> 1:>2
        SWAP -> 2:>2
        EXCH -> 2:>3
        INC -> 1:>1
        DEC -> 1:>1
        NEG -> 1:>1
        _   -> 2:>1

Комбинаторы циклов имеют валентность, не зависящую от тела цикла, поскольку код тела при выполнении программы может не исполниться вовсе. А так как мы рассматриваем строгие требования, мы можем точно сказать, что гарантированно выполнится только проверка на вход в цикл.


Рассчитаем требования для некоторых программ (кроме рекурсивных):


λ> arity (exch <> exch)
2 :> 4

λ> arity fact1
1 :> 1

λ> arity range
2 :> 1

λ> arity (push 3 <> dup <> pow)
0 :> 1

Что ещё можно посчитать перед выполнением? Так как регистры памяти указываются статически, каждая программа "знает" какой объём памяти ей потребуется. Можно построить гомоморфизм Program' a -> Max Int, и при иниализации машины создавать область памяти нужного объёма. Он может быть построен, например, так:


memoryUse :: Program' a -> Max Int
memoryUse = hom . toCode
  where
    hom = foldMap $
      \case
        IF b1 b2 -> hom b1 <> hom b2
        REP p -> hom p
        WHILE t b -> hom t <> hom b
        PUT i -> Max (i+1)
        GET i -> Max (i+1)
        _ -> 0

λ> memoryUse fact1
Max {getMax = 0}

λ> memoryUse fact3
Max {getMax = 1}

λ> memoryUse pow
Max {getMax = 2}

При конкатенации программ могут возникать конфликты с совместным использованием памяти. Это можно решить автоматически вводя соответствующие смещения для всех указываемых индексов, ведь на требования памяти доступны до выполнения программы.


Вычисление валентности позволяет провести простую, но эффектную оптимизацию: можно выделять максимально длинные непрерывные линейные отрезки программ, которые не требуют элементов на стеке перед выполнением, то есть, с валентностью 0:>_ и не задействуют память. Такие цепочки не зависят от текущих данных и могут быть вычислены заранее и заменены результатом на этапе трансляции. Обычно, это арифметические вычисления.


Пример построения оптимизатора
isReducible p = let p' = fromCode p
                in case arity p' of
                     0:>_ -> memoryUse p' == 0
                     _    -> False

reducible = go [] . toCode
  where go res [] = reverse res
        go res (p:ps) = if isReducible [p]
                        then let (a,b) = spanBy isReducible (p:ps)
                             in go (a:res) b
                        else go res ps

-- здесь используется моноид Last, который комбинируется,
-- оставляя последний нетривиальный результат
spanBy test l = case foldMap tst $ zip (inits l) (tails l) of
                  Last Nothing -> ([],l)
                  Last (Just x) -> x
  where tst x = Last $ if test (fst x) then Just x else Nothing 

-- здесь используется моноид Endo комбинирующийся как эндоморфизм
-- функции intercalate и splitOn можно подгрузить из библиотек
-- Data.List и Data.List.Split
reduce p = fromCode . process (reducible p) . toCode $ p
  where
    process = appEndo . foldMap (\x -> Endo $ x `replaceBy` shrink x)
    shrink = toCode . foldMap push . reverse . stack . exec . fromCode
    replaceBy x y = intercalate y . splitOn x

Пример оптимизации простой программы:


λ> let p = push 6 <> fact1 <> swap <> push 5 <> dup <> push 14 <> gcd1 <> put 1

λ> toCode $ p
[PUSH 6,PUSH 1,SWAP,WHILE [DUP,PUSH 1,GTH] 
[SWAP,EXCH,MUL,SWAP,DEC],POP,SWAP,PUSH 5,DUP,PUSH 14,WHILE 
[EXCH,EXCH,NEQ] [EXCH,EXCH,LTH,IF [] [SWAP],EXCH,SUB],POP,PUT 1]

λ> toCode $ reduce p
[PUSH 720,SWAP,PUSH 5,PUSH 1,PUT 1]

λ> execLog logSteps (push 8 <> p)
VM {stack = [5,8,720], status = Nothing, memory = [0,1,0,0], 
journal = Sum {getSum = 107}}

λ> execLog logSteps (push 8 <> reduce p)
VM {stack = [5,8,720], status = Nothing, memory = [0,1,0,0], 
journal = Sum {getSum = 6}}

Оптимизация сократила число шагов нужных программе со 107 до 6.


Далее, от валентности можно перейти, скажем, к тройкам Хоара и формально верифицировать программы, выводя логические пред- и постусловия для работы линейных участков программ (для циклов придётся возиться инвариантами).



От моноидов к монадам и снова к моноидам


Но что если нашей машине нужно выйти в мир эффектов: общаться с пользователем, с файловой системой, базой данных, случайными числами и т.д.? Можно ли наше решение оснастить монадическими вычислениями? Можно, хоть и придётся переписывать реализацию, но оно того стоит!


При использовании монады m преобразователи VM -> VM должны превратиться в VM -> m VM, это уже не эндоморфизм. Но вспомним крылатую фразу: "Монада — это всего лишь моноид в категории эндофункторов, в чём проблема?!" В категории Клейсли, которую образуют преобразователи VM -> m VM определена композиция, а она, согласно правилам категорий, ассоциативна и имеет нейтральный элемент. Эту композицию в Haskell обозначают оператором >=> и называют "рыбкой Клейсли". Значит, для выхода в мир вычислений с эффектами достаточно поменять начинку Action на моноид ActionM, определив его следующим образом:


newtype ActionM m a = ActionM { runActionM :: a -> m a }

instance Monad m => Semigroup (ActionM m a) where
  ActionM f <> ActionM g = ActionM (f >=> g)

instance Monad m => Monoid (ActionM m a) where
  mempty = ActionM return

Поменяются сеттеры, они должны стать монадическими, и везде вместо их композиции надо будет будет использовать оператор >=>. Все же прочие определения останутся без изменений.


Стековая машина с монадическими вычислениями
{-# LANGUAGE LambdaCase, GeneralizedNewtypeDeriving, TupleSections #-}

import Data.Monoid hiding ((<>))
import Data.Semigroup (Semigroup(..),stimes,Max(..))
import Data.Vector ((//),(!),Vector,toList)
import qualified Data.Vector as V (replicate)
import Control.Monad
import Control.Monad.Identity

type Stack = [Int]
type Memory = Vector Int

memSize = 4

data VM a = VM { stack :: Stack
               , status :: Maybe String
               , memory :: Memory
               , journal :: a }
            deriving Show

mkVM = VM mempty mempty (V.replicate memSize 0)

setStack  x (VM _ st m l) = return $ VM x st m l
setStatus st (VM s _ m l) = return $ VM s st m l
setMemory m (VM s st _ l) = return $ VM s st m l
addRecord x (VM s st m l) = VM s st m (x<>l)

------------------------------------------------------------

data Code = IF [Code] [Code]
          | REP [Code]
          | WHILE [Code] [Code]
          | PUT Int | GET Int
          | PUSH Int | POP | DUP | SWAP | EXCH
          | INC | DEC | NEG
          | ADD | MUL | SUB | DIV | MOD
          | EQL | LTH | GTH | NEQ
          | ASK | PRT | PRTS String
          | FORK [Code] [Code]
          deriving (Read, Show)

newtype ActionM m a = ActionM {runActionM :: a -> m a}

instance Monad m => Semigroup (ActionM m a) where
  ActionM f <> ActionM g = ActionM (f >=> g)

instance Monad m => Monoid (ActionM m a) where
  ActionM f `mappend` ActionM g = ActionM (f >=> g)
  mempty = ActionM return

newtype Program m a = Program { getProgram :: ([Code], ActionM m (VM a)) }
  deriving (Semigroup, Monoid)

type Program' m a = (Code -> VM a -> m (VM a)) -> Program m a

program c f p = Program . ([c],) . ActionM $
  \vm -> case status vm of
    Nothing -> p c =<< f (stack vm) vm
    m -> return vm

programM c f p = Program . ([c],) . ActionM $
  \vm -> case status vm of
    Nothing -> p c =<< f (memory vm, stack vm) vm
    m -> return vm

run :: Monad m => Program m a -> VM a -> m (VM a) 
run = runActionM . snd . getProgram

toCode :: Monad m => Program' m a -> [Code]
toCode prog = fst . getProgram $ prog none

none :: Monad m => Code -> VM a -> m (VM a)
none = const return

-- запуск программы вне монад
exec :: Program' Identity () -> VM ()
exec = runIdentity . execM

execM :: Monad m => Program' m () -> m (VM ())
execM prog = run (prog none) (mkVM ())

execLog p prog = run (prog $ \c -> \vm -> return $ addRecord (p c vm) vm) (mkVM mempty)

f &&& g = \c -> \r -> (f c r, g c r)

logStack _ vm   = [stack vm]
logStackUsed _ = Max . length . stack
logSteps _     = const (Sum 1)
logCode c _   = [c]
logRun com vm = [pad 10 c ++ "| " ++ pad 20 s ++ "| " ++ m]
  where c = show com
        m = unwords $ show <$> toList (memory vm)
        s = unwords $ show <$> stack vm
        pad n x = take n (x ++ repeat ' ')

debug p = unlines . reverse . journal <$> execLog logRun p

------------------------------------------------------------
pop,dup,swap,exch :: Monad m => Program' m a
put,get,push :: Monad m => Int -> Program' m a
add,mul,sub,frac,modulo,inc,dec,neg :: Monad m => Program' m a
eq,neq,lt,gt :: Monad m => Program' m a

err m = setStatus . Just $ "Error : " ++ m

pop = program POP $ 
  \case x:s -> setStack s
        _ -> err "pop expected an argument."

push x = program (PUSH x) $ \s -> setStack (x:s)

dup = program DUP $ 
  \case x:s -> setStack (x:x:s)
        _ -> err "dup expected an argument."

swap = program SWAP $ 
  \case x:y:s -> setStack (y:x:s)
        _ -> err "swap expected two arguments."

exch = program EXCH $ 
  \case x:y:s -> setStack (y:x:y:s)
        _ -> err "expected two arguments."

put i = indexed (PUT i) i $
    \case (m, x:s) -> setStack s <=< setMemory (m // [(i,x)])
          _ -> err "put expected an argument"

get i = indexed (GET i) i $ \(m, s) -> setStack ((m ! i) : s)

indexed c i f = programM c $ if (i < 0 || i >= memSize)
                             then const $ err "index in [0,16]"
                             else f

app1 c f = program c $
  \case x:s -> setStack (f x:s)
        _ -> err $ "operation " ++ show c ++ " expected an argument"

app2 c f = program c $
  \case x:y:s -> setStack (f x y:s)
        _ -> err $ "operation " ++ show c ++ " expected two arguments"

add = app2 ADD (+)
sub = app2 SUB (flip (-))
mul = app2 MUL (*)
frac = app2 DIV (flip div)
modulo = app2 MOD (flip mod)
neg = app1 NEG (\x -> -x)
inc = app1 INC (\x -> x+1)
dec = app1 DEC (\x -> x-1)
eq = app2 EQL (\x -> \y -> if (x == y) then 1 else 0)
neq = app2 NEQ (\x -> \y -> if (x /= y) then 1 else 0)
lt = app2 LTH (\x -> \y -> if (x > y) then 1 else 0)
gt = app2 GTH (\x -> \y -> if (x < y) then 1 else 0)

proceed p prog s = run (prog p) <=< setStack s

rep body p = program (REP (toCode body)) go none
  where go (n:s) = if n >= 0
                   then proceed p (stimes n body) s
                   else err "rep expected positive argument."
        go _ = err "rep expected an argument."

branch br1 br2 p = program (IF (toCode br1) (toCode br2)) go none
   where go (x:s) = proceed p (if (x /= 0) then br1 else br2) s
         go _ = err "branch expected an argument."

while test body p = program (WHILE (toCode test) (toCode body)) (const go) none
  where go vm = do res <- proceed p test (stack vm) vm
                   case (stack res) of
                     0:s -> proceed p mempty s res
                     _:s -> go =<< proceed p body s res
                     _ -> err "while expected an argument." vm

ask :: Program' IO a
ask = program ASK $
  \case s -> \vm -> do x <- getLine
                       setStack (read x:s) vm

prt :: Program' IO a
prt = program PRT $
  \case x:s -> \vm -> print x >> return vm
        _ -> err "PRT expected an argument"

prtS :: String -> Program' IO a
prtS s = program (PRTS s) $
  const $ \vm -> print s >> return vm

fork :: Program' [] a -> Program' [] a -> Program' [] a
fork br1 br2 p = program (FORK (toCode br1) (toCode br2)) (const go) none
  where go = run (br1 p) <> run (br2 p)

------------------------------------------------------------

fromCode :: Monad m => [Code] -> Program' m a
fromCode = hom
  where
    hom = foldMap $ \case
      IF b1 b2 -> branch (hom b1) (hom b2)
      REP p -> rep (hom p)
      WHILE t b -> while (hom t) (hom b)
      PUT i -> put i
      GET i -> get i
      PUSH i -> push i
      POP -> pop
      DUP -> dup
      SWAP -> swap
      EXCH -> exch
      INC -> inc
      DEC -> dec
      ADD -> add
      MUL -> mul
      SUB -> sub
      DIV -> frac
      MOD -> modulo
      EQL -> eq
      LTH -> lt
      GTH -> gt
      NEQ -> neq
      NEG -> neg
      _ -> mempty

fromCodeIO :: [Code] -> Program' IO a
fromCodeIO = hom
  where
    hom = foldMap $ \case
      IF b1 b2 -> branch (hom b1) (hom b2)
      REP p -> rep (hom p)
      WHILE t b -> while (hom t) (hom b)
      ASK -> ask
      PRT -> ask
      PRTS s -> prtS s
      c -> fromCode [c]

fromCodeList :: [Code] -> Program' [] a
fromCodeList = hom
  where
    hom = foldMap $ \case
      IF b1 b2 -> branch (hom b1) (hom b2)
      REP p -> rep (hom p)
      WHILE t b -> while (hom t) (hom b)
      FORK b1 b2 -> fork (hom b1) (hom b2)
      c -> fromCode [c]

В рамках такой модели вычислений можно определить две новых команды: для считывания данных из stdin или с клавиатуры и для вывода значения либо сообщения на печать.


ask, prt :: Program' IO a
ask = program ASK $
  \case s -> \vm -> do x <- getLine
                       setStack (read x:s) vm

prt = program PRT $
  \case x:s -> \vm -> print x >> return vm
        _ -> err "PRT expected an argument"

prtS :: String -> Program' IO a
prtS s = program (PRTS s) $
  const $ \vm -> print s >> return vm

Теперь можно написать что-то такое интерактивное и убедиться в том, что нам удалось совместить вычисления и эффекты:


ioprog = prtS "input first number" <> ask <>
         prtS "input second number" <> ask <>
         rep (prt <> dup <> inc) <>
         prt

λ> exec ioprog
 input first number
 3 
 input second number
 5 
 3
 4
 5
 6
 7
 8
 VM {stack = [8,7,6,5,4,3], status = Nothing, memory = [0,0,0,0], journal = ()}

Для организации неоднозначных вычислений достаточно определить комбинатор, разветвляющий поток:


fork :: Program' [] a -> Program' [] a -> Program' [] a
fork br1 br2 p = program (FORK (toCode br1) (toCode br2)) (const go) pure
  where go = run (br1 p) <> run (br2 p)

Здесь опять сработала алгебра моноидов: функции run возвращают преобразователь VM -> m VM, их моноидальная композиция — функцию, возвращающую композицию преобразователей, но теперь уже в рамках монады [], то есть — список вариантов.


Результатом работы разветвлённой программы будет список конечный состояний машины:


λ> stack <$> exec (push 5 <> push 3 <> add `fork` sub)
[[8],[2]]

λ> stack <$> exec (push 5 <> push 3 `fork` dup <> push 2)
[[2,3,5],[2,5,5]]

Посчитаем пример из начала статьи: $(2 \pm 3)*((4 \pm 8)\pm 5)$:


λ> let pm = add `fork` sub
λ> stack <$> exec (push 2 <> push 3 <> push 4 <> push 8 <> pm <> push 5 <> pm <> pm <> mul)
[[40],[-28],[20],[-8],[8],[4],[-12],[24]]

А вот сравнение эффективности четырёх реализаций факториалов:


λ> journal <$> execLog logSteps (push 8 <> fact `fork` fact1 `fork` fact2 `fork` fact3)
[Sum {getSum = 48},Sum {getSum = 63},Sum {getSum = 34},Sum {getSum = 43}]

Записать выражение из четырёх ветвей вычислений без скобок нам позволило то, что программы образуют моноид с операцией fork, значит, операция fork ассоциативна.


Приятно что все базовые команды и комбинаторы сосуществуют вместе в одном модуле и склеиваются однотипно. Для всех типов вычислений работает отладка. Единственное ограничение состоит в том, что в нашей реализации невозможно комбинировать неоднозначные вычисления и ввод/вывод, однако, и это решается при помощи трансформеров монад.


$* * *$


С древне-греческого μάγμα переводится как грязь или тесто. Действительно, склеивая куски теста, мы вновь будем получать куски теста, которые можно склеивать. Это кажется более чем тривиальным наблюдением, но именно в этом заключается очарование пластилина или, например, конструктора Lego: благодаря универсальному интерфейсу соединение двух кубиков конструктора порождает новый кубик, готовый с кем-нибудь соединиться. С игрушками, соединяемыми липучками, например, так уже не получится.


Кубики Lego позволяют мастерить то, что даже не могло прийти в голову их создателям, в то время как многие конструкторы не допускают расширения модели — как на фабрике сделали, какую программу зашили, так и будет. И как ни соединяй, получится только то, что предусмотрено конструкцией либо неработающий хлам. С точки зрения защиты от дурака — это замечательно! Но если серьёзно, то суть и ценность функционального программирования состоит именно в богатстве и гибкости комбинирования. Функции при комбинировании могут образовывать новые функции, которые снова можно по-разному комбинировать. Десятками лет люди не перестают находить новые комбинации (это и продолжения и пресловутые монады и линзы-профункторы) с полезными, а иногда и восхитительными свойствами. Но самое главное — этот подход не прерогатива функционального программирования! В любой парадигме можно создавать жёсткие "одноразовые" блоки, громоздя из них фреймворки, требующие производства новых и новых блоков, поскольку они не комбинируются произвольным образом, либо создавать изящные расширяемые долгоживущие решения. Но именно в функциональной парадигме такие решения можно строить последовательно, доказывать и исследовать их свойства математически, оттачивать их прежде чем упаковывать в красивые и непрозрачные коробки и выпускать в мир технологий.




Все модули доступны в репозитории. Кое-какие цифры, отражающие производительность решения добавлены в комментарии. Самый важный результат — использование моноида в категории Клейсли открывает возможности для существенного увеличения скорости выполнения программ стековой машины, использующей память. Принцип построения программы при этом не меняется.

Поделиться публикацией
Комментарии 28
    0
    Очень интересная статья, спасибо. Побольше бы такого контента на Хабре!
      0
      А все-таки интересно, насколько быстро такая реализация работает по сравнению с той статьей, где на C? Вы не пробовали замерить время на аналогичных примерах?

      Статья чудесная, и хочется верить, что подобная компиляторная магия работает, но все-таки есть сомнения, в том что все композиции происходят бесшовно.

      В вашем же коде например есть стек представлений списком. И в силу иммутабельности, каждая команда машины, изменяющая стек означает создание нового списка с соответствующими аллокациями памяти. Это действительно как-то оптимизируется в одну операцию, и все эти аллокации исчезают?
        +2

        Сравнения с программой на С я не проводил, хотя и правда это интересно.


        Я собрал тестовую задачу в которой склеил все программы-примеры и умножил моноидально ещё 10000 раз.


        test = stimes 10000 $
          push 8 <>
          dup <> fact1 <> swap <>
          dup <> fact2 <> swap <>
          dup <> fact3 <> swap <>
          push 54 <> gcd1 <>
          dup <> push 20 <> pow

        Хвала ленивым вычислениям — этот монстр не создавался в памяти ни разу!
        При запуске получилось 3 миллиона шагов выполнения программы.


        Простое вычисление — 1.26 секунд
        Простое вычисление, компиляция с флагом -O2 — 0.47 секунд
        Простое вычисление (в монаде IO, -O2) — 0.35 секунд
        Вычисление с логированием числа шагов (-O2) — 1.28 секунд
        Вычисление с логированием числа шагов и кода (-O2) — 2.62 секунд. Замедление связано с ленивостью кортежа.
        Вычисление с логированием используемой длины стека (-O2) — 65.24 секунд. Замедление связано с вычислением длины списка.


        Вполне неплохо, в монаде IO компилятор оптимизирует вычисления максимально.

          +1

          Наивная реализация решета эратосфена требует для массива 65000 ячеек 16 миллионов шагов и каждый в десятка два инструкций, так что, скорее всего, моя реализация здорово уступит решению на С: там прямая работа с памятью, а у меня — программная реализация вектора. Мы в разных категориях, и задачи у нас разные.

            +2

            Моноид в категории Клейсли — это круто!!!
            Посвятил часок вечером пятницы написанию варианта интерпретатора с внешней памятью (он в находится в репозитории). Разница в коде только в том, что команды PUT, GET, PUTI и GETI поселились в монаде IO, в которой есть возможность доступа к Vector.Mutable. После чего можно было приступить к тесту решетом Эратосфена.
            При тех же условиях, что в статье про поросят (заполнение решетом памяти в 65536 ячейки, сто запусков):
            чистый вариант (один прогон) — 43 сек! 100 прогонов — больше часа! Хаскель отстой, ФП — сферический конь в вакууме и т.д…
            вариант с мутабельным вектором (тоже чистый, но запускаемый в монаде IO) — 9 сек на все сто прогонов!
            С решением на Питоне для этого же компьютера я не сравнивал, но для меня было главное не победить кого-то. Основная задача — убедиться в том, что не изменяя принципам чистого функционального программирования, можно выбирать максимально подходящий вычислительный процесс, а так же что моноидальное решение легко расширяется и способно использовать эффективную внешнюю память.

            0
            Cпасибо за статью! А на github выложите код?
              0

              Добавил в статью ссылку на репозиторий.

                0
                Спасибо. Добавил несколько правок в Readme.
              0
              Постскриптум прекрасен! Как и вся статья, по-больше бы такого на Хабре, спасибо!
                0
                очень хорошо показаны сразу несколько реализаций стековой виртуальной машины.
                Причём легко расширяемой!
                  +1
                  Поучительно. Создается какое-то смутное впечатление, что программирование (структурирование и осмысление задачи) в терминах моноидальных типов, их комбинаций и морфизмов очень близко духу и сути ФП вообще :)
                    0
                    А так и есть :)
                    0

                    Эпичная статья! Спасибо, я получил огромное наслаждение от прочтения.

                      +1
                      Честно всё прочитал, но увы, мало что понял. Я хаскелем только начинаю интересоваться, всё всерьёз никак нет времени взяться. Статья несколько не моего уровня. Так что закинул к себе в закладки и буду возвращаться ещё не раз и не два. Но один серьёзный вопрос всё-таки возник. Скажите, такой как в этой статье сильно алгебраизированный тип рассуждений и разработки, это норма в хаскеле (и вообще в ФП)? Или это во-первых достаточно специфическая задача и во-вторых именно такой стиль Вы хотели показать?
                        +2

                        Рад, что материал вызвал любопытство, значит, вы подошли к важному моменту и, возможно, готовы нырнуть в новую область. Алгебраический подход, действительно, очень свойственен функциональному программированию вообще и программированию на Haskell в частности. Он пронизывает всю архитектуру и экосистему языка, от системы типов до базовых принципов построения программ. Попытки просто взять и начать программировать по рецептам, как это можно делать в Javascript и Python, для Haskell быстро приводят к отторжению: сложно, неудобно, непонятно, не нужно. Если зацепило или соответствует складу характера, то наработка опыта приводит к глобальной перестройке подхода к разработке — к той самой математической магии. Хорошо это или плохо, не берусь судить, но из преимуществ отмечу: это последовательный подход, опирающийся не на опыт или эмпирику, а на строгие проверяемые рассуждения; он учит подмечать общие структуры и схемы вместе с их свойствами; он соответствует тому, что называется computer science.

                          0
                          Рад, что материал вызвал любопытство, значит, вы подошли к важному моменту и, возможно, готовы нырнуть в новую область.

                          Понимаете, у меня сейчас серьёзная проблема. Внуку подходит возраст, когда его надо уже приобщать к чему-то в этой проклятой жизни интересному. Вот я и думаю с чего начать… С кошерного, православного и духоскрепного С++ (ассемблер PDP-11 с которого начинал я сам, даже не рассматривается)? Или с жесткого, хулиганского и нигилистического хардкора типа хаскеля? Что такое группа, подгруппа и даже смежные классы, он благодаря моим усердным молитвам Одину и Джа, уже знает. Молодой да ранний :) Хочется чтобы мужик если уж не стал математиком, то во всяком случае умел в математике ориентироваться и применять её к практическим задачам. Ну и разумеется умение программировать, это вообще даже не обсуждается. Эта Ваша статья огромный плюс в пользу выбора хаскеля. Я мало что встречал по программированию столь же красивое. Беда в том, что хаскеля я не знаю от слова совсем. И освоить как следует тоже хронически не хватает времени… Я таварисчь очень и очень низкоуровневый. Между паяльником и клавиатурой, даже не знаю кто я больше, электронщик или программист. Плюс добротное, советское физико-математическое образование. Таких требуется не слишком много, но если уж потребовался, то специалист по рисованию формочек на джаваскрипте его никак не заменит. А такие как я в основном все уехали. Вот и приходится вместо тихой спокойной пенсии, за всех отдуваться. Где уж тут освоить что-то новое, ради своей бессмертной души и во благо единокровного внука… Вобщем просто интересно что Вы посоветуете. До нового года пока не горит. На новый год я хочу ему подарить хороший ноут, и с этого времени плотненько начать процесс приобщения. Вопрос С ЧЕГО это начинать…
                            0

                            Математика, по моему мнению — это, в первую очередь, дисциплина ума, во вторую — красота и только в третью — непосредственная польза. Поэтому приобщение к ней это благо, даже если математика не станет профессией. Хаскель и подобные языки вовсе не хулиганские: они жестко требуют согласованности всех частей программы. Строить архитектуру по принципу: "я художник, я так вижу", в них не получится. В JavaScript — можно, в С очень можно. Кривые хаки, гениальные хаки, если они удовлетворяют основному критерию — это работает, становятся классикой и живут десятилетиями, и это круто! ФП про другое. Огород абстракций сам по себе не нужен, важнее связи между ними и универсальные свойства, выходящие за пределы конкрентого представления. Тогда программирование становится исследованием предметной области, вместо набора рецептов. Правда, это интересно сильно не всем, но именно из исследований вырастают новые технологии. Моё убеждение: программиста (молодого человека) нужно знакомить со всеми парадигмами и предоставить выбор по складу ума и вкусу. Я предложил бы набор простых задач (из RosettaCode, например) дать решить на js, (C или Python) и на PureScript (Haskell) и пусть само сложится ощущение от этих подходов.

                              0
                              Сколько внуку лет?
                                0
                                Десять. Уже пора :))
                                  0

                                  Для десяти, боюсь, чистое ФП жестковато будет. Лучше JavaScript или Python в котором показывать лямбды, отображения, свертки и т.д. Так у ученика больше свободы, а привычки вырабатываются.

                                    0
                                    Нафиг. Это только мозги калечить. Разве что каждый раз объяснять, что подобные языки только чтобы быстро написать что-то не очень большое и не очень сложное. По моему опыту, если нет сильной статической типизации, для серьёзных проектов язык непригоден. А показывать лямбды и свертки можно и в хаскеле. Благо с jupyter он дружит, что сильно облегчает процесс.
                                    +1
                                    С одной стороны погрузить ребенка в «мир» функционального программирования на самой ранней стадии, когда его разум еще не «испорчен» естественной концепцией императивного программирования (утонуть в которой ему не удастся избежать начиная со школьных уроков информатики) имеет смысл. С другой стороны мне кажется, эти знания, наверное, навряд ли понадобятся и будут полезны ему в ближайшие 8 лет — не знаю.

                                    А как научить? Если выдвигаться в сторону ФП, то мне кажется лучше все же давать язык в котором есть алгебраическая система типов (т.е. Haskell, а не Lisp допустим), т.к. она сама по себе играет большую роль в программировании. Базовый учебник по Haskell от начальных понятий до продвинутых тем — можно взять wikibook.

                                    А вообще, по-правильному ФП надо начинать с комбинаторной логики и лямбда-исчисления — те основы (до комбинатора неподвижной точки и стратегий редукции лямбда-термов), которым учат студентов до того, как давать просто программирование в Haskell каких-то задачек. На мой взгляд это темы как раз для ребенка — стоит только правильно заинтересовать: ясность и простота концепций хорошо ляжет на такой же ясный незамутненный ум. И этот опыт как раз будет играть и как математический бэкграунд (хотя в школе тоже не понадобится). Подходящий (и на русском) базовый материал, наверное, вот (можно использовать и для самостоятельного изучения). Страничка курса — 2015 (который на видео), 2018 (только файлы).
                                      0

                                      Это большая и жутко интересная тема. Как активно преподающий программирование и студентам (ФП) и школьникам (кружок программирования), скажу, что большее значение имеют интересные задачи (не посчитать, а построить) и быстрый отклик обучающей среды (графика, интерактив), нежели язык. Красиво работать можно в любом языке. Но учащиеся ценят свободу и "настоящесть", так что Scratch не катит. И черепашья графика становится интересной после того, как черепашку они построили сами и "учат" её, понимая возможности и ограничения. Haskell дает невероятную свободу только после принятия его ограничений (как в боевых искусствах). Детям это непросто, может отпугнуть. Я привожу примеры на нём, чтобы "показать кунгфу" — то, к чего можно достичь.

                                0
                                P.S. Да, насчет проблем чисто воспитательных не беспокойтесь. Я его уже учил рукопашке и в школе он всем п@зды даёт. Так что знает, что деда Женя фигни не посоветует. Вопрос ЧЕМУ учить… Я сам воспитан на классике. Но то что функциональщина это наше будущее, ни капли не сомневаюсь, по множеству причин. Вопрос КАК этому ребёнка научить, если сам этим не особо владею…
                              0
                              Ещё вопрос вытекающий из первого. Народ, если кто реально в таком стиле что-то пишет. Как, обратное влияние ощущается? В смысле помогает ли использование такого стиля лучше понимать алгебру (а пожалуй и вообще математику)?
                                0
                                Скорее обратное: понимание математики позволяет лучше понимать такой вот стиль.
                                  0

                                  Думаю, тут взаимные процессы. Работа в Haskell или PureScript — это живая математика, абстрактная алгебра, с которой можно экспериментировать, а значит, лучше понимать её на уровне "спинного мозга". По крайней мере, у меня — так.

                                    0
                                    PureScript это спасибо. Слыхал про него немного, сейчас обязательно гляну подробнее. Веб-программированием я тоже немного занимаюсь, хотя и чисто для себя(хотя и надеюсь кое-что из своих поделок продавать). Сейчас пишу на typescript. Очень интересно было бы иметь инструмент не только помогающий писать код, но и развивающий мозги.

                              Только полноправные пользователи могут оставлять комментарии. Войдите, пожалуйста.

                              Самое читаемое