🦥

HaskellからCのライブラリを使う

2021/12/22に公開

Haskell

ffi

ghc

tech

はじめにの前に

これはHaskell Advent Calendar 2021の23日目の記事です。長くなってしまったのと、時間がなくて説明が雑になっているところが多々あるかと。C言語で書かれたライブラリをHaskellから使うときに「ここどうやったらいいかな」というのを自力で解決してきた、いくつかの手法を、ひとつのライブラリをHaskellから使っていくというストーリーのなかで解説してみました。今後また手を入れて洗練させていきたいと思っています。

はじめに

ふだんHaskellで楽していたとしても、もっと楽しいことをやろうとしたら、多くの場合にC言語のライブラリを使うことになる。Cの関数を使うことは楽しくスリリングな作業になる。柵のない屋上でローラースケートを楽しむようなものだ。使い捨てのコードであれば、FFIで取り込んだ関数をそのまま使えばいい。そうではなく、すこし腰をすえて取り組むコードを書くときには、屋上に柵を作りローラースケート用のコースを整備していくことになる。そういった作業のなかで、いろいろな問題を解決してきた。その「問題と解決方法のひとつ」をここで共有したい。

記事を書くうえで、C言語の既存のライブラリを対象とするのには、つぎのような問題がある。

APIが複雑すぎて1記事にはおさまらなくなる
環境によってどのライブラリが使えるかが異なる

これらの問題を解消するために、ここでは新たに単純なC言語によるライブラリを作成し、それをHaskellから使用するようにする。この記事は大きくふたつの部分に分けられる。

ビルド時に必要なオプションについて
Cのライブラリを設計して、それをHaskellから使う

既存のパッケージを使うときにビルド時に必要なオプションを説明する小さな部分と、Cの関数や値を実際に使用していく比較的大きな部分とのふたつだ。前者ではLinuxを前提に説明していくが、後者はより広い環境で試せる内容になっている。前者と後者は分かれているので、前者を読み飛ばして、本題となる後者の部分から読んでいくこともできる。

ビルド時に必要なオプションについて

この部分についてはLinux環境のみをターゲットにしている。この部分で大事なことはつぎの2つだ。

pkg-configが使えるライブラリであればpackage.yamlのpkg-config-dependenciesを追加する
そうでなければ、include-dirs, extra-lib-dirs, extra-librariesを追加する

Linuxユーザでなければ「Cのライブラリを設計して、それをHaskellから使う」へ飛ぼう。

ダミーのライブラリを作成

ビルドに必要なオプションなどを説明するための小さなコードを作成する。適当なディレクトリを作成し、そこにファイルを配置する。

% cd ~
% mkdir zenn
% mkdir zenn/use_c
% mkdir zenn/use_c/c_source
% cd ~/zenn/use_c/c_source

foo.c

#include "foo.h"

int
add(int x, int y) { return x + y; }

foo.h

#ifndef _FOO_H
#define _FOO_H

#define FOO 123

int add(int x, int y);

#endif

定数FOOと関数addとを定義している。コンパイルして、ホームディレクトリ下のディレクトリ.zenn/の下に配置する。

% mkdir ~/.zenn
% mkdir ~/.zenn/include
% mkdir ~/.zenn/lib

% cp foo.h ~/.zenn/include
% gcc --shared -o libfoo.so foo.c
% cp libfoo.so ~/.zenn/lib

C言語から呼んでみる

コンパイルオプションを指定

C言語のmainからこのプチライブラリを呼んでみよう。

main.c

#include <stdio.h>

#include <foo.h>

int
main(int argc, char *argv[])
{
	printf("%d\n", FOO);
	printf("%d\n", add(3, 8));
}

コンパイルして試してみよう。動的リンクをするので実行時には、環境変数LD_LIBRARY_PATHの設定が必要になる。

% gcc -I~/.zenn/include -L~/.zenn/lib -lfoo main.c -o use_foo
% LD_LIBRARY_PATH=~/.zenn/lib ./use_foo
123
11

pkg-configを使う

Wikipedia:pkg-config

pkg-configとは、ライブラリを利用する際に必要となる各種フラグやパス等を、共通したインターフェースで提供するための手段である。

ライブラリの使用者がひとつひとつ-I/include/directory -L/lib/directory -lfooのようにオプションを手書きしなくても、つぎのように書けば必要なフラグが指定できるようにしてくれる仕組みだ。

% gcc `pkg-config foo --cflags --libs` main.c -o use_foo

このように使用者の便宜を図るために、ライブラリの作者は.pcファイルを作成する必要がある。

% cat foo.pc
prefix=/home/your_user_name/.zenn
libdir=${prefix}/lib
includedir=${prefix}/include

Name: Foo
Description: Foo
version: 0.1
Libs: -L${libdir} -lfoo
Cflags: -I${includedir}

foo.pcを.zenn/の下に配置する。

% mkdir ~/.zenn/share
% mkdir ~/.zenn/share/pkgconfig
% cp foo.pc ~/.zenn/share/pkgconfig

そのままだとpkg-configは.pcファイルを見つけるのにディレクトリ/usr/share/pkgconfigを探す。環境変数PKG_CONFIG_PATHに指定することで、そのディレクトリを探してくれる。

% PKG_CONFIG_PATH=~/.zenn/share/pkgconfig pkg-config foo --cflags --libs
-I/home/your_user_name/.zenn/include -L/home/youre_user_name/.zenn/lib -lfoo

これで、ちまちまとフラグなどを指定せずにコンパイルができる。

% gcc `PKG_CONFIG_PATH=~/.zenn/share/pkgconfig pkg-config foo --cflags --libs` main.c -o use_foo

Haskellから呼んでみる

コンパイルオプションを指定する

まずはディレクトリのパスなどを直接指定するやりかたで、ライブラリfooを使ってみる。パッケージtry-use-fooを作成する。

% cd ~/zenn/use_c
% stack new try-use-foo
% cd try-use-foo

ファイルpackage.yamlを編集する。

package.yaml

...

library:
  source-dirs: src
  include-dirs: /home/your_user_name/.giita/include
  extra-lib-dirs: /home/your_user_name/.zenn/lib
  extra-libraries: foo

...

ファイルsrc/Lib.hsの名前をsrc/Lib.hscに変更し、編集する。.hscファイルはhsc2hsで処理される。C言語の定数や構造体をあつかうことができる。

src/Lib.hsc

module Lib where

import Foreign.C.Types

#include <foo.h>

foo :: CInt
foo = #{const FOO}

foreign import ccall "add" c_add :: CInt -> CInt -> CInt

#includeでfoo.hを導入し、#constで定数FOOを読み込んでいる。また、foreign importでC言語の関数addをc_addという名前で取り込んでいる。つぎに、ファイルapp/Main.hsを編集する。

app/Main.hs

module Main where

import Lib

main :: IO ()
main = do
	print foo
	print $ c_add 3 8

コンパイルして試してみる。

% stack build
% LD_LIBRARY_PATH=~/.zenn/lib stack exec try-use-foo-exe
123
11

pkg-configを利用する

pkg-configを利用すれば、もっとスマートに設定できる。

% cd ~/zenn/use_c
% stack new try-use-foo-pkg
% cd try-use-foo-pkg

ファイルpackage.yamlを編集する。

...

library:
  source-dirs: src
  pkg-config-dependencies: foo

...

src/Lib.hscやapp/Main.hsはpkg-configを利用しない版とおなじだ。

% rm src/Lib.hs
% cp ../try-use-foo/src/Lib.hsc src
% cp ../try-use-foo/app/Main.hs app

ビルド時に環境変数PKG_CONFIG_PATHに~/.zenn/share/pkgconfigを指定する必要がある。

% PKG_CONFIG_PATH=~/.zenn/share/pkgconfig stack build
% LD_LIBRARY_PATH=~/.zenn/lib stack exec try-use-foo-pkg-exe
123
11

pkg-configに対応したライブラリなら、package.yamlでpkg-config-dependenciesを設定してやるだけで、いろいろなフラグをうまく指定してくれるということだ。

Cのライブラリを設計して、それをHaskellから使う

ソースコード

ソースコードは以下にある。

GitHub: zenn-use-c-lib

はじめに

CのライブラリとしてCLIの画面に「人間」を描画するライブラリを考える。また、そのライブラリは一定時間ごとにイベントを発生させるものとする。イベントは時間の経過を表すTickイベントと入力された文字を表すCharイベントがあるとする。そういうC言語のライブラリを使って、右から流れてくる「敵」を「主人公」が踏んでいくゲームを作る。

.....
.\o..
..A\.
./.\.
.....

これが主人公である。で、

.....
.\O/.
..A..
./.\.
.....

これが敵だ。

実際にこの記事であつかうのは、Cのライブラリの作成と、それをHaskellから使う機構のところまでとする。ゲームそのもののコードはGitHubを参照してほしい。

記事を読む前に「ゲーム」を試してみるには、つぎのようにする。

% git clone https://github.com/YoshikuniJujo/zenn-samples
% cd zenn-samples/zenn-use-c-lib
% stack build
% stack exec try-game

'h': 左に歩き出す
2回目の'h': 左に走り出す
'l': 右に歩き出す
2回目の'l': 右に走り出す
'j': 立ち止まる
'k': ジャンプ

準備

stack newでプロジェクトを生成して、C言語のソースコードとヘッダファイルを格納するディレクトリを作成する。実戦では既存のCライブラリを使用するが、ここではC言語のライブラリを作りながら、同時にHaskellから使用するためのコードを書いていく。

まずはプロジェクトを作成する。名前はzenn-use-c-libとでもしておこうか。

% stack new zenn-use-c-lib
% cd zenn-use-c-lib

ヘッダファイルを格納するディレクトリを作成し、そのディレクトリをpackage.yamlで設定する。

% mkdir include
% vi package.yaml
...
library:
  source-dirs: src
  include-dirs: include
...

ディレクトリinclude/を作成し、設定ファイルpackage.yamlにinclude-dirs:の行を追加した。つぎにC言語のソースコードを格納するディレクトリcsrcと空のソースコードcsrc/human.cを作成し、設定ファイルに必要な行を追加する。

% mkdir csrc
% touch csrc/human.c
% vi package.yaml
...
library:
  source-dirs: src
  include-dirs: include
  c-sources:
  - csrc/human.c
...

ここで一度ビルドを試してみよう。

% stack build

単純な関数

まずは単純な関数をC言語側で定義してHaskell側から使ってみよう。「人間」の位置を引数にとり、その左右上下の位置を返す関数だ。

csrc/human.c

int hm_left(int x, int y) { return x; }
int hm_right(int x, int y) { return x + 2; }
int hm_top(int x, int y) { return y; }
int hm_bottom(int x, int y) { return y + 2; }

「人間」は以下のような見た目をしている。

\o.
.A\
/.\

「人間の位置」である(x, y)は左上の位置を示すので、左右上下はそれぞれx, x + 2, y, y + 2となる。これらの関数にHaskell側からアクセスしてみよう。

src/Human.hs

{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}

module Human where

import Foreign.C.Types

foreign import ccall "hm_left" left :: CInt -> CInt -> CInt
foreign import ccall "hm_right" right :: CInt -> CInt -> CInt
foreign import ccall "hm_top" top :: CInt -> CInt -> CInt
foreign import ccall "hm_bottom" bottom :: CInt -> CInt -> CInt

C言語の関数を呼び出すHaskellの関数を定義している。書式はつぎのようになる。

foreign import ccall "Cの関数名" Haskellの関数名 :: 型

Foreign.C.Types.CIntはC言語の型intに対応するHaskellの型だ。

ビルドして対話環境で試してみよう。

% stack build
% stack ghci
> left 8 5
8
> right 8 5
10
> top 8 5
5
> bottom 8 5
7

あとで使うので左右上下から「人間の位置」のX座標、Y座標の値を計算する関数も定義しておく。

csrc/human.c

int hm_x_from_left(int l) { return l; }
int hm_x_from_right(int r) { return r - 2; }
int hm_y_from_top(int t) { return t; }
int hm_y_from_bottom(int b) { return b - 2; }

src/Human.hs

