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