haskell-gtk: debian/patches/gtk-thread-backport-597837.patch: Backport from 0.11.2, Closes: #597837

3 files changed, 315 insertions, 0 deletions

diff --git a/p/haskell-gtk/debian/changelog b/p/haskell-gtk/debian/changelog
index 4eab568aa..add8557a5 100644
--- a/p/haskell-gtk/debian/changelog
+++ b/p/haskell-gtk/debian/changelog
@@ -1,3 +1,10 @@
+haskell-gtk (0.11.0-5) UNRELEASED; urgency=low
+
+  * debian/patches/gtk-thread-backport-597837.patch:
+    Backport from 0.11.2, Closes: #597837
+
+ -- Joachim Breitner <nomeata@debian.org>  Sat, 02 Oct 2010 16:35:34 +0200
+
 haskell-gtk (0.11.0-4) unstable; urgency=low
 
   * Work around ghc timer issues on hppa (Closes: #590258)
diff --git a/p/haskell-gtk/debian/patches/gtk-thread-backport-597837.patch b/p/haskell-gtk/debian/patches/gtk-thread-backport-597837.patch
new file mode 100644
index 000000000..21855a2b1
--- /dev/null
+++ b/p/haskell-gtk/debian/patches/gtk-thread-backport-597837.patch
@@ -0,0 +1,307 @@
+Backport of changes in 0.11.2, closes freeze in
+http://bugs.debian.org/cgi-bin/bugreport.cgi?bug=597837
+--- gtk-0.11.0//Graphics/UI/Gtk/General/General.chs	2010-10-02 16:31:19.000000000 +0200
++++ gtk-0.11.2//Graphics/UI/Gtk/General/General.chs	2010-10-02 16:31:19.000000000 +0200
+@@ -49,6 +49,7 @@
+   mainLevel,
+   mainIteration,
+   mainIterationDo,
++  mainDoEvent,
+
+   -- * Grab widgets
+   grabAdd,
+@@ -69,8 +70,9 @@
+   idleRemove,
+   inputAdd,
+   inputRemove,
+-  IOCondition,
+-  HandlerId
++  IOCondition(..),
++  HandlerId,
++  FD
+   ) where
+
+ import System.Environment (getProgName, getArgs)
+@@ -81,8 +83,14 @@
+
+ import System.Glib.FFI
+ import System.Glib.UTFString
+-import System.Glib.MainLoop
++import qualified System.Glib.MainLoop as ML
++import System.Glib.MainLoop ( Priority, priorityLow, priorityDefaultIdle,
++  priorityHighIdle, priorityDefault, priorityHigh, timeoutRemove, idleRemove,
++  inputRemove, IOCondition(..), HandlerId )
+ import Graphics.UI.Gtk.Abstract.Object	(makeNewObject)
++import Graphics.UI.Gtk.Gdk.EventM (EventM)
++import Control.Monad.Reader (ask)
++import Control.Monad.Trans (liftIO)
+ {#import Graphics.UI.Gtk.Types#}
+
+ {#context lib="gtk" prefix ="gtk"#}
+@@ -121,7 +129,7 @@
+ --
+ --
+ -- * If you want to use Gtk2Hs and in a multi-threaded application then it is your obligation
+---   to ensure that all calls to Gtk+ happen on a single OS thread.
++--   to ensure that all calls to Gtk+ happen in a single OS thread.
+ --   If you want to make calls to Gtk2Hs functions from a Haskell thread other
+ --   than the one that calls this functions and 'mainGUI' then you will have to
+ --   \'post\' your GUI actions to the main GUI thread. You can do this using
+@@ -130,7 +138,7 @@
+ initGUI :: IO [String]
+ initGUI = do
+   when rtsSupportsBoundThreads initialiseGThreads
+-  threadsEnter
++  -- note: initizliseGThreads calls 'threadsEnter'
+   prog <- getProgName
+   args <- getArgs
+   let allArgs = (prog:args)
+@@ -173,7 +181,7 @@
+   idleAdd (action >> return False) priorityDefault
+   return ()
+
+--- | Acquired the global Gtk lock.
++-- | Acquire the global Gtk lock.
+ --
+ -- * During normal operation, this lock is held by the thread from which all
+ --   interaction with Gtk is performed. When calling 'mainGUI', the thread will
+@@ -243,6 +251,45 @@
+ mainIterationDo blocking =
+   liftM toBool $ {#call main_iteration_do#} (fromBool blocking)
+
++-- | Processes a single GDK event. This is public only to allow filtering of events between GDK and
++-- GTK+. You will not usually need to call this function directly.
++--
++-- While you should not call this function directly, you might want to know how exactly events are
++-- handled. So here is what this function does with the event:
++--
++--  1. Compress enter/leave notify events. If the event passed build an enter/leave pair together with
++--     the next event (peeked from GDK) both events are thrown away. This is to avoid a backlog of
++--     (de-)highlighting widgets crossed by the pointer.
++--
++--  2. Find the widget which got the event. If the widget can't be determined the event is thrown away
++--     unless it belongs to a INCR transaction. In that case it is passed to
++--     'selectionIncrEvent'.
++--
++--  3. Then the event is passed on a stack so you can query the currently handled event with
++--  'getCurrentEvent'.
++--
++--  4. The event is sent to a widget. If a grab is active all events for widgets that are not in the
++--     contained in the grab widget are sent to the latter with a few exceptions:
++--
++--       * Deletion and destruction events are still sent to the event widget for obvious reasons.
++--
++--       * Events which directly relate to the visual representation of the event widget.
++--
++--       * Leave events are delivered to the event widget if there was an enter event delivered to it
++--         before without the paired leave event.
++--
++--       * Drag events are not redirected because it is unclear what the semantics of that would be.
++--
++--     Another point of interest might be that all key events are first passed through the key snooper
++--     functions if there are any. Read the description of 'keySnooperInstall' if you need this
++--     feature.
++--
++--  5. After finishing the delivery the event is popped from the event stack.
++mainDoEvent :: EventM t ()
++mainDoEvent = do
++  ptr <- ask
++  liftIO $ {#call main_do_event #} (castPtr ptr)
++
+ -- | add a grab widget
+ --
+ grabAdd :: WidgetClass wd => wd -> IO ()
+@@ -260,3 +307,75 @@
+ --
+ grabRemove :: WidgetClass w => w -> IO ()
+ grabRemove  = {#call grab_remove#} . toWidget
++
++-- | Sets a function to be called at regular intervals, with the default
++-- priority 'priorityDefault'. The function is called repeatedly until it
++-- returns @False@, after which point the timeout function will not be called
++-- again. The first call to the function will be at the end of the first interval.
++--
++-- Note that timeout functions may be delayed, due to the processing of other
++-- event sources. Thus they should not be relied on for precise timing. After
++-- each call to the timeout function, the time of the next timeout is
++-- recalculated based on the current time and the given interval (it does not
++-- try to 'catch up' time lost in delays).
++--
++-- This function differs from 'ML.timeoutAdd' in that the action will
++-- be executed within the global Gtk+ lock. It is therefore possible to
++-- call Gtk+ functions from the action.
++--
++timeoutAdd :: IO Bool -> Int -> IO HandlerId
++timeoutAdd fun msec = timeoutAddFull fun priorityDefault msec
++
++-- | Sets a function to be called at regular intervals, with the given
++-- priority. The function is called repeatedly until it returns @False@, after
++-- which point the timeout function will not be called again. The first call
++-- to the function will be at the end of the first interval.
++--
++-- Note that timeout functions may be delayed, due to the processing of other
++-- event sources. Thus they should not be relied on for precise timing. After
++-- each call to the timeout function, the time of the next timeout is
++-- recalculated based on the current time and the given interval (it does not
++-- try to 'catch up' time lost in delays).
++--
++-- This function differs from 'ML.timeoutAddFull' in that the action will
++-- be executed within the global Gtk+ lock. It is therefore possible to
++-- call Gtk+ functions from the action.
++--
++timeoutAddFull :: IO Bool -> Priority -> Int -> IO HandlerId
++timeoutAddFull fun pri msec =
++  ML.timeoutAddFull (threadsEnter >> fun >>= \r -> threadsLeave >> return r)
++                    pri msec
++
++-- | Add a callback that is called whenever the system is idle.
++--
++-- * A priority can be specified via an integer. This should usually be
++--   'priorityDefaultIdle'.
++--
++-- * If the function returns @False@ it will be removed.
++--
++-- This function differs from 'ML.idleAdd' in that the action will
++-- be executed within the global Gtk+ lock. It is therefore possible to
++-- call Gtk+ functions from the action.
++--
++idleAdd :: IO Bool -> Priority -> IO HandlerId
++idleAdd fun pri =
++  ML.idleAdd (threadsEnter >> fun >>= \r -> threadsLeave >> return r) pri
++
++type FD = Int
++
++-- | Adds the file descriptor into the main event loop with the given priority.
++--
++-- This function differs from 'ML.inputAdd' in that the action will
++-- be executed within the global Gtk+ lock. It is therefore possible to
++-- call Gtk+ functions from the action.
++--
++inputAdd ::
++    FD            -- ^ a file descriptor
++ -> [IOCondition] -- ^ the condition to watch for
++ -> Priority      -- ^ the priority of the event source
++ -> IO Bool       -- ^ the function to call when the condition is satisfied.
++                  --   The function should return False if the event source
++                  --   should be removed.
++ -> IO HandlerId  -- ^ the event source id
++inputAdd fd conds pri fun =
++  ML.inputAdd fd conds pri (threadsEnter >> fun >>= \r -> threadsLeave >> return r)
+\ Kein Zeilenumbruch am Dateiende.
+--- gtk-0.11.0//Graphics/UI/Gtk/General/hsgthread.c	2010-10-02 16:31:19.000000000 +0200
++++ gtk-0.11.2//Graphics/UI/Gtk/General/hsgthread.c	2010-10-02 16:31:19.000000000 +0200
+@@ -40,7 +40,7 @@
+ #if defined( WIN32 )
+ static CRITICAL_SECTION gtk2hs_finalizer_mutex;
+ #else
+-static GStaticMutex gtk2hs_finalizer_mutex = G_STATIC_MUTEX_INIT;
++static GStaticMutex gtk2hs_finalizer_mutex;
+ #endif
+ static GSource* gtk2hs_finalizer_source;
+ static guint gtk2hs_finalizer_id;
+@@ -51,13 +51,24 @@
+ /* Initialize the threads system of Gdk and Gtk. */
+ void gtk2hs_threads_initialise (void) {
+
++#ifdef DEBUG
++  printf("gtk2hs_threads_initialise: threads_initialised=%i, g_thread_get_initialized=%i\n",
++		threads_initialised, g_thread_get_initialized());
++#endif
++
+   if (!threads_initialised) {
+     threads_initialised = 1;
+ #if defined( WIN32 )
+     InitializeCriticalSection(&gtk2hs_finalizer_mutex);
++#else
++    g_static_mutex_init(&gtk2hs_finalizer_mutex);
+ #endif
+     g_thread_init(NULL);
+     gdk_threads_init();
++
++    /* from here onwards, the Gdk lock is held */
++    gdk_threads_enter();
++
+   }
+ }
+
+@@ -66,6 +77,12 @@
+
+   int mutex_locked = 0;
+   if (threads_initialised) {
++#ifdef DEBUG
++      printf("acquiring lock to add a %s object at %lx\n",
++             g_type_name(G_OBJECT_TYPE(object)), (unsigned long) object);
++      printf("value of lock function is %lx\n",
++             (unsigned long) g_thread_functions_for_glib_use.mutex_lock);
++#endif
+ #if defined( WIN32 )
+     EnterCriticalSection(&gtk2hs_finalizer_mutex);
+ #else
+@@ -75,7 +92,8 @@
+   }
+
+ #ifdef DEBUG
+-  printf("adding finalizer!\n");
++  if (mutex_locked) printf("within mutex: ");
++  printf("adding finalizer to a %s object!\n", g_type_name(G_OBJECT_TYPE(object)));
+ #endif
+
+   /* Ensure that the idle handler is still installed and that
+@@ -84,8 +102,14 @@
+
+     if (gtk2hs_finalizers == NULL)
+       gtk2hs_finalizers = g_array_new(0, 0, sizeof(gpointer));
++#ifdef DEBUG
++    printf("creating finalizer list.\n");
++#endif
+
+     if (gtk2hs_finalizer_source != NULL) {
++#ifdef DEBUG
++      printf("re-initializing finalizer source.\n");
++#endif
+       g_source_destroy(gtk2hs_finalizer_source);
+       g_source_unref(gtk2hs_finalizer_source);
+     };
+@@ -100,6 +124,10 @@
+   g_array_append_val(gtk2hs_finalizers, object);
+
+   if (mutex_locked) {
++#ifdef DEBUG
++    printf("releasing lock to add a %s object at %lx\n",
++           g_type_name(G_OBJECT_TYPE(object)), (unsigned long) object);
++#endif
+ #if defined( WIN32 )
+     LeaveCriticalSection(&gtk2hs_finalizer_mutex);
+ #else
+@@ -113,8 +141,13 @@
+   gint index;
+   g_assert(gtk2hs_finalizers!=NULL);
+
++  gdk_threads_enter();
++
+   int mutex_locked = 0;
+   if (threads_initialised) {
++#ifdef DEBUG
++    printf("acquiring lock to kill objects\n");
++#endif
+ #if defined( WIN32 )
+     EnterCriticalSection(&gtk2hs_finalizer_mutex);
+ #else
+@@ -135,6 +168,9 @@
+   gtk2hs_finalizer_id = 0;
+
+   if (mutex_locked) {
++#ifdef DEBUG
++    printf("releasing lock to kill objects\n");
++#endif
+ #if defined( WIN32 )
+     LeaveCriticalSection(&gtk2hs_finalizer_mutex);
+ #else
+@@ -142,6 +178,8 @@
+ #endif
+   }
+
++  gdk_threads_leave();
++
+   return FALSE;
+ }
diff --git a/p/haskell-gtk/debian/patches/series b/p/haskell-gtk/debian/patches/series
index 58db47099..fbf7a4e1a 100644
--- a/p/haskell-gtk/debian/patches/series
+++ b/p/haskell-gtk/debian/patches/series
@@ -1 +1,2 @@
 utf8.patch
+gtk-thread-backport-597837.patch