From 522a92970ef407c2936c461cac53f987513d380b Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Wed, 4 Apr 2012 06:59:55 -0600
Subject: [PATCH] ffi/com: fix GC issue related to COM events

---
 collects/ffi/unsafe/com.rkt | 25 ++++++++++++++++++-------
 1 file changed, 18 insertions(+), 7 deletions(-)

diff --git a/collects/ffi/unsafe/com.rkt b/collects/ffi/unsafe/com.rkt
index 408d7b9269..ec06e34a46 100644
--- a/collects/ffi/unsafe/com.rkt
+++ b/collects/ffi/unsafe/com.rkt
@@ -479,6 +479,7 @@
                     [connection-point #:mutable]
                     [connection-cookie #:mutable]
                     [sink #:mutable]
+                    [sink-table-links #:mutable]
                     [types #:mutable]
                     [mref #:mutable])
   #:property prop:equal+hash (list
@@ -590,6 +591,7 @@
               #f
               #f
               #f
+              #f
               (make-hash)
               #f))
 
@@ -1809,13 +1811,21 @@
 (define (sink-make-scode v)
   (malloc-immobile-cell v))
 
-(define myssink-table
-  (make-MYSSINK_TABLE sink-release-handler
-                      sink-release-arg
-                      sink-apply
-                      sink-variant-to-scheme
-                      sink-unmarshal-scheme
-                      sink-make-scode))
+(define myssink-table (cast (malloc _MYSSINK_TABLE 'atomic-interior)
+                            _pointer
+                            (_gcable _MYSSINK_TABLE-pointer)))
+(define sink-table-links 
+  ;; used to ensure that everything is retained long enough:
+  (list myssink-table
+        sink-release-handler
+        sink-release-arg
+        sink-apply
+        sink-variant-to-scheme
+        sink-unmarshal-scheme
+        sink-make-scode))
+(memcpy myssink-table
+        (apply make-MYSSINK_TABLE (cdr sink-table-links))
+        (ctype-sizeof _MYSSINK_TABLE))
 
 (define (connect-com-object-to-event-sink obj)
   (or (com-object-connection-point obj)
@@ -1847,6 +1857,7 @@
         (set-com-object-connection-point! obj connection-point)
         (set-com-object-connection-cookie! obj cookie)
         (set-com-object-sink! obj sink)
+        (set-com-object-sink-table-links! obj sink-table-links)
         (Release connection-point-container)
         connection-point)))