用于编写低级代码的带箭头的 EDSL
Arrowized EDSL for Writing Lower Level Code
通常为 Arrows 提供的大多数激励性示例都展示了如何在 Hask 之上构建更复杂的计算系统（例如，用于效果的 Kleisli 类别、Arrowized FRP 等）是否有任何关于使用的工作编写 较低级别 代码（例如汇编、Javascript）的箭头？虽然这可能不完全符合 Arrow 的标准定义（尤其是 arr :: (a -> b) -> cat a b），但 Arrows 似乎为某种串联编程奠定了坚实的基础。
设置栏
我们正在进入编程边缘竞赛，看看我们可以用箭头走到多低。在观众的喧闹声中，评委们要求我们的起跑杆高度。受到粉丝的青睐，我们 select 人群的最爱 low level virtual machine as our target height. For the technical portion of the performance, we will implement a compiler for the primitive recursive functions defined via an 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 接口来处理寄存器和 PrimRec 接口来定义自然数函数。
设备检查
裁判要求查看我们将带到场上的设备。我们将面临两个主要挑战。即使没有 arr 引入任意函数，与所有 Hask 相比，我们的 LLVM 编译器可以操作的类型将受到很大限制。第二个挑战是从程序中获取我们的 LLVM 指令。两者都与 Categorys、Arrows 或制作编译器没有太大关系，但我们的设备包和我们的代码将充满它们，以至于有时很难看到我们的片段关心.
在我们的设备包中，我们打包了大量用于处理类型的工具。
{-# 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 package has an AST for LLVM. We can pretty print the AST for use with the llvm tools with either llvm-general or 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)
检查管道以确保其中 none 可以与规则边缘条混淆后，裁判允许我们开始编码。
编译器架构
轰轰烈烈，我们定义了一个编译器的状态。
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 Instructions 以外的东西时，我们可以使用 yield 来发出它们。
我们的编译器部分是从操作数（寄存器或常量）指向编译器中的副作用和新寄存器或常量的箭头。它们是编译程序的 Kleisli 箭头：Operands x -> Build (Named Instruction) m (Operands y)。我们确定了在编译程序中制作新符号和发出具有副作用的指令的编译器副作用。编译后的程序也将具有全局定义，因此我们将 Kleisli 箭头包装在发出全局定义的类别中。与大多数箭头不同，由于我们瞄准的级别较低，因此我们无法容纳任意类型。从寄存器到寄存器的箭头 + 副作用仅适用于 Registerable 可以存储在 LLVM 寄存器中或由寄存器引用的类型。
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. However, when we stay with Category we will smash your desire to "abstract away allowing for a variety of backends" - we will have the backend of ordinary Haskell functions -> described earlier、前面描述的原始递归 Haskell 函数的后端以及我们新的 LLVM 编译器后端会更容易。所以，首先我们上去谈谈约束和种类。
Registerable 类型是那些可以与寄存器 RegisterRep 中的表示相关联的类型，即 Traversable 并支持应用程序（Apply 是 Applicative没有 pure)。他们还必须有一个 LLVM Type 与每个寄存器关联。
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
RegisterableCtx和RegisterableDict后面用于归纳证明
单元类型不带寄存器。它的表示是一个 Proxy 什么都不包含。
instance Registerable () where
type RegisterRep () = Proxy
type RegisterableCtx () = ()
registerableDict _ = Dict
types _ = Registers Proxy
一个自然数可以存储在一个寄存器中。它的表示是一个Identity，里面存储了一个东西，那个东西的类型是一个64位的整数。
instance Registerable Nat where
type RegisterRep Nat = Identity
type RegisterableCtx Nat = ()
registerableDict _ = Dict
types _ = Registers . Identity $ IntegerType 64
一个元组可以存储在它存储的两个东西的寄存器中。它的表示是它存储的两个事物的表示的乘积 :*:。它的类型是它存储的两个东西的类型的乘积。元组还引入了 RegisterableCtx - 为了用元组做任何事情，我们需要知道它的两边都是 Registerable.
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)
我们可以定义一个 Functor 具有 Registerable 类型寄存器的形状。
data Registers r a where
Registers :: Registerable r => RegisterRep r a -> Registers r a
因为每个 Registerable 类型的表示都是 Traversable 并且有一个 Apply，我们可以为 Registers.
定义相同的实例
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)
我们之前使用的类型的 Operands 只是一个结构，其形状与保存该类型的寄存器具有相同的形状，但在每个地方保存一个 Operand。
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..]
又跑了一圈...
随着高级类型编程的有趣部分被排除在外，跟踪什么是 Registerable 变成了一项艰巨的任务。请记住，其中的 none 对库的用户可见，他们只能看到 Category、ArrowLike 和 PrimRec 类型 类.
A RegisterableDict 持有一个类型是 Registerable 的证明以及该类型需要的任何 RegisterableCtx 证明。
type RegisterableDict a = Dict (Registerable a, RegisterableCtx a)
A Dict 保存约束的字典。当我们在 Dict 上进行模式匹配时，将字典引入 ghc。为了构造一个 Dict，约束需要在 ghc 的范围内。早先的Registers和RegisterArrow也在随身携带字典，解构时利器，构建时障碍
data Dict c where
Dict :: c => Dict c
我们现在可以定义与第一部分中的 RegisterArrow 等价的东西，可以为所有类型定义。在分发存储在内部的 RegisterArrow 之前，我们要求以 RegisterableDict 的形式证明输入类型满足约束，而不是限制类型。我们将从输入中归纳证明约束在其他地方也得到满足。
data PRFCompiled m a b where
BlockLike :: (RegisterableDict a -> RegisterArrow m a b) -> PRFCompiled m a b
为了帮助跟踪词典，我们将制作一些工具。 rarrowDict 直接从 RegisterArrow
恢复所有已知的约束
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
fstDict 和 sndDict 表明如果一个元组是 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
同时上下
编译器本身会同时检查类型和下栏。它生成低级指令并构建每种类型的归纳证明 Registerable.
以下每个实例从内到外阅读起来最容易。
寄存器上的 Kleisli 箭头形成 Category。身份 id 是 return 输入所在的寄存器。它不产生任何定义，因此在定义类别中，它只能被 returned。如果为 Registerable 输入传入 Dict，我们知道输出（相同）也是 Registerable，因此可以构建 RegisterArrow.
Kleisli 箭头在寄存器上的组合，\a -> g a >>= f，表示完成第一个的所有副作用，将结果传递给第二个寄存器，完成第二个的所有副作用一个，return 其结果所在的寄存器。每个组件也可以在定义类别中生成定义，因此我们按顺序从两者发出定义 g <- mg; f <- mf; return ...。最后三行以上的所有内容都将约束纳入范围以归纳证明约束成立。
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)
仅用一个类别实例，我们就编写了大部分编译器。我们可以将两个计算放在一起来构建一个新的计算。 Category构成了串联编程的坚实基础。
ArrowLike 实例除了处理编译器所指的注册之外什么都不做。这也是 Arrow 在 Haskell 中所做的所有事情——兼顾你正在使用元组处理的结构的哪一部分。 fst关注寄存器结构的一部分，snd关注另一部分。 &&& 在同一组寄存器上进行两次计算并记住两者的结果。
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)
对于 Category 和 ArrowLike 实例，我们已经编写了三分之二的编译器，甚至没有发出一条指令。任何一个实例所做的都是操纵编译器的状态或组合计算。两者都没有执行任何指令。我们所有的计算都来自 PrimRec 实例，它引入了构造和解构自然数。
我们通过构造zero（将操作数绑定到0常量）或计算数字的后继（将操作数绑定到adding的结果来构造自然数1 到输入操作数）。
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'
我们刚刚在 Category 和 ArrowLike 实例中直接为低级代码编写了一个编译器。当震惊的乐队指挥错过了问题时，礼堂里一片寂静。前排观众晕倒
收拾行李
我们开始随便收拾东西，定义一个极其简单的递归，用在prec的定义中。我们的 "calling convention" per say 将传递两个指向函数的指针，一个指向它可以从中读取其参数的内存，另一个指向它应该写入其结果的内存。笨拙而朴实的观众开始在结局中闲聊，但评委们仍然急切地想看看这一切是否真的有效。
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 位数字！”。
在内存中一个接一个地存储或检索 Traversable 结构的每个字段就像遍历它一样简单。我们将所有数据打包到堆栈内存中，而不用担心共享或重复。毕竟我们早就 "从琐碎的担忧中解放[d]
关于，例如，基于硬件的整数的效率。
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 位整数放入其分配给堆栈的单元格中时，最后一位观众缓缓离开看台。
前进时侧身
hoist 周围聚集了一小群人。 "You never used this"，一个说。 "We did, it just might not have made the jumbo-tron. We used it when we went deeper into a block".
每次我们 yield 或 await 管道时，数据都会横向移动到计算流中。当我们 await 一个新名字时它从一侧进来，当我们 yield 一个结果时它从另一边出去。每次我们将一个操作数绑定到一条指令时，我们都在做这两个操作，但在 monad 的结果中，只需要担心操作数保存计算结果。
bind :: (Monad m) => Type -> Instruction -> Build (Named Instruction) m (Operand)
bind t instruction = do
name <- getName
instr $ name := instruction
return (LocalReference t name)
为了制作一个区块，我们收集了子计算的 yielded 结果。
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,()))
为了收集子计算的结果，我们利用了管道非常纯净的事实，只要您有自然转换 forall x. m x -> n x，您就可以换掉底层的 monad。这就是 hoist 所做的；它允许我们 lift 管道下的所有底层 monad 操作在另一个转换器上使用管道，在这种情况下 WriterT.
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)
我们跌到多低？
裁判长出示了我们选择的柱子高度的select离子，并要求我们编译isOdd。示例代码仅针对Category、ArrowLike、PrimRec.
三个接口编写
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)
小组对 极其 低效的 isZero 实施傻笑。
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
}
一位初级评委说，"It's technically correct" 同事评论说是“最差 种正确”。裁判在控制台坐下并尝试一些输入：
123456
0
54321
1
654321
[Stack Overflow]
主审祝贺我们的水平较低，但建议我们应该尝试一些"more technical"以获得满分。
大事记
当我们走出大厅时，我们注意到 our complete code and output 印在 CoPointed Sheet 的特别后期版本中，在体育场内售价 12.50 美元，在外面的报摊上售价 1.25 美元.
通常为 Arrows 提供的大多数激励性示例都展示了如何在 Hask 之上构建更复杂的计算系统（例如，用于效果的 Kleisli 类别、Arrowized FRP 等）是否有任何关于使用的工作编写 较低级别 代码（例如汇编、Javascript）的箭头？虽然这可能不完全符合 Arrow 的标准定义（尤其是 arr :: (a -> b) -> cat a b），但 Arrows 似乎为某种串联编程奠定了坚实的基础。
设置栏
我们正在进入编程边缘竞赛，看看我们可以用箭头走到多低。在观众的喧闹声中，评委们要求我们的起跑杆高度。受到粉丝的青睐，我们 select 人群的最爱 low level virtual machine as our target height. For the technical portion of the performance, we will implement a compiler for the primitive recursive functions defined via an 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 接口来处理寄存器和 PrimRec 接口来定义自然数函数。
设备检查
裁判要求查看我们将带到场上的设备。我们将面临两个主要挑战。即使没有 arr 引入任意函数，与所有 Hask 相比，我们的 LLVM 编译器可以操作的类型将受到很大限制。第二个挑战是从程序中获取我们的 LLVM 指令。两者都与 Categorys、Arrows 或制作编译器没有太大关系，但我们的设备包和我们的代码将充满它们，以至于有时很难看到我们的片段关心.
在我们的设备包中，我们打包了大量用于处理类型的工具。
{-# 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 package has an AST for LLVM. We can pretty print the AST for use with the llvm tools with either llvm-general or 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)
检查管道以确保其中 none 可以与规则边缘条混淆后，裁判允许我们开始编码。
编译器架构
轰轰烈烈，我们定义了一个编译器的状态。
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 Instructions 以外的东西时，我们可以使用 yield 来发出它们。
我们的编译器部分是从操作数（寄存器或常量）指向编译器中的副作用和新寄存器或常量的箭头。它们是编译程序的 Kleisli 箭头：Operands x -> Build (Named Instruction) m (Operands y)。我们确定了在编译程序中制作新符号和发出具有副作用的指令的编译器副作用。编译后的程序也将具有全局定义，因此我们将 Kleisli 箭头包装在发出全局定义的类别中。与大多数箭头不同，由于我们瞄准的级别较低，因此我们无法容纳任意类型。从寄存器到寄存器的箭头 + 副作用仅适用于 Registerable 可以存储在 LLVM 寄存器中或由寄存器引用的类型。
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. However, when we stay with Category we will smash your desire to "abstract away allowing for a variety of backends" - we will have the backend of ordinary Haskell functions -> described earlier、前面描述的原始递归 Haskell 函数的后端以及我们新的 LLVM 编译器后端会更容易。所以，首先我们上去谈谈约束和种类。
Registerable 类型是那些可以与寄存器 RegisterRep 中的表示相关联的类型，即 Traversable 并支持应用程序（Apply 是 Applicative没有 pure)。他们还必须有一个 LLVM Type 与每个寄存器关联。
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
RegisterableCtx和RegisterableDict后面用于归纳证明
单元类型不带寄存器。它的表示是一个 Proxy 什么都不包含。
instance Registerable () where
type RegisterRep () = Proxy
type RegisterableCtx () = ()
registerableDict _ = Dict
types _ = Registers Proxy
一个自然数可以存储在一个寄存器中。它的表示是一个Identity，里面存储了一个东西，那个东西的类型是一个64位的整数。
instance Registerable Nat where
type RegisterRep Nat = Identity
type RegisterableCtx Nat = ()
registerableDict _ = Dict
types _ = Registers . Identity $ IntegerType 64
一个元组可以存储在它存储的两个东西的寄存器中。它的表示是它存储的两个事物的表示的乘积 :*:。它的类型是它存储的两个东西的类型的乘积。元组还引入了 RegisterableCtx - 为了用元组做任何事情，我们需要知道它的两边都是 Registerable.
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)
我们可以定义一个 Functor 具有 Registerable 类型寄存器的形状。
data Registers r a where
Registers :: Registerable r => RegisterRep r a -> Registers r a
因为每个 Registerable 类型的表示都是 Traversable 并且有一个 Apply，我们可以为 Registers.
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)
我们之前使用的类型的 Operands 只是一个结构，其形状与保存该类型的寄存器具有相同的形状，但在每个地方保存一个 Operand。
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..]
又跑了一圈...
随着高级类型编程的有趣部分被排除在外，跟踪什么是 Registerable 变成了一项艰巨的任务。请记住，其中的 none 对库的用户可见，他们只能看到 Category、ArrowLike 和 PrimRec 类型 类.
A RegisterableDict 持有一个类型是 Registerable 的证明以及该类型需要的任何 RegisterableCtx 证明。
type RegisterableDict a = Dict (Registerable a, RegisterableCtx a)
A Dict 保存约束的字典。当我们在 Dict 上进行模式匹配时，将字典引入 ghc。为了构造一个 Dict，约束需要在 ghc 的范围内。早先的Registers和RegisterArrow也在随身携带字典，解构时利器，构建时障碍
data Dict c where
Dict :: c => Dict c
我们现在可以定义与第一部分中的 RegisterArrow 等价的东西，可以为所有类型定义。在分发存储在内部的 RegisterArrow 之前，我们要求以 RegisterableDict 的形式证明输入类型满足约束，而不是限制类型。我们将从输入中归纳证明约束在其他地方也得到满足。
data PRFCompiled m a b where
BlockLike :: (RegisterableDict a -> RegisterArrow m a b) -> PRFCompiled m a b
为了帮助跟踪词典，我们将制作一些工具。 rarrowDict 直接从 RegisterArrow
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
fstDict 和 sndDict 表明如果一个元组是 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
同时上下
编译器本身会同时检查类型和下栏。它生成低级指令并构建每种类型的归纳证明 Registerable.
以下每个实例从内到外阅读起来最容易。
寄存器上的 Kleisli 箭头形成 Category。身份 id 是 return 输入所在的寄存器。它不产生任何定义，因此在定义类别中，它只能被 returned。如果为 Registerable 输入传入 Dict，我们知道输出（相同）也是 Registerable，因此可以构建 RegisterArrow.
Kleisli 箭头在寄存器上的组合，\a -> g a >>= f，表示完成第一个的所有副作用，将结果传递给第二个寄存器，完成第二个的所有副作用一个，return 其结果所在的寄存器。每个组件也可以在定义类别中生成定义，因此我们按顺序从两者发出定义 g <- mg; f <- mf; return ...。最后三行以上的所有内容都将约束纳入范围以归纳证明约束成立。
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)
仅用一个类别实例，我们就编写了大部分编译器。我们可以将两个计算放在一起来构建一个新的计算。 Category构成了串联编程的坚实基础。
ArrowLike 实例除了处理编译器所指的注册之外什么都不做。这也是 Arrow 在 Haskell 中所做的所有事情——兼顾你正在使用元组处理的结构的哪一部分。 fst关注寄存器结构的一部分，snd关注另一部分。 &&& 在同一组寄存器上进行两次计算并记住两者的结果。
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)
对于 Category 和 ArrowLike 实例，我们已经编写了三分之二的编译器，甚至没有发出一条指令。任何一个实例所做的都是操纵编译器的状态或组合计算。两者都没有执行任何指令。我们所有的计算都来自 PrimRec 实例，它引入了构造和解构自然数。
我们通过构造zero（将操作数绑定到0常量）或计算数字的后继（将操作数绑定到adding的结果来构造自然数1 到输入操作数）。
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'
我们刚刚在 Category 和 ArrowLike 实例中直接为低级代码编写了一个编译器。当震惊的乐队指挥错过了问题时，礼堂里一片寂静。前排观众晕倒
收拾行李
我们开始随便收拾东西，定义一个极其简单的递归，用在prec的定义中。我们的 "calling convention" per say 将传递两个指向函数的指针，一个指向它可以从中读取其参数的内存，另一个指向它应该写入其结果的内存。笨拙而朴实的观众开始在结局中闲聊，但评委们仍然急切地想看看这一切是否真的有效。
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 位数字！”。
在内存中一个接一个地存储或检索 Traversable 结构的每个字段就像遍历它一样简单。我们将所有数据打包到堆栈内存中，而不用担心共享或重复。毕竟我们早就 "从琐碎的担忧中解放[d]
关于，例如，基于硬件的整数的效率。
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 位整数放入其分配给堆栈的单元格中时，最后一位观众缓缓离开看台。
前进时侧身
hoist 周围聚集了一小群人。 "You never used this"，一个说。 "We did, it just might not have made the jumbo-tron. We used it when we went deeper into a block".
每次我们 yield 或 await 管道时，数据都会横向移动到计算流中。当我们 await 一个新名字时它从一侧进来，当我们 yield 一个结果时它从另一边出去。每次我们将一个操作数绑定到一条指令时，我们都在做这两个操作，但在 monad 的结果中，只需要担心操作数保存计算结果。
bind :: (Monad m) => Type -> Instruction -> Build (Named Instruction) m (Operand)
bind t instruction = do
name <- getName
instr $ name := instruction
return (LocalReference t name)
为了制作一个区块，我们收集了子计算的 yielded 结果。
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,()))
为了收集子计算的结果，我们利用了管道非常纯净的事实，只要您有自然转换 forall x. m x -> n x，您就可以换掉底层的 monad。这就是 hoist 所做的；它允许我们 lift 管道下的所有底层 monad 操作在另一个转换器上使用管道，在这种情况下 WriterT.
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)
我们跌到多低？
裁判长出示了我们选择的柱子高度的select离子，并要求我们编译isOdd。示例代码仅针对Category、ArrowLike、PrimRec.
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)
小组对 极其 低效的 isZero 实施傻笑。
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
}
一位初级评委说，"It's technically correct" 同事评论说是“最差 种正确”。裁判在控制台坐下并尝试一些输入：
123456
0
54321
1
654321
[Stack Overflow]
主审祝贺我们的水平较低，但建议我们应该尝试一些"more technical"以获得满分。
大事记
当我们走出大厅时，我们注意到 our complete code and output 印在 CoPointed Sheet 的特别后期版本中，在体育场内售价 12.50 美元，在外面的报摊上售价 1.25 美元.