FFI (その2)
前回の続き。
今日はコードがひときわ多い。
CからHaskellは呼び出せたので、
今度はHaskellからCコードを呼び出してみようと思う。
…しっかし、マニュアルが全然読めない。英語なので…
どうでもいいがForeignモジュールはHaskellの暗黒方面っぽい。
メモリ確保とかメモリの読み書きとか、見ていて眩暈が…
-- foo.c #include "HsFFI.h" #includeHsInt 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上にするかな…