OpenGL context sharing

collects/mred/private/wx/cocoa/agl.rkt

@@ -70,6 +70,9 @@
       (class orig-gl-context%
         (init-field agl)
 
+        (define/override (get-handle)
+          agl)
+        
         (define/override (do-call-as-current t)
           (dynamic-wind
               (lambda () 
@@ -107,7 +110,9 @@
     bitmap%))
 
 (define (create-gl-bitmap w h conf)
-  (let ([fmt (aglChoosePixelFormat
+  (let* ([share-context (send conf get-share-context)]
+         [context-handle (if share-context (send share-context get-handle) #f)]
+         [fmt (aglChoosePixelFormat
               #f
               0
               (append
@@ -132,9 +137,9 @@
                            AGL_SAMPLES_ARB ms)))
                (list AGL_NONE)))])
     (and fmt
-         (let ([agl (aglCreateContext fmt #f)]
+         (let ([agl (aglCreateContext fmt context-handle)]
                [d-agl (or dummy-agl
-                          (let ([d (aglCreateContext fmt #f)])
+                          (let ([d (aglCreateContext fmt context-handle)])
                             (when d
                               (set! dummy-agl d)
                               d)))])

collects/mred/private/wx/cocoa/canvas.rkt

@@ -35,7 +35,7 @@
 
 (import-class NSView NSGraphicsContext NSScroller NSComboBox NSWindow 
               NSImageView NSTextFieldCell 
-              NSOpenGLView NSOpenGLPixelFormat)
+              NSOpenGLView NSOpenGLContext NSOpenGLPixelFormat)
 
 (import-protocol NSComboBoxDelegate)
 
@@ -354,12 +354,25 @@
               (tell (tell (if is-combo? RacketComboBox RacketView)
                           alloc)
                     initWithFrame: #:type _NSRect r)
-              (let ([pf (gl-config->pixel-format gl-config)])
+              (let* ([share-context (send gl-config get-share-context)]
-                (begin0
+                     [context-handle (and share-context (send share-context get-handle))]
-                 (tell (tell RacketGLView alloc) 
+                     [pf (gl-config->pixel-format gl-config)]
-                       initWithFrame: #:type _NSRect r
+                     [new-context (and
-                       pixelFormat: pf)
+                                   context-handle
-                 (tellv pf release)))))))
+                                   (tell (tell NSOpenGLContext alloc)
+                                         initWithFormat: pf
+                                         shareContext: context-handle))]
+                     [gl-view (tell (tell RacketGLView alloc)
+                                    initWithFrame: #:type _NSRect r
+                                    pixelFormat: pf)])
+                (when new-context
+                  (tellv gl-view setOpenGLContext: new-context)
+                  ;; We're supposed to sync via `setView:' but it fails,
+                  ;; perhaps because the view isn't yet visible:
+                  ;;   (tellv new-context setView: gl-view)
+                  (tellv new-context release))
+                (tellv pf release)
+                gl-view)))))
      (tell #:type _void cocoa addSubview: content-cocoa)
      (set-ivar! content-cocoa wxb (->wxb this))
 

collects/mred/private/wx/cocoa/dc.rkt

@@ -36,6 +36,7 @@
            (let ([gl-ctx (tell (send canvas get-cocoa-content) openGLContext)])
              (or gl
                  (let ([g (new (class gl-context%
+                                 (define/override (get-handle) gl-ctx)
                                  (define/override (do-call-as-current t)
                                    (dynamic-wind
                                        (lambda () (tellv gl-ctx makeCurrentContext))

collects/mred/private/wx/gtk/gl-context.rkt

@@ -123,6 +123,8 @@
     (init-field [gl gl]
                 [drawable drawable])
 
+    (define/override (get-handle) gl)
+
     (define/override (draw:do-call-as-current t)
       (dynamic-wind
           (lambda ()
@@ -146,14 +148,17 @@
 
 (define (prepare-widget-gl-context gtk config)
   (init!)
-  (let ([config (config->GdkGLConfig #f ; (gtk_widget_get_screen gtk)
+  (let ([share-context (send config get-share-context)]
+        [config (config->GdkGLConfig #f ; (gtk_widget_get_screen gtk)
                                      (or config
                                          (new gl-config%))
                                      #t)])
     (when config
 	  (gtk_widget_set_gl_capability gtk
 					config
-					#f
+					(if share-context
+                                            (send share-context get-handle)
+                                            #f)
 					#t
 					0))))
 
@@ -172,7 +177,9 @@
 
 (define (create-and-install-gl-context bm config)
   (init!)
-  (let ([config (config->GdkGLConfig #f config #f)])
+  (let* ([share-context (send config get-share-context)]
+         [context-handle (if share-context (send share-context get-handle) #f)]
+         [config (config->GdkGLConfig #f config #f)])
     (when config
       (let ([gdkpx (send bm get-gdk-pixmap)])
         (let ([glpx (gdk_pixmap_set_gl_capability gdkpx config #f)])
@@ -180,7 +187,7 @@
                (let ([gl
 		      ;; currently uses "indirect" mode --- can we
 		      ;; reliably use direct in some environments?
-		      (gdk_gl_context_new glpx #f #f GDK_GL_RGBA_TYPE)])
+		      (gdk_gl_context_new glpx context-handle #f GDK_GL_RGBA_TYPE)])
                  (and gl
                       (send bm install-gl-context
 			    (new gl-context% 

collects/mred/private/wx/win32/gl-context.rkt

@@ -71,6 +71,9 @@
 (define tried-multisample? #f)
 (define wglChoosePixelFormatARB #f)
 
+(define looked-for-createcontextattribs? #f)
+(define wglCreateContextAttribsARB #f)
+
 ;; ----------------------------------------
 
 (define gl-context% 
@@ -78,6 +81,8 @@
     (init-field [hglrc hglrc]
                 [hdc hdc])
 
+    (define/override (get-handle) hglrc)
+
     (define/override (draw:do-call-as-current t)
       (dynamic-wind
           (lambda ()
@@ -119,6 +124,7 @@
 (define (create-gl-context hdc config offscreen? 
                            #:try-ms? [try-ms? (not offscreen?)])
   (when try-ms? (unless tried-multisample? (init-multisample! config)))
+  (unless looked-for-createcontextattribs? (init-createcontextattribs! config))
   (let* ([config (or config (new gl-config%))]
          [accum (send config get-accum-size)]
          [pfd
@@ -156,7 +162,9 @@
 			    wglChoosePixelFormatARB 
 			    (or (choose-multisample hdc config offscreen? ms)
 				(choose-multisample hdc config offscreen? 2)))
-		       (ChoosePixelFormat hdc pfd))])
+		       (ChoosePixelFormat hdc pfd))]
+         [share-context (send config get-share-context)]
+         [context-handle (if share-context (send share-context get-handle) #f)])
     (and (not (zero? pixelFormat))
 	 (and (SetPixelFormat hdc pixelFormat pfd)
 	      (begin
@@ -164,20 +172,18 @@
 		(when (not (zero? (bitwise-and (PIXELFORMATDESCRIPTOR-dwFlags pfd)
 					       PFD_NEED_PALETTE)))
 		      (log-error "don't know how to create a GL palette, yet"))
-		(let ([hglrc (wglCreateContext hdc)])
+		(let ([hglrc (if wglCreateContextAttribsARB
+                                 (wglCreateContextAttribsARB hdc context-handle (vector 0))
+                                 (wglCreateContext hdc))])
 		  (and hglrc
 		       (new gl-context% [hglrc hglrc] [hdc hdc]))))))))
 
-(define (init-multisample! config)
+(define (with-dummy-context config thunk)
-  ;; To create a multisampled context, we need
-  ;; wglChoosePixelFormatARB().
-  ;; To look up wglChoosePixelFormatARB(), we need
-  ;; an existing gl context.
   ;; To create a gl context, we need a separate window 
   ;; (because you can't change a window's pixel format
   ;; after it is set).
   ;; So, create a dummy window to make a context to
-  ;; try to get wglChoosePixelFormatARB().
+  ;; try to do whatever needs doing.
   (let ([hwnd (CreateWindowExW 0
 			       "PLTFrame"
 			       ""
@@ -194,20 +200,43 @@
 	    (call-with-context
 	     (get-field hdc c)
 	     (get-field hglrc c)
-	     (lambda ()
+             thunk)))
-	       (set! wglChoosePixelFormatARB
+        (ReleaseDC hwnd hdc)))))
-		     (let ([f (wglGetProcAddress "wglChoosePixelFormatARB")])
+
-		       (and f
+(define (init-createcontextattribs! config)
-			    (function-ptr f (_wfun _HDC 
+  ;; look for wglCreateContextAttribsARB which is a beefed
-						   (_vector i _int)
+  ;; up version of wglCreateContext
-						   (_vector i _float)
+  (set! looked-for-createcontextattribs? #t)
-						   (_UINT  = 1)
+  (with-dummy-context config
-						   (formats : (_ptr o _int))
+    (lambda ()
-						   (num-formats : (_ptr o _UINT))
+      (set! wglCreateContextAttribsARB
-						   -> (r : _BOOL)
+            (let ([f (wglGetProcAddress "wglCreateContextAttribsARB")])
-						   -> (and r formats))))))
+              (and f
-	       (set! tried-multisample? #t)))))
+                   ((allocator wglDeleteContext)
-	(ReleaseDC hwnd hdc)))))
+                    (function-ptr f (_wfun _HDC
+                                           _HGLRC
+                                           (_vector i _int)
+                                           -> _HGLRC)))))))))
+
+(define (init-multisample! config)
+  ;; To create a multisampled context, we need
+  ;; wglChoosePixelFormatARB().
+  ;; To look up wglChoosePixelFormatARB(), we need
+  ;; an existing gl context.
+  (with-dummy-context config
+    (lambda ()
+      (set! wglChoosePixelFormatARB
+            (let ([f (wglGetProcAddress "wglChoosePixelFormatARB")])
+              (and f
+                   (function-ptr f (_wfun _HDC 
+                                          (_vector i _int)
+                                          (_vector i _float)
+                                          (_UINT  = 1)
+                                          (formats : (_ptr o _int))
+                                          (num-formats : (_ptr o _UINT))
+                                          -> (r : _BOOL)
+                                          -> (and r formats))))))
+      (set! tried-multisample? #t))))
 
 (define GL_TRUE 1)
 (define GL_FALSE 0)

collects/racket/draw/private/contract.rkt

@@ -392,7 +392,8 @@
     (set-double-buffered (->m any/c void?))
     (set-multisample-size (->m (integer-in 0 256) void?))
     (set-stencil-size (->m (integer-in 0 256) void?))
-    (set-stereo (->m any/c void?))))
+    (set-stereo (->m any/c void?))
+    (set-share-context (->m (or/c (is-a?/c gl-context%) #f) void?))))
 
 (define bitmap%/c
   (class/c

collects/racket/draw/private/gl-config.rkt

@@ -33,4 +33,9 @@
   (define multisample-size 0)
   (define/public (get-multisample-size) multisample-size)
   (define/public (set-multisample-size s)
-    (set! multisample-size s)))
+    (set! multisample-size s))
+
+  (define share-context #f)
+  (define/public (get-share-context) share-context)
+  (define/public (set-share-context s)
+    (set! share-context s)))

collects/racket/draw/private/gl-context.rkt

@@ -41,7 +41,8 @@
   (interface ()
     [call-as-current (->*m [(-> any)] [evt? any/c] any)]
     [ok? (->m boolean?)]
-    [swap-buffers (->m any)]))
+    [swap-buffers (->m any)]
+    [get-handle (->m any)]))
 
 ;; Implemented by subclasses:
 (define gl-context%
@@ -63,6 +64,9 @@
                                  (channel-put ch #t))))))
            alternate-evt)))
 
+    (define/public (get-handle)
+      #f)
+    
     (define/public (call-as-current t [alternate-evt never-evt] [enable-breaks? #f])
       (with-gl-lock
        (lambda ()

collects/scribblings/draw/gl-config-class.scrbl

@@ -49,6 +49,18 @@ Reports the multisampling size that the configuration requests, where
 
 }
 
+@defmethod[(get-share-context)
+           (or/c #f (is-a?/c gl-context<%>))]{
+
+Returns a @racket[gl-context<%>] object that shares certain objects
+(textures, display lists, etc.) with newly created OpenGL drawing
+contexts, or @racket[#f] is none is set.
+
+See also @method[gl-config% set-share-context].
+
+}
+          
+
 @defmethod[(get-stencil-size)
            (integer-in 0 256)]{
 
@@ -97,6 +109,27 @@ Adjusts the configuration to request a particular multisample size,
 
 }
 
+@defmethod[(set-share-context [context (or/c #f (is-a?/c gl-context<%>))])
+           void?]{
+
+Determines a @racket[gl-context<%>] object that shares certain objects
+(textures, display lists, etc.) with newly created OpenGL drawing
+contexts, where @racket[#f] indicates
+that no sharing should occur.
+
+When a context @racket[_B] shares objects with context @racket[_A], it
+is also shares objects with every other context sharing with
+@racket[_A], and vice versa.
+
+If an OpenGL implementation does not support sharing, @racket[context]
+is effectively ignored when a new context is created.
+Sharing should be supported in all versions of Mac OS X.
+On Windows and Linux, sharing is provided by the presence of the
+@tt{WGL_ARB_create_context} and @tt{GLX_ARB_create_context} extensions,
+respectively (and OpenGL 3.2 requires both).
+
+}
+
 @defmethod[(set-stencil-size [on? (integer-in 0 256)])
            void?]{
 

collects/scribblings/draw/gl-context-intf.scrbl

@@ -1,5 +1,6 @@
 #lang scribble/doc
-@(require "common.rkt")
+@(require "common.rkt"
+          (for-label (only-in ffi/unsafe cpointer?)))
 
 @definterface/title[gl-context<%> ()]{
 
@@ -76,6 +77,22 @@ If @racket[enable-breaks?] is true, then the method uses
 
 }
 
+@defmethod[(get-handle) cpointer?]{
+
+Returns a handle to the platform's underlying context. The value that the
+pointer represents depends on the platform:
+
+@itemize[
+@item{Windows: @tt{HGLRC}}
+@item{Mac OS X: @tt{NSOpenGLContext}}
+@item{Unix: @tt{GdkGLContext}}
+]
+
+Note that these values are not necessary the most ``low-level'' context objects,
+but are instead the ones useful to Racket. A @tt{NSOpenGLContext} wraps a
+@tt{CGLContextObj}, and a @tt{GdkGLContext} contains a @tt{GLXcontext}.
+}
+
 @defmethod[(ok?)
            boolean?]{