1

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

我正在尝试使用 ghc 7.4.1 在 Ubuntu 12.04 上做这件事。这是我的阴谋集团文件：

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 的第 8 课的代码）

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 ()

我做错了什么？

4

1 回答 1

2

我认为这在使用优化编译时显示了段错误。我试过了-O0，没有段错误，但-O2给出了段错误。

cabal 构建版本默认提供 segfault。这可能是因为 cabal 默认启用优化。

尝试构建

cabal configure --disable-optimization
cabal build
于 2012-09-15T09:04:23.350 回答