2

我围绕 bindings-fluidsynth 库编写了一组实用函数：

module FSUtilities where

import Control.Monad
import System.Directory
import Foreign.Ptr
import Foreign.ForeignPtr
import Foreign.C.Types
import Foreign.C.String
import Bindings.FluidSynth

newtype Settings = Settings (ForeignPtr C'fluid_settings_t)

newtype Synth = Synth (ForeignPtr C'fluid_synth_t)

type Channel = Int
type Key = Int
type Velocity = Int

initSynth :: IO Synth
initSynth = createSettings >>=
            changeSettingStr "audio.driver" "alsa" >>=
            changeSettingInt "synth.polyphony" 64 >>=
            (\s -> createSynth s >>= createDriver s) >>=
            loadSF "GS.sf2"

createSettings :: IO Settings
createSettings =
    c'new_fluid_settings >>=
    newForeignPtr p'delete_fluid_settings >>= (pure $!) . Settings

changeSettingStr :: String -> String -> Settings -> IO Settings
changeSettingStr k v (Settings s) =
    withForeignPtr s $ \ptr ->
          withCAString k $ \cstr ->
              withCAString v $ \cstr' ->
                  c'fluid_settings_setstr ptr cstr cstr' >>
    (pure $! Settings s)

changeSettingInt :: String -> Int -> Settings -> IO Settings
changeSettingInt k v (Settings s) =
    withForeignPtr s $ \ptr ->
          withCAString k $ \cstr ->
              c'fluid_settings_setint ptr cstr (fromIntegral v) >>
    (pure $! Settings s)

createSynth :: Settings -> IO Synth
createSynth (Settings s) =
    withForeignPtr s c'new_fluid_synth >>=
    newForeignPtr p'delete_fluid_synth >>= (pure $!) . Synth

createDriver :: Settings -> Synth -> IO Synth
createDriver (Settings set) (Synth syn) =
    withForeignPtr set $ \ptr ->
        withForeignPtr syn $ \ptr' ->
            c'new_fluid_audio_driver ptr ptr' >>=
    newForeignPtr p'delete_fluid_audio_driver >>
    (pure $! Synth syn)

loadSF :: String -> Synth -> IO Synth
loadSF path (Synth syn) =
    withForeignPtr syn $ \s ->
      makeAbsolute path >>= \p ->
        withCAString p $ \p' ->
          c'fluid_synth_sfload s p' 1 >>=
    \c -> if c == (-1) then error    "loadSF: Could not load SoundFont"
                       else putStrLn "loadSF: SoundFont loaded" >>
                            (pure $! Synth syn)

noteOn :: Channel -> Key -> Velocity -> Synth -> IO ()
noteOn c k v (Synth ptr) =
    withForeignPtr ptr $ \syn ->
        c'fluid_synth_noteon syn c' k' v' >> pure ()
            where c' = fromIntegral c
                  k' = fromIntegral k
                  v' = fromIntegral v

justPlay :: Channel -> Key -> IO ()
justPlay c k = initSynth >>= noteOn c k 127

justPlay' :: Channel -> Key -> IO Synth
justPlay' c k = initSynth >>= \s -> noteOn c k 127 s >> pure s

和函数用于说明问题justPlay。justPlay'当我justPlay从 ghci 调用时，我会得到随机的段错误（不一致，大约 30% 的时间），而justPlay'从来没有这样做过（但由于 dangling s，在一堆调用后迅速填满了我的系统内存Synth。我认为这是因为当Synth不再引用时，我不会自己清理，但我认为newForeignPtr在创建时使用终结器函数调用Synth应该自动处理。

我是 Haskell 的新手，我不知道 C，所以我试图通过这个来感受我的方式。处理这种情况的正确方法是什么？

4

1 回答 1

2

很难说到底是什么导致了崩溃，但至少有一件明显错误的事情。发生在文档中：

在释放 FluidSynth 实例之前，应删除合成器实例的其他用户，例如音频和 MIDI 驱动程序。

在您的情况下，未定义终结器的顺序，因此可以在驱动程序之前删除合成器。可能其他物体的生命圈也有限制。

要显式完成外部指针，请使用finalizeForeignPtr.

于 2017-11-29T13:19:27.240 回答