不久前，哈布雷（Habré）上刊登了一篇关于编译器和堆栈式机器的出色且启发人心的文章 。 它显示了从字节码执行器的简单实现到越来越高效的版本的方法。 我想以开发堆叠机的示例为例，说明如何在Haskell-way中完成此操作。
以一台堆叠机器的语言解释为例，我们将看到半群和单半体的数学概念如何帮助开发和扩展程序体系结构，如何使用单半体代数以及如何以代数系统之间的同构集形式构建程序。 作为工作示例，我们首先构建一个与EDSL形式的代码不可分离的解释器，然后教给它不同的东西：记录任意调试信息，将程序代码与程序本身分开，进行简单的静态分析并计算出各种效果。
本文面向的读者是那些了解中级及更高水平的Haskell语言的人员，已经在工作或研究中使用过Haskell语言的人员以及所有好奇地看了一眼看看工作人员还需要做什么的人。 好吧，对于那些当然没有受到上一段惊吓的人。
结果证明了很多材料，代码中有许多示例，为了使读者更容易理解他是否需要深入研究，我将提供带注释的内容。
翻译和口译任务提供了许多有趣且有用的示例，以演示编程的最多样化方面。 它们使您可以转至不同级别的复杂性和抽象性，同时仍保持实用性。 在本文中，我们将重点说明两个重要数学结构的能力- 半群和半群 。 它们的讨论不像monads或lens那样频繁，并且它们不会吓到小型程序员，这些结构更容易理解，但是尽管如此，它们还是函数式编程的基础。 专业人士证明了对单曲面类型的熟练掌握，他们钦佩解决方案的简洁性和优雅性。
在有关《哈布雷》的文章中搜索“ monoid”一词的文章不超过4篇（例如，关于同一单子，则有300篇）。 从概念上讲，它们全都以这样的方式开始：一个类人动物是如此之多...然后，以一种可以理解的热情，他们列出了一个类人动物是什么-从线条到手指树，从正则表达式解析器到上帝，他们还知道其他什么 ！ 但是在实践中，我们以相反的顺序思考：我们有一个需要建模的对象，我们对其属性进行分析，发现它具有一个或另一个抽象结构的迹象，我们决定：我们是否需要这种情况的后果以及如何使用它？ 我们将以这种方式。 同时，我们将在有用的半身像集合中添加几个有趣的示例。
堆栈机的语言和程序
函数式编程研究中的堆栈机通常是在它们接近卷积概念时出现的。 在这种情况下，给出了最简单的堆栈计算器的执行程序的极其简洁的实现，例如：
最简单的堆栈计算器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 fs = case s of x:_ -> fs _ -> error $ "Error: " ++ c ++ " expected an argument." binary fs = case s of x:y:_ -> fs _ -> error $ "Error: " ++ c ++ " expected two arguments."
它使用Text.Read模块中的全部readMaybe解析器。 可以使程序缩短两倍，但不会提供信息错误的消息，这很丑陋。
对话的好开始！ 然后，通常，它们开始附加效果：将foldl卷积更改为foldM ，通过Either String monad提供foldM ，然后添加日志记录，使用WriterT转换器包装所有内容，为变量实现StateT字典，等等。 有时，为了证明单子计算的凉爽性，他们实现了一个模糊的计算器，该计算器返回表达式的所有可能值 （ 2 p m 3 ） ∗ （（（（ 4 p m 8 ） p m 5 ） 。 这是一个漫长，愉快而有趣的对话。 但是，尽管我们以相同的结果结束了故事，但我们将立即以不同的方式领导我们的故事。
一般来说，为什么要折叠？ 因为卷积（同态）是归纳数据顺序处理的抽象 。 堆栈机器通过代码线性运行，执行一系列指令并生成一个值-堆栈状态。 我喜欢想象卷积堆栈机在活细胞中翻译基质RNA的工作。 核糖体逐步穿过整个RNA链，将核苷酸的三联体与氨基酸进行比较，并创建蛋白质的一级结构。
卷积机有很多局限性，最主要的是程序总是从头到尾读取一次。 分支，循环和子例程调用需要对解释器进行概念上的更改。 当然没有什么复杂的，但是这样的机器不再可以通过简单的卷积来描述。
根据语言相对论的假设，我们使用的语言的属性直接影响我们思维的属性。 让我们注意的不是机器，而是机器控制的语言和程序 。
所有面向堆栈的语言，包括相对较低的级别（Java和Python或.NET虚拟机的字节码）和较高级别的语言（PostScript，Forth或Joy），都具有一个基本的共同属性：如果依次编写两个正确的程序，则获取正确的程序。 正确，正确并不意味着“正确”，该程序可能会因任何数据而崩溃或无休止地失败，并且毫无意义，但最主要的是该程序可以由机器执行。 同时，将正确的程序分成几个部分，正是由于它们的正确性，我们才能轻松地重用这些部分。 最后，在任何堆栈语言中，您都可以选择仅在计算机内部状态（堆栈或寄存器）上运行而不使用任何外部存储器的命令子集。 该子集将形成具有串联属性的语言。 用这种语言，任何程序都具有机器状态转换器的含义，并且顺序执行程序等效于它们的组成，这意味着它也是一个状态转换器。
可以看到一般的模式：正确程序的组合（串联）生成正确的程序，转换器的组合生成转换器。 事实证明，堆栈语言程序相对于串联操作而言是封闭的，或形成称为groupoid或magma的结构。 这意味着，您可以通过将程序写入磁带，几乎随机地剪切它，然后从结果段中形成新程序。 此外，您可以使用一条指令来分割成段。
粘接时，顺序很重要。 例如，这两个程序无疑是不同的：
\ texttt {5 dup pop} \ neq \ texttt {5 dup
但是，在哪里剪切程序都没有关系，如果您立即在此处粘贴它：
（ texttt5dup）+ textttpop= texttt5+（ textttduppop）
这个简单的事实反映了级联操作的
关联性，并将堆栈程序形成的结构提高到了一个新的水平，我们知道这是一个
半群 。
这给我们程序员带来了什么？ 关联性使您可以为此预先编译，优化甚至并行化任意合适的程序节，然后将它们组合为等效程序。 我们有能力对程序的任何部分进行静态分析，并将其用于整个程序的分析中，这恰恰是因为我们不在乎放在何处。 对于不是人写作，而是翻译的低级语言或中级语言，这是非常重要且严重的机会。 从数学家和经验丰富的函数工作者的角度来看，这使机器状态转换程序具有完全的内同态性 。 内同构还通过合成运算形成一个半群。 在代数中，相对于某些集合，这种内同态被称为变换半群 。 例如，有限状态机形成许多状态转换的半群。
“ Semigroup”听起来有点三心二意，有点自卑。 也许堆栈程序组成一个小组 ？ 呃……不，大多数程序都是不可逆的，也就是说，根据执行的结果，将不可能明确地还原原始数据。 但是我们有一个中立的元素。 用汇编语言表示 textttnop 什么也没做。 如果未在堆栈语言中明确定义此类运算符，则可以通过组合一些命令来轻松获得它，例如： textttincdec ， textttduppop 或 texttt交换掉期 。 可以从程序中安全地剪切此类对，或者相反，可以任意插入任意位置。 由于存在一个单位，我们的程序与一个单位或monoid组成一个半 群 。 因此，您可以以monoid的形式以编程方式实现它们-堆叠式计算机状态上的同态。 这将允许您为机器定义一小组基本操作，然后使用它们的组成来创建程序，从而以嵌入式领域特定语言（EDSL）的形式获得堆叠的语言。
在Haskell中，使用Semigroup和Monoid描述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)
我们将立即制造一台具有堆栈，有限内存并可以良好，干净的方式紧急停止的机器。 所有这些都无需使用monad即可实现，而是将必要的数据封装在描述机器的类型中。 因此，所有基本程序及其所有组合都将是其状态的纯转换器。
让我们从定义虚拟机的类型和简单的setter函数开始。
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 _ sm) = VM xsm setStatus :: Maybe String -> Processor setStatus x (VM s _ m) = VM sxm setMemory :: Memory -> Processor setMemory x (VM s st _) = VM s st x
需要使用Setter来使程序语义明确。 处理器（类型Processor ）是指转换器VM -> VM 。
现在，我们为转换monoid和程序定义包装器类型：
newtype Action a = Action { runAction :: a -> a } 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."
算术运算和关系 unary nf = program $ \case x:s -> setStack (fx:s) _ -> err $ "operation " ++ show n ++ " expected an argument" binary nf = program $ \case x:y:s -> setStack (fxy: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函数的类型表明它们不是独立程序，而是程序组合器：在Haskell中创建EDSL的一种典型方法。 stimes函数stimes为所有半组定义的；它返回指定数量的元素的组成。
最后，我们将编写一些用于实验的程序。
结果显示了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]}
实际上，我们并没有做任何新的事情-通过组合同态转换器，我们实质上返回了卷积，但是卷积变得隐含了。 回想一下，卷积提供了归纳数据顺序处理的抽象。 在我们的情况下，数据是在操作员粘贴程序时以感应方式生成的 \钻石 ，并将它们以机器变换函数组成的链的形式“存储”在同构状态中，直到将此链应用于初始状态。 在组合器branch且while branch的情况下while链开始变成树或循环。 在一般情况下，我们得到一个图形，该图形反映了具有存储内存的自动机（即堆叠的机器）的操作。 我们在程序执行过程中就是“折叠”了这种结构。
此实施效果如何？ 函数组合是Haskell编译器可以做到的最好的事情。 他是为此而生的！ 当谈到使用类人动物的知识带来的好处时，他们通常会给出一个差异列表diffList的示例- diffList态同构的形式实现一个链表。 由于功能组合的关联性，差异列表从根本上加速了许多部件的列表形成。 包装类型的混乱并不会导致开销的增加，它们会在编译阶段“分解”。 在额外的工作中，程序的每个步骤仅保留状态检查。
合并Monoid
我认为，此时此刻，怀疑论者和随便的读者已经离开了我们，您可以让自己放松一下，进入抽象的更高层次。
如果没有针对所有半群和monoid固有的一系列特性，半群和monoid的概念将不会那么有用和通用，这将使我们能够从简单结构中构建复杂结构，就像从简单程序中构建复杂程序一样。 这些属性不再适用于对象，而是适用于类型，并且最好不要以数学符号来编写它们，而是以Haskell中的程序形式编写它们，借助于Curry-Howard同构性，它们就是它们的证明。
1）Monoid和半群可以“相乘”。 这是指类型的乘积，在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）有一个单一的monoid，由一个单一的类型() ：
instance Semigroup () where () <> () = () instance Monoid () where mempty = ()
通过乘法运算，半群本身就构成了一个半群，考虑到单位类型，我们可以说mono半身就是一个a半身！ 单元的关联性和中立性可以满足同构性，但这并不重要。
3）分别映射为半群或单半群形式。 在这里，用Haskell编写此语句也更容易：
instance Semigroup a => Semigroup (r -> a) where f <> g = \r -> fr <> gr instance Monoid a => Monoid (r -> a) where mempty = const mempty
我们将使用这些组合器来扩展我们已构建的堆栈语言的功能。 让我们进行重大更改，并设置返回程序的基本命令功能 。 这不会剥夺他们的单调性，但允许从外部将任意信息输入到所有机器命令的工作中。 这是什么意思：
(command1 <> command2) r == command1 r <> command2 r
该信息可以是任何信息，例如，带有某些定义的外部词典，或者是一种在调试过程中保持所需计算日志的方式。 这与monad Reader的操作非常相似，后者只是一个功能。
我们将在机器的结构中引入日志，但是我们不会将其绑定到任何特定类型，而是将其输出到type参数。 我们将使用广义Monoidal运算将其写入日记。
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 ml) = VM x st ml setStatus st (VM s _ ml) = VM s st ml setMemory m (VM s st _ l) = VM s st ml addRecord x (VM s st mj) = 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 fp = Program . Action $ \vm -> case status vm of Nothing -> p . (f (stack vm)) $ vm m -> vm programM fp = 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 ())
在这里，一个简单的monoid ()对我们很有用-在monoid代数中的中性元素。 此外，可以为准备好在日志中记录有关机器状态的信息的执行者定义一个功能。
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 -> (fr, gr)
因此，您可以通过步骤数和堆栈的最大长度来比较阶乘的四种实现
λ> 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})
如果日志记录器&&&都返回相同的类型，则可以将其声明为带有操作的Monoid 。但是由于它们不同，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)
→ :
fromCode :: [Code] -> Program' a fromCode = hom where hom = foldMap $ \case IF b1 b2 -> branch (hom b1) (hom b2) REP p -> rep (hom p) WHILE tb -> 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]
→ , 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 cfp = Program . ([c],) . Action $ \vm -> case status vm of Nothing -> pc . f (stack vm) $ vm _ -> vm programM cfp = Program . ([c],) . Action $ \vm -> case status vm of Nothing -> pc . f (memory vm, stack vm) $ vm _ -> vm
, , , . , -:
none = const id exec prog = run (prog none) (mkVM ()) execLog p prog = run (prog $ \c -> \vm -> addRecord (pc vm) vm) (mkVM mempty) logStack _ vm = [stack vm] logStackUsed _ = Max . length . stack logSteps _ = const (Sum 1)
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 cf = program c $ \case x:s -> setStack (fx:s) _ -> err $ "operation " ++ show c ++ " expected an argument" app2 cf = program c $ \case x:y:s -> setStack (fxy: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 cif = 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 tb -> 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
我们将不再赘述，而是尝试对堆叠机器的程序进行简单的静态分析。我们只有一种数据类型，因此静态类型与该语言无关，但是堆栈上可能没有足够的数据来执行程序。我们有机会计算程序在执行之前的严格要求。
我们引入了程序的价等特性-这是关于执行之前必须在堆栈上的最大参数数量以及执行之后将保留在堆栈上的最小元素数量的信息。例如，在执行加法运算之前，您需要在堆栈上至少包含两个元素，并且在执行之后将至少保留一个元素。我们用以下形式写这个事实：
arity(add)=2▹1
以下是一些其他运算符的化合价：arity(push)=0▹1arity(pop)=1▹0arity(exch)=2▹3
为什么我们总是要预订：最少人数，最多需求..？事实是，所有基本运算符都有精确定义的化合价，但是在分支时，不同的分支可能有不同的要求和结果。我们的任务：计算最严格的要求，以确保所有分支机构（无论有多少分支机构）的运行。当顺序执行价命令时，它们以以下非平凡的方式组合：
(i1▹o1)⋄(i2▹o2)=(a+i1)▹(a+o1+o2−i2),a=max(0,i2−o1).
该操作是关联的并且具有中性元素，这对于有关类半体动物的文章而言并不奇怪。将此结果添加到程序中： 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 tb -> 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 tb -> 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
优化简单程序的示例：
λ> 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 ma = ActionM { runActionM :: a -> ma } instance Monad m => Semigroup (ActionM ma) where ActionM f <> ActionM g = ActionM (f >=> g) instance Monad m => Monoid (ActionM ma) 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 ml) = return $ VM x st ml setStatus st (VM s _ ml) = return $ VM s st ml setMemory m (VM s st _ l) = return $ VM s st ml addRecord x (VM s st ml) = VM s st m (x<>l)
: 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±3)∗((4±8)±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 , , — , , . , , . — ! , . , - . ( -) , . — ! "" , , , , . , , .
. - , . — , . .