use a C global variable for locking

Replaces the unsafePerformIO solution, which is broken because of GHC
bug #5558.

This is the same idea used in the global-lock package.

Propane/IO.hs

@@ -1,5 +1,3 @@
-{-# LANGUAGE
-    TemplateHaskell #-}
 -- | Input and output.
 --
 -- TODO: input.
@@ -13,19 +11,16 @@ import qualified Data.Array.Repa.IO.DevIL as D
 
 import qualified Data.Foldable as F
 
-import Data.Global
 import Control.Monad
-import Control.Concurrent.MVar
 import Control.Concurrent.Spawn
 import Control.Exception
 import System.FilePath
 import System.Directory
 import Text.Printf
 
 import Propane.Types
+import Propane.IO.Lock ( lock )
 
--- Serialize access to DevIL, which isn't thread-safe
-declareMVar  "devilLock"  [t| () |]  [e| () |]
 
 errStr :: String -> String
 errStr = ("Propane.IO: " ++)
@@ -37,8 +32,7 @@ errStr = ("Propane.IO: " ++)
 saveRaster :: FilePath -> Raster -> IO ()
 saveRaster name (Raster img) = do
     evaluate (R.deepSeqArray img ())
-    withMVar devilLock $ \() ->
-        D.runIL (D.writeImage name img)
+    lock $ D.runIL (D.writeImage name img)
 
 -- | Save the @'Rastimation'@ to a sequence of frames in
 -- the given directory.

Propane/IO/Lock.hs

@@ -0,0 +1,37 @@
+{-# LANGUAGE
+    ForeignFunctionInterface #-}
+-- | Protect calls into DevIL with a global lock.
+module Propane.IO.Lock
+    ( lock
+    ) where
+
+import Foreign
+import Foreign.C
+import Control.Monad
+import Control.Concurrent.MVar
+
+
+foreign import ccall "hs_propane_get_global"
+    c_get_global :: IO (Ptr ())
+
+foreign import ccall "hs_propane_set_global"
+    c_set_global :: Ptr () -> IO CInt
+
+
+set :: IO ()
+set = do
+    mv  <- newMVar ()
+    ptr <- newStablePtr mv
+    ret <- c_set_global (castStablePtrToPtr ptr)
+    when (ret == 0) $
+        freeStablePtr ptr
+
+get :: IO (MVar ())
+get = do
+    p <- c_get_global
+    if p == nullPtr
+        then set >> get
+        else deRefStablePtr (castPtrToStablePtr p)
+
+lock :: IO a -> IO a
+lock act = get >>= flip withMVar (const act)

cbits/global-lock.c

@@ -0,0 +1,19 @@
+// Based on the global-lock package.
+
+// Atomic builtins were added in GCC 4.1.
+#if  !defined(__GNUC__) \
+  || (__GNUC__ < 4) \
+  || (__GNUC__ == 4 && __GNUC_MINOR__ < 1)
+#error global-lock requires GCC 4.1 or later.
+#endif
+
+static void* global = 0;
+
+void* hs_propane_get_global(void) {
+    return global;
+}
+
+int hs_propane_set_global(void* new_global) {
+    void* old = __sync_val_compare_and_swap(&global, 0, new_global);
+    return (old == 0);
+}

propane.cabal

@@ -42,21 +42,25 @@ library
     , Propane.IO
     , Propane.Colour
     , Propane.Transform
+  other-modules:
+      Propane.IO.Lock
+  c-sources:
+      cbits/global-lock.c
+
   ghc-options:      -Wall
   build-depends:
       base         >= 3 && < 5
     , containers   >= 0.4
     , repa         >= 2.0
     , repa-devil   >= 0.1
     , colour       >= 2.3
-    , safe-globals >= 0.1
     , directory    >= 1.1
     , filepath     >= 1.0
     , spawn        >= 0.3
 
   other-extensions:
       DeriveDataTypeable
-    , TemplateHaskell
+    , ForeignFunctionInterface
 
 source-repository head
     type:     git