November 4th, 2010, 06:53 PM
|
|
|
|
Haskell - Async FFI Callback causes crash
I'm trying to use libSDL. Sometimes the program crashes immediately, other times it will run for minutes before dying. I have no problem until I use SDL_AddTimer which is making a callback to a Haskell function asynchronously.
The error message is:
Code:
test: schedule: re-entered unsafely.
Perhaps a 'foreign import unsafe' should be 'safe'?
To answer the obvious questions:
- none of my foreign import statements are marked unsafe.
- The libSDL wrapper on Hackage doesn't support SDL_AddTimer
Apologies for the large code dump, the FFI needs a lot of boilerplate. I'm compiling with "ghc --make test.hs \path\to\libsdl\SDL.lib"
haskell Code:
 Original
- haskell Code |
|
|
|
{-# LANGUAGE ForeignFunctionInterface #-}
module Main where
import Foreign
import Foreign.Ptr
data SDL_EventType = SDL_QUIT | SDL_TODOEVENT | SDL_USEREVENT Int8
deriving Show
toEventType :: Int8 -> SDL_EventType
toEventType 12 = SDL_QUIT
toEventType t
| t < 24 = SDL_TODOEVENT
| otherwise = SDL_USEREVENT t
fromEventType :: SDL_EventType -> Int8
fromEventType (SDL_USEREVENT t) = t
data SDL_Surface =
SDL_Surface {
pitch :: Int16,
pixels :: Ptr Int8
}
data SDL_Event =
GenericEvent {
eventType :: SDL_EventType
}
deriving Show
sdl_INIT_VIDEO = 0x20 :: Int32
sdl_INIT_TIMER = 0x01 :: Int32
sdl_SWSURFACE = 0 :: Int32
instance Storable SDL_Surface where
alignment _ = 4
sizeOf _ = 60
peek ptr = do
pitch' <- peek $ plusPtr ptr 16
pixels' <- peek $ plusPtr ptr 20
return $ SDL_Surface {
pitch = pitch',
pixels = pixels'
}
poke ptr _ = return ()
instance Storable SDL_Event where
alignment _ = 4
sizeOf _ = 20
peek ptr = do
eventType' <- peek eventTypePtr >>= return . toEventType
return $ GenericEvent { eventType = eventType' }
where eventTypePtr = (castPtr ptr) :: (Ptr Int8)
poke ptr evt@GenericEvent{} = do
poke eventTypePtr (fromEventType $ eventType evt)
where eventTypePtr = (castPtr ptr) :: (Ptr Int8)
foreign import stdcall "GetModuleHandleA"
getModuleHandle :: Ptr Int32 -> IO Int32
foreign import ccall "SDL_SetModuleHandle"
sdl_setModuleHandle :: Int32 -> IO ()
foreign import ccall "SDL_Init"
sdl_init :: Int32 -> IO Int32
foreign import ccall "SDL_Quit"
sdl_quit :: IO Int32
foreign import ccall "SDL_SetVideoMode"
sdl_setVideoMode :: Int32 -> Int32 -> Int32 -> Int32 -> IO (Ptr SDL_Surface)
foreign import ccall "SDL_WaitEvent"
sdl_waitEvent :: Ptr SDL_Event -> IO Int32
foreign import ccall "SDL_LockSurface"
sdl_lockSurface :: Ptr SDL_Surface -> IO Int32
foreign import ccall "SDL_UnlockSurface"
sdl_unlockSurface :: Ptr SDL_Surface -> IO Int32
foreign import ccall "SDL_UpdateRect"
sdl_updateRect :: Ptr SDL_Surface -> Int32 -> Int32 -> Int32 -> Int32 -> IO Int32
foreign import ccall "SDL_AddTimer"
sdl_addTimer :: Word32 -> FunPtr (Word32 -> Ptr() -> IO Word32) -> Ptr () -> IO Word32
foreign import ccall "SDL_PushEvent"
sdl_pushEvent :: Ptr SDL_Event -> IO Int32
foreign import ccall "SDL_FillRect"
sdl_fillRect :: Ptr SDL_Surface -> Ptr () -> Word32 -> IO Int32
foreign import ccall "wrapper"
wrapCallback :: (Word32 -> Ptr () -> IO Word32) -> IO (FunPtr (Word32 -> Ptr () -> IO Word32))
-- Pokes a 32-bit 0RGB value into a surface's pixel data
setPixel32 :: Ptr SDL_Surface -> Int -> Int -> Int32 -> IO ()
setPixel32 ps x y c = do
s <- peek ps
let offset = (x * 4) + y * (fromIntegral $ pitch s) in
poke (plusPtr (pixels s) offset) c
-- Runs an action surrounding it with SDL_LockSurface / SDL_UnlockSurface
withLockedSurface :: Ptr SDL_Surface -> IO b -> IO b
withLockedSurface s f = do
sdl_lockSurface s
result <- f
sdl_unlockSurface s
return result
-- Initialize SDL
-- Schedule a timer event @ 20ms intervals
-- Start the event loop
main = do
getModuleHandle nullPtr >>= sdl_setModuleHandle
sdl_init $ sdl_INIT_VIDEO .|. sdl_INIT_TIMER
screen <- sdl_setVideoMode 640 480 32 sdl_SWSURFACE
ticker <- malloc >>= wrapCallback . makeTicker
sdl_addTimer 20 ticker nullPtr
alloca $ eventLoop screen 0
sdl_quit
-- Create a timer that queues up an SDL_USEREVENT
-- and then schedules itself w/ the same time interval
makeTicker :: Ptr SDL_Event -> (Word32 -> Ptr () -> IO Word32)
makeTicker evt = \i _ -> do
poke evt $ GenericEvent { eventType = SDL_USEREVENT 24 }
sdl_pushEvent evt
return i
drawSine ofst s = mapM_ drawPoint [0..639]
where drawPoint x =
let theta = (fromIntegral $ x + ofst) * 2 * pi / 640
y = round $ 240 + 100 * sin theta
in setPixel32 s x y 0xFFFFFF
-- Handle SDL Events
-- SDL_QUIT -> exit event loop
-- SDL_USEREVENT -> draw sinewave & increment frame
-- otherwise -> ignore
eventLoop :: Ptr SDL_Surface -> Int -> Ptr SDL_Event -> IO ()
eventLoop screen frame event = do
sdl_waitEvent event
evt <- peek event
case evt of
GenericEvent SDL_QUIT -> return ()
GenericEvent (SDL_USEREVENT et)
| et == 24 -> do
withLockedSurface screen $ do
sdl_fillRect screen nullPtr 0
drawSine frame screen
sdl_updateRect screen 0 0 0 0
eventLoop screen (frame+1) event
| otherwise -> eventLoop screen frame event
_ -> eventLoop screen frame event
__________________
sub{*{$::{$_}}{CODE}==$_[0]&& print for(%:: )}->(\&Meh);
|
Del.icio.us
Digg
Google
Spurl
Blink
Furl
Simpy
Y! MyWeb
Linear Mode
