All geek questions in one place

Arrowed EDSL for writing lower level code

Most of the motivating examples that are usually provided for arrows show how more complex computing systems can be built on top of Hask (for example, the Kleisli categories for effects, Arrowized FRP, etc.) Have you done any work on using Arrows to write code lower level (e.g. assembly, javascript)? Although this may not correspond to the completely standard definitions of Arrow (esp. arr :: (a -> b) -> cat a b), It seems that Arrows form a solid foundation for some kind of concatenative programming.

+4
source share
1 answer

Panel customization

, , . , . , . , ArrowLike .

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 , LLVM, Hask. - LLVM . Category s, Arrow s , , , .

.

{-# 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 AST LLVM. AST llvm tools llvm-general 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 tools

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)

, , limbo bar, , .

clang .

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 . , - , , . + 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 .

-. , , Haskell Category, . , Category. Category leftaroundabout . , Category, ", " - Haskell -> , Haskell, , LLVM. , .

Registerable - , RegisterRep, Traversable (Apply is 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, slog. , , Category, ArrowLike PrimRec.

A RegisterableDict , Registerable, RegisterableCtx .

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

A Dict . ghc, Dict. Dict, ghc. Registers RegisterArrow , .

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

- RegisterArrow , . , a RegisterableDict, RegisterArrow, . , .

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 a Category. id return , . , return ed. Dict Registerable, , ( ) Registerable a RegisterArrow.

Kleisli , \a -> g a >>= f, , , , , . , 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) ( add ing 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)

, .

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. " " , , , , - , . Hackish , , , .

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

- : "... !".

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. " ", - . " , , jumbo-tron. , ".

, yield await , . , await , yield . , , , , , .

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

, yield 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,()))

, , , , forall x. m x -> n x. , hoist; lift , 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)

?

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
}

: " ", , , " ". :

123456
0

54321
1

654321
[Stack Overflow]

, - " " .

, , CoPointed Sheet, 12,50 , $1,25.

+8

Source: https://habr.com/ru/post/1570398/

More articles:


All Articles