FFI (その2)

前回の続き。
今日はコードがひときわ多い。

CからHaskellは呼び出せたので、
今度はHaskellからCコードを呼び出してみようと思う。

…しっかし、マニュアルが全然読めない。英語なので…
どうでもいいがForeignモジュールはHaskellの暗黒方面っぽい。
メモリ確保とかメモリの読み書きとか、見ていて眩暈が…

 -- foo.c
#include "HsFFI.h"
#include 

HsInt foo(HsInt n)
{
  int i,sum=0;
  for (i=1;i<=n;i++){
    printf("%d\n",i);
    sum+=i;
  }
  return sum;
}

 -- main.hs
foreign import ccall "foo" foo :: Int -> IO Int

main :: IO ()
main = do
  n <- foo 10
  putStrLn ("sigma 10 = "++show n)

コンパイル方法

ghc foo.c main.hs -fglasgow-exts -o foo

なんかすごい簡単だったのですが。
CからHaskell呼ぶより簡単。
IntとDoubleならHsIntとかHsFloatとかで関数を宣言すればいいらしい。
で、問題になるのがカスタムなデータタイプ。
IntとDoubleで表現できるもの以外は全部ポインタで受け渡しをする模様。
とりあえず配列を受け渡ししてみることにする。

 -- array_test.c
#include "HsFFI.h"
#include 
#include 

