From de783c8378f27765c8e554b9b8b14fa27e66f635 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Tue, 6 Jan 2015 19:54:21 -0700
Subject: [PATCH] avoid crashing via GCed `racket/gui` instance

---
 gui-lib/mred/private/wx/cocoa/queue.rkt         |  4 +++-
 gui-lib/mred/private/wx/common/keep-forever.rkt | 12 ++++++++++++
 gui-lib/mred/private/wx/common/queue.rkt        |  5 ++++-
 gui-lib/mred/private/wx/gtk/queue.rkt           |  5 ++++-
 4 files changed, 23 insertions(+), 3 deletions(-)
 create mode 100644 gui-lib/mred/private/wx/common/keep-forever.rkt

diff --git a/gui-lib/mred/private/wx/cocoa/queue.rkt b/gui-lib/mred/private/wx/cocoa/queue.rkt
index 796caa3c..ac45423f 100644
--- a/gui-lib/mred/private/wx/cocoa/queue.rkt
+++ b/gui-lib/mred/private/wx/cocoa/queue.rkt
@@ -10,7 +10,8 @@
          "../common/queue.rkt"
          "../common/handlers.rkt"
          "../../lock.rkt"
-         "../common/freeze.rkt")
+         "../common/freeze.rkt"
+         "../common/keep-forever.rkt")
 
 (provide 
  (protect-out app
@@ -486,3 +487,4 @@
   (post-dummy-event) ; why do we need this? 'nextEventMatchingMask:' seems to hang if we don't use it
   (scheme_set_place_sleep (function-ptr sleep-until-event 
                                         (_fun #:atomic? #t _float _gcpointer -> _void))))
+(keep-forever sleep-until-event)
diff --git a/gui-lib/mred/private/wx/common/keep-forever.rkt b/gui-lib/mred/private/wx/common/keep-forever.rkt
new file mode 100644
index 00000000..df437434
--- /dev/null
+++ b/gui-lib/mred/private/wx/common/keep-forever.rkt
@@ -0,0 +1,12 @@
+#lang racket/base
+(require ffi/unsafe)
+
+(provide (protect-out keep-forever))
+
+(define forever (box null))
+
+;; Keeps as long as the place runs, at least:
+(void (malloc-immobile-cell forever))
+
+(define (keep-forever v)
+  (set-box! forever (cons v (unbox forever))))
diff --git a/gui-lib/mred/private/wx/common/queue.rkt b/gui-lib/mred/private/wx/common/queue.rkt
index b445134e..04267ff4 100644
--- a/gui-lib/mred/private/wx/common/queue.rkt
+++ b/gui-lib/mred/private/wx/common/queue.rkt
@@ -7,7 +7,8 @@
          "rbtree.rkt"
          "../../lock.rkt"
          "handlers.rkt"
-         "once.rkt")
+         "once.rkt"
+         "keep-forever.rkt")
 
 (provide 
  (protect-out queue-evt
@@ -86,6 +87,8 @@
 (define (queue-wakeup o fds)
   (do-queue-wakeup fds))
 (scheme_add_evt event-queue-type check-queue queue-wakeup #f 0)
+(keep-forever check-queue)
+(keep-forever queue-wakeup)
 (define queue-evt (let ([p (malloc 16)]
                         [p2 (malloc 'nonatomic _pointer)])
                     (memset p 0 16)
diff --git a/gui-lib/mred/private/wx/gtk/queue.rkt b/gui-lib/mred/private/wx/gtk/queue.rkt
index 9f6a0d62..9e2d28c0 100644
--- a/gui-lib/mred/private/wx/gtk/queue.rkt
+++ b/gui-lib/mred/private/wx/gtk/queue.rkt
@@ -9,7 +9,8 @@
          "clipboard.rkt"
          "const.rkt"
 	 "w32.rkt"
-         "unique.rkt")
+         "unique.rkt"
+         "../common/keep-forever.rkt")
 
 (provide (protect-out gtk-start-event-pump
                       try-to-sync-refresh
@@ -203,6 +204,8 @@
 (gdk_event_handler_set event-dispatch
                        #f
                        uninstall)
+(keep-forever event-dispatch)
+(keep-forever uninstall)
 
 (define (dispatch-all-ready)
   (pre-event-sync #f)