1#lang racket/base
2(require racket/class
3         racket/promise
4         racket/string
5         ffi/unsafe
6         ffi/unsafe/define
7         ffi/unsafe/alloc
8         ffi/cvector
9         (prefix-in draw: racket/draw/private/gl-context)
10         racket/draw/private/gl-config
11         "../../lock.rkt"
12         "types.rkt"
13         "utils.rkt"
14         "window.rkt"
15         "x11.rkt")
16
17(provide
18 (protect-out prepare-widget-gl-context
19              create-widget-gl-context
20
21              create-and-install-gl-context
22              get-gdk-pixmap
23              install-gl-context))
24
25(define (ffi-lib/complaint-on-failure name vers)
26  (ffi-lib name vers
27           #:fail (lambda ()
28                    (log-warning "could not load library ~a ~a"
29                                 name vers)
30                    #f)))
31
32;; ===================================================================================================
33;; X11/GLX FFI
34
35(define gl-lib (ffi-lib/complaint-on-failure "libGL" '("1" "")))
36
37(define-ffi-definer define-glx gl-lib
38  #:default-make-fail make-not-available)
39
40;; X #defines/typedefs/enums
41(define _Display (_cpointer 'Display))
42(define _XErrorEvent (_cpointer 'XErrorEvent))
43(define _XID _ulong)
44(define True 1)
45(define False 0)
46(define None 0)
47(define Success 0)
48
49;; GLX #defines/typedefs/enums
50(define _GLXFBConfig (_cpointer 'GLXFBConfig))
51(define _GLXContext (_cpointer/null 'GLXContext))
52(define _XVisualInfo (_cpointer 'XVisualInfo))
53;; Attribute tokens for glXGetConfig variants (all GLX versions):
54(define GLX_DOUBLEBUFFER     5)
55(define GLX_STEREO           6)
56(define GLX_DEPTH_SIZE       12)
57(define GLX_STENCIL_SIZE     13)
58(define GLX_ACCUM_RED_SIZE   14)
59(define GLX_ACCUM_GREEN_SIZE 15)
60(define GLX_ACCUM_BLUE_SIZE  16)
61(define GLX_ACCUM_ALPHA_SIZE 17)
62;; GLX 1.3 and later:
63(define GLX_X_RENDERABLE     #x8012)
64(define GLX_RGBA_TYPE        #x8014)
65;; GLX 1.4 and later:
66(define GLX_SAMPLES          #x186a1)
67(define GLX_SAMPLE_BUFFERS   #x186a0)
68;; Attribute tokens for glXCreateContextAttribsARB (also GLX 1.4 and later):
69(define GLX_CONTEXT_MAJOR_VERSION_ARB #x2091)
70(define GLX_CONTEXT_MINOR_VERSION_ARB #x2092)
71(define GLX_CONTEXT_FLAGS_ARB         #x2094)
72(define GLX_CONTEXT_PROFILE_MASK_ARB  #x9126)
73;; GLX_CONTEXT_FLAGS_ARB bits
74(define GLX_CONTEXT_DEBUG_BIT_ARB              #x1)
75(define GLX_CONTEXT_FORWARD_COMPATIBLE_BIT_ARB #x2)
76;; GLX_CONTEXT_PROFILE_MASK_ARB bits
77(define GLX_CONTEXT_CORE_PROFILE_BIT_ARB          #x1)
78(define GLX_CONTEXT_COMPATIBILITY_PROFILE_BIT_ARB #x2)
79
80(define-x11 XFree (_fun _pointer -> _int)
81  #:wrap (deallocator))
82
83(define-x11 XSetErrorHandler
84  (_fun _fpointer -> _fpointer))
85
86(define-x11 XSync
87  (_fun _Display _int -> _void))
88
89(define-glx glXQueryVersion
90  (_fun _Display (major : (_ptr o _int)) (minor : (_ptr o _int))
91        -> (ret : _bool)
92        -> (values ret major minor)))
93
94(define-glx glXQueryExtensionsString
95  (_fun _Display _int -> _string/utf-8))
96
97(define-glx glXChooseFBConfig
98  (_fun _Display _int (_list i _int) (len : (_ptr o _int))
99        -> (_cvector o _GLXFBConfig len))
100  #:wrap (allocator (λ (v) (XFree (cvector-ptr v)))))
101
102(define-glx glXGetFBConfigAttrib
103  (_fun _Display _GLXFBConfig _int (out : (_ptr o _int))
104        -> (ret : _int)
105        -> (values ret out)))
106
107(define-glx glXCreateNewContext
108  (_fun _Display _GLXFBConfig _int _GLXContext _bool -> _GLXContext))
109
110(define-glx glXDestroyContext
111  (_fun _Display _GLXContext -> _void))
112
113(define-glx glXMakeCurrent
114  (_fun _Display _XID _GLXContext -> _bool))
115
116(define-glx glXSwapBuffers
117  (_fun _Display _XID -> _void))
118
119(define-glx glXIsDirect
120  (_fun _Display _GLXContext -> _bool))
121
122(define-glx glXGetVisualFromFBConfig
123  (_fun _Display _GLXFBConfig -> _XVisualInfo)
124  #:wrap (allocator XFree))
125
126(define-glx glXCreateGLXPixmap
127  (_fun _Display _XVisualInfo _XID -> _XID))
128
129(define-glx glXDestroyGLXPixmap
130  (_fun _Display _XID -> _void))
131
132(define-glx glXGetProcAddressARB
133  (_fun _string -> _pointer))
134
135(define lazy-glXCreateContextAttribsARB
136  (delay
137    (function-ptr (glXGetProcAddressARB "glXCreateContextAttribsARB")
138                  (_fun _Display _GLXFBConfig _GLXContext _bool (_list i _int)
139                        -> _GLXContext))))
140
141(define (glXCreateContextAttribsARB . args)
142  (apply (force lazy-glXCreateContextAttribsARB) args))
143
144(define-gtk gtk_widget_get_display (_fun _GtkWidget -> _GdkDisplay))
145(define-gtk gtk_widget_get_screen (_fun _GtkWidget -> _GdkScreen))
146
147(define-glx glXSwapIntervalEXT (_fun _Display _XID _int -> _void)
148  #:fail (lambda () void))
149
150;; ===================================================================================================
151;; GLX versions and extensions queries
152
153(define lazy-get-glx-version
154  (delay
155    (define-values (worked? glx-major glx-minor)
156      (glXQueryVersion (gdk_x11_display_get_xdisplay (gdk_display_get_default))))
157
158    (unless worked?
159      (error 'get-glx-version "can't get GLX version using default display"))
160
161    (define glx-version (+ glx-major (/ glx-minor 10)))
162
163    (when (< glx-version #e1.3)
164      (error 'get-glx-version "need GLX version 1.3 or greater; given version ~a.~a"
165             glx-major glx-minor))
166
167    glx-version))
168
169;; -> positive-exact-rational
170(define (get-glx-version)
171  (force lazy-get-glx-version))
172
173(define lazy-glx-extensions
174  (delay
175    (define str
176      (glXQueryExtensionsString (gdk_x11_display_get_xdisplay (gdk_display_get_default))
177                                (gdk_x11_screen_get_screen_number (gdk_screen_get_default))))
178    (string-split str)))
179
180(define lazy-GLX_ARB_create_context?
181  (delay (member "GLX_ARB_create_context"
182                 (force lazy-glx-extensions))))
183
184(define lazy-GLX_ARB_create_context_profile?
185  (delay (member "GLX_ARB_create_context_profile"
186                 (force lazy-glx-extensions))))
187
188;; ===================================================================================================
189;; Wrapper for the _GLXContext (if we can get one from GLX)
190
191(define gl-context%
192  (class draw:gl-context%
193    (init-field gl display drawable pixmap)
194
195    (define/override (get-handle) gl)
196
197    (define/public (get-gtk-display) display)
198    (define/public (get-gtk-drawable) drawable)
199    (define/public (get-glx-pixmap) pixmap)
200
201    (define (get-drawable-xid)
202      (if pixmap pixmap (gdk_x11_drawable_get_xid drawable)))
203
204    (define/override (draw:do-call-as-current t)
205      (define xdisplay (gdk_x11_display_get_xdisplay display))
206      (dynamic-wind
207       (lambda ()
208         (glXMakeCurrent xdisplay (get-drawable-xid) gl))
209       t
210       (lambda ()
211         (glXMakeCurrent xdisplay 0 #f))))
212
213    (define/override (draw:do-swap-buffers)
214      (glXSwapBuffers (gdk_x11_display_get_xdisplay display)
215                      (get-drawable-xid)))
216
217    (super-new)))
218
219;; ===================================================================================================
220;; Getting OpenGL contexts
221
222;; STUPIDITY ALERT
223
224;; Apparently, the designers of glXCreateNewContext and glXCreateContextAttribsARB didn't trust us to
225;; check return values or output arguments, so when these functions fail, they raise an X error and
226;; send an error code to the X error handler. X errors, by default, *terminate the program* and print
227;; an annoyingly vague, barely helpful error message.
228
229;; This is especially bad with glXCreateContextAttribsARB, which always fails (i.e. crashes the
230;; program) if we ask for an unsupported OpenGL version. Worse, this is the only way to find out
231;; which OpenGL versions are available!
232
233;; So we override the X error handler to silently fail, and sync right after the calls to make sure
234;; the errors are processed immediately. With glXCreateContextAttribsARB, we then try the next lowest
235;; OpenGL version. If all attempts to get a context fail, we return #f.
236
237(define create-context-error? #f)
238(define (flag-x-error-handler xdisplay xerrorevent)
239  (set! create-context-error? #t)
240  0)
241
242;; _Display _GLXFBConfig _GLXContext -> _GLXContext
243(define (glx-create-new-context xdisplay cfg share-gl)
244  ;; Sync right now, or the sync further on could crash Racket with an [xcb] error about events
245  ;; happening out of sequence
246  (XSync xdisplay False)
247
248  (define old-handler #f)
249  (define gl
250    (dynamic-wind
251     (λ ()
252       (set! old-handler
253             (XSetErrorHandler
254              (cast flag-x-error-handler
255                    (_fun #:atomic? #t _Display _XErrorEvent -> _int)
256                    _fpointer))))
257     (λ ()
258       (set! create-context-error? #f)
259       (glXCreateNewContext xdisplay cfg GLX_RGBA_TYPE share-gl #t))
260     (λ ()
261       ;; Sync to ensure errors are processed
262       (XSync xdisplay False)
263       (XSetErrorHandler old-handler))))
264
265  (cond
266    [(and gl create-context-error?)
267     (log-error (string-append
268		 "gl-context: glXCreateNewContext raised an error but (contrary to standards)"
269		 " returned a non-NULL context; ignoring possibly corrupt context"))
270     #f]
271    [else
272     (unless gl
273       (log-warning "gl-context: glXCreateNewContext was unable to get an OpenGL context"))
274     gl]))
275
276;; OpenGL core versions we'll try to get, in order
277(define core-gl-versions '((4 5) (4 4) (4 3) (4 2) (4 1) (4 0) (3 3) (3 2) (3 1) (3 0)))
278
279;; _Display _GLXFBConfig _GLXContext (List Byte Byte) -> _GLXContext
280(define (glx-create-context-attribs xdisplay cfg share-gl gl-version)
281  ;; Sync right now, or the sync further on could crash Racket with an [xcb] error about events
282  ;; happening out of sequence
283  (XSync xdisplay False)
284
285  (define gl-major (car gl-version))
286  (define gl-minor (cadr gl-version))
287  (define context-attribs
288    (list GLX_CONTEXT_MAJOR_VERSION_ARB gl-major
289          GLX_CONTEXT_MINOR_VERSION_ARB gl-minor
290          GLX_CONTEXT_PROFILE_MASK_ARB GLX_CONTEXT_CORE_PROFILE_BIT_ARB
291          None))
292
293  (define old-handler #f)
294  (define gl
295    (dynamic-wind
296     (λ ()
297       (set! old-handler
298             (XSetErrorHandler
299              (cast flag-x-error-handler
300                    (_fun #:atomic? #t _Display _XErrorEvent -> _int)
301                    _fpointer))))
302     (λ ()
303       (set! create-context-error? #f)
304       (glXCreateContextAttribsARB xdisplay cfg share-gl #t context-attribs))
305     (λ ()
306       ;; Sync to ensure errors are processed
307       (XSync xdisplay False)
308       (XSetErrorHandler old-handler))))
309
310  (cond
311    [(and gl create-context-error?)
312     (log-error (string-append
313		 "gl-context: glXCreateContextAttribsARB raised an error for version ~a.~a but"
314		 " (contrary to standards) returned a non-NULL context;"
315		 " ignoring possibly corrupt context")
316                gl-major gl-minor)
317     #f]
318    [else
319     (unless gl
320       (log-info "gl-context: glXCreateContextAttribsARB returned NULL for version ~a.~a"
321                 gl-major gl-minor))
322     gl]))
323
324;; _Display _GLXFBConfig _GLXContext -> _GLXContext
325(define (glx-create-core-context xdisplay cfg share-gl)
326  (let/ec return
327    (for ([gl-version  (in-list core-gl-versions)])
328      (define gl (glx-create-context-attribs xdisplay cfg share-gl gl-version))
329      (when gl (return gl)))
330    (log-warning "gl-context: unable to get core context; falling back")
331    (glx-create-new-context xdisplay cfg share-gl)))
332
333;; ===================================================================================================
334
335;; (or/c #f _GtkWidget) -> _GdkDisplay
336(define (gtk-maybe-widget-get-display widget)
337  (cond [widget  (gtk_widget_get_display widget)]
338        [else    (gdk_display_get_default)]))
339
340;; (or/c #f _GtkWidget) -> _GdkScreen
341(define (gtk-maybe-widget-get-screen widget)
342  (cond [widget  (gtk_widget_get_screen widget)]
343        [else    (gdk_screen_get_default)]))
344
345;; _Display _GLXFBConfig int int -> int
346(define (glx-get-fbconfig-attrib xdisplay cfg attrib bad-value)
347  (define-values (err value) (glXGetFBConfigAttrib xdisplay cfg attrib))
348  (if (= err Success) value bad-value))
349
350;; (or/c #f _GtkWidget) _GdkDrawable gl-config% boolean? -> gl-context%
351;;   where _GdkDrawable = (or/c _GtkWindow _GdkPixmap)
352(define (make-gtk-drawable-gl-context widget drawable conf wants-double?)
353  (define glx-version (get-glx-version))
354
355  ;; If widget isn't #f, use its display and screen
356  (define display (gtk-maybe-widget-get-display widget))
357  (define screen (gtk-maybe-widget-get-screen widget))
358
359  ;; Get the X objects wrapped by the GDK objects
360  (define xdisplay (gdk_x11_display_get_xdisplay display))
361  (define xscreen (gdk_x11_screen_get_screen_number screen))
362
363  ;; Create an attribute list using the GL config
364  (define xattribs
365    (append
366     ;; Be aware: we may get double buffering even if we don't ask for it
367     (if wants-double?
368         (if (send conf get-double-buffered) (list GLX_DOUBLEBUFFER True) null)
369         null)
370     (if (send conf get-stereo) (list GLX_STEREO True) null)
371     ;; Finish out with standard GLX 1.3 attributes
372     (list
373      GLX_X_RENDERABLE True  ; yes, we want to use OpenGL to render today
374      GLX_DEPTH_SIZE (send conf get-depth-size)
375      GLX_STENCIL_SIZE (send conf get-stencil-size)
376      GLX_ACCUM_RED_SIZE (send conf get-accum-size)
377      GLX_ACCUM_GREEN_SIZE (send conf get-accum-size)
378      GLX_ACCUM_BLUE_SIZE (send conf get-accum-size)
379      GLX_ACCUM_ALPHA_SIZE (send conf get-accum-size)
380      ;; GLX_SAMPLES is handled below - GLX regards it as an absolute lower bound, which makes it
381      ;; too easy for user programs to fail to get a context
382      None)))
383
384  (define multisample-size (send conf get-multisample-size))
385
386  ;; Get all framebuffer configs for this display and screen that match the requested attributes,
387  ;; then sort them to put the best in front
388  ;; GLX already sorts them pretty well, so we just need a stable sort on multisamples at the moment
389  (define cfgs
390    (let* ([cfgs  (cvector->list (glXChooseFBConfig xdisplay xscreen xattribs))]
391           ;; Keep all configs with multisample size <= requested (i.e. make multisample-size an
392           ;; abolute upper bound)
393           [cfgs  (if (< glx-version #e1.4)
394                      cfgs
395                      (filter (λ (cfg)
396                                (define m (glx-get-fbconfig-attrib xdisplay cfg GLX_SAMPLES 0))
397                                (<= m multisample-size))
398                              cfgs))]
399           ;; Sort all configs by multisample size, decreasing
400           [cfgs  (if (< glx-version #e1.4)
401                      cfgs
402                      (sort cfgs >
403                            #:key (λ (cfg) (glx-get-fbconfig-attrib xdisplay cfg GLX_SAMPLES 0))
404                            #:cache-keys? #t))])
405      cfgs))
406
407  (cond
408    [(null? cfgs)  #f]
409    [else
410     ;; The framebuffer configs are sorted best-first, so choose the first
411     (define cfg (car cfgs))
412     (define share-gl
413       (let ([share-ctxt  (send conf get-share-context)])
414         (and share-ctxt (send share-ctxt get-handle))))
415
416     ;; Get a GL context
417     (define gl
418       (if (and (>= glx-version #e1.4)
419                (not (send conf get-legacy?))
420                (force lazy-GLX_ARB_create_context?)
421                (force lazy-GLX_ARB_create_context_profile?))
422           ;; If the GLX version is high enough, legacy? is #f, and GLX has the right extensions,
423           ;; try to get a core-profile context
424           (glx-create-core-context xdisplay cfg share-gl)
425           ;; Otherwise use the old method
426           (glx-create-new-context xdisplay cfg share-gl)))
427     ;; The above will return a direct rendering context when it can
428     ;; If it doesn't, the context will be version 1.4 or lower, unless GLX is implemented with
429     ;; proprietary extensions (NVIDIA's drivers sometimes do this)
430
431     (when (and widget (send conf get-sync-swap))
432       (glXSwapIntervalEXT xdisplay (gdk_x11_drawable_get_xid drawable) 1))
433
434     ;; Now wrap the GLX context in a gl-context%
435     (cond
436       [gl
437        ;; If there's no widget, this is for a pixmap, so get the stupid GLX wrapper for it or
438        ;; indirect rendering may crash on some systems (notably mine)
439        (define pixmap
440          (if widget #f (glXCreateGLXPixmap xdisplay
441                                            (glXGetVisualFromFBConfig xdisplay cfg)
442					    (if gtk3?
443						(cast drawable _Pixmap _ulong)
444						(gdk_x11_drawable_get_xid drawable)))))
445
446        (define ctxt (new gl-context% [gl gl] [display display] [drawable drawable] [pixmap pixmap]))
447        ;; Refcount these so they don't go away until the finalizer below destroys the GLXContext
448        (g_object_ref display)
449        (unless (and gtk3? (not widget)) (g_object_ref drawable))
450        (register-finalizer
451         ctxt
452         (λ (ctxt)
453           (define gl (send ctxt get-handle))
454           (define display (send ctxt get-gtk-display))
455           (define drawable (send ctxt get-gtk-drawable))
456           (define pixmap (send ctxt get-glx-pixmap))
457           (define xdisplay (gdk_x11_display_get_xdisplay display))
458           (when pixmap (glXDestroyGLXPixmap xdisplay pixmap))
459           (glXDestroyContext xdisplay gl)
460           (unless (and gtk3? (not widget)) (g_object_unref drawable))
461           (g_object_unref display)))
462        ctxt]
463       [else  #f])]))
464
465(define (make-gtk-widget-gl-context widget conf)
466  (atomically
467   (make-gtk-drawable-gl-context widget (widget-window widget) conf #t)))
468
469(define (make-gtk-pixmap-gl-context pixmap conf)
470  (atomically
471   (make-gtk-drawable-gl-context #f pixmap conf #f)))
472
473;; ===================================================================================================
474
475(define widget-config-hash (make-weak-hasheq))
476
477(define (prepare-widget-gl-context widget conf)
478  (hash-set! widget-config-hash widget (if conf conf (make-object gl-config%))))
479
480(define (create-widget-gl-context widget)
481  (define conf (hash-ref widget-config-hash widget #f))
482  (and conf (make-gtk-widget-gl-context widget conf)))
483
484(define-local-member-name
485  get-gdk-pixmap
486  install-gl-context)
487
488(define (create-and-install-gl-context bm conf)
489  (define ctxt (make-gtk-pixmap-gl-context (send bm get-gdk-pixmap) conf))
490  (and ctxt (send bm install-gl-context ctxt)))
491