haskell - 箭式EDSL，用于编写下层代码

通常为Arrows提供的大多数激励示例都显示了如何在Hask之上构建更复杂的计算系统(例如，效果的Kleisli类别，Arrowized FRP等)。是否有任何使用Arrows编写较低层次的工作？代码(例如，汇编，Javascript)？尽管这可能不完全符合Arrow的标准定义(特别是arr :: (a -> b) -> cat a b)，但似乎Arrows为某种串联编程奠定了坚实的基础。

最佳答案

设定标准

我们正在参加一场编程界的竞赛，看看我们能用箭头走多低。面对观众的怒吼，评委要求我们的起跑高度。在粉丝们的拥护下，我们选择了喜欢的人群low level virtual machine作为目标身高。对于性能的技术部分，我们将为通过ArrowLike接口(interface)I previously described定义的原始递归函数实现一个编译器。

module Control.PrimRec (
    ArrowLike (..),
    PrimRec (..),
    module Control.Category,
    module Data.Nat
) where

import Control.Category
import Data.Nat

import Prelude hiding (id, (.), fst, snd, succ)
import qualified Prelude (fst, snd)

class Category a => ArrowLike a where
    fst   :: a (b, d) b
    snd   :: a (d, b) b
    (&&&) :: a b c -> a b c' -> a b (c,c')

    first :: a b c -> a (b, d) (c, d)
    first = (*** id)

    second :: a b c -> a (d,b) (d,c)
    second = (id ***)

    (***) :: a b c -> a b' c' -> a (b,b') (c,c')
    f *** g = (f . fst) &&& (g . snd)

class ArrowLike a => PrimRec a where
    zero :: a b   Nat
    succ :: a Nat Nat
    prec :: a e c -> a (c, (Nat,e)) c -> a (Nat, e) c

我们的目标是制作一个Category，使我们可以一起编写LLVM指令。我们还将提供一个ArrowLike接口(interface)来处理寄存器，并提供PrimRec接口(interface)来定义自然数函数。

设备检查

裁判要求看我们将要带到地板上的设备。我们将面临两个主要挑战。即使没有arr引入任意函数，与所有Hask相比，我们的LLVM编译器可以操作的类型也会受到很大的限制。第二个挑战是将LLVM指令从程序中删除。两者与Category，Arrow或编译器都没有多大关系，但是我们的设备包和代码将充满它们，以至于有时很难看到我们关心的部分。

在设备包中，我们包装了许多用于处理类型的工具。