foreign import ccall "hm_x_from_left" xFromLeft :: CInt -> CInt
foreign import ccall "hm_x_from_right" xFromRight :: CInt -> CInt
foreign import ccall "hm_y_from_top" yFromTop :: CInt -> CInt
foreign import ccall "hm_y_from_bottom" yFromBottom :: CInt -> CInt

定数

「人間」を表示していくフィールドの大きさを定数FIELD_WIDTHとFIELD_HEIGHTで定義する。

include/human.h

#ifndef _HUMAN_H
#define _HUMAN_H

#define FIELD_WIDTH 79
#define FIELD_HEIGHT 23

#endif

C言語の定数をHaskellから使うためにhsc2hsを使う。Stackだと拡張子を.hsから.hscにすればいい。

% mv src/Human.hs src/Human.hsc

ヘッダファイルhuman.hを導入する。

src/Human.hsc

import Foreign.C.Types

#include <human.h>

#includeはhsc2hsによって処理される。導入されたヘッダに定義された定数などがhsc2hsの続く処理に使用される。定数fieldWidthとfieldHeightを定義する。

src/Human.hsc

fieldWidth, fieldHeight :: CInt
fieldWidth = #{const FIELD_WIDTH}
fieldHeight = #{const FIELD_HEIGHT}

#{...}のように書かれた部分はhsc2hsによって処理される。定数の展開の書式はつぎのようになる。

#{const 定数名}

ビルドして試してみよう。

% stack build
% stack ghci
> fieldWidth
79
> fieldHeight
23

ヘッダファイルhuman.hを作成したので、Cのソースコード内でもincludeしておこう。ついでに、今後使用するヘッダファイルもここでincludeする。

csrc/human.c

#include <stdlib.h>
#include <stdio.h>
#include <stdbool.h>
#include <string.h>
#include <sys/select.h>

#include <human.h>

入出力

フィールドを格納する2次元配列を定義する。

include/human.h

typedef char HmFieldArray[FIELD_HEIGHT][FIELD_WIDTH + 1];
typedef char (*HmField)[FIELD_WIDTH + 1];

型HmFieldArrayは配列の領域確保などに使用し、型HmFieldはそれに対するアクセスに使用する。また、文字列の終わりを示す'\0'を格納するために、FIELD_WIDTHではなくFIELD_WIDTH + 1のようにしてある。

まずは、静的に確保されたフィールドとしてhm_field0を宣言する。

csrc/human.c

HmFieldArray hm_field0;

この領域を初期化する関数と、領域を標準出力に書き出す関数を定義する。

csrc/human.c

void
hm_field0_init(void)
{
	for (int i = 0; i < FIELD_HEIGHT; i++) {
		int j;
		for (j = 0; j < FIELD_WIDTH; j++) hm_field0[i][j] = '.';
		hm_field0[i][j] = '\0';
	}
}

void
hm_field0_draw(void)
{
	for (int i = 0; i < FIELD_HEIGHT; i++) printf("%s\n", hm_field0[i]);
}

ごく普通のforループだ。関数hm_field0_initでは、それぞれの行ごとに79個の'.'とそれに続く、ひとつの'\0'とを配置している。関数hm_field0_drawでは、それぞれの行を文字列として出力する。Haskell側から使えるようにする。

src/Human.hsc

foreign import ccall "hm_field0_init" field0Init :: IO ()
foreign import ccall "hm_field0_draw" field0Draw :: IO ()

状態変化や入力、出力がからんでくる場合には返り値をIO値にする。ビルドして試してみる。

% stack build
% stack ghci
> field0Init
> field0Draw
....................

例外処理

静的に確保されたフィールドに「人間」を置いていこうと思う。もし「人間」がフィールドからはみ出るような場合や、完全にフィールドの外に出るような位置を指定された場合のことを考える。そういう場合への対策として、いくつか考えられるが、ここでは「例外」を引き起こすようにしよう。

Cの関数から返すエラーを表す値

まずはC言語の側に「人間を配置しようとした」ときに起こる正常終了やエラーを表す列挙型HmPutHumanResultを定義する。

include/human.h

typedef enum {
	HM_PUT_HUMAN_SUCCESS, HM_PUT_HUMAN_PARTIAL, HM_PUT_HUMAN_OFFSCREEN }
	HmPutHumanResult;

つぎのようになる。

HM_PUT_HUMAN_SUCCESS: 正常終了
HM_PUT_HUMAN_PARTIAL: 「人間」が一部はみ出る
HM_PUT_HUMAN_OFFSCREEN: 「人間」が全部フィールドの外に出てしまう

列挙型の特徴として上記の3つの値以外の値を取り得ることもることに注意が必要だ。

例外を表す型

Haskell側での例外を表す型を定義しよう。例外を表す型は階層構造にすることができる。たとえば、つぎのような階層があったとする。

AError +- BError
       |
       +- CError

このときBErrorとCErrorのどちらかだけを別々に捕捉することもできるが、捕捉する例外としてAErrorを指定することでBErrorとCErrorの両方を捕捉することができる。ここでは、つぎのような階層構造を持つ型を定義する。

PutHumanError +- PutHumanOutOfFieldError +- PutHumanPartialError
              |                          |
              |                          +- PutHumanOffscreenError
	      +- PutHumanUnknownError

それぞれ、つぎのような意味だ。

PutHumanError: 「人間」を配置するときに生じるエラー
PutHumanOutOfFieldError: 「人間」の全体または一部がフィールドの外に出てしまう
PutHumanPartialError: 「人間」の一部がフィールドの外にはみ出る
PutHumanOffscreenError: 「人間」の全体がフィールドの外に出てしまう
PutHumanUnknownError: t 「人間」を配置するときに生じる、その他のエラー

このような階層構造は型クラスの仕組みを使って、巧妙なやりかたで定義できる。定義できるが、いろいろと煩雑なコードを書く必要がある。パッケージexception-hierarchyのモジュールControl.Exception.Hierarchyには、TemplateHaskellを使って、この階層構造を定義する仕組みが用意されている。

パッケージexception-hierarchyをpackage.yamlの「依存するパッケージ」に追加する。

package.yaml

dependencies:
- base >= 4.7 && < 5
- exception-hierarchy

モジュールHuman.Exceptionに例外の型を定義する。

src/Human/Exception.hsc

