Haskellを使ってRubyのクラスメソッドを書く(その3) FFI+MessagePack

(2018.5.13)
(その4)まとめを公開しました。ベンチマーク結果もありますのでご参考に。

はじめに

その2のコメントでMessagePackを紹介していただきました。それを使ったプログラムに挑戦してみました。
基本的にはバイナリ形式ですので速度はJSONより変換がだいぶ速いようです。64ビットを超える整数型は直接扱えませんが、それ以外はJSONとほぼ同じ表現力があるようです。
同じくフィボナッチ数を1つだけ、それと配列にして求める2つを示します。

Haskell

Haskellの関数を用意します。

src/Fib.hs

module Fib (fib) where

-- フィボナッチ数の計算
fibs = 0:1:zipWith (+) fibs (tail fibs)
fib :: Int -> Int
fib i = fibs !! i

Main.hsでfibの型注釈を書いていますが、fibの実体を書いてあるsrc/Fib.hsと別ファイルになっているので
fib :: Int -> Int
と型クラス制約を入れておかないのエラーが出てしまいます。

Lib.hsはそのまま使ってください。

src/Lib.hs

{-# LANGUAGE OverloadedStrings #-}

module Lib where

import Foreign.C.Types
import GHC.Ptr (Ptr)
import qualified Data.MessagePack as MP
import Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import Foreign.Marshal.Array (newArray)
import Foreign.Storable (Storable(..))
import Foreign.Marshal.Utils (new)
import Data.Word

data ByteArrayStruct = ByteArrayStruct {len :: CLong, ptr_msg :: Ptr Word8} deriving Show
instance Storable ByteArrayStruct where
    sizeOf = const (16)
    alignment = sizeOf
    poke ary (ByteArrayStruct len ptr_msg) = do
        ((\hsc_ptr -> pokeByteOff hsc_ptr 0)) ary len
        ((\hsc_ptr -> pokeByteOff hsc_ptr 8)) ary ptr_msg
    peek ary = do
        len <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) ary
        ptr_msg <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) ary
        return $ ByteArrayStruct len ptr_msg

-- バイト配列をBL.ByteStringに変換し、funcで変換後バイトの配列に戻す
convertByteArrayViaMsgPack
  :: (BL.ByteString -> BL.ByteString) -> (Int, Ptr CChar) -> IO (Ptr ByteArrayStruct)
convertByteArrayViaMsgPack func (len, ptr) = do
    b1 <- B.packCStringLen (ptr, len)
    let b2 = (BL.toStrict . func . BL.fromStrict) b1
    ary <- newArray $ B.unpack b2
    new $ ByteArrayStruct (fromIntegral $ B.length b2) ary

-- MessagePack(Data.ByteString.Layzy)をunpackし、funcで変換後packする
convertMsgPackBy
  :: (MP.MessagePack a, MP.MessagePack t) => (t -> a) -> BL.ByteString -> BL.ByteString
convertMsgPackBy func msgpk = MP.pack $ func d
    where d = case MP.unpack msgpk of
              Just a -> a
              Nothing -> errorWithoutStackTrace "MessagePack unpack error"

MessagePackはデータ途中にバイト0を含みますので、JSONのようなCStringは使えません。

app/Main.hs

module Main where

import Foreign.C.Types
import Foreign.Marshal.Alloc (free)
import GHC.Ptr (Ptr)
import Lib
import Fib

main = undefined

-- 整数値のMessagePackを受け取って、fibを計算してMessagePackで返す
fib_hm len ptr = convertByteArrayViaMsgPack (convertMsgPackBy  (fib :: Int -> Int)) (fromIntegral len, ptr)
foreign export ccall fib_hm :: CLong -> Ptr CChar -> IO (Ptr ByteArrayStruct)

-- 配列形式のMessagePackを受け取って、fibを計算してMessagePackで返す
fibs_hm len ptr = convertByteArrayViaMsgPack (convertMsgPackBy (map fib :: [Int] -> [Int])) (fromIntegral len, ptr)
foreign export ccall fibs_hm :: CLong -> Ptr CChar -> IO (Ptr ByteArrayStruct)

foreign export ccall "free_ptr" free :: Ptr a -> IO ()

JSONのときと同じように、(fib :: Int -> Int)と(map fib :: [Int] -> [Int])の違いだけでデータ型の違いを吸収しています。この部分だけを書き換えることで色々な関数やデータ構造に対応できます。
使われている関数(ここではfib)の型注釈は、型推論する上で重要ですので忘れないようにしてください。

コンパイル等はその1を参考に
今回はData.ByteStringやmsgpackを使っていますので、package.yamlにdependenciesを追加しておいてください。

package.yaml

その1からの変更点
(省略)
library:
  source-dirs: src
  dependencies:
  - data-msgpack
  - bytestring
(省略)

テスト用プログラム

test.rb

require "ffi"
require "msgpack"

module Test
    extend FFI::Library
    ffi_lib "./.stack-work/install/x86_64-osx/lts-11.5/8.2.2/bin/testFFI.so"
    attach_function :c_hs_init, :hs_init, [:pointer, :pointer], :void
    attach_function :hs_exit, [], :void
    attach_function :hs_free, :free_ptr, [:pointer], :void  
    def self.hs_init() c_hs_init(nil, nil) end
    def self.ffi_msgpk(data, &func)
        msg=MessagePack.pack(data)
        msg_len=msg.length
        arg_ptr=FFI::MemoryPointer.new(:uchar, msg_len)
        arg_ptr.put_bytes(0, msg, 0, msg_len)
        ret_ptr=func[msg_len, arg_ptr]
        ret_msg_len=ret_ptr.get(:int64,0)
        ret_msg_ptr=ret_ptr.get_pointer(8)
        ret_msg=ret_msg_ptr.get_bytes(0, ret_msg_len)
        self.hs_free(ret_msg_ptr)
        self.hs_free(ret_ptr)
        MessagePack.unpack(ret_msg)
    end

    attach_function :fib_hm, [:int64, :pointer], :pointer
    attach_function :fibs_hm, [:int64, :pointer], :pointer

    def self.fib(data) self.ffi_msgpk(data){|*a| Test.fib_hm(*a)} end
    def self.fibs(data) self.ffi_msgpk(data){|*a| Test.fibs_hm(*a)} end
end

Test.hs_init
p Test.fib(10)
p Test.fibs([*10..20])
Test.hs_exit