suzanne.soy/gui
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fix GC blit for Mac OS X 10.11

Browse Source 
The old strategy of switching a transparent window to solid and back
doesn't work on 10.11; it appears that queued messages must be handled
for the window to become visible, but that's not allowed during a GC.
The strategy for 10.11 and up create an OpenGL canvas, which acts as a
direct-to-screen drawing area that a GC callback can affect without
Racket-level allocation.
This commit is contained in:
Matthew Flatt 2015-10-01 21:28:19 -06:00
parent ed01aa1e43
commit ac2d39e0e1
5 changed files with 301 additions and 25 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

76
gui-lib/mred/private/wx/cocoa/canvas.rkt
View File

@ -12,6 +12,7 @@
"const.rkt" "const.rkt"
"types.rkt" "types.rkt"
"window.rkt" "window.rkt"
"frame.rkt"
"dc.rkt" "dc.rkt"
"cg.rkt" "cg.rkt"
"queue.rkt" "queue.rkt"
@ -41,7 +42,7 @@
(define NSWindowAbove 1) (define NSWindowAbove 1)
(define o (current-error-port)) (define gc-via-gl? (version-10.11-or-later?))
;; Called when a canvas has no backing store ready ;; Called when a canvas has no backing store ready
(define (clear-background wxb) (define (clear-background wxb)
@ -97,6 +98,16 @@
#:mixins (RacketViewMixin) #:mixins (RacketViewMixin)
[wxb]) [wxb])
(define-objc-class RacketGCGLView NSOpenGLView
#:mixins (KeyMouseResponder)
[wxb])
(define-objc-class RacketGCWindow NSWindow
#:mixins (RacketEventspaceMethods)
[wxb])
(install-RacketGCWindow! RacketGCWindow)
(define-objc-class CornerlessFrameView NSView (define-objc-class CornerlessFrameView NSView
[] []
(-a #:async-apply (box (void)) (-a #:async-apply (box (void))
@ -451,6 +462,10 @@
(make-window-bitmap w h (get-cocoa-window))) (make-window-bitmap w h (get-cocoa-window)))
(define/override (fix-dc [refresh? #t]) (define/override (fix-dc [refresh? #t])
(when (pair? blits)
(atomically
(suspend-all-reg-blits)
(resume-all-reg-blits)))
(when (dc . is-a? . dc%) (when (dc . is-a? . dc%)
(send dc reset-backing-retained) (send dc reset-backing-retained)
(send dc set-auto-scroll (send dc set-auto-scroll
@ -914,17 +929,17 @@
(when (pair? blits) (when (pair? blits)
(set! reg-blits (set! reg-blits
(for/list ([b (in-list blits)]) (for/list ([b (in-list blits)])
(let-values ([(x y w h img) (apply values b)]) (let-values ([(x y w h s img) (apply values b)])
(register-one-blit x y w h img))))))) (register-one-blit x y w h s img)))))))
(define/private (register-one-blit x y w h img) (define/private (register-one-blit x y w h s img)
(let ([xb (box x)] (let ([xb (box x)]
[yb (box y)]) [yb (box y)])
(client-to-screen xb yb #f) (client-to-screen xb yb #f)
(let* ([cocoa-win (get-cocoa-window)]) (let* ([cocoa-win (get-cocoa-window)])
(atomically (atomically
(let ([win (as-objc-allocation (let ([win (as-objc-allocation
(tell (tell NSWindow alloc) (tell (tell (if gc-via-gl? RacketGCWindow NSWindow) alloc)
initWithContentRect: #:type _NSRect (make-NSRect (make-NSPoint (unbox xb) initWithContentRect: #:type _NSRect (make-NSRect (make-NSPoint (unbox xb)
(- (unbox yb) (- (unbox yb)
h)) h))
@ -932,26 +947,59 @@
styleMask: #:type _int NSBorderlessWindowMask styleMask: #:type _int NSBorderlessWindowMask
backing: #:type _int NSBackingStoreBuffered backing: #:type _int NSBackingStoreBuffered
defer: #:type _BOOL NO))] defer: #:type _BOOL NO))]
[iv (tell (tell NSImageView alloc) init)]) [glv (and gc-via-gl?
(let ([pf (gl-config->pixel-format #f)])
(begin0
(tell (tell RacketGCGLView alloc)
initWithFrame: #:type _NSRect (make-NSRect (make-NSPoint 0 0)
(make-NSSize w h))
pixelFormat: pf)
(tellv pf release))))]
[iv (and (not gc-via-gl?)
(tell (tell NSImageView alloc) init))])
(cond
[gc-via-gl?
(tellv win setAcceptsMouseMovedEvents: #:type _BOOL #t)
(set-ivar! win wxb (->wxb this))
(set-ivar! glv wxb (->wxb this))
(tellv glv setWantsBestResolutionOpenGLSurface: #:type _uint 1)
(tellv (tell win contentView) addSubview: glv)]
[else
(tellv win setAlphaValue: #:type _CGFloat 0.0)
(tellv iv setImage: img) (tellv iv setImage: img)
(tellv iv setFrame: #:type _NSRect (make-NSRect (make-NSPoint 0 0) (tellv iv setFrame: #:type _NSRect (make-NSRect (make-NSPoint 0 0)
(make-NSSize w h))) (make-NSSize w h)))
(tellv (tell win contentView) addSubview: iv) (tellv (tell win contentView) addSubview: iv)
(tellv win setAlphaValue: #:type _CGFloat 0.0) (tellv iv release)])
(tellv cocoa-win addChildWindow: win ordered: #:type _int NSWindowAbove) (tellv cocoa-win addChildWindow: win ordered: #:type _int NSWindowAbove)
(tellv iv release) (when gc-via-gl?
(tellv win orderWindow: #:type _int NSWindowAbove
relativeTo: #:type _NSInteger (tell #:type _NSInteger cocoa-win windowNumber)))
(let ([r (scheme_add_gc_callback (let ([r (scheme_add_gc_callback
(make-gc-action-desc win (selector setAlphaValue:) 1.0) (if gc-via-gl?
(make-gc-action-desc win (selector setAlphaValue:) 0.0))]) (make-gl-install win glv w h img s)
(make-gc-action-desc win (selector setAlphaValue:) 1.0))
(if gc-via-gl?
(make-gl-uninstall win glv w h)
(make-gc-action-desc win (selector setAlphaValue:) 0.0)))])
(when gc-via-gl?
(tellv glv release))
(cons win r))))))) (cons win r)))))))
(define/public (register-collecting-blit x y w h on off on-x on-y off-x off-y) (define/public (register-collecting-blit x y w h on off on-x on-y off-x off-y)
(let ([on (fix-bitmap-size on w h on-x on-y)]) (let ([on (fix-bitmap-size on w h on-x on-y)]
(let ([img (bitmap->image on)]) [s (send on get-backing-scale)])
(let ([img (if gc-via-gl?
(let* ([xw (inexact->exact (ceiling (* s w)))]
[xh (inexact->exact (ceiling (* s h)))]
[rgba (make-bytes (* xw xh 4))])
(send on get-argb-pixels 0 0 xw xh rgba #:unscaled? #t)
rgba)
(bitmap->image on))])
(atomically (atomically
(set! blits (cons (list x y w h img) blits)) (set! blits (cons (list x y w h s img) blits))
(when (is-shown-to-root?) (when (is-shown-to-root?)
(set! reg-blits (cons (register-one-blit x y w h img) reg-blits))))))) (set! reg-blits (cons (register-one-blit x y w h s img) reg-blits)))))))
(define/public (unregister-collecting-blits) (define/public (unregister-collecting-blits)
(atomically (atomically

20
gui-lib/mred/private/wx/cocoa/frame.rkt
View File

@ -18,7 +18,10 @@
(provide (provide
(protect-out frame% (protect-out frame%
location->window location->window
get-front)) get-front
RacketEventspaceMethods
install-RacketGCWindow!))
;; ---------------------------------------- ;; ----------------------------------------
@ -56,11 +59,18 @@
(set-screen-changed-callback! send-screen-change-notifications) (set-screen-changed-callback! send-screen-change-notifications)
(define-objc-mixin (RacketWindowMethods Superclass) (define RacketGCWindow #f)
(define (install-RacketGCWindow! c) (set! RacketGCWindow c))
(define-objc-mixin (RacketEventspaceMethods Superclass)
[wxb] [wxb]
[-a _scheme (getEventspace) [-a _scheme (getEventspace)
(let ([wx (->wx wxb)]) (let ([wx (->wx wxb)])
(and wx (send wx get-eventspace)))] (and wx (send wx get-eventspace)))])
(define-objc-mixin (RacketWindowMethods Superclass)
#:mixins (RacketEventspaceMethods)
[wxb]
[-a _BOOL (canBecomeKeyWindow) [-a _BOOL (canBecomeKeyWindow)
(let ([wx (->wx wxb)]) (let ([wx (->wx wxb)])
(and wx (and wx
@ -189,7 +199,9 @@
(not (ptr-equal? w (send root-fake-frame get-cocoa))) (not (ptr-equal? w (send root-fake-frame get-cocoa)))
(is-mouse-or-key?)) (is-mouse-or-key?))
(or (objc-is-a? w RacketWindow) (or (objc-is-a? w RacketWindow)
(objc-is-a? w RacketPanel)) (objc-is-a? w RacketPanel)
(and RacketGCWindow
(objc-is-a? w RacketGCWindow)))
(tell #:type _scheme w getEventspace))] (tell #:type _scheme w getEventspace))]
[front (send front get-eventspace)] [front (send front get-eventspace)]
[root-fake-frame [root-fake-frame

214
gui-lib/mred/private/wx/cocoa/gc.rkt
View File

@ -1,13 +1,19 @@
#lang racket/base #lang racket/base
(require ffi/unsafe (require ffi/unsafe
ffi/unsafe/objc ffi/unsafe/objc
ffi/unsafe/define
"utils.rkt" "utils.rkt"
"types.rkt") "types.rkt")
(provide (provide
(protect-out scheme_add_gc_callback (protect-out scheme_add_gc_callback
scheme_remove_gc_callback scheme_remove_gc_callback
make-gc-action-desc)) make-gc-action-desc
make-gl-install
make-gl-uninstall))
;; ----------------------------------------
;; 10.10 and earlier: change window opacity
(define objc-lib (ffi-lib "libobjc")) (define objc-lib (ffi-lib "libobjc"))
@ -25,3 +31,209 @@
win win
sel sel
val))) val)))
;; ----------------------------------------
;; 10.11 and later: OpenGL texture
(define gl-lib (ffi-lib "/System/Library/Frameworks/OpenGL.framework/Versions/A/Libraries/libGL"))
(define-ffi-definer define-gl gl-lib)
(import-class NSOpenGLContext)
(define _GLsizei _int)
(define _GLint _int)
(define _GLuint _uint)
(define _GLenum _int)
(define _GLbitfield _int)
(define _GLfloat _float)
(define _GLclampf _float)
(define-gl glGenTexture (_fun (_GLsizei = 1) (v : (_ptr o _GLuint)) -> _void -> v)
#:c-id glGenTextures)
(define-gl glGenLists (_fun _GLsizei -> _GLuint))
(define-gl glNewList (_fun _GLuint _GLenum -> _void))
(define-gl glEndList (_fun -> _void))
(define-gl glBindTexture (_fun _GLenum _GLuint -> _void))
(define-gl glTexParameteri (_fun _GLenum _GLenum _GLint -> _void))
(define-gl glTexImage2D (_fun _GLenum _GLint _GLint _GLsizei _GLsizei _GLint _GLenum _GLenum _pointer -> _void))
(define-gl glBegin (_fun _GLenum -> _void))
(define-gl glEnd (_fun -> _void))
(define-gl glEnable (_fun _GLenum -> _void))
(define-gl glDisable (_fun _GLenum -> _void))
(define-gl glMaterialfv (_fun _GLenum _GLenum (_vector i _GLfloat) -> _void))
(define-gl glTexCoord2f (_fun _GLfloat _GLfloat -> _void))
(define-gl glVertex3f (_fun _GLfloat _GLfloat _GLfloat -> _void))
(define-gl glViewport (_fun _GLint _GLint _GLsizei _GLsizei -> _void))
(define-gl glMatrixMode (_fun _GLenum -> _void))
(define-gl glLoadIdentity (_fun -> _void))
(define-gl glOrtho (_fun _double _double _double _double _double _double -> _void))
(define-gl glClearColor (_fun _GLclampf _GLclampf _GLclampf _GLclampf -> _void))
(define-gl glClear (_fun _GLbitfield -> _void))
(define-gl glClear-pointer _fpointer
#:c-id glClear)
(define-gl glCallList-pointer _fpointer
#:c-id glCallList)
(define-gl glFlush-pointer _fpointer
#:c-id glFlush)
(define GL_TEXTURE_2D #x0DE1)
(define GL_TEXTURE_MAG_FILTER #x2800)
(define GL_TEXTURE_MIN_FILTER #x2801)
(define GL_TEXTURE_WRAP_S #x2802)
(define GL_TEXTURE_WRAP_T #x2803)
(define GL_LINEAR #x2601)
(define GL_CLAMP #x2900)
(define GL_RGBA #x1908)
(define GL_UNSIGNED_BYTE #x1401)
(define GL_COMPILE #x1300)
(define GL_FRONT #x0404)
(define GL_AMBIENT_AND_DIFFUSE #x1602)
(define GL_POLYGON #x0009)
(define GL_PROJECTION #x1701)
(define GL_MODELVIEW #x1700)
(define GL_COLOR_BUFFER_BIT #x00004000)
(define (make-gl-square argb uw uh backing-scale)
(define w (inexact->exact (ceiling (* backing-scale uw))))
(define h (inexact->exact (ceiling (* backing-scale uh))))
(define size (* w h 4))
(define size-4 (- size 4))
(define rgba (make-bytes size))
(for ([i (in-range 0 size 4)])
(define j (- size-4 i))
(bytes-set! rgba (+ i 3) (bytes-ref argb j))
(bytes-set! rgba i (bytes-ref argb (+ j 1)))
(bytes-set! rgba (+ i 1) (bytes-ref argb (+ j 2)))
(bytes-set! rgba (+ i 2) (bytes-ref argb (+ j 3))))
(define tex (glGenTexture))
(glBindTexture GL_TEXTURE_2D tex)
(glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_LINEAR)
(glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_LINEAR)
(glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_CLAMP)
(glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_CLAMP)
(glTexImage2D GL_TEXTURE_2D 0 GL_RGBA
w h 0
GL_RGBA GL_UNSIGNED_BYTE rgba)
(define wi (exact->inexact uw))
(define hi (exact->inexact uh))
(define list-id (glGenLists 1))
(glNewList list-id GL_COMPILE)
(glEnable GL_TEXTURE_2D)
(glBindTexture GL_TEXTURE_2D tex)
(glMaterialfv GL_FRONT GL_AMBIENT_AND_DIFFUSE (vector 1.0 1.0 1.0 1.0))
(glBegin GL_POLYGON)
(glTexCoord2f 0.0 0.0)
(glVertex3f 0.0 0.0 0.0)
(glTexCoord2f 1.0 0.0)
(glVertex3f wi 0.0 0.0)
(glTexCoord2f 1.0 1.0)
(glVertex3f wi hi 0.0)
(glTexCoord2f 0.0 1.0)
(glVertex3f 0.0 hi 0.0)
(glEnd)
(glDisable GL_TEXTURE_2D)
(glEndList)
list-id)
(define (make-gl-install win glv w h argb backing-scale)
(define gl (tell glv openGLContext))
(define old-gl (tell NSOpenGLContext currentContext))
(tell gl makeCurrentContext)
(glViewport 0 0 w h)
(glMatrixMode GL_PROJECTION)
(glLoadIdentity)
(glOrtho 0.0 (exact->inexact w) 0.0 (exact->inexact h) -1.0 1.0)
(glMatrixMode GL_MODELVIEW)
(glClearColor 1.0 1.0 1.0 1.0)
(glClear GL_COLOR_BUFFER_BIT)
(define list-id (make-gl-square argb w h backing-scale))
(if old-gl
(tellv old-gl makeCurrentContext)
(tellv NSOpenGLContext clearCurrentContext))
(vector
(vector 'ptr_ptr->save
msg-send-proc
NSOpenGLContext
(selector currentContext))
(vector 'ptr_ptr_ptr->void
msg-send-proc
gl
(selector makeCurrentContext)
#f)
(vector 'int->void
glClear-pointer
GL_COLOR_BUFFER_BIT)
(vector 'int->void
glCallList-pointer
list-id)
(vector 'int->void
glFlush-pointer
0)
(vector 'ptr_ptr_ptr->void
msg-send-proc
gl
(selector flushBuffer)
#f)
(vector 'ptr_ptr_ptr->void
msg-send-proc
NSOpenGLContext
(selector clearCurrentContext)
#f)
(vector 'save!_ptr->void
msg-send-proc
(selector makeCurrentContext))))
(define (make-gl-uninstall win glv w h)
(define gl (tell glv openGLContext))
(vector
(vector 'ptr_ptr->save
msg-send-proc
NSOpenGLContext
(selector currentContext))
(vector 'ptr_ptr_ptr->void
msg-send-proc
gl
(selector makeCurrentContext)
#f)
(vector 'int->void
glClear-pointer
GL_COLOR_BUFFER_BIT)
(vector 'int->void
glFlush-pointer
0)
(vector 'ptr_ptr_ptr->void
msg-send-proc
gl
(selector flushBuffer)
#f)
(vector 'ptr_ptr_ptr->void
msg-send-proc
NSOpenGLContext
(selector clearCurrentContext)
#f)
(vector 'save!_ptr->void
msg-send-proc
(selector makeCurrentContext))))

3
gui-lib/mred/private/wx/cocoa/procs.rkt
View File

@ -90,8 +90,9 @@
(define (get-control-font-face) (define (get-control-font-face)
;; Using `(tell NSFont systemFontOfSize: ...)` gives us an OS-determined ;; Using `(tell NSFont systemFontOfSize: ...)` gives us an OS-determined
;; font, but my attempts to extract the name give something like ".LucidaGrandeUI" ;; font, but my attempts to extract the name give something like ".LucidaGrandeUI"
;; instead of "Lucida Grande" ;; instead of "Lucida Grande" have failed.
(cond (cond
;; [(version-10.11-or-later?) "San Francisco"]
[(version-10.10-or-later?) "Helvetica Neue"] [(version-10.10-or-later?) "Helvetica Neue"]
[else "Lucida Grande"])) [else "Lucida Grande"]))
(define (get-control-font-size) 13) (define (get-control-font-size) 13)

5
gui-lib/mred/private/wx/cocoa/utils.rkt
View File

@ -25,7 +25,8 @@
version-10.6-or-later? version-10.6-or-later?
version-10.7-or-later? version-10.7-or-later?
version-10.9-or-later? version-10.9-or-later?
version-10.10-or-later?) version-10.10-or-later?
version-10.11-or-later?)
with-autorelease with-autorelease
call-with-autorelease call-with-autorelease
define-mz) define-mz)
@ -86,3 +87,5 @@
(NSAppKitVersionNumber . >= . 1265)) (NSAppKitVersionNumber . >= . 1265))
(define (version-10.10-or-later?) (define (version-10.10-or-later?)
(NSAppKitVersionNumber . >= . 1331)) (NSAppKitVersionNumber . >= . 1331))
(define (version-10.11-or-later?)
(NSAppKitVersionNumber . >= . 1404))