使用cabal构建应用程序时，TTF_Quit调用上的Segfault

Question

我有个奇怪的问题。我用sdl在haskell中创建了一个简单的应用程序，当它是用ghc构建的时候没有问题，但是当它是用cabal构建的时候，我在关闭我的应用程序后有一个段错误。我注意到，当Graphics.UI.SDL.TTF.General.quit调用被注释时，也没有问题。

我正尝试在Ubuntu 12.04和ghc 7.4.1上做这件事。这是我的cabal文件：

Name:           simple app
Version:        0.0.0.1
Build-Type:     Simple
Cabal-Version:  >= 1.8
Executable invaders
  Main-is:         App.hs
  Build-Depends:   base > 3 && < 5,
                   mtl,
                   SDL,
                   SDL-image,
                   SDL-ttf

这是我的应用程序(它至多是LasyFooHaskell的lesson08的代码)

module App where

import Data.Word

import Control.Monad
import Control.Monad.State
import Control.Monad.Reader

import Graphics.UI.SDL
import Graphics.UI.SDL.Image

import Graphics.UI.SDL.TTF
import qualified Graphics.UI.SDL.TTF.General as TTFG

screenWidth = 640
screenHeight = 480
screenBpp = 32

data MessageDir = MessageDir {
     upMessage    :: Surface,
     downMessage  :: Surface,
     leftMessage  :: Surface,
     rightMessage :: Surface
}

data AppConfig = AppConfig {
     screen       :: Surface,
     background   :: Surface,
     messageDir   :: MessageDir
}

type AppState = StateT (Maybe Surface) IO
type AppEnv = ReaderT AppConfig AppState

runLoop :: AppConfig -> IO()
runLoop config = (evalStateT . runReaderT loop) config Nothing

loadImage :: String -> Maybe (Word8, Word8, Word8) -> IO Surface
loadImage filename colorKey = load filename >>= displayFormat >>= setColorKey' colorKey

setColorKey' Nothing s = return s
setColorKey' (Just (r, g, b)) surface = (mapRGB . surfaceGetPixelFormat) surface r g b >>= setColorKey surface [SrcColorKey] >> return surface

applySurface :: Int -> Int -> Surface -> Surface -> Maybe Rect -> IO Bool
applySurface x y src dst clip = blitSurface src clip dst offset
             where offset = Just Rect { rectX = x, rectY = y, rectW = 0, rectH = 0 }

initEnv :: IO AppConfig
initEnv = do
        screen <- setVideoMode screenWidth screenHeight screenBpp [SWSurface]
        setCaption "Press an Arrow Key" []

        background      <- loadImage "res/img/background.png" $ Just (0x00, 0xff, 0xff)
        font            <- openFont "res/lazy.ttf" 72

        upMessage       <- renderTextSolid font "Up was pressed" textColor
        downMessage     <- renderTextSolid font "Down was pressed" textColor
        leftMessage     <- renderTextSolid font "Left was pressed" textColor
        rightMessage    <- renderTextSolid font "Right was pressed" textColor

        applySurface 0 0 background screen Nothing

        let msgDir = MessageDir upMessage downMessage leftMessage rightMessage
        return $ AppConfig screen background msgDir
      where textColor = Color 0 0 0

loop :: AppEnv ()
loop = do

     quit <- whileEvents $ \event -> do
       case event of 
         (KeyDown (Keysym key _ _)) -> do
           mdir <- messageDir `liftM` ask
           case key of
             SDLK_UP    -> put $ Just $ upMessage mdir
             SDLK_DOWN  -> put $ Just $ downMessage mdir
             SDLK_LEFT  -> put $ Just $ leftMessage mdir
             SDLK_RIGHT -> put $ Just $ rightMessage mdir
             _          -> put Nothing
         _ -> return ()

     screen     <- screen `liftM` ask
     background <- background `liftM` ask
     msg        <- get

     case msg of
          Nothing       -> return ()
          Just message  -> do
               applySurface' 0 0 background screen Nothing
               applySurface' ((screenWidth - surfaceGetWidth message) `div` 2) ((screenHeight - surfaceGetHeight message) `div` 2) message screen Nothing
               put Nothing

     liftIO $ Graphics.UI.SDL.flip screen

     unless quit loop

  where applySurface' x y src dst clip = liftIO (applySurface x y src dst clip)

whileEvents :: MonadIO m => (Event -> m()) -> m Bool
whileEvents act = do
            event <- liftIO pollEvent
            case event of
                 Quit -> return True
                 NoEvent -> return False
                 _ -> do
                   act event
                   whileEvents act

main = withInit [InitEverything] $ do
     result <- TTFG.init
     if not result
        then putStr "Failed to init ttf\n"
        else do
             env <- initEnv
             runLoop env
             ttfWasInit <- TTFG.wasInit
             case ttfWasInit of
               True -> TTFG.quit
               False -> return ()

我做错了什么？

Answer 1

我认为，当使用优化进行编译时，这显示了segfault。我用-O0试了一下，没有得到段错误，而-O2给出了段错误。

默认情况下，cabal构建版本提供了segfault。这可能是因为cabal在默认情况下启用了优化。

尝试通过以下方式构建

cabal configure --disable-optimization
cabal build