{-# LANGUAGE GADTs #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeOperators #-}

import GHC.Exts (Constraint)
import Data.Proxy

裁判接受我们对普通零件的要求。

import Data.Word
import Data.Char (ord)

import Control.PrimRec

import Prelude hiding (
    id, (.), fst, snd, succ,
    sequence, sequence_, foldr,
    add)

llvm-general-pure软件包具有用于LLVM的AST。我们可以使用llvm tools或llvm-general漂亮地打印AST以便与llvm-pp一起使用。

import LLVM.General.AST hiding (type')
import LLVM.General.AST.Global
import LLVM.General.AST.Type
import qualified LLVM.General.AST.Constant as C
import qualified LLVM.General.AST.IntegerPredicate as ICmp
import qualified LLVM.General.AST.CallingConvention as CallingConvention

import LLVM.General.Pretty

我们接受Applicative和Monad工具的标准版本

import Data.Monoid
import Data.Foldable
import Data.Traversable

import Control.Applicative
import Control.Monad (forever)
import Control.Monad.Trans.Class
import Control.Monad.Trans.Writer.Strict (tell)
import Data.Functor.Identity

然后将 hoist 带到小车上。

import Control.Monad.Morph

袋子底部有一堆pipes叮当响。

import Pipes hiding (Proxy, void)
import qualified Pipes as P
import qualified Pipes.Prelude as P
import Pipes.Lift (runWriterP)

在检查了管道以确保它们都不能与调节弯管混淆后，裁判清除了我们开始编码的要求。

编译器架构

用繁华和c语，我们定义了编译器的状态。

type Build w = Pipe Name w

在人群中喘不过气来之后，我们定义了编译器中发生的两个主要操作:分配新符号并发出指令。

getName :: (Monad m) => Build w m (Name)
getName = await

instr :: (Monad m) => Named Instruction -> Build (Named Instruction) m ()
instr = yield

当我们的编译器构建的不是Named Instruction时，我们可以使用yield来发出它们。

我们的编译器片段是从操作数(寄存器或常量)指向编译器和新寄存器或常量的副作用的箭头。它们是已编译程序的Kleisli箭头:Operands x -> Build (Named Instruction) m (Operands y)。我们确定了在编译的程序中产生新符号并发出带有副作用的指令的编译器副作用。编译后的程序还将具有全局定义，因此我们将Kleisli箭头包装在发出全局定义的类别中。与大多数箭头不同，由于级别较低，我们的目标是我们不能容纳任意类型。从寄存器到寄存器的箭头+副作用仅适用于可以存储在LLVM寄存器中或由寄存器引用的Registerable类型。

data RegisterArrow m x y where
    RegisterArrow :: (Registerable x, Registerable y) =>
                     (
                        Build Definition m (
                            Operands x ->
                            Build (Named Instruction) m (Operands y)
                        )
                     ) -> RegisterArrow m x y

下一节将介绍Registerable的类型。

上去下

在我们的第一次尝试中，我们跳过了边缘区。我们想编写低级代码，但是，由于低级类型与Category的Haskell类型不完全匹配，因此我们需要首先进行编写。我们将需要兼顾类型和约束以保持与Category的兼容性。通常，放弃与Category的兼容性并使用leftaroundabout's constrained-categories会更容易。但是，当我们使用Category时，我们将粉碎您“抽象地允许各种后端”的愿望-我们将拥有普通Haskell函数-> described earlier的后端，先前描述的原始递归Haskell函数的后端以及新的LLVM编译器后端。因此，首先我们开始讨论约束和种类。
Registerable类型是那些可以与寄存器RegisterRep中的表示形式相关联的类型，Traversable是Apply并支持应用程序(Applicative是pure而没有Type)。它们还必须具有与每个寄存器关联的LLVM RegisterableCtx。

class (Traversable (RegisterRep a), Apply (RegisterRep a)) => Registerable a where
    type RegisterRep a :: * -> *
    type RegisterableCtx a :: Constraint
    registerableDict :: Proxy a -> RegisterableDict a
    types :: Proxy a -> Registers a Type

RegisterableDict和Proxy稍后将用于归纳证明。

单元类型不带寄存器。它的表示形式是Identity，不包含任何内容。

instance Registerable () where
    type RegisterRep () = Proxy
    type RegisterableCtx () = ()
    registerableDict _ = Dict
    types _ = Registers Proxy

自然数可以存储在寄存器中。它的表示形式是一个:*:，它存储一个对象，并且该对象的类型是64位整数。

instance Registerable Nat where
    type RegisterRep Nat = Identity
    type RegisterableCtx Nat = ()
    registerableDict _ = Dict
    types _ = Registers . Identity $ IntegerType 64

一个元组可以存储在寄存器中，用于存储两个内容。它的表示形式是它存储的两个事物的表示形式的乘积RegisterableCtx。它的类型是它存储的两种事物的类型的乘积。元组还引入了Registerable-为了对元组执行所有操作，我们需要知道它的两侧都是Functor。

instance (Registerable a, Registerable b) => Registerable (a, b) where
    type RegisterRep (a, b) = Registers a :*: Registers b
    type RegisterableCtx (a, b) = (Registerable a, Registerable b)
    registerableDict _ = Dict
    types _ = Registers $ types (Proxy :: Proxy a) :*: types (Proxy :: Proxy b)

我们可以定义一个Registerable，它具有Registerable类型的寄存器的形状。

data Registers r a where
    Registers :: Registerable r => RegisterRep r a -> Registers r a

因为每种Traversable类型的表示形式都是Apply并具有Registers，所以我们可以为Operands定义相同的实例。

instance Functor (Registers r) where
    fmap f (Registers xs) = Registers (fmap f xs)

instance Foldable (Registers r) where
    foldr f z (Registers xs) = foldr f z xs

instance Traversable (Registers r) where
    traverse f (Registers xs) = fmap Registers (traverse f xs)

instance Apply (Registers r) where
    Registers f <.> Registers x = Registers (f <.> x)

我们之前使用的类型的Operand只是一种结构，其形状与保存该类型的寄存器的形状相同，但是在每个位置都保留了Registerable。

 type Operands f = Registers f Operand

由于寄存器的形状可以遍历，因此可以按顺序编号。

number :: (Enum e, Traversable t) => (a -> e -> b) -> t a -> t b
number f = snd . mapAccumL (\(h:t) a -> (t, f a h)) [toEnum 0..]

又一圈

随着高级类型编程的有趣部分逐渐消失，跟踪Category变成了一个口号。请记住，库用户对这些都不是可见的，他们只看到ArrowLike，PrimRec和RegisterableDict类型类。
Registerable既包含类型为RegisterableCtx的证明，也包含该类型所需的任何Dict证明。

type RegisterableDict a = Dict (Registerable a, RegisterableCtx a)

Dict保存用于约束的字典。当我们在Dict上进行模式匹配时，字典将被引入到ghc中。为了构造Registers，约束必须在ghc中。较早的RegisterArrow和RegisterArrow也带有字典，它们在解构时是一个福音，而在构建时是一个障碍。

data Dict c where
    Dict :: c => Dict c

现在，我们可以在第一部分中定义与RegisterableDict等效的东西，可以为所有类型定义。而不是限制类型，我们需要证明以RegisterArrow的形式满足输入类型的约束，然后再分发存储在内部的rarrowDict。我们将通过输入来归纳证明所有其他地方也都满足约束。

data PRFCompiled m a b where
    BlockLike :: (RegisterableDict a -> RegisterArrow m a b) -> PRFCompiled m a b

为了帮助跟踪字典，我们将制作一些工具。 RegisterArrow直接从fstDict恢复所有已知的约束

rarrowDict :: forall m x y. RegisterArrow m x y -> Dict (Registerable x, Registerable y, RegisterableCtx x, RegisterableCtx y)
rarrowDict (RegisterArrow _) =
    case registerableDict (Proxy :: Proxy x)
    of Dict ->
        case registerableDict (Proxy :: Proxy y)
        of Dict -> Dict

sndDict和Registerable证明，如果一个元组是Registerable，则其两个组成部分都是。

fstDict :: forall a b. RegisterableDict (a, b) -> RegisterableDict a
fstDict Dict = case registerableDict (Proxy :: Proxy a) of Dict -> Dict

sndDict :: forall a b. RegisterableDict (a, b) -> RegisterableDict b
sndDict Dict = case registerableDict (Proxy :: Proxy b) of Dict -> Dict

上下同时

编译器本身会同时遍历类型和下标。它产生低级指令，并建立每种类型均为Category的归纳证明。

从内部到外部最容易阅读以下每个实例。

寄存器上的Kleisli箭头形成id。标识return是输入输入所在的寄存器的return。它不产生任何定义，因此在定义的类别中，可以仅将Dict进行编辑。如果传入Registerable输入的Registerable，我们知道输出(相同)也是RegisterArrow，因此可以构建\a -> g a >>= f。

寄存器上的Kleisli箭头g <- mg; f <- mf; return ...的组成表示执行第一个的所有副作用，将结果传递到第二个寄存器中，执行第二个的所有副作用，并将结果返回寄存器in。每个组件也可能在定义类别中生成定义，因此我们从这两个定义中按Category顺序发出。最后三行上方的所有内容都将约束纳入范围，以归纳证明约束成立。

instance (Monad m) => Category (PRFCompiled m) where
    id  = BlockLike $ \Dict -> RegisterArrow . return $ return
    BlockLike df . BlockLike dg = BlockLike $ \Dict ->
        case dg Dict
        of rg@(RegisterArrow mg) ->
            case rarrowDict rg
            of Dict ->
                case df Dict
                of RegisterArrow mf -> RegisterArrow $ do
                    g <- mg
                    f <- mf
                    return (\a -> g a >>= f)

仅使用类别实例，我们就编写了大部分编译器。我们可以将两个计算放在一起以构建新的计算。 ArrowLike构成了串联编程的强大基础。
Arrow实例仅执行杂项操作，该杂项注册了编译器所引用的内容。在Haskell中，这也是fst的全部工作-调整要使用元组的结构的哪一部分。 snd专注于寄存器结构的一部分，&&&专注于另一部分。 Category对同一组寄存器进行两次计算，并记住两者的结果。

instance (Monad m) => ArrowLike (PRFCompiled m) where
    fst = BlockLike $ \Dict -> RegisterArrow . return $ \(Registers (regs :*: _)) -> return regs
    snd = BlockLike $ \Dict -> RegisterArrow . return $ \(Registers (_ :*: regs)) -> return regs
    BlockLike df &&& BlockLike dg = BlockLike $ \Dict ->
        case (df Dict, dg Dict)
        of (RegisterArrow mf, RegisterArrow mg) -> RegisterArrow $ do
            f <- mf
            g <- mg
            return $ \regs -> do
                rf <- f regs
                rg <- g regs
                return $ Registers (rf :*: rg)

对于ArrowLike和PrimRec实例，我们已经编写了三分之二的编译器，甚至没有发出任何指令。任何一个实例完成的操作都是操纵编译器或组合计算的状态。两者均未执行任何指令。我们所有的计算都来自zero实例，该实例介绍了自然数的构造和解构。

我们通过构造0(将操作数绑定(bind)到add常数)来构造自然数，或计算数字的后继(将操作数绑定(bind)到1的结果，然后将Category绑定(bind)到输入操作数)。

instance (Monad m) => PrimRec (PRFCompiled m) where
    zero = BlockLike $ \Dict -> RegisterArrow . return $ \_ -> return . Registers . Identity . constant $ C.Int 64 0
    succ = BlockLike $ \Dict -> RegisterArrow . return $ regSucc
        where
            regSucc (Registers op) = (>>= return) . traverse opSucc $ Registers op
            opSucc op = bind i64 $ add op (constant $ C.Int 64 1)

我们通过primitive recursion来解构自然数，我们将在递归方面幼稚而低效地实现它。

prec (BlockLike df) (BlockLike dg) = BlockLike $ \d@Dict ->
    case df $ sndDict d
    of (RegisterArrow mf) ->
        case dg Dict
        of (RegisterArrow mg) -> RegisterArrow $ do
            f <- mf
            g <- mg
            defineRecursive $ \go read ret -> do
                headName <- getName
                brName <- getName
                zeroName <- getName
                succName <- getName
                rs@(Registers (Registers (Identity n) :*: e)) <- block headName $ do
                    rs <- read
                    return (br brName,rs)
                block' brName $ do
                    cmp <- bind i1 $ icmp ICmp.EQ n (constant $ C.Int 64 0)
                    return (condbr cmp zeroName succName)
                block' zeroName $ do
                    c <- f e
                    ret c
                block' succName $ do
                    pred <- bind i64 $ sub n (constant $ C.Int 64 1)
                    c <- go (Registers (Registers (Identity pred) :*: e))
                    c' <- g (Registers (c :*: rs))
                    ret c'

我们刚刚在ArrowLike和prec实例内部直接编写了用于低级代码的编译器。当震惊的乐队负责人错过比赛时，沉默充斥了礼堂。前排的观众昏昏欲睡。

打包

我们开始随意打包我们的东西，定义了一个非常简单的递归，用于Traversable的定义。我们所说的“调用约定”是将两个指针传递给一个函数，一个指针指向可以从中读取其参数的内存，另一个指向应该向其写入结果的内存。观众们步履蹒跚而又老练，开始在结语中聊天，但是评委们仍然渴望看到这一切是否真的有效。

defineRecursive :: forall x y m. (Registerable x, Registerable y, Monad m) =>
                    (
                        (Operands x -> Build (Named Instruction) m (Operands y))       ->  -- recursive call
                                       Build (Named Instruction) m (Operands x)        ->  -- read parameters
                        (Operands y -> Build (Named Instruction) m (Named Terminator)) ->  -- return results
                        Build (BasicBlock) m ()                                            -- function body
                    ) ->
                    Build Definition m (
                        Operands x -> Build (Named Instruction) m (Operands y))            -- call function
defineRecursive def = do
    functionName <- getName
    inPtrName <- getName
    outPtrName <- getName
    let
        inType  = StructureType False . toList $ types (Proxy :: Proxy x)
        outType = StructureType False . toList $ types (Proxy :: Proxy y)
        outPtrType = ptr outType
        inPtrType  = ptr inType
        go  regs = do
            inPtr  <- bind (ptr inType)  $ alloca inType
            outPtr <- bind (ptr outType) $ alloca outType
            writePtr inPtr regs
            instr $ call
                        (constant $ C.GlobalReference (FunctionType void [ptr outType, ptr inType] False) functionName)
                        [outPtr, inPtr]
            readPtr outPtr
        ret regs = do
            writePtr (LocalReference outPtrType outPtrName) regs
            return (retVoid)
        read = readPtr (LocalReference inPtrType inPtrName)
    (blocks, _) <- collect (def go read ret)
    yield $ global $ define void functionName [(outPtrType, outPtrName), (inPtrType, inPtrName)] blocks
    return go

一个小问题使每个继承者大喊一堆有关堆栈帧的内容，“...最多5位!”。

遍历在内存中一个接一个地存储或检索hoist结构的每个字段，就像遍历它一样简单。我们将所有数据打包到堆栈内存中，无需担心共享或重复。毕竟，我们距离"liberate[d] from petty concernsabout, e.g., the efficiency of hardware-based integers"很久了。

elemPtrs :: (Monad m, Traversable f) => Operand -> f Type -> Build (Named Instruction)  m (f Operand)
elemPtrs struct ts = do
    sequence $ number getElemPtr ts
    where
        getElemPtr t n = bind (ptr t) $ getelementptr struct [C.Int 32 0, C.Int 32 n]

readPtr :: forall r m. (Registerable r, Monad m) => Operand ->  Build (Named Instruction) m (Operands r)
readPtr struct = do
    let ts  = types (Proxy :: Proxy r)
    elems <- elemPtrs struct ts
    sequence $ (bind <$> ts) <.> (load <$> elems)

writePtr :: forall r m. (Registerable r, Monad m) => Operand -> Operands r -> Build (Named Instruction) m ()
writePtr struct ops = do
    let ts  = types (Proxy :: Proxy r)
    elems <- elemPtrs struct ts
    sequence_ $ instr . Do <$> (store <$> ops <.> elems)

当我们将最后的64位整数放入其分配的堆栈单元中时，最后的观众会从看台上滴下。

边走边走

一小群人围在yield周围。一个人说:“您从未使用过它。” “我们做到了，它可能还没有制造出超大加速器。当我们深入研究一个街区时，我们就使用了它。”

每次我们对管道进行await或await编码时，数据都会在计算流程中横向移动。当我们用yield一个新名称时，它出现在一侧，而当我们用yield结果时，它出现在另一侧。每次将操作数绑定(bind)到一条指令时，我们都会同时执行这两种操作，但是在monad的结果中，只需担心操作数保存了计算结果。

bind :: (Monad m) => Type -> Instruction -> Build (Named Instruction) m (Operand)
bind t instruction = do
    name <- getName
    instr $ name := instruction
    return (LocalReference t name)

为了制作一个块，我们收集子计算的forall x. m x -> n x ed结果。

block :: (Monad m) => Name -> Build (Named Instruction) m (Named Terminator, r) -> Build BasicBlock m r
block name definition = do
    (instructions, (terminator, r)) <- collect definition
    yield $ BasicBlock name instructions terminator
    return r

block' name = block name . (>>= \x -> return (x,()))

为了收集子计算的结果，我们利用了管道如此纯净的事实，只要您具有自然转换hoist，就可以换出基础的monad。这就是lift所做的；它使我们可以对管道下的所有基础monad操作进行WriterT编码，以在另一个转换器(在本例中为isOdd)上使用管道。

collect :: (Monad m) => Pipe a b m r -> Pipe a c m ([b], r)
collect subDef = do
    (r, w) <- runWriterP $
        hoist lift subDef >->
        forever (await >>= \x -> lift $ tell (++[x]))
    return (w [], r)

我们走了多低？

首席法官从我们选择的小节高度中提出一个选择，并要求我们编译Category。示例代码仅根据ArrowLike，PrimRec和isZero这三个接口(interface)编写。

match :: PrimRec a => a b c -> a (Nat, b) c -> a (Nat, b) c
match fz fs = prec fz (fs . snd)

one :: PrimRec a => a b Nat
one = succ . zero

isZero :: PrimRec a => a Nat Nat
isZero = match one zero . (id &&& id)

isOdd :: PrimRec a => a Nat Nat
isOdd = prec zero (isZero . fst) . (id &&& id)

小组 mock CoPointed Sheet的实现效率极低。

define void @n1({i64}* %n3, {i64, i64}* %n2){
n4:
  %n8 = getelementptr inbounds {i64, i64}* %n2, i32 0, i32 0
  %n9 = getelementptr inbounds {i64, i64}* %n2, i32 0, i32 1
  %n10 = load i64* %n8
  %n11 = load i64* %n9
  br label %n5
n5:
  %n12 = icmp eq i64 %n10, 0
  br i1 %n12, label %n6, label %n7
n6:
  %n13 = add i64 0, 1
  %n14 = getelementptr inbounds {i64}* %n3, i32 0, i32 0
  store i64 %n13, i64* %n14
  ret void
n7:
  %n15 = sub i64 %n10, 1
  %n16 = alloca {i64, i64}
  %n17 = alloca {i64}
  %n18 = getelementptr inbounds {i64, i64}* %n16, i32 0, i32 0
  %n19 = getelementptr inbounds {i64, i64}* %n16, i32 0, i32 1
  store i64 %n15, i64* %n18
  store i64 %n11, i64* %n19
  call void @n1({i64}* %n17, {i64, i64}* %n16)
  %n20 = getelementptr inbounds {i64}* %n17, i32 0, i32 0
  %n21 = load i64* %n20
  %n22 = getelementptr inbounds {i64}* %n3, i32 0, i32 0
  store i64 0, i64* %n22
  ret void
}

一位初级法官说，同事所说的“技术上正确”是“最糟糕的正确”。裁判坐在控制台上，尝试一些输入:

123456
0

54321
1

654321
[Stack Overflow]

首席法官对我们的门槛低表示祝贺，但建议我们应该尝试“更具技术性”的事情以获得满分。

大事记

当我们走出大厅时，我们注意到our complete code and output是在特殊的ojit_code后期版本中印刷的，在球场上以12.50美元的价格出售，在室外的报摊以1.25美元的价格出售。