HsPtr alloc_array(int size)
{
  int *ret=malloc(size*sizeof(int)),i;
  for (i=0;i

 -- arrayTest.hs
import Control.Monad
import Foreign

main = do
  arr <- allocArray 10
  putStrLn "init value:"
  showArray 10 arr

  n <- peekElemOff arr 5
  putStrLn $ "5th value = " ++ show n

  mapM_ (\(a,b) -> f arr a b) $ zip [0..8] [1..]

  putStrLn "final value:"
  showArray 10 arr

  n <- peekElemOff arr 5
  putStrLn $ "5th value = " ++ show n

  freeArray arr

  where
    f arr a b = do
      v <- liftM2 (+) (peekElemOff arr a) (peekElemOff arr b)
      pokeElemOff arr a v

foreign import ccall "alloc_array" allocArray :: Int -> IO (Ptr Int32)
foreign import ccall "free_array"  freeArray  :: Ptr Int32 -> IO ()
foreign import ccall "show_array"  showArray  :: Int -> Ptr Int32 -> IO ()

Haskellのほうもこれでもかというぐらい手続きチックなのだが…。
Ptr Int32という型で配列を受け取ることにした。
Ptrに対する読み書きはForeign.Storable中、
Storableクラスにて定義されている。
ストア可能な型、数値型はおおよそ可能なのだが、
それのポインタ(Ptr a 型)について

peekElemOff :: Ptr a -> Int -> IO a 
pokeElemOff :: Ptr a -> Int -> a -> IO () 
peekByteOff :: Ptr b -> Int -> IO a 
pokeByteOff :: Ptr b -> Int -> a -> IO () 
peek :: Ptr a -> IO a 
poke :: Ptr a -> a -> IO () 

こないな関数が定義されている。
…こんなんHaskellじゃないやい。
まぁ、でもこれを使えば構造体も受け渡し出来そうである。

で、ようやくSDLを呼び出してみることにする。
SDLはその昔DirectX向けに作ったプログラムをSDLに移植した程度の
経験しかないのであるが…

とりあえずチュートリアルを読みながら適当に作っていくことにする。
教科書は http://www.libsdl.org/intro.jp/toc.html これ。
まずは

#include 
#include "SDL.h"

main(int argc, char *argv[])
{
    if ( SDL_Init(SDL_INIT_AUDIO|SDL_INIT_VIDEO) < 0 ) {
        fprintf(stderr, "Unable to init SDL: %s\n", SDL_GetError());
        exit(1);
    }
    atexit(SDL_Quit);

    ...
}

これを移植することにする。(いきなり目標がめちゃくちゃ低い…)
まず、スタブの作成。
(これ、なんかヘッダファイル使って自動的にやる方法が
マニュアルに書いてあったような気がするけど、
英語が全然読めなかった。詳しい方、こっそりと教えてください…)

 -- sdl_init.c
#include 
#include "HsFFI.h"

HsInt sdl_init(HsWord32 flags)
{
  return SDL_Init((Uint32)flags);
}

HsInt sdl_initsubsystem(HsWord32 flags)
{
  return SDL_InitSubSystem((Uint32)flags);
}

void sdl_quit()
{
  SDL_Quit();
}

void sdl_quitsubsystem(HsWord32 flags)
{
  SDL_QuitSubSystem(flags);
}

Haskell側のインターフェース

 --sdlInit.hs
module SdlInit(
  Subsystem(..),

  sdlInit, sdlInitSubSystem,
  sdlQuit, sdlQuitSubSystem,

) where

import Data.Bits

data Subsystem =
    TIMER | AUDIO | VIDEO | CDROM | JOYSTICK
  | EVERYTHING | NOPARACHUTE | EVENTTHREAD
  deriving (Eq,Show)

subsystemToInt :: Subsystem -> Int
subsystemToInt TIMER       = 0x00000001
subsystemToInt AUDIO       = 0x00000010
subsystemToInt VIDEO       = 0x00000020
subsystemToInt CDROM       = 0x00000100
subsystemToInt JOYSTICK    = 0x00000200
subsystemToInt NOPARACHUTE = 0x00100000
subsystemToInt EVENTTHREAD = 0x01000000
subsystemToInt EVERYTHING  = 0x0000FFFF

subsystemsToInt :: [Subsystem] -> Int
subsystemsToInt ss = foldl (.|.) 0 $ map subsystemToInt ss

sdlInit :: [Subsystem] -> IO Bool
sdlInit ss = do
  ret <- inSDLInit $ subsystemsToInt ss
  return $ ret>=0

sdlInitSubSystem :: [Subsystem] -> IO Bool
sdlInitSubSystem ss = do
  ret <- inSDLInitSubSystem $ subsystemsToInt ss
  return $ ret>=0

sdlQuit :: IO ()
sdlQuit = inSDLQuit

sdlQuitSubSystem :: [Subsystem] -> IO ()
sdlQuitSubSystem ss =
  inSDLQuitSubSystem $ subsystemsToInt ss

foreign import ccall "sdl_init" inSDLInit :: Int -> IO Int
foreign import ccall "sdl_initsubsystem" inSDLInitSubSystem :: Int -> IO Int
foreign import ccall "sdl_quit" inSDLQuit :: IO ()
foreign import ccall "sdl_quitsubsystem" inSDLQuitSubSystem :: Int -> IO ()

一応フラグだけはデータ型作ってみたり。
で、呼び出すプログラム。

 -- main.hs
module Main(main) where

import Control.Monad
import SdlInit

main :: IO ()
main = do
  ret <- sdlInit [VIDEO]
  when (not ret) then
    putStrLn "unable to init SDL."
  sdlQuit

Haskell版とはいえラッパが薄いのでコードがCのとほとんど同じになってる。

SDLだが、今回はmingw版をGHCのディレクトリにインストールした。
GHCをCコンパイラとしても使うことに。
GHCがmingw抱えてるからVisualCとのリンクがうまく行くかわからんとか、
mingwを別にインストールしてないとかそんな具合で、
別に積極的な理由があったわけではないのだが…

コンパイルして、-lsdlオプションをつけてリンクするとひとまず完成。
問題なく動いた。

しかし、何も表示されないのでうれしくない。
ウインドウを出したいので次のチュートリアルへ。

{ SDL_Surface *screen;

    screen = SDL_SetVideoMode(640, 480, 16, SDL_SWSURFACE);
    if ( screen == NULL ) {
        fprintf(stderr, "Unable to set 640x480 video: %s\n", SDL_GetError());
        exit(1);
    }
}

次はこの辺を移植する。(また目標が小さい…)

 --sdl_video.c
#include 
#include "HsFFI.h"

HsPtr sdl_setvideomode(HsInt width,HsInt height,HsInt depth,HsWord32 flags)
{
  return SDL_SetVideoMode(width,height,depth,flags);
}

 -- sdlVideo.hs
module SdlVideo(
  SurfaceFlag(..),
  Surface,

  sdlSetVideoMode,
) where

import Data.Bits
import Foreign

type Surface = Ptr ()

data SurfaceFlag =
    SWSURFACE | HWSURFACE | ASYNCBLIT

  | ANYFORMAT | HWPALETTE | DOUBLEBUF
  | FULLSCREEN | OPENGL | OPENGLBLIT
  | RESIZABLE | NOFRAME

  | HWACCEL | SRCCOLORKEY | RLEACCELOK | RLEACCEL
  | SRCALPHA | PREALLOC

flagToInt SWSURFACE  = 0x00000000
flagToInt HWSURFACE  = 0x00000001
flagToInt ASYNCBLIT  = 0x00000004

flagToInt ANYFORMAT  = 0x10000000
flagToInt HWPALETTE  = 0x20000000
flagToInt DOUBLEBUF  = 0x40000000
flagToInt FULLSCREEN = 0x80000000
flagToInt OPENGL     = 0x00000002
flagToInt OPENGLBLIT = 0x0000000A
flagToInt RESIZABLE  = 0x00000010
flagToInt NOFRAME    = 0x00000020

flagToInt HWACCEL    = 0x00000100
flagToInt SRCCOLORKEY= 0x00001000
flagToInt RLEACCELOK = 0x00002000
flagToInt RLEACCEL   = 0x00004000
flagToInt SRCALPHA   = 0x00010000
flagToInt PREALLOC   = 0x01000000

sdlSetVideoMode :: Int -> Int -> Int -> [SurfaceFlag] -> IO Surface
sdlSetVideoMode width height depth sf = do
  inSDLSetVideoMode width height depth $ foldl (.|.) 0 $ map flagToInt sf

foreign import ccall "sdl_setvideomode" inSDLSetVideoMode :: Int -> Int -> Int -> Int -> IO Surface

Surfaceはよくわからないが、Ptr ()にしておいた。
今のところは使わないし。
peek/pokeでがりがり読み書きしてHaskell側で同じ構造体を構築するか、
はたまた、アクセス関数をCで書いてPtr ()を渡し続けるか、
そのへんは未定。

 -- main.hs
module Main(main) where

import Control.Concurrent
import Control.Monad
import SdlInit
import SdlVideo

main :: IO ()
main = do
  ret <- sdlInit [VIDEO]
  if ret then
    do putStrLn "initialize successed."
       sur <- sdlSetVideoMode 640 480 32 [SWSURFACE,ANYFORMAT]
       threadDelay (1000*1000)
    else
      putStrLn "initialize failed."
  sdlQuit

mainはこないな感じ。
現時点でイベント処理を実装していないので
threadDelayで1秒寝た後に終了。
とりあえずウインドウの出現を確認できてちょっとうれしかった。

ときに、ここまで作ってコンパイルコマンドが

>ghc sdlInit.hs sdl_init.c sdlVideo.hs sdl_video.c main.hs -fglasgow-exts -lsdl -o sdltest.exe

こんな状態になってしまった。
Windowsのcmdで作業してるのだが、
そろそろ(makeを使うためだけに)Cygwin上にするかな…

コンパイラ

結局レポートは結構適当な出来で提出。
Haskellのほうがおもろいんだもん…

鴨川

自転車撤去がリアルタイムで進行中。
どうしたものか。