x11: Use the GLXFBConfig to set the visual of an OpenGL canvas

Without doing this, the visual will not necessarily match that required
by GLX, which prevents certain features from working correctly, most
notably multisampling.

Author: lexi-lambda

gui-lib/mred/private/wx/gtk/gl-context.rkt

@@ -166,7 +166,6 @@
 ;; GLX #defines/typedefs/enums
 (define _GLXFBConfig (_cpointer 'GLXFBConfig))
 (define _GLXContext (_cpointer/null 'GLXContext))
-(define _XVisualInfo (_cpointer 'XVisualInfo))
 ;; Attribute tokens for glXGetConfig variants (all GLX versions):
 (define GLX_DOUBLEBUFFER     5)
 (define GLX_STEREO           6)
@@ -237,11 +236,11 @@
   (_fun _Display _GLXContext -> _bool))
 
 (define-glx glXGetVisualFromFBConfig
-  (_fun _Display _GLXFBConfig -> _XVisualInfo)
+  (_fun _Display _GLXFBConfig -> _XVisualInfo-pointer)
   #:wrap (allocator XFree))
 
 (define-glx glXCreateGLXPixmap
-  (_fun _Display _XVisualInfo _XID -> _XID))
+  (_fun _Display _XVisualInfo-pointer _XID -> _XID))
 
 (define-glx glXDestroyGLXPixmap
   (_fun _Display _XID -> _void))
@@ -573,6 +572,67 @@
   (define-values (err value) (glXGetFBConfigAttrib xdisplay cfg attrib))
   (if (= err Success) value bad-value))
 
+;; (or/c #f _GtkWidget) gl-config% boolean? -> (or/c _GLXFBConfig #f)
+(define (choose-glx-fbconfig widget conf wants-double?)
+  (define glx-version (get-glx-version))
+
+  ;; If widget isn't #f, use its display and screen
+  (define display (gtk-maybe-widget-get-display widget))
+  (define screen (gtk-maybe-widget-get-screen widget))
+
+  ;; Get the X objects wrapped by the GDK objects
+  (define xdisplay (gdk_x11_display_get_xdisplay display))
+  (define xscreen (gdk_x11_screen_get_screen_number screen))
+
+  ;; Create an attribute list using the GL config
+  (define xattribs
+    (append
+     ;; Be aware: we may get double buffering even if we don't ask for it
+     (if wants-double?
+         (if (send conf get-double-buffered) (list GLX_DOUBLEBUFFER True) null)
+         null)
+     (if (send conf get-stereo) (list GLX_STEREO True) null)
+     ;; Finish out with standard GLX 1.3 attributes
+     (list
+      GLX_X_RENDERABLE True  ; yes, we want to use OpenGL to render today
+      GLX_DEPTH_SIZE (send conf get-depth-size)
+      GLX_STENCIL_SIZE (send conf get-stencil-size)
+      GLX_ACCUM_RED_SIZE (send conf get-accum-size)
+      GLX_ACCUM_GREEN_SIZE (send conf get-accum-size)
+      GLX_ACCUM_BLUE_SIZE (send conf get-accum-size)
+      GLX_ACCUM_ALPHA_SIZE (send conf get-accum-size)
+      ;; GLX_SAMPLES is handled below - GLX regards it as an absolute lower bound, which makes it
+      ;; too easy for user programs to fail to get a context
+      None)))
+
+  (define multisample-size (send conf get-multisample-size))
+
+  ;; Get all framebuffer configs for this display and screen that match the requested attributes,
+  ;; then sort them to put the best in front
+  ;; GLX already sorts them pretty well, so we just need a stable sort on multisamples at the moment
+  (define cfgs
+    (let* ([cfgs  (cvector->list (glXChooseFBConfig xdisplay xscreen xattribs))]
+           ;; Keep all configs with multisample size <= requested (i.e. make multisample-size an
+           ;; abolute upper bound)
+           [cfgs  (if (< glx-version #e1.4)
+                      cfgs
+                      (filter (λ (cfg)
+                                (define m (glx-get-fbconfig-attrib xdisplay cfg GLX_SAMPLES 0))
+                                (<= m multisample-size))
+                              cfgs))]
+           ;; Sort all configs by multisample size, decreasing
+           [cfgs  (if (< glx-version #e1.4)
+                      cfgs
+                      (sort cfgs >
+                            #:key (λ (cfg) (glx-get-fbconfig-attrib xdisplay cfg GLX_SAMPLES 0))
+                            #:cache-keys? #t))])
+      cfgs))
+
+  ;; The framebuffer configs are sorted best-first, so choose the first
+  (if (null? cfgs)
+      #f
+      (car cfgs)))
+
 ;; (or/c #f _GtkWidget) (or/c _GdkDrawable (is-a/c bitmap%) gl-config% boolean? -> gl-context%
 ;;   where X11 uses _GdkDrawable = (or/c _GtkWindow _GdkPixmap)
 ;;         and Wayland uses bitmap% that holds a Cairo ARGB32 image surface
@@ -711,68 +771,18 @@
     ctxt]
    [else
     (define glx-version (get-glx-version))
-
-    ;; If widget isn't #f, use its display and screen
     (define display (gtk-maybe-widget-get-display widget))
-    (define screen (gtk-maybe-widget-get-screen widget))
-
-    ;; Get the X objects wrapped by the GDK objects
     (define xdisplay (gdk_x11_display_get_xdisplay display))
-    (define xscreen (gdk_x11_screen_get_screen_number screen))
-
-    ;; Create an attribute list using the GL config
-    (define xattribs
-      (append
-       ;; Be aware: we may get double buffering even if we don't ask for it
-       (if wants-double?
-           (if (send conf get-double-buffered) (list GLX_DOUBLEBUFFER True) null)
-           null)
-       (if (send conf get-stereo) (list GLX_STEREO True) null)
-       ;; Finish out with standard GLX 1.3 attributes
-       (list
-	GLX_X_RENDERABLE True  ; yes, we want to use OpenGL to render today
-	GLX_DEPTH_SIZE (send conf get-depth-size)
-	GLX_STENCIL_SIZE (send conf get-stencil-size)
-	GLX_ACCUM_RED_SIZE (send conf get-accum-size)
-	GLX_ACCUM_GREEN_SIZE (send conf get-accum-size)
-	GLX_ACCUM_BLUE_SIZE (send conf get-accum-size)
-	GLX_ACCUM_ALPHA_SIZE (send conf get-accum-size)
-	;; GLX_SAMPLES is handled below - GLX regards it as an absolute lower bound, which makes it
-	;; too easy for user programs to fail to get a context
-	None)))
-
-    (define multisample-size (send conf get-multisample-size))
-
-    ;; Get all framebuffer configs for this display and screen that match the requested attributes,
-    ;; then sort them to put the best in front
-    ;; GLX already sorts them pretty well, so we just need a stable sort on multisamples at the moment
-    (define cfgs
-      (let* ([cfgs  (cvector->list (glXChooseFBConfig xdisplay xscreen xattribs))]
-             ;; Keep all configs with multisample size <= requested (i.e. make multisample-size an
-             ;; abolute upper bound)
-             [cfgs  (if (< glx-version #e1.4)
-			cfgs
-			(filter (λ (cfg)
-                                  (define m (glx-get-fbconfig-attrib xdisplay cfg GLX_SAMPLES 0))
-                                  (<= m multisample-size))
-				cfgs))]
-             ;; Sort all configs by multisample size, decreasing
-             [cfgs  (if (< glx-version #e1.4)
-			cfgs
-			(sort cfgs >
-                              #:key (λ (cfg) (glx-get-fbconfig-attrib xdisplay cfg GLX_SAMPLES 0))
-                              #:cache-keys? #t))])
-	cfgs))
- 
+    (define cfg (choose-glx-fbconfig widget conf wants-double?))
     (cond
-     [(null? cfgs)  #f]
-     [else
-      ;; The framebuffer configs are sorted best-first, so choose the first
-      (define cfg (car cfgs))
+     [cfg
       (define share-gl
 	(let ([share-ctxt  (send conf get-share-context)])
           (and share-ctxt (send share-ctxt get-handle))))
 
+      (when (and widget (send conf get-sync-swap))
+        (glXSwapIntervalEXT xdisplay (gdk_x11_drawable_get_xid drawable) 1))
+
       ;; Get a GL context
       (define gl
 	(if (and (>= glx-version #e1.4)
@@ -788,9 +798,6 @@
       ;; If it doesn't, the context will be version 1.4 or lower, unless GLX is implemented with
       ;; proprietary extensions (NVIDIA's drivers sometimes do this)
 
-      (when (and widget (send conf get-sync-swap))
-	(glXSwapIntervalEXT xdisplay (gdk_x11_drawable_get_xid drawable) 1))
-
       ;; Now wrap the GLX context in a gl-context%
       (cond
        [gl
@@ -820,7 +827,8 @@
            (unless (and gtk3? (not widget)) (g_object_unref drawable))
            (g_object_unref display)))
         ctxt]
-       [else  #f])])]))
+       [else  #f])]
+     [else #f])]))
 
 (define (make-gtk-widget-gl-context widget conf)
   (call-as-atomic
@@ -842,7 +850,20 @@
 (define widget-config-hash (make-weak-hasheq))
 
 (define (prepare-widget-gl-context widget conf)
-  (hash-set! widget-config-hash widget (if conf conf (make-object gl-config%))))
+  (hash-set! widget-config-hash widget (if conf conf (make-object gl-config%)))
+
+  (when (and gtk_widget_set_visual (not wayland?))
+    (cond
+      [(and gtk_widget_get_realized
+            (gtk_widget_get_realized widget))
+       (log-warning "prepare-widget-gl-context: widget is already realized, cannot set visual from FBConfig")]
+      [else
+       (define cfg (choose-glx-fbconfig widget conf #t))
+       (define display (gtk-maybe-widget-get-display widget))
+       (define screen (gtk-maybe-widget-get-screen widget))
+       (define xdisplay (gdk_x11_display_get_xdisplay display))
+       (define xvisual-id (XVisualInfo-visual-id (glXGetVisualFromFBConfig xdisplay cfg)))
+       (gtk_widget_set_visual widget (gdk_x11_screen_lookup_visual screen xvisual-id))])))
 
 (define (create-widget-gl-context widget)
   (define conf (hash-ref widget-config-hash widget #f))

gui-lib/mred/private/wx/gtk/types.rkt

@@ -6,6 +6,8 @@
               _GtkWidget _GtkWindow
               _GdkDisplay
               _GdkScreen
+              _GdkVisual
+              _GdkPixmap
               _gpointer
               _GType
               _GdkEventType
@@ -49,6 +51,8 @@
 
 (define _GdkDisplay (_cpointer 'GdkDisplay))
 (define _GdkScreen (_cpointer 'GdkScreen))
+(define _GdkVisual (_cpointer 'GdkVisual))
+(define _GdkPixmap (_cpointer 'GdkPixmap))
 
 (define _gpointer _GtkWidget)
 

gui-lib/mred/private/wx/gtk/widget.rkt

@@ -1,5 +1,6 @@
 #lang racket/base
 (require ffi/unsafe
+         ffi/unsafe/define
          racket/class
          "../../syntax.rkt"
          "../../lock.rkt"
@@ -19,6 +20,8 @@
 	      gtk_widget_queue_draw
 	      gtk_widget_get_toplevel
 	      gtk_widget_translate_coordinates
+              gtk_widget_get_realized
+              gtk_widget_set_visual
 
               gtk_vbox_new
               gtk_hbox_new
@@ -42,6 +45,10 @@
 						   (x : (_ptr o _int)) (y : (_ptr o _int))
 						   -> _gboolean
 						   -> (values x y)))
+(define-gtk gtk_widget_get_realized (_fun _GtkWidget -> _gboolean)
+  #:fail (λ () #f))
+(define-gtk gtk_widget_set_visual (_fun _GtkWidget _GdkVisual -> _void)
+  #:fail (λ () #f))
 
 (define-signal-handler connect-destroy "destroy"
   (_fun _GtkWidget _pointer -> _void)

gui-lib/mred/private/wx/gtk/x11.rkt

@@ -2,6 +2,7 @@
 (require ffi/unsafe
          ffi/unsafe/define
          ffi/unsafe/alloc
+         "types.rkt"
          "utils.rkt")
 
 (provide 
@@ -19,9 +20,14 @@
               gdk_x11_display_get_xdisplay
               gdk_x11_visual_get_xvisual
               gdk_x11_screen_get_screen_number
+              gdk_x11_screen_lookup_visual
 	      gdk_x11_window_get_xid
 
 	      _Display
+              _Visual
+              _XVisualInfo
+              _XVisualInfo-pointer
+              (struct-out XVisualInfo)
 	      _Window
 	      _Pixmap
 	      XCreatePixmap
@@ -35,15 +41,23 @@
   #:default-make-fail make-not-available)
 
 (define _GdkDrawable _pointer)
-(define _GdkDisplay (_cpointer 'GdkDisplay))
-(define _GdkWindow (_cpointer 'GdkWindow))
-(define _GdkScreen (_cpointer 'GdkScreen))
-(define _GdkVisual (_cpointer 'GdkVisual))
-(define _GdkPixmap (_cpointer 'GdkPixmap))
 (define _Visual (_cpointer 'Visual))
+(define _VisualID _ulong)
 (define _Display (_cpointer 'Display))
 (define _Drawable _ulong)
 
+(define-cstruct _XVisualInfo
+  ([visual _Visual]
+   [visual-id _VisualID]
+   [screen _int]
+   [depth _int]
+   [class _int]
+   [red-mask _ulong]
+   [green-mask _ulong]
+   [blue-mask _ulong]
+   [colormap-size _int]
+   [bits-per-rgb _int]))
+
 ;; This should be `_ulong`, but we use pointers for various
 ;; reasons, including support for dealloctaors:
 (define _Window (_cpointer 'Window))
@@ -88,6 +102,9 @@
 (define-gdk gdk_x11_screen_get_screen_number (_fun _GdkScreen -> _int)
   #:make-fail make-not-available)
 
+(define-gdk gdk_x11_screen_lookup_visual (_fun _GdkScreen _VisualID -> _GdkVisual)
+  #:make-fail make-not-available)
+
 (define-x11 XFreePixmap (_fun _Display _Pixmap -> _void)
   #:wrap (deallocator cadr))
 (define-x11 XCreatePixmap (_fun _Display _Window _int _int _int -> _Pixmap)

gui-test/tests/gracket/gl-multisample.rkt

@@ -0,0 +1,13 @@
+#lang racket/gui
+(require ffi/cvector
+         sgl/gl
+         rackunit)
+
+(define gl-config (new gl-config%))
+(send gl-config set-multisample-size 4)
+
+(define f (new frame% [label ""] [width 100] [height 300]))
+(define c (new canvas% [parent f] [style '(gl no-autoclear)] [gl-config gl-config]))
+(send c with-gl-context
+      (λ ()
+        (check-equal? (cvector-ref (glGetIntegerv GL_SAMPLE_BUFFERS 1) 0) 1)))