{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE PatternSynonyms #-}
{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}

module Human.Exception where

import Control.Exception
import Control.Exception.Hierarchy
import Data.Typeable
import Data.Word

#include <human.h>

data PutHumanPartialError = PutHumanPartialError deriving (Typeable, Show)
data PutHumanOffscreenError = PutHumanOffscreenError deriving (Typeable, Show)

data PutHumanUnknownError = PutHumanUnknownError #{type HmPutHumanResult}
	deriving (Typeable, Show)

exceptionHierarchy Nothing (
	ExNode "PutHumanError" [
		ExNode "PutHumanOutOfFieldError" [
				ExType ''PutHumanPartialError,
				ExType ''PutHumanOffscreenError ],
		ExType ''PutHumanUnknownError ] )

まずは階層構造の葉になるデータ型を定義している。最後のPutHumanUnknownErrorは、C言語の列挙型HmPutHumanResultの想定されていない値が返ったときのための型だ。hsc2hsは#{type Foo}のようにすると、C言語上の型FooのHaskell上での対応する型に展開してくれる。関数exceptionHierarchyは、例外を表す型が、第2引数の木構造に示されるような形の階層構造になるようなソースコードを生成する。

指定した例外を捕捉する関数を書く。新たにモジュールTryHumanを作成しよう。

src/TryHuman.hs

{-# LANGUAGE ScopedTypeVariables, AllowAmbiguousTypes #-}
{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}

module TryHuman where

import Control.Exception

catchAndShow :: forall e . Exception e => IO () -> IO ()
catchAndShow act = act `catch` \(e :: e) -> putStrLn "CATCHED" >> print e

ビルドして試してみる。

% stack build
% stack ghci
> :set -XTypeApplications
> :module + Control.Exception
> catchAndShow @PutHumanPartialError $ throw PutHumanPartialError
CATCHED
PutHumanPartialError
> catchAndShow @PutHumanPartialError $ throw PutHumanOffscreenError
*** Exception: PutHumanOffscreenError
> catchAndShow @PutHumanOffscreenError $ throw PutHumanPartialError
*** Exception: PutHumanPartialError
> catchAndShow @PutHumanOffscreenError $ throw PutHumanOffscreenError
CATCHED
PutHumanOffscreenError
> catchAndShow @PutHumanOutOfFieldError $ throw PutHumanPartialError
CATCHED
PutHumanPartialError
> catchAndShow @PutHumanOutOfFieldError $ throw PutHumanOffscreenError
CATCHED
PutHumanOffscreenError

捕捉する例外をPutHumanPartialErrorやPutHumanOffscreenErrorにした場合には、それぞれの例外だけを捕捉し、PutHumanOutOfFieldErrorを指定した場合には両方の例外が捕捉されているのがわかる。

列挙型

列挙型をHaskellから使う

C言語側では「人間」を置く関数は成功やエラーを列挙型HmPutHumanResultで返す。この型は以下の値を取り得る。

HM_PUT_HUMAN_SUCCESS
HM_PUT_HUMAN_PARTIAL
HM_PUT_HUMAN_OFFSCREEN
その他の値

C言語の列挙型をあつかうのに便利な道具として、パッケージc-enumのForeign.C.Enum.enumがある。パッケージc-enumが使えるように、package.yamlの「依存するパッケージ」にc-enumを追加する。

package.yaml

...
dependencies:
- base >= 4.7 && < 5
- exception-hierarchy
- c-enum
...

言語拡張TemplateHaskellとPatternSynonymsを使うのでモジュールHumanの先頭にプラグマをつける。

src/Human.hsc

{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE PatternSynonyms #-}
...

モジュールForeign.C.Enumを導入する。また、型として#{type HmPutHumanResult}を使うが、これはWord32に展開されるので、モジュールData.Wordを導入する必要がある。

src/Human.hsc

...
import Foreign.C.Types
import Foreign.C.Enum
import Data.Word
...

関数enumはC言語の列挙型をHaskell側から利用するためのコードを生成する。モジュールHumanに、つぎのように定義する。

src/Human.hsc

enum "PutHumanResult" ''#{type HmPutHumanResult} [''Show, ''Read] [
	("PutHumanResultSuccess", #{const HM_PUT_HUMAN_SUCCESS}),
	("PutHumanResultPartial", #{const HM_PUT_HUMAN_PARTIAL}),
	("PutHumanResultOffscreen", #{const HM_PUT_HUMAN_OFFSCREEN}) ]

これは、だいたい、つぎのようなコードに展開される。

newtype PutHumanResult = PutHumanResult #{type HmPutHumanResult}

pattern PutHumanResultSuccess :: PutHumanResult
pattern PutHumanResultSuccess <- PutHumanResult #{const HM_PUT_HUMAN_SUCCESS}
	where
	PUtHumanResultSuccess = PutHumanResult #{const HM_PUT_HUMAN_SUCCESS}

...

これは、たとえばPutHumanResult 0に別名としてPutHumanResultSuccessという名前が用意されるということだ。そして、その別名はパターンマッチにも使える。また、クラスShowやReadのインスタンス宣言が「いい感じ」に定義される。ビルドして試してみよう。

% stack build
% stack ghci
> PutHumanResultSuccess
PutHumanResultSuccess
> PutHumanResultPartial
PutHumanResultPartial
> PutHumanResult 1
PutHumanResultPartial
> PutHumanResult 123
PutHumanResult 123
> case PutHumanResultPartial of PutHumanResultPartial -> 123; _ -> 456
123
> read "PutHumanResultPartial" :: PutHumanResult
PutHumanResultPartial
> read "PutHumanResult 1" :: PutHumanResult
PutHumanResultPartial
> read "PutHumanResult 123" :: PutHumanResult
PutHumanResult 123

別名が値としてもパターンとしても使えることがわかる。また、クラスShowのインスタンスとしては「別名」のほうが優先して表示されること、クラスReadのインスタンスとしては別名でも「もともとの名前」でも読み込むことができることがわかる。

一文字、フィールドに置く

「人間」をフィールドに置くために、まずは文字をひとつフィールドに置く関数を定義する。

csrc/human.c

void
hm_field0_put_char(int x, int y, char c)
{
	if (0 <= x && x < FIELD_WIDTH && 0 <= y && y < FIELD_HEIGHT)
		hm_field0[y][x] = c;
}

引数x, yで指定した位置がフィールド内であれば、その位置の文字を指定された値に置き換える。そうでなければ何もしない。

「人間」を置く

「人間」の位置を指定したとき、つぎの3つの状態が考えられる。

フィールドにおさまる
フィールドから一部分はみ出る
全体がフィルドの外に出てしまう

この3つの状態のうち、どの状態になるかを調べる関数を定義する。

csrc/human.c

HmPutHumanResult
hm_check_inside(int x, int y)
{
	if (	0 <= hm_left(x, y) && hm_right(x, y) < FIELD_WIDTH &&
		0 <= hm_top(x, y) && hm_bottom(x, y) < FIELD_HEIGHT )
		return HM_PUT_HUMAN_SUCCESS;
	else if (
		0 <= hm_right(x, y) && hm_left(x, y) < FIELD_WIDTH &&
		0 <= hm_bottom(x, y) && hm_top(x, y) < FIELD_HEIGHT )
		return HM_PUT_HUMAN_PARTIAL;
	else	return HM_PUT_HUMAN_OFFSCREEN;
}

「人間」の左端が0以上で右端がフィールドの幅未満、かつ上端が0以上で下端がフィールドの高さ未満なら、「人間」の全体がフィールドにおさまる。HM_PUT_HUMAN_SUCCESSを返す。「人間」の右端が0以上で左端が幅未満で、下端が0以上で上端が高さ未満ならば「人間」の一部はフィールド内だ。HM_PUT_HUMAN_PARTIALを返す。そうでなければ、「人間」の全体がフィールドの外にある。HM_PUT_HUMAN_OFFSCREENを返す。

関数hm_field0_put_char, hm_field0_draw, hm_check_insideを使って、「人間」を静的に確保されたフィールドに置き、それを標準出力に出力する関数を書く。

csrc/human.c

HmPutHumanResult
hm_field0_draw_human(int x, int y)
{
	hm_field0_put_char(x, y, '\\');
	hm_field0_put_char(x + 1, y, 'o');
	hm_field0_put_char(x + 1, y + 1, 'A');
	hm_field0_put_char(x + 2, y + 1, '\\');
	hm_field0_put_char(x, y + 2, '/');
	hm_field0_put_char(x + 2, y + 2, '\\');
	hm_field0_draw();
	return hm_check_inside(x, y);
}

「人間」を構成する、それぞれの文字をフィールドに置き、それを関数hm_field0_drawで出力する。「人間」がフィールドにおさまったかどうかを返り値として返す。

これをHaskell側から利用できるようにする。まずは、必要な言語拡張LambdaCaseと導入するモジュールControl.ExceptionとHuman.Exceptionを追加する。あとで必要になるので言語拡張BlockArgumentsも追加しておこう。

src/Human.hsc

{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE BlockArguments, LambdaCase #-}
{-# LANGUAGE PatternSynonyms #-}
{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}

module Human where

import Foreign.C.Types
import Foreign.C.Enum
import Control.Exception
import Data.Word

import Human.Exception
...

関数field0DrawHumanを定義する。

src/Haskell.hsc

foreign import ccall "hm_field0_draw_human"
	c_hm_field0_draw_human :: CInt -> CInt -> IO PutHumanResult

field0DrawHuman :: CInt -> CInt -> IO ()
field0DrawHuman x y = c_hm_field0_draw_human x y >>= \case
	PutHumanResultSuccess -> pure ()
	PutHumanResultPartial -> throw PutHumanPartialError
	PutHumanResultOffscreen -> throw PutHumanOffscreenError
	PutHumanResult n -> throw $ PutHumanUnknownError n

C言語側の関数をc_hm_field0_draw_humanという名前で呼び出す。この関数の返り値によって、呼び出しが成功したことにするか、例外を発生させるか、またどの例外を発生させるかを決める。ビルドして試してみよう。

% stack build
% stack ghci
> field0Init
> field0DrawHuman 30 15
...(人間が表示される)...
> field0DrawHuman 30 22
...
***Exception: PutHumanPartialError
> field0DrawHuman 30 25
...
***Exception: PutHumanOffscreenError

GCを使う

ここまでは静的に確保されたフィールドを利用してきた。しかし、より柔軟に、複数のフィールドを使いたくなることもある。フィールドを動的に確保するような関数を定義しよう。動的に確保されたメモリーは解放する必要がある。ここでは、HaskellのGCのシステムを利用して自動でのメモリの解放を試してみよう。

まずはC言語側で、必要な関数を定義する。

csrc/human.c

void
hm_field_clear(HmField f)
{
	for (int i = 0; i < FIELD_HEIGHT; i++) {
		int j;
		for (j = 0; j < FIELD_WIDTH; j++) f[i][j] = '.';
		f[i][j] = '\0'; }
}

HmField
hm_field_new(void)
{
	HmField f;
	f = (HmField)malloc(sizeof(HmFieldArray));
	hm_field_clear(f);
	return f;
}

void hm_field_destroy(HmField f) { free(f); }

void
hm_field_draw(HmField f)
{
	for (int i = 0; i < FIELD_HEIGHT; i++) printf("%s\n", f[i]);
}

void
hm_field_put_char(HmField f, int x, int y, char c)
{
	if (0 <= x && x < FIELD_WIDTH && 0 <= y && y < FIELD_HEIGHT)
		f[y][x] = c;
}

HmPutHumanResult
hm_field_put_human(HmField f, int x, int y)
{
	hm_field_put_char(f, x, y, '\\');
	hm_field_put_char(f, x + 1, y, 'o');
	hm_field_put_char(f, x + 1, y + 1, 'A');
	hm_field_put_char(f, x + 2, y + 1, '\\');
	hm_field_put_char(f, x, y + 2, '/');
	hm_field_put_char(f, x + 2, y + 2, '\\');
	return hm_check_inside(x, y);
}

6つの関数を定義した。関数hm_field_clear, hm_field_draw, hm_field_put_charの3つは、それぞれ関数hm_field0_clear, hm_field0_draw, hm_field0_put_charを、静的なfield0の代わりに、引数としてとったフィールドを使うように修正したものだ。関数hm_field_put_humanも同様に関数hm_field0_draw_humanを、引数としてとったフィールドを使うように修正したものだが、それだけではなく、標準出力への出力をわけて純粋にフィールドへの書き込みだけに機能をしぼっている。残りの関数hm_field_newとhm_field_destroyはそれぞれ、フィールドのメモリの確保と解放を行う。

これらのC言語の関数を使ってHaskell側にフィールドを生成して使用する仕組みを組み立てていく。型PtrやForeignPtrを使うのでモジュールForeign.PtrとForeign.ForeignPtrが必要だ。また、Foreign.Concurrent.newForeignPtrを使うのでモジュールForeign.Concurrentも導入する。

src/Human.hsc

...
module Human where

import Foreign.Ptr
import Foreign.ForeignPtr hiding (newForeignPtr)
import Foreign.Concurrent
import Foreign.C.Types
import Foreign.C.Enum
import Control.Exception
import Data.Word

import Human.Exception

...

データ型Fieldを定義する。

src/Human.hsc

newtype Field s = Field (ForeignPtr (Field s)) deriving Show

型引数sはこの時点では必要ないが後の話題で必要になる。今のところは気にしないでほしい。ForeignPtrはポインタとそのポインタを解放するための処理をまとめたもので、このポインタは参照されなくなったあとに、その処理によって解放される。Field型の値を生成するには、C言語側の関数hm_field_newとhm_field_destroyとを使う。

src/Human.hsc

foreign import ccall "hm_field_new" c_hm_field_new :: IO (Ptr (Field s))

foreign import ccall "hm_field_destroy"
	c_hm_field_destroy :: Ptr (Field s) -> IO ()

fieldNewRaw :: IO (Field s)
fieldNewRaw = Field <$> do
	p <- c_hm_field_new
	newForeignPtr p $ c_hm_field_destroy p

動作fieldNewRawの名前の-Rawの部分は、今は気にしないでほしい。動作c_hm_field_newによって返されたポインタpと、それを解放する処理c_hm_field_destroy pとを関数newForeignPtrによってまとめることで、ForeignPtr型の値を生成している。

関数fieldClearRaw, fieldDrawRaw, fieldPutHumanRawを定義する。

src/Human.hsc

foreign import ccall "hm_field_clear" c_hm_field_clear :: Ptr (Field s) -> IO ()
foreign import ccall "hm_field_draw" c_hm_field_draw :: Ptr (Field s) -> IO ()

foreign import ccall "hm_field_put_human" c_hm_field_put_human ::
	Ptr (Field s) -> CInt -> CInt -> IO PutHumanResult

fieldClearRaw :: Field s -> IO ()
fieldClearRaw (Field ff) = withForeignPtr ff c_hm_field_clear

fieldDrawRaw :: Field s -> IO ()
fieldDrawRaw (Field ff) = withForeignPtr ff c_hm_field_draw

fieldPutHumanRaw :: Field s -> CInt -> CInt -> IO ()
fieldPutHumanRaw (Field ff) x y = withForeignPtr ff \pf ->
	c_hm_field_put_human pf x y >>= \case
		PutHumanResultSuccess -> pure ()
		PutHumanResultPartial -> throw PutHumanPartialError
		PutHumanResultOffscreen -> throw PutHumanOffscreenError
		PutHumanResult n -> throw $ PutHumanUnknownError n

関数withForeignPtrはForeignPtr a -> (Ptr a -> IO b) -> IO b型の関数であり、第2引数の関数に対して第1引数がもつポインタを引数としてあたえるという働きをする。第2引数である関数が処理を行っているあいだは、そのポインタは解放されることはない。

ビルドして試してみる。

% stack build
% stack ghci
> f <- fieldNewRaw
> fieldPutHuman f 30 15
> fieldDraw f
.....(「人間」が表示される)...

STモナドとIOモナド

Image

Field型の値は変化する状態を指し示すタグのようなものと考えられる。変化しない「値そのもの」と見なせる値の型を用意すると、いろいろと便利だ。そのようなImage型を用意する。Field型と同様に定義するが、なかの状態を変化させないように気をつけることで「値そのもの」と見なすことができる。

まずは、C言語側で型HmImageとHmField型の値からHmImage型の値を生成する関数を定義する。

csrc/human.c

typedef char HmImageArray[FIELD_HEIGHT][FIELD_WIDTH + 1];
typedef char (*HmImage)[FIELD_WIDTH + 1];

HmImage
hm_field_get_image(HmField f)
{
	HmImage img = (HmImage)malloc(sizeof(HmImageArray));
	memcpy(img, f, (FIELD_WIDTH + 1) * FIELD_HEIGHT);
	return img;
}

void hm_image_destroy(HmImage img) { free(img); }

void
hm_image_draw(HmImage img)
{
	for (int i = 0; i < FIELD_HEIGHT; i++) printf("%s\n", img[i]);
}

ここでは、HmField型の値もHmImage型の値も、どちらも「charの2次元配列」なのでわかりにくいが、たとえばウィンドウの描画内容を画像データとして取り出すような場面を想像してほしい。

これをHaskell側から利用する。

src/Human.hs

newtype Image = Image (ForeignPtr Image) deriving Show

foreign import ccall "hm_field_get_image"
	c_hm_field_get_image :: Ptr (Field s) -> IO (Ptr Image)

foreign import ccall "hm_image_destroy" c_hm_image_destroy :: Ptr Image -> IO ()

fieldGetImageRaw :: Field s -> IO Image
fieldGetImageRaw (Field ff) = Image <$> withForeignPtr ff \pf -> do
	p <- c_hm_field_get_image pf
	newForeignPtr p $ c_hm_image_destroy p

foreign import ccall "hm_image_draw" c_hm_image_draw :: Ptr Image -> IO ()

imageDraw :: Image -> IO ()
imageDraw (Image fi) = withForeignPtr fi c_hm_image_draw

関数fieldGetImageRawとimageDrawとを定義した。ビルドして試してみよう。

% stack build
% stack ghci
> f <- fieldNewRaw
> fieldPutHuman f 30 10
> img <- fieldGetImageRaw f
> imageDraw img
...(「人間」が表示される)...

Field型の値から出力するのと何の変わりもないように思えるが、感じとしてはウィンドウの表示領域から画像を取り出して、その画像を表示したようなイメージだ。Field型の値は変化していく「状態」だけど、Image型の値は変化しない「値」と考える。

STモナド

Field型の値は変化する。つまり、Field型の値を変化させる処理はIOモナドのなかでしか使えない。でも、もしField型の値が特定のスコープのなかで生成されて、そのスコープの外には持ち出せないとしたら、そのスコープを外から見れば状態変化のない純粋な処理に見える。そういう考えかたを仕組みとして用意したものがSTモナドだ。STモナドのなかでのField型の値を利用を試してみよう。

モジュールControl.Monad.STとControl.Monad.ST.Unsafeが必要だ。

src/Human.hsc

...
{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}

module Human where

import Foreign.Ptr
import Foreign.ForeignPtr hiding (newForeignPtr)
import Foreign.Concurrent
import Foreign.C.Types
import Foreign.C.Enum
import Control.Monad.ST
import Control.Monad.ST.Unsafe
import Control.Exception
import Data.Word

import Human.Exception

#include <human.h>

...

動作fieldNewStと関数fieldPutHumanStとfieldGetImageStとを定義する。

src/Human.hsc

fieldNewSt :: ST s (Field s)
fieldNewSt = unsafeIOToST fieldNewRaw

fieldPutHumanSt :: Field s -> CInt -> CInt -> ST s ()
fieldPutHumanSt f x y = unsafeIOToST $ fieldPutHumanRaw f x y

fieldGetImageSt :: Field s -> ST s Image
fieldGetImageSt f = unsafeIOToST $ fieldGetImageRaw f

モジュールTryHumanで純粋なImage型の値を定義してみる。言語拡張BlockArgumentsを使う。また、モジュールControl.Monad.STとHumanとを導入する。

src/TryHuman.hsc

{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE ScopedTypeVariables, AllowAmbiguousTypes #-}
{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}

module TryHuman where

import Control.MOnad.ST
import Control.Exception

import Human

...

Image型の値image1を定義してみる。

src/TryHuman.hsc

image1 :: Image
image1 = runST do
	f <- fieldNewSt
	fieldPutHumanSt f 30 10
	fieldGetImageSt f

ビルドして試してみる。

% stack build
% stack ghci
> imageDraw image1
...(「人間」が表示される)...

IOモナドとSTモナドをまとめる

ここまでの話ではField型の値をあつかう処理はIOモナド用とSTモナド用とを別々に用意しなければならない。パッケージprimitiveで定義されている型クラスPrimMonadを使えば両方をまとめて定義することができる。型クラスPrimMonadのメンバ型としてPrimStateが定義されている。モナドIOとモナドSTとは両方とも、このクラスのインスタンスであり、つぎのようになっている。

type PrimState IO = RealWorld
type PrimState (ST s) = s

型クラスPrimMonadを使ってFieldをあつかう処理のIO版とST版とをまとめてみよう。まずは、パッケージprimitiveをpackage.yamlに追加する。

package.yaml

...

dependencies:
- base >= 4.7 && < 5
- primitive
- exception-hierarchy
- c-enum

...

モジュールControl.Monad.Primitiveを導入する。

src/Human.hsc

...
import Foreign.C.Enum
import Control.Monad.Primitive
import Control.Monad.ST
import Control.Monad.ST.Unsafe
...

動作fieldNewと関数fieldClear, fieldPutHuman, fieldGetImageとを定義する。

src/Human.hsc

fieldNew :: PrimMonad m => m (Field (PrimState m))
fieldNew = unsafeIOToPrim fieldNewRaw

fieldClear :: PrimMonad m => Field (PrimState m) -> m ()
fieldClear = unsafeIOToPrim . fieldClearRaw

fieldPutHuman :: PrimMonad m => Field (PrimState m) -> CInt -> CInt -> m ()
fieldPutHuman f x y = unsafeIOToPrim $ fieldPutHumanRaw f x y

fieldGetImage :: PrimMonad m => Field (PrimState m) -> m Image
fieldGetImage = unsafeIOToPrim . fieldGetImageRaw

関数fieldDrawはIOのみに定義できる。

src/Human.hsc

fieldDraw :: Field RealWorld -> IO ()
fieldDraw = fieldDrawRaw

ビルドして試してみよう。

% stack build
% stack ghci
> f <- fieldNew
> fieldPutHuman f 30 10
> fieldDraw f
...(「人間」が表示される)...
> :set -XBlockArguments
> :module + Control.Monad.ST
> img = runST do f <- fieldNew; fieldPutHuman f 30 10; fieldGetImage f
> imageDraw img
...(「人間」が表示される)...

構造体

「『人間の形』が一種類しかないんじゃつまらない」と思ったとする。左右の手を上下させることができて、さらに頭の大きさを変えられたら(たぶんすこしは)おもしろいんじゃないかな、と。

...........................
....\o......\o/......O.....
.....A\......A....../A\....
..../.\...../.\...../.\....
...........................

そういう「いろいろな形の人間」を表示できるようにしよう。まずは必要な列形体と構造形とをinclude/human.hに定義する。

include/human.h

typedef enum { HM_SMALL_HEAD, HM_LARGE_HEAD } HmHead;
typedef enum { HM_DOWN_ARM, HM_UP_ARM } HmArm;
typedef struct { HmHead head_size; HmArm left_arm; HmArm right_arm; } HmHuman;

「頭の大きさ」を表す列挙型HmHeadと、「腕の上下」を表す列挙型HmArmと、それらを使って「人間の形」を表現する構造体HmHumanを定義した。この構造体HmHumanを引数としてとり、「色々な形の人間」をフィールドに配置する関数hm_field_put_various_humanを定義する。まずは、頭の大きさによって使う文字を選ぶ関数select_headと、腕が上か下かによって動作を変える、左右の「腕を配置する」関数put_left_arm, put_right_armとを定義する。

csrc/human.c

char
select_head(HmHuman *hm)
{
	switch (hm->head_size) {
		case HM_SMALL_HEAD: return 'o';
		case HM_LARGE_HEAD: return 'O';
		default: return '.'; }
}

void
put_left_arm(HmField f, HmHuman *hm, int x, int y)
{
	switch (hm->left_arm) {
		case HM_DOWN_ARM: hm_field_put_char(f, x, y + 1, '/'); return;
		case HM_UP_ARM: hm_field_put_char(f, x, y, '\\'); return; }
}

void
put_right_arm(HmField f, HmHuman *hm, int x, int y)
{
	switch (hm->right_arm) {
		case HM_DOWN_ARM:
			hm_field_put_char(f, x + 2, y + 1, '\\'); return;
		case HM_UP_ARM: hm_field_put_char(f, x + 2, y, '/'); return; }
}

それぞれswitch文で「選ぶ文字」や「腕を配置する動作」を選んでいる。これらを使って「いろいろな形の人間」を配置する関数を定義する。

csrc/human.c

HmPutHumanResult
hm_field_put_various_human(HmField f, HmHuman *hm, int x, int y)
{
	hm_field_put_char(f, x + 1, y, select_head(hm));
	put_left_arm(f, hm, x, y);
	put_right_arm(f, hm, x, y);
	hm_field_put_char(f, x + 1, y + 1, 'A');
	hm_field_put_char(f, x, y + 2, '/');
	hm_field_put_char(f, x + 2, y + 2, '\\');
	return hm_check_inside(x, y);
}

この関数をHaskell側から使えるようにしていこう。まずは構造体をHaskell側で生成できるようにする。これはパッケージc-structのForeign.C.Struct.structを使うと簡潔に書くことができる。パッケージc-structを設定ファイルpackage.yamlに追加する。

package.yaml

...
- exception-hierarchy
- c-enum
- c-struct

...

言語拡張TupleSections, GeneralizedNewtypeDeriving, ViewPatternsを使う。

src/Human.hsc

{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE BlockArguments, LambdaCase, TupleSections #-}
{-# LANGUAGE PatternSynonyms, ViewPatterns #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

module Human where

...

モジュールForeign.C.Structを導入する。またForeign.Storableも必要になる。

src/Human.hsc

...
import Foreign.Concurrent
import Foreign.Storable
import Foreign.C.Types
import Foreign.C.Enum
import Foreign.C.Struct
import Control.Monad.Primitive
...

列挙型HmHead, HmArmをHaskell側から使えるようにする。

src/Human.hsc

enum "Head" ''#{type HmHead} [''Show, ''Read, ''Storable] [
	("SmallHead", #{const HM_SMALL_HEAD}),
	("LargeHead", #{const HM_LARGE_HEAD}) ]

enum "Arm" ''#{type HmArm} [''Show, ''Read, ''Storable] [
	("DownArm", #{const HM_DOWN_ARM}), ("UpArm", #{const HM_UP_ARM}) ]

これらをメンバーとして持つデータ型Humanを定義する。

src/Human.hsc

struct "Human" #{size HmHuman}
	[	("headSize", ''Head, [| #{peek HmHuman, head_size} |],
			[| #{poke HmHuman, head_size} |]),
		("leftArm", ''Arm, [| #{peek HmHuman, left_arm} |],
			[| #{poke HmHuman, left_arm} |]),
		("rightArm", ''Arm, [| #{peek HmHuman, right_arm} |],
			[| #{poke HmHuman, right_arm} |]) ]
	[''Show, ''Read]

関数structの書式はつぎのようになる。

struct データ型の名前 記憶領域における大きさ
	メンバーの定義のリスト
	自動でインスタンスにする型のリスト

で、「メンバーの定義」はつぎのようになる。

(メンバーの名前, メンバーの型, メンバーの値の取り出しの処理,
	メンバーの値の書き込みの処理)

#{size Foo}はhsc2hsで処理されて型Fooのサイズに展開される。#{peek Foo, bar}は構造体Fooからの領域barの値の取り出しの処理に、#{poke Foo, bar}は構造体Fooの領域barへの書き込みの処理に、それぞれ展開される。

データ型Humanはつぎのように定義されている。

newtype Human = Human_ (ForeignPtr Human)

しかし、「あたかも」つぎのように定義されている「かのように」使える。

data Human = Human { headSize :: Head, leftArm :: Arm, rightArm :: Arm }

ビルドして試してみる。

% stack build
% stack ghci
> Human SmallHead DownArm UpArm
Human {headSize = SmalHead, leftArm = DownArm, rightArm = UpArm}
> Human_ fh = it
> print fh
0x0000000001fcb120
> :type fh
fh :: GHC.ForeignPtr.ForeignPtr Human

これで、「いろいろな形の人間」を表示できるようになる。Haskellの関数fieldPutVariousHumanを定義する。

src/Human.hsc

foreign import ccall "hm_field_put_various_human"
	c_hm_field_put_various_human ::
	Ptr (Field s) -> Ptr Human -> CInt -> CInt -> IO PutHumanResult

fieldPutVariousHumanRaw :: Field s -> Human -> CInt -> CInt -> IO ()
fieldPutVariousHumanRaw (Field ff) (Human_ fhm) x y =
	withForeignPtr ff \pf -> withForeignPtr fhm \phm ->
		c_hm_field_put_various_human pf phm x y >>= \case
			PutHumanResultSuccess -> pure ()
			PutHumanResultPartial -> throw PutHumanPartialError
			PutHumanResultOffscreen -> throw PutHumanOffscreenError
			PUtHumanResult n -> throw $ PutHumanUnknownError n

fieldPutVariousHuman ::
	PrimMonad m => Field (PrimState m) -> Human -> CInt -> CInt -> m ()
fieldPutVariousHuman f hm x y =
	unsafeIOToPrim $ fieldPutVariousHumanRaw f hm x y

Human型の値をHuman_ fhmにマッチさせることでForeignPtr Human型の値fhmを取り出して、そこから関数withForeignPtrでポインタを取り出して関数c_hm_field_put_various_humanに第2引数としてあたえている。それ以外については概出の話を組み合わせただけだ。ビルドして試してみる。

% stack build
% stack ghci
> f <- fieldNew
> fieldPutVariousHuman f (Human LargeHead UpArm UpArm) 30 10
> fieldDraw f
...(フィールドのなかに、つぎのような人間が表示される)...
........................................................
........................................................
.....\O/................................................
......A.................................................
...../.\................................................
........................................................

C言語の側で構造体を更新する

「C言語の構造体をHaskellのデータ型で表現できました(パチパチ)」というところまでは良かったのだけど、もしもC言語の関数が構造体の領域への代入によって構造体の内容を変化させたとすると、中身が変わるはずのないHaskellの値(のように見せているもの)が変化してしまい、わけがわからなくなる。多少のオーバーヘッドが生じるが、Haskellのデータ型として利用する領域は変化させずに、コピーを生成したうえで、コピーのほうをいじるほうが安全だ。

よくあるライブラリの作りとして、構造体をコピーする関数を用意してあることがある。そのような「用意されている構造体をコピーする関数」を使って、C言語側で変化させる目的で作られた領域をHaskell側から使うための型や関数を用意してくれる道具がモジュールForeign.C.Structから公開されている。

まずは、C言語側に構造体HmHumanをコピーする関数と、その領域を解放する関数、それに構造体HmHumanを変化させる関数とを定義する。

csrc/human.c

HmHuman *
hm_human_copy(HmHuman *hm)
{
	HmHuman *dst = (HmHuman *)malloc(sizeof(HmHuman));
	dst->head_size = hm->head_size;
	dst->left_arm = hm->left_arm;
	dst->right_arm = hm->right_arm;
	return dst;
}

void hm_human_destroy(HmHuman *hm) { free(hm); }

void
hm_human_flip_head(HmHuman *hm)
{
	hm->head_size =
		hm->head_size == HM_SMALL_HEAD ? HM_LARGE_HEAD : HM_SMALL_HEAD;
}

void
hm_human_flip_left_arm(HmHuman *hm)
{
	hm->left_arm =
		hm->left_arm = HM_DOWN_ARM ? HM_UP_ARM : HM_DOWN_ARM;
}

void
hm_human_flip_right_arm(HmHuman *hm)
{
	hm->right_arm =
		hm->right_arm = HM_DOWN_ARM ? HM_UP_ARM : HM_DOWN_ARM;
}

関数hm_human_copyはメモリ領域を確保したうえで、引数の構造体のそれぞれの要素をコピーしている。関数hm_human_destroyはメモリ領域を解放している。残りの3つの関数はそれぞれ頭の大きさ、左腕の上下、右腕の上下を切り換える関数だ。これらをHaskell側から使えるようにする。

src/Human.hsc

foreign import ccall "hm_human_copy"
	c_hm_human_copy :: Ptr Human -> IO (Ptr Human)

foreign import ccall "hm_human_destroy" c_hm_human_destroy :: Ptr Human -> IO ()

structPrim "Human" 'c_hm_human_copy 'c_hm_human_destroy [''Show]

関数structPrimはつぎのような書式になる。

structPrim もとのデータ型の名前 構造体をコピーする関数 構造体の領域を解放する関数
	diriveする型クラスのリスト

関数structPrimによって生成されたコードが展開されることで、つぎのような関数が定義される。

humanFreeze :: PrimMonad m => HumanPrim (PrimState m) -> m Human
humanThaw :: PrimMonad m => Human -> m (HumanPrim (PrimState m))
humanCopy ::
	PrimMonad m => HumanPrim (PrimState m) -> m (HumanPrim (PrimState m))

関数humanFreezeはIOモナドまたはSTモナドの文脈下で「変化しうる状態」を「変化しない値」に固める。関数humanThawは「変化しない値」から「変化する状態」を生成する。関数humanCopyは「変化する状態」から新しいコピーである「変化する状態」を作る。

状態HumanPrimを変化させる関数humanFlipHead, humanFlipLeftArm, humanFlipRightArmを定義する。

src/Human.hsc

foreign import ccall "hm_human_flip_head"
	c_hm_human_flip_head :: Ptr Human -> IO ()

foreign import ccall "hm_human_flip_left_arm"
	c_hm_human_flip_left_arm :: Ptr Human -> IO ()

foreign import ccall "hm_human_flip_right_arm"
	c_hm_human_flip_right_arm :: Ptr Human -> IO ()

humanFlipHead, humanFlipLeftArm, humanFlipRightArm ::
	PrimMonad m => HumanPrim (PrimState m) -> m ()
humanFlipHead (HumanPrim fhm) =
	unsafeIOToPrim $ withForeignPtr fhm c_hm_human_flip_head

humanFlipLeftArm (HumanPrim fhm) =
	unsafeIOToPrim $ withForeignPtr fhm c_hm_human_flip_left_arm

humanFlipRightArm (HumanPrim fhm) =
	unsafeIOToPrim $ withForeignPtr fhm c_hm_human_flip_right_arm

ビルドして試してみる。

% stack build
% stack ghci
> f <- fieldNew
> hm0 = Human SmallHead DownArm DownArm
> hmp <- humanThaw hm0
> humanFlipHead hmp
> hm1 <- humanFreeze hmp
> fieldPutVariousHuman f hm1 10 15
> humanFlipLeftArm hmp
> hm2 <- humanFreeze hmp
> fieldPutVariousHuman f hm2 20 15
> fieldDraw f
...(つぎのような2人の人間が表示される)...
.........................................
.........................................
.....O..........\O.......................
..../A\..........A\......................
..../.\........./.\......................
.........................................

`ForeignPtr`によるGCを利用するやりかたが適切でない場合

自分が操作できる「人間」を「主人公」と呼び、「主人公」が踏んでいく「人間」を「敵」と呼ぶことにしよう。「主人公」がジャンプしたり「敵」が動いたりするためには、一定時間ごとに処理を行う必要がある。呼び出すと一定時間待ってから、Tickイベントを返す関数を使う。また、「主人公」を操作するためにキーボードからの入力を受けとるためのイベントも必要だ。Tickイベントを返す関数を定義していく。

自前でのメモリ割り当て

ライブラリによっては効率などの理由で一般的なmalloc()とfree()ではなく、自前でメモリの確保や解放を実装している場合がある。そのような場合に生じる問題を再現するために、自前でのメモリの確保と解放を行う関数を定義してみよう。

仕様

静的に確保された1024バイトの領域から引数で指定したサイズの未使用の領域のアドレスを返す関数allocate_memoryと、その領域を解放する関数free_memoryとを用意する。領域を確保できないときはNULLを返す。

アルゴリズム

領域の確保は2の累乗のサイズで行う。また、領域の大きさの最小値は8バイトとする。つまり、確保される領域のサイズは8, 16, 32, 64, 128となる。

実際の領域とは別に「領域が使われているかどうか」という情報を格納する木構造の領域を用意する。木は2分木であり、木の末端がそれぞれの8バイトの領域を表す。木の階層をひとつ上がるごとに2倍の領域を表現する。それぞれのノードに、そのノード以下の使われている領域のバイト数の合計と、そのノードに対応する領域が使われているかどうかの情報が格納される。

たとえば、つぎのような場合を考える。

24, f
  |
  +--------------------------------------+
  |                                      |
8, f                                   16, f
  |                                      |
  +------------------+                   +----------------+
  |                  |                   |                |
0, f                8, f                16, t             0, f
  |                  |                   |                |
  +---------+        +---------+         +--------+       +-------+
  |         |        |         |         |        |       |       |
0, f       0, f     8, t      0, f      0, f    0, f    0, f     0, f

t: true
f: false

24, fのノードを階層0とする。また、先頭のアドレスを0とする。上の図では、階層3の左から2番目のノードがtrueなので、2x8でアドレス16の領域が8バイトぶん確保済みとなる。階層2の左から2番目のノードがtrueなので2x16でアドレス32の領域が16バイトぶん確保されていることになる。trueとなっているノード以下のノードは参照する必要がないので、デフォルトの値のままになっている。

メモリの確保は木の上から確保されたメモリのすくないほうの枝をたどっていき、確保したいサイズと合った階層に達したところのノードをtrueとする。メモリの解放は一番下の階層からはじめて、trueのノードがあるまで階層を上にたどり、そのtrueをfalseにする。メモリの確保、解放のどちらの際にも、「確保されたメモリのサイズの合計」もその都度修正していく。

メモリの使用状態を表現する木構造

配列で2分木を表現するために、インデックスについて「左の子」「右の子」「親」にそれぞれ移動するマクロを定義する。また、それぞれの情報を格納する構造体を定義する。

include/mem_alloc_local.h

#ifndef _MEM_ALLOC_LOCAL_H
#define _MEM_ALLOC_LOCAL_H

#include <stdbool.h>

#define TREE_SIZE(h)	((1 << h) - 1)

#define LEFT_CHILD(i)	((i) * 2 + 1)
#define RIGHT_CHILD(i)	((i) * 2 + 2)
#define PARENT(i)	(((i) + 1) / 2 - 1)

typedef struct { bool allocated; int used; } AllocInfo;
extern AllocInfo alloc_info[];

#endif

TREE_SIZEは「木の高さ」から必要なメモリの量を計算するマクロだ。LEFT_CHILDとRIGHT_CHILDあるノードを表すインデックスから、それぞれ左の子と右の子とを表すインデックスを返すマクロであり、PARENTは同様に親のインデックスを返す。型AllocInfoは、それぞれの「メモリの使用状況」を表すノードに格納される値の型だ。externで変数alloc_infoを宣言することで、コード内で定義されるメモリの使用状況を表現する情報にアクセスできるようにしている。

メモリの確保と解放

メモリの確保

確保する領域のサイズと現在の木構造内での深さと現在の木構造を表す配列内でのインデックスなどの情報を引数にして、領域の確保の状況を更新して、確保できたメモリ内でのインデックスを返す関数を定義する。

まずは、package.yamlに新しいC言語のソースファイルcsrc/mem_alloc.cとcsrc/mem_alloc_draw.cとを追加する。

package.yaml

...

library:
  source-dirs: src
  include-dirs: include
  c-sources:
  - csrc/human.c
  - csrc/mem_alloc.c
  - csrc/mem_alloc_draw.c

...

関数get_indexを定義する。

csrc/mem_alloc.c

#include <stdlib.h>
#include <stdbool.h>
#include <stdint.h>
#include <mem_alloc_local.h>

AllocInfo alloc_info[TREE_SIZE(8)];
uint64_t memory[1 << 7];

int
get_index(int sz, int dp, int ii, int mi)
{
	AllocInfo *inf = &(alloc_info[ii]);
	AllocInfo *l = &(alloc_info[LEFT_CHILD(ii)]);
	AllocInfo *r = &(alloc_info[RIGHT_CHILD(ii)]);

	if (inf->used + sz > (1024 >> dp)) {
		while (ii) { ii = PARENT(ii); alloc_info[ii].used -= sz; }
		return -1; }

	inf->used += sz;
	if (sz << dp == 1024) { inf->allocated = true; return mi; }
	else if (l->used <= r->used) get_index(sz, dp + 1, LEFT_CHILD(ii), mi);
	else get_index(sz, dp + 1, RIGHT_CHILD(ii), mi + (64 >> dp));
}

引数szは確保したい領域のサイズだ。単位はバイトで最低8バイトで2の累乗であることが前提となっている。引数dpは木構造内での深さであり、引数iiは木構造内でのインデックス。引数miは返り値である「メモリ領域内」でのインデックスである。関数のはじめの3行では、それぞれ「このノードがもつ情報」「左の子ノードがもつ情報」「右の子ノードがもつ情報」へのポインタを変数inf, l, rとして定義している。

つぎのif文では、領域が確保できなかった場合の処理だ。inf->used + szはそのノードに対応する領域について「使われているバイト数」と「確保したいバイト数」の和であり、1024 >> dpはそのノードに対応する領域のサイズを示す。while文では現在のノードの祖先の「使用済みのバイト数」について、これまで「確保済み」にしてきたバイト数ぶんだけ減算することで、もとにもどしている。領域確保の失敗は-1を返り値とすることにより示す。

そのノードに対応する領域に確保したいバイト数以上の残りがある場合に、残りの処理に進む。使用済みのバイト数に確保したいバイト数を加算する。そのつぎに、確保したいバイト数とそのノードに対応する領域のバイト数とを比較して、等しければそのノードに使用済みのフラグを立てて、メモリのインデックスを返す。そうでなかったときは、左右のノードの「使用済み」のバイト数を比較して、すくないほうについて再帰的に関数get_indexを適用する。

関数get_indexを使えばメモリの確保関数は簡単に定義できる。

csrc/mem_alloc.c

int normalize(int sz)
{
	if (sz <= 8) return 8;

	int rslt = 1, tmp = sz - 1;
	while (tmp) { tmp >>= 1; rslt <<= 1; }
	return rslt;
}

void *
allocate_memory(int sz)
{
	int i = get_index(normalize(sz), 0, 0, 0);
	if (i < 0) return NULL; else return memory + i;
}

関数allocate_memoryは、関数normalizeで確保するサイズを8以上の2の累乗の値に変換した値を関数get_indexにわたす。返り値が負(-1)ならばNULLを返し、そうでないなら、返されたインデックスをuint64_tの配列memory内のアドレスに変換して返す。ここまでの関数を試すためにメモリの確保の状態を可視化する関数を定義して試してみよう。

csrc/mem_alloc_draw.c

#include <stdio.h>
#include <mem_alloc_local.h>

void
put_used(int i, int sz, char *buf)
{
	if (alloc_info[i].allocated) for (int j; j < sz; j++) buf[j] = '*';
	else if (alloc_info[i].used == 0) /* DO NOTHING */;
	else {	int hf = sz >> 1;
		put_used(LEFT_CHILD(i), hf, buf);
		put_used(RIGHT_CHILD(i), hf, buf + hf); }
}

void
draw_memory(void)
{
	char buf[(1 << 7) + 1];
	int i;
	for (i = 0; i < (1 << 7); i++) buf[i] = '.';
	buf[i] = '\0';
	put_used(0, 1 << 7, buf);
	printf("%.64s\n", buf);
	printf("%s\n", buf + 64);
}

関数draw_memoryは、いろいろと準備したうえで関数put_usedを呼ぶ。関数put_usedはノードを上からたどっていき、ノードに対応する領域が確保済であるかどうかを調べ、確保済みであればそれに対応する表示領域に'*'を書き込む。

Haskell側で使えるようにして試してみる。

src/TryMemory.hs

{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}

module TryMemory where

import Foreign.Ptr
import Foreign.C.Types

foreign import ccall "allocate_memory" allocateMemory :: CInt -> IO (Ptr a)
foreign import ccall "draw_memory" drawMemory :: IO ()

ビルドして試してみる。

% stack build
% stack ghci
> drawMemory
................................................................
................................................................
> allocateMemory 15
0x00007f1ec9ddcba0
> drawMemory
**..............................................................
................................................................
> allocateMemory 100
0x00007f1ec9ddcda0
> drawMemory
**..............................................................
****************................................................
> allocateMemory 150
0x00007f1ec9ddcca0
> drawMemory
**..............................********************************
****************................................................
> allocateMemory 180
0x00007f1ec9ddcea0
> drawMemory
**..............................********************************
****************................********************************
> allocateMemory 180
0x0000000000000000
> drawMemory
**..............................********************************
****************................********************************
> allocateMemory 30
0x00007f1ec9ddcc20
> drawMemory
**..............****............********************************
****************................********************************

メモリの解放

メモリを解放する関数を定義する。

csrc/mem_alloc.c

int
free_memory(void *addr)
{
	int mi = (uint64_t *)addr - memory;
	if (mi < 0 || 127 < mi) return -1;

	int i, sz, size; bool flag;
	for (i = mi + 127, sz = 8, flag = false; i; i = PARENT(i), sz <<= 1) {
		if (alloc_info[i].allocated) {
			alloc_info[i].allocated = false;
			flag = true; size = sz; }
		if (flag )alloc_info[i].used -= size; }
	if (flag) alloc_info[i].used -= size;
	return 0;
}

変数miは確保されたメモリ領域内でのインデックスだ。それに127を足すことで、メモリのアロケーションの状態を示す木alloc_infoの末端での対応する位置へのインデックスになる。対応する位置について親ノードへとたどっていき、allocatedがtrueであるノードをみつけたら、それをfalseにしたうえで変数flagをtrueにする。そのあとは、親ノードへとたどりながら、解放されたメモリ領域の大きさぶんusedの値を減算していく。

Haskell側でこれにアクセスするために関数freeMemoryを定義する。

src/TryMemory.hs

...

foreign import ccall "allocate_memory" allocateMemory :: CInt -> IO (Ptr a)
foreign import ccall "free_memory" freeMemory :: Ptr a -> IO CInt

foreign import ccall "draw_memory" drawMemory :: IO ()

ビルドして試してみる。

% stack build
% stack ghci
> drawMemory
................................................................
................................................................
> allocateMemory 15
0x00007f1ce046ec40
> drawMemory
**..............................................................
................................................................
> allocateMemory 15
0x00007f1ce046ee40
> m1 <- allocateMemory 15
> drawMemory
**..............................**..............................
**..............................................................
> allocateMemory 100
0x00007f1ce046ef40
> drawMemory
**..............................**..............................
**..............................****************................
> m2 <- allocateMemory 100
> drawMemory
**..............******************..............................
**..............................****************................
> allocateMemory 100
0x00007f1ce046eec0
> drawMemory
**..............******************..............................
**..............********************************................
> freeMemory m2
0
> drawMemory
**..............................**..............................
**..............********************************................
> freeMemory m1
0
> drawMemory
**..............................................................
**..............********************************................

関数allocate_memoryとfree_memoryとをcsrc/human.cで使うので、ヘッダファイルを作成しておく。

include/mem_alloc.h

#ifndef _MEM_ALLOC_H
#define _MEM_ALLOC_H

void *allocate_memory(int sz);
int free_memory(void *addr);

#endif

イベントの定義

Tickイベントを返す関数を定義していく。まずはイベントを表すデータ構造の定義だ。

include/human.h

typedef enum { HM_EVENT_TYPE_TICK, HM_EVENT_TYPE_CHAR } HmEventType;

typedef struct { HmEventType event_type; } HmEventAny;
typedef struct { HmEventType event_type; int times; } HmEventTick;
typedef struct { HmEventType event_type; char character; } HmEventChar;

typdef union {
	HmEventAny event_any; HmEventTick event_tick; HmEventChar event_char; }
	HmEvent;

共用体HmEventは構造体HmEventAnyまたはHmEventTickまたはHmEventCharのどれかである。構造体HmEventTickはTickイベントであり、領域timesはそのTickイベントが何番目であるかを示す値が格納される。また、構造体HmEventAnyは、すべてのイベントに定義される「イベントの種類」を取り出すのに使われる。構造体HmEventCharは、あとでキーボードの入力を受けとるのに使う。

`Tick`イベントの生成

まずはmem_alloc.hをインクルードする。

csrc/human.c

#include <stdlib.h>
#include <stdio.h>
#include <stdbool.h>
#include <string.h>
#include <sys/select.h>

#include <human.h>
#include <mem_alloc.h>

...

Tickイベントを生成する。現在何回目のTickかを記録する関数hm_tickを定義し、領域を確保しTickイベントの中身をうめる関数hm_make_event_tickを定義する。それらを利用して、0.01秒スリープしたあとにTickイベントを返す関数hm_get_event_only_tickを定義する。

csrc/human.c

int
hm_tick(void)
{
	static int tms = 0;
	return tms++;
}

HmEvent *
hm_make_event_tick(void)
{
	int t = hm_tick();
	HmEvent *ev = allocate_memory(sizeof(HmEvent));
	if (ev != NULL) {
		ev->event_tick.event_type = HM_EVENT_TYPE_TICK;
		ev->event_tick.times = t; }
	return ev;
}

HmEvent *
hm_get_event_only_tick(void)
{
	struct timeval tv;
	tv.tv_sec = 0; tv.tv_usec = 10000;
	select(0, NULL, NULL, NULL, &tv);
	return hm_make_event_tick();
}

イベント用の領域を解放する関数を定義する。

csrc/human.c

void hm_event_destroy(HmEvent *ev) { free_memory(ev); }

ForeignPtrによりHaskellのGCを利用してみる

src/Human/EventGc.hscを用意する。

src/Human/EventGc.hsc

{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE BlockArguments, TupleSections #-}
{-# LANGUAGE PatternSynonyms, ViewPatterns #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}

module Human.EventGc where

import Foreign.Ptr
import Foreign.ForeignPtr hiding (newForeignPtr)
import Foreign.Concurrent
import Foreign.Storable
import Foreign.C.Types
import Foreign.C.Enum
import Foreign.C.Struct
import Data.Word
import System.IO.Unsafe

#include <human.h>

Haskell側でイベントを表す型Eventと関数getEventを定義する。

src/Human/EventGc.hsc

data Event = Event (ForeignPtr Event) deriving Show

foreign import ccall "hm_get_event_only_tick" c_hm_get_event :: IO (Ptr Event)
foreign import ccall "hm_event_destroy" c_hm_event_destroy :: Ptr Event -> IO ()

getEventGc :: IO Event
getEventGc = Event <$> do
	pe <- c_hm_get_event
	newForeignPtr pe $ c_hm_event_destroy pe

Tickイベントを表現するテータ型EventTickを用意する。またEvent型の値からEventTick型の値を取り出すパターンEventEventTickGcを定義する。

src/Human/EventGc.hsc

enum "EventType" ''#{type HmEventType} [''Show, ''Storable] [
	("EventTypeTick", #{const HM_EVENT_TYPE_TICK}) ]

struct "EventTick" #{size HmEventTick}
	[	("eventType", ''(), [| const $ pure () |],
			[| \p _ -> #{poke HmEventTick, event_type}
				p EventTypeTick |]),
		("times", ''CInt, [| #{peek HmEventTick, times} |],
			[| #{poke HmEventTick, times} |]) ]
	[''Show]

getEventType :: Event -> EventType
getEventType (Event fev) =
	unsafePerformIO $ withForeignPtr fev #{peek HmEventAny, event_type}

getEventTick :: Event -> (Eventtype, EventTick)
getEventTick ev@(Event fev) = (getEventType ev, EventTick_ $ castForeignPtr fev)

pattern EventEventTickGc :: EventTick -> Event
pattern EventEventTickGc evt <- (getEventTick -> (EventTypeTick, evt)) where
	EventEventTickGc (EventTick_ fev) = Event $ castForeignPtr fev

ビルドして試してみる。

% stack build
% stack ghci
> e <- getEventGc
> EventEventTickGc et = e
> et
EventTick {eventTickEventType = (), eventTickEventTimes = 0}
> :module + Control.Monad
> replicateM_ 10 getEventGc
> e <- getEventGc
> EventEventTickGc et = e
EventTick {eventTickEventType = (), eventTickEventTimes = 11}

連続してイベントを取得してみる。app/try-event-gc.hsを作成する。package.yamlのexecutablesのMain.hsのところをコピーして、zenn-use-c-lib-testとMain.hsを書き換える。

package.yaml

...

executables:
  zenn-use-c-lib-exe:
    main:               Main.hs
    source-dirs:        app
    ghc-options:
    - -threaded
    - -rtsopts
    - -with-rtsopts=-N
    dependencies:
    - zenn-use-c-lib
  try-event-gc:
    main:               try-event-gc.hs
    source-dirs:        app
    ghc-options:
    - -threaded
    - -rtsopts
    - -with-rtsopts=-N
    dependencies:
    - zenn-use-c-lib

...

10回連続してイベントを取得して表示する動作を20回くりかえしてみる。

app/try-event-gc.hs

{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}

module Main where

import Control.Monad
import Human.EventGc

main :: IO ()
main = replicateM_ 20 $ print =<< replicateM 10 getEventGc

ビルドして試してみる。

% stack build
% stack exec try-event-gc
[Event 0x000000000002e440,Event 0x00000000002e4640,...]
...
[Event 0x0000000000000000,Event 0x0000000000000000,...]

最後のほうは0x0000000000000000つまりNULLポインタになっている。これはイベント用の領域が独自の領域確保の仕組みを使っているからだ。独自の領域に空きがなくなってもHaskellはGCを走らせないので、領域が解放されることなく、領域の確保だけ進み空き領域が不足したということだ。

イベントが発生したら、その都度領域を解放するやりかた

解放済みの領域にアクセスさせない仕組み

つまり、一般的なmallocやfreeではないやりかたで領域の確保や解放を実装している関数についてはForeignPtrでHaskellのGCを利用するやりかたは、うまく動かないということだ。こういう場合、つぎのようなやりかたができる。

withFoo :: (Foo -> IO a) -> IO a
withFoo fun = do
	foo <- fooNew
	fun foo
	fooDestroy foo

ただし、これだと問題が残る。たとえば、つぎのようなことができてしまう。

runBad :: IO ()
runBad = do
	q <- withFoo \p -> do
		doSomething1 p
		pure p
	doSomething2 q

関数withFooのIO aの型変数aを型Fooにすることができるので、すでに解放された領域へのアクセスを許してまうということだ。そうしないために、型変数のスコープを利用する。

withFoo2 :: (forall s . Foo s -> IO a) -> IO a
withFoo2 fun = do
	...

このように型を定義すると型変数sが丸括弧内のスコープから外に出られないため、型変数aを型Foo sにすることができないので、解放済みの領域へのアクセスを防ぐことができる。この考えかたで、スコープを外れるときに領域が解放されるような形でイベントを取得する関数を定義していく。

イベントの取得

package.yamlの依存するパッケージにstmを追加する。

package.yaml

...

dependencies:
- base >= 4.7 && < 5
- stm
- primitive
- exception-hierarchy
- c-enum
- c-struct

...

ソースファイルsrc/Human/Event.hscを用意して、言語拡張や導入するモジュールを記述する。

src/Human/Event.hsc

{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE BlockArguments, TupleSections #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE PatternSynonyms, ViewPatterns #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}

module Human.Event where

import Foreign.Ptr
import Foreign.ForeignPtr hiding (newForeignPtr)
import Foreign.Concurrent
import Foreign.Marshal
import Foreign.Storable
import Foreign.C.Types
import Foreign.C.Enum
import Foreign.C.Struct
import Control.Monad
import Control.Concurrent
import Control.Concurrent.STM
import Control.Exception
import Data.Bool
import Data.Word
import System.IO
import System.IO.Unsafe

#include <human.h>

新しくイベントを表す型Event sとそれを取得する関数withEventOnlyTickを定義する。

src/Human/Event.hsc

data Event s = Event (Ptr (Event s)) deriving Show

foreign import ccall "hm_get_event_only_tick"
	c_hm_get_event_only_tick :: IO (Ptr (Event s))

foreign import ccall "hm_event_destroy"
	c_hm_event_destroy :: Ptr (Event s) -> IO ()

withEventOnlyTick :: (forall s . Event s -> IO a) -> IO a
withEventOnlyTick f =
	bracket c_hm_get_event_only_tick c_hm_event_destroy (f . Event)

関数bracketはたとえ例外が起きたとしても、リソースの解放をするために使われる。書式はつぎのようになる。

bracket リソースを生成する リソースを解放する リソースを使う

ビルドして試してみる。

% stack build
% stack ghci
> withEventOnlyTick print
Event 0x00007f8a95075c40

`Tick`イベント

イベントの種類と、それを取得する関数を定義する。

src/Human/Event.hsc

enum "EventType" ''#{type HmEventType} [''Show, ''Storable] [
	("EventTypeTick", #{const HM_EVENT_TYPE_TICK}),
	("EventTypeChar", #{const HM_EVENT_TYPE_CHAR}) ]

eventType :: Event s -> EventType
eventType (Event pev) = unsafePerformIO $ #{peek HmEventAny, event_type} pev

ビルドして試してみる。

% stack build
% stack ghci
> withEventOnlyTick $ print . eventType
EventTypeTick

型EventTickを定義する。

src/Human/Event.hsc

struct "EventTick" #{size HmEventTick}
	[	("eventType", ''(), [| const $ pure () |],
			[| \p _ -> #{poke HmEventTick, event_type}
				p EventTypeTick |]),
		("times", ''CInt, [| #{peek HmEventTick, times} |],
			[| #{poke HmEventTick, times} |]) ]
	[''Show]

このように定義した型EventTickだと型引数sを持たないため、領域の解放後もアクセスできてしまうという問題がある。そのため、値をスコープ内にとじこめるために使う型Sealed sを定義する。

src/Human/Event.hsc

newtype Sealed s a = Sealed a deriving Show

Event s型の値からSealed s EventTick型の値を取り出すパターンEventEventTickを定義する。

src/Human/Event.hsc

getEventTick :: Event s -> (EventType, Sealed s EventTick)
getEventTick ev@(Event pev) =
	(eventType ev, Sealed . EventTick_ . noFinalizer $ castPtr pev)

noFinalizer :: Ptr a -> ForeignPtr a
noFinalizer = unsafePerformIO . (`newForeignPtr` pure ())

pattern EventEventTick :: Sealed s EventTick -> Event s
pattern EventEventTick evt <- (getEventTick -> (EventTypeTick, evt))

イベントの領域はwithEventOnlyTick内で解放されるので、finalizerは必要ない。なので、何もしないfinalizerをつけてForeignPtr型の値を作る。

Tickイベントから「回数」を取り出す関数を定義する。この値は整数値であり、領域の解放後にアクセスしても安全だ。

src/Human/Event.hsc

eventTickToTimes :: Sealed s EventTick -> CInt
eventTickToTimes (Sealed evt) = eventTickTimes evt

ビルドして試してみる。

% stack build
% stack ghci
> :set -XBlockArguments
> :{
| withEventOnlyTick \ev -> do
|   let EventEventTick evt = ev
|   print evt
|   return $ eventTickToTimes evt
:}
Sealed EventTick {eventTickEventType = (), eventTickTimes = 0}
0

Haskellの関数をC言語側にわたす

関数`withEvent`

「ゲーム」をするには、時間の経過だけではなく何らかのインプットが必要だ。文字入力を一文字ずつイベントにして返すようにしよう。C言語のライブラリとしては、一文字入力を取得する関数の関数ポインタを引数として取って、イベントを返すような形にする。

csrc/human.c

HmEvent *
hm_make_event_char(char c)
{
	HmEvent *ev = allocate_memory(sizeof(HmEvent));
	if (ev != NULL) {
		ev->event_char.event_type = HM_EVENT_TYPE_CHAR;
		ev->event_char.character = c; }
	return ev;
}

HmEvent *
hm_get_event(char (*get_char)())
{
	char c = get_char();
	if (c != '\0') return hm_make_event_char(c);

	struct timeval tv;
	tv.tv_sec = 0; tv.tv_usec = 10000;
	select(0, NULL, NULL, NULL, &tv);
	return hm_make_event_tick();
}

これをHaskell側で呼び出す関数はつぎのようになる。

src/Human/Event.hsc

foreign import ccall "hm_get_event"
	c_hm_get_event :: FunPtr (IO CChar) -> IO (Ptr (Event s))

C言語の関数ポインタはHaskellではFunPtr a型の値として表現される。このままではHaskellの動作や関数を、引数としてC言語の関数にわたすことはできない。そこでwrapperという「C言語側の関数」が用意されている。

src/Human/Event.hsc

foreign import ccall "wrapper"
	wrap_getCChar :: IO CChar -> IO (FunPtr (IO CChar))

このようにすることで、CChar型の値を返すHaskellの動作から、C言語の関数ポインタを生成することができる。ここで、関数ポインタとしてc_hm_get_eventの引数とするHaskell側の動作については、「入力がない場合に'\0'を返す」という処理のために「チャンネル」を使うことにする。関数hGetBufNonBlockingにつぎのような記述があったので。

NOTE: on Windows, this function does not work correctly; it behaves identically to hGetBuf

関数Control.Concurrent.STM.TChan.isEmptyTChanを使えば、ブロックすることなく「入力があったかどうか」を判定できる。

(「入力があったかどうか」をブロックなしに判定するのって実はけっこう難しいようで、MVarを利用したControl.Concurrent.Chan.isEmptyChanはブロックしてしまう動作が修正できずdeprecatedになったうえで、現在は削除されている)

src/Human/Event.hsc

withEvent :: TChan CChar -> (forall s . Event s -> IO a) -> IO a
withEvent ch f = bracket (c_hm_get_event =<< wrap_getCChar getc)
	c_hm_event_destroy (f . Event)
	where
	getc = atomically $ bool (readTChan ch) (pure 0) =<< isEmptyTChan ch

TChan CChar型のチャンネルを生成して、入力ハンドルからの値を送り続ける関数hGetAndPushCCharを定義する。

src/Human/Event.hsc

hGetAndPushCChar :: Handle -> IO (TChan CChar)
hGetAndPushCChar h = atomically newTChan >>= \ch ->
	ch <$ forkIO (forever $ getcs >>= mapM_ (atomically . writeTChan ch))
	where getcs = allocaBytes 64 \cstr -> do
		cnt <- hGetBufSome h cstr 64
		when (cnt == 0) $ error "EOF"
		peekArray cnt cstr

64バイトの領域を確保して、そこに関数hGetBufSomeでバイト列を書き込む。その領域を関数peekArrayでC言語のcharのリストにして返す。forkIOで別スレッドにしたうえで、永遠にそのcharをチャンネルに一文字ずつ送り込んでいる。試してみよう。実際にゲームをするときにはハンドルstdinを使うが、ここではテキストファイルを用意して、そこから読み込んでみる。

% stack build
% echo 'abc' > dummy.txt
% stack ghci
> :module + System.IO
> h <- openFile "dummy.txt" ReadMode
> ch <- hGetAndPushCChar h
<interactive>: EOF
CallStack (from HasCallStack):
  error, called at src/Human/Event.hsc:88:35 in main:Human.Event
> withEvent ch $ pure . eventType
EventTypeChar
> withEvent ch $ pure . eventType
EventTypeChar
> withEvent ch $ pure . eventType
EventTypeChar
> withEvent ch $ pure . eventType
EventTypeChar
> withEvent ch $ pure . eventType
EventTypeTick
> withEvent ch $ pure . eventType
EventTypeTick

関数hGetAndPushCCharを呼び出したときにエラーが生じる。これは、この関数がハンドルstdinなどの「終わりのないハンドル」を想定しているからだ。エラーが生じても'a', 'b', 'c', '\n'はちゃんとチャンネルに送られている。

文字入力イベント

文字入力イベントを表す型を定義してEvent s型の値からそれを取り出せるようにする。

src/Human/Event.hsc

struct "EventChar" #{size HmEventChar}
	[	("eventType", ''(), [| const $ pure () |],
			[| \p _ -> #{poke HmEventChar, event_type}
				p EventTypeChar |]),
		("character", ''CChar, [| #{peek HmEventChar, character} |],
			[| #{poke HmEventChar, character} |]) ]
	[''Show]

getEventChar :: Event s -> (EventType, Sealed s EventChar)
getEventChar ev@(Event pev) =
	(eventType ev, Sealed . EventChar_ . noFinalizer $ castPtr pev)

pattern EventEventChar :: Sealed s EventChar -> Event s
pattern EventEventChar evc <- (getEventChar -> (EventTypeChar, evc))

eventCharToCharacter :: Sealed s EventChar -> CChar
eventCharToCharacter (Sealed evc) = eventCharCharacter evc

Tickイベントの定義と同様に定義した。

% stack build
% stack ghci
> :set -XLambdaCase
> :module + System.IO
> h <- openFile "dummy.txt" ReadMode
> ch <- hGetAndPUshChar h
<interactive>: EOF
CallStack (from HasCallStack):
  error, called at src/Human/Event.hsc:88:35 in main:Human.Event
> :{
| f = \case
	EventEventTick evt -> Left $ eventTickToTimes evt
	EventEventChar evc -> Right $ eventCharToCharacter evc
> :}
> withEvent ch $ pure . f
Right 97
> withEvent ch $ pure . f
Right 98
> withEvent ch $ pure . f
Right 99
> withEvent ch $ pure . f
Right 10
> withEvent ch $ pure . f
Left 0
> withEvent ch $ pure . f
Left 1

C言語の関数ポインタからHaskellの関数を作る

% stack ghci
> f <- fieldNew
> fieldPUtHuman f 30 15
> fieldDraw f
.............................................
...............(「人間」が表示される)........
.............................................

ここまで作ってきた関数だと「人間」の背景は'.'でうめられる。これを'.'ではなく' 'にしたいとする。

csrc/human.c

void
hm_field_clear_bg_space(HmField f)
{
	for (int i = 0; i < FIELD_HEIGHT; i++) {
		int j;
		for (j = 0; j < FIELD_WIDTH; j++) f[i][j] = ' ';
		f[i][j] = '\0'; }

}

HmField
hm_field_new_bg_space(void)
{
	HmField f = (HmField)malloc(sizeof(HmFieldArray));
	hm_field_clear_bg_space(f);
	return f;
}

これらの背景が' 'である関数と'.'である関数とをブール値で切り換えられるようにする。

csrc/human.c

void
(*hm_field_clear_background(bool b)) (HmField)
{
	return b ? hm_field_clear : hm_field_clear_bg_space;
}

HmField
(*hm_field_new_background(bool b)) (void)
{
	return b ? hm_field_new : hm_field_new_bg_space;
}

これらは引数の真偽値によって、返す関数ポインタを選ぶ関数だ。これをHaskellから呼び出す。

src/Human.hsc

foreign import ccall "hm_field_new_background"
	c_hm_field_new_background :: #{type bool} -> FunPtr (IO (Ptr (Field s)))

foreign import ccall "hm_field_clear_background"
	c_hm_field_clear_background :: #{type bool} -> FunPtr (Ptr (Field s) -> IO ())

bool型の値をとって関数ポインタを返す関数だ。しかし、関数ポインタのままではHaskell側からは使えない。Haskellの関数を関数ポインタにするにはwrapperが用意されていた。おなじように関数ポインタからHaskellの関数や動作を取得するのに、「C言語の関数」であるdynamicが用意されている。

src/Human.hsc

foreign import ccall "dynamic"
	mkFieldNewBg :: FunPtr (IO (Ptr (Field s))) -> IO (Ptr (Field s))

foreign import ccall "dynamic" mkFieldClearBg ::
	FunPtr (Ptr (Field s) -> IO ()) -> Ptr (Field s) -> IO ()

これで関数ポインタが指す関数をHaskell側から使えるようになる。

src/Human.hsc

fieldNewBackgroundRaw :: Bool -> IO (Field s)
fieldNewBackgroundRaw (boolToCBool -> b) = Field <$> do
	pf <- mkFieldNewBg $ c_hm_field_new_background b
	newForeignPtr pf $ c_hm_field_destroy pf

fieldClearBackgroundRaw :: Bool -> Field s -> IO ()
fieldClearBackgroundRaw (boolToCBool -> b) (Field ff) =
	withForeignPtr ff $ mkFieldClearBg (c_hm_field_clear_background b)

boolToCBool :: Bool -> #{type bool}
boolToCBool = \case False -> #{const false}; True -> #{const true}

C言語の型boolを使うのでヘッダstdbool.hを導入する。

src/Human.hsc

...

import Human.Exception

#include <human.h>
#include <stdbool.h>

...

前にやったようにIO aではなくPrimMonad m => m aを使うようにする。

src/Human.hsc

fieldNewBackground :: PrimMonad m => Bool -> m (Field (PrimState m))
fieldNewBackground = unsafeIOToPrim . fieldNewBackgroundRaw

fieldClearBackground :: PrimMonad m => Bool -> Field (PrimState m) -> m ()
fieldClearBackground b = unsafeIOToPrim . fieldClearBackgroundRaw b

ビルドして試してみる。

% stack build
% stack ghci
> f <- fieldNewBackground False
> fieldPutHuman f 30 15
> fieldDraw f
(スペースの背景に「人間」が表示される)
> g <- fieldNewBackground True
> fieldPutHuman g 30 15
> fieldDraw g
.....('.'の背景に「人間」が表示される)...
> fieldClearBackground False f
> fieldDraw f
(スペースの背景が表示される)
> fieldClearBackground True g
> fieldDraw g
('.'の背景が表示される)

ポインタを含む構造体

ゲームには主人公と敵キャラだけでなく文字列も表示したくなる。現在のポインタを見たいだろうし、失敗したら「GAME OVER」とか表示したい。位置と文字列とをもつ構造体を引数にとり、メッセージを表示する関数を定義する。まずは、構造体を定義しよう。

include/human.h

typedef struct { int x; int y; } HmPosition;
typedef struct { HmPosition *position; char *message; } HmMessage;

関数hm_field_put_messageを定義する。

csrc/human.c

void
hm_field_put_message(HmField f, HmMessage *msg)
{
	int x = msg->position->x;
	int y = msg->position->y;
	char *m = msg->message;
	for (; *m; x++, m++) hm_field_put_char(f, x, y, *m);
}

X座標の値を増やしつつ文字列のなかの文字を指すポインタmの値を増やしながら、関数hm_field_put_charを呼び出している。これをHaskell側から使ってみる。

型Foreign.C.String.CStringを使うのでモジュールを導入する。

src/Human.hsc

...
import Foreign.Storable
import Foreign.C.Types
import Foreign.C.String
import Foreign.C.Enum
...

C言語の構造体HmPositionとHmMessageに対応する型を定義する。

src/Human.hsc

struct "Position" #{size HmPosition}
	[	("x", ''CInt, [| #{peek HmPosition, x} |],
			[| #{poke HmPosition, x} |]),
		("y", ''CInt, [| #{peek HmPosition, y} |],
			[| #{poke HmPosition, y} |]) ]
	[''Show]

type PtrPosition = Ptr Position

struct "CMessage" #{size HmMessage}
	[	("position", ''PtrPosition, [| #{peek HmMessage, position} |],
			[| #{poke HmMessage, position} |]),
		("message", ''CString, [| #{peek HmMessage, message} |],
			[| #{poke HmMessage, message} |]) ]
	[''Show]

構造体HmMessageはほかの構造体や文字列へのポインタを含む構造体だ。この構造体をそのまま使うとなると、いつGCするべきかについて問題が出てくる。関数addForeignPtrFinalizerとtouchForeignPtrを使って、そのあたりを制御することもできるが、Haskellネイティブなデータ型を作って、上で定義したCMessage型の値をC言語の関数を使うときだけ使う一時的なものとしたほうが、話は単純になる。

src/Human.hsc

data Message = Message { messagePosition :: Position, messageMessage :: String }
	deriving Show

foreign import ccall "hm_field_put_message"
	c_hm_field_put_message :: Ptr (Field s) -> Ptr CMessage -> IO ()

fieldPutMessageRaw :: Field s -> Message -> IO ()
fieldPutMessageRaw (Field ff)
	Message { messagePosition = Position_ fp, messageMessage = msg } =
	withForeignPtr fp \pp -> withCString msg \cmsg -> do
		let	CMessage_ fmsg = CMessage {
				cMessagePosition = pp,
				cMessageMessage = cmsg }
		withForeignPtr ff $ withForeignPtr fmsg . c_hm_field_put_message

値構築子CMessageで生成したCMessage型の値を、値構築子CMessage_でマッチすることによって、ForeignPtr型の値を取得し、そこから取り出したポインタを関数`c_hm_field_put_messageにわたしている。

src/Human.hsc

fieldPutMessage :: PrimMonad m => Field (PrimState m) -> Message -> m ()
fieldPutMessage f = unsafeIOToPrim . fieldPutMessageRaw f

IO aではなくPrimMonad m => m aを使うfieldPutMessageを定義した。試してみる。

% stack build
% stack ghci
> f <- fieldNew
> fieldPutMessage f $ Message (Position 10 15) "Hello, world!"
> fieldDraw f
....(Hello, world!が表示される)...

これでC言語のライブラリと、それにアクセスするHaskell側の機構は完成した。これらを使ってゲームを作っていく。

関数`mainLoop`

関数withEventをくりかえし実行するよりも関数mainLoopを定義しておいたほうが便利だ。

src/Human/MainLoop.hs

{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE RankNTypes #-}
{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}

module Human.MainLoop where

import Control.Monad.Fix
import Control.Exception
import Data.Bool
import Ssytem.IO

import Human.Event

mainLoop :: (forall s . Event s -> IO Bool) -> IO ()
mainLoop f = hGetBuffering stdin >>= \bm -> finally (hSetBuffering stdin bm) do
	hSetBuffering stdin NoBuffering
	go . (`withEvent` f) =<< hGetAndPushCChar stdin
	where go = fix \l act -> bool (pure ()) (l act) =<< act

いろいろと難しいことをやっていそうに見えるが、関数fの動作が返す値がTrueのあいだ関数withEventを呼び出し続けているだけだ。関数hSetBufferingで標準入力のバッファリングを無効にしているのと、finallyによって最後にバッファリングをもとにもどしている。

試してみよう。まずはpackage.yamlにtry-main-loopを追加する。

package.yaml

...
  try-main-loop:
    main:          try-main-loop.hs
    source-dirs:   app
    ghc-options:
    - -threaded
    - -rtsopts
    - -with-rtsopts=-N
    dependencies:
    - zenn-use-c-lib

...

app/try-main-loop.hsを作成する。

app/try-main-loop.hs

{-# LANGUAGE BlockArguments, LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}

module Main where

import Human.MainLoop
import Human.Event

main :: IO ()
main = mainLoop \case
	EventEventTick evt -> True <$ print evt
	EventEventChar evc -> (eventCharToCharacter evc /= 113) <$ print evc
	ev -> False <$ print ev

ビルドして試してみる。

% stack build
% stack exec try-main-loop
(いろいろな文字を入力してみる)
('q'を入力すると終わる)

ゲームを作る

ここの部分は主題ではなく、さらにすでに分量も多く、時間もないので「GitHubを見て」とだけ...。

src/Game.hsを作成
package.yamlにtry-gameを追加
app/try-game.hsを作成

% stack build
% stack exec try-game

'h': 左に歩き出す
2回目の'h': 左に走り出す
'l': 右に歩き出す
2回目の'l': 右に走り出す
'j': 立ち止まる
'k': ジャンプsrc

まとめ

なんか長くなってしまったし疲れたし、ぎりぎりでなんとかまにあったという感じ。

はじめにの前に

はじめに

ビルド時に必要なオプションについて

ダミーのライブラリを作成

C言語から呼んでみる

コンパイルオプションを指定

pkg-configを使う

Haskellから呼んでみる

コンパイルオプションを指定する

pkg-configを利用する

Cのライブラリを設計して、それをHaskellから使う

ソースコード

はじめに

準備

単純な関数

定数

入出力

例外処理

Cの関数から返すエラーを表す値

例外を表す型

列挙型

列挙型をHaskellから使う

一文字、フィールドに置く

「人間」を置く

GCを使う

STモナドとIOモナド

Image

STモナド

IOモナドとSTモナドをまとめる

構造体

C言語の側で構造体を更新する

ForeignPtrによるGCを利用するやりかたが適切でない場合

自前でのメモリ割り当て

仕様

アルゴリズム

メモリの使用状態を表現する木構造

メモリの確保と解放

メモリの確保

メモリの解放

イベントの定義

Tickイベントの生成

ForeignPtrによりHaskellのGCを利用してみる

イベントが発生したら、その都度領域を解放するやりかた

解放済みの領域にアクセスさせない仕組み

イベントの取得

Tickイベント

Haskellの関数をC言語側にわたす

関数withEvent

文字入力イベント

C言語の関数ポインタからHaskellの関数を作る

ポインタを含む構造体

関数mainLoop

ゲームを作る

まとめ

Discussion

`ForeignPtr`によるGCを利用するやりかたが適切でない場合

`Tick`イベントの生成

`Tick`イベント

関数`withEvent`

関数`mainLoop`