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

ffi/unsafe/objc: repair use of objc_msgSendSuper_stret

Browse Source 
TTo keep stack alignment correct, the `objc_msgSendSuper_stret`
function needs to be used with a structure return type on i386,
instead of making the implicit return-pointer argument explicit.
(For BC, libffi apparently makes the wrong style work anyway.)
This commit is contained in:
Matthew Flatt 2020-12-22 10:51:54 -07:00
parent b8f0c96756
commit 15ab674ef8
1 changed files with 17 additions and 30 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

47
racket/collects/ffi/unsafe/objc.rkt
View File

@ -273,18 +273,18 @@
(define objc_msgSendSuper_fpret objc_msgSendSuper) ; why no fpret variant? (define objc_msgSendSuper_fpret objc_msgSendSuper) ; why no fpret variant?
(define-objc/private objc_msgSendSuper_stret _fpointer) (define-objc/private objc_msgSendSuper_stret _fpointer)
(define sizes-for-direct-struct-results (define use-stret?
(case (string->symbol (path->string (system-library-subpath #f))) (case (string->symbol (path->string (system-library-subpath #f)))
[(i386-macosx i386-darwin) (lambda (v) (memq (ctype-sizeof v) '(1 2 4 8)))] [(i386-macosx i386-darwin) (lambda (v) (not (memq (ctype-sizeof v) '(1 2 4 8))))]
[(ppc-macosx ppc-darwin) (lambda (v) (memq (ctype-sizeof v) '(1 2 3 4)))] [(ppc-macosx ppc-darwin) (lambda (v) (not (memq (ctype-sizeof v) '(1 2 3 4))))]
[(x86_64-macosx x86_64-darwin) [(x86_64-macosx x86_64-darwin)
(lambda (v) (lambda (v)
;; Remarkably complex rules govern sizes > 8 and <= 32. ;; Remarkably complex rules govern sizes > 8 and <= 32.
;; But if we assume no unaligned data and that fancy types ;; But if we assume no unaligned data and that fancy types
;; like _m256 won't show up with ObjC, it seems to be as ;; like _m256 won't show up with ObjC, it seems to be as
;; simple as this: ;; simple as this:
((ctype-sizeof v) . <= . 16))] ((ctype-sizeof v) . > . 16))]
[(aarch64-macosx aarch64-darwin) (lambda (v) #t)])) [(aarch64-macosx aarch64-darwin) (lambda (v) #f)]))
;; Make `msgSends' access atomic, so that a thread cannot be suspended ;; Make `msgSends' access atomic, so that a thread cannot be suspended
;; or killed during access, which would block other threads. ;; or killed during access, which would block other threads.
@ -295,31 +295,18 @@
;; First type in `types' vector is the result type ;; First type in `types' vector is the result type
(or (as-atomic (hash-ref msgSends types #f)) (or (as-atomic (hash-ref msgSends types #f))
(let ([ret-layout (ctype->layout (vector-ref types 0))]) (let ([ret-layout (ctype->layout (vector-ref types 0))])
(if (and (list? ret-layout) (let ([m (function-ptr (cond
(not (sizes-for-direct-struct-results (vector-ref types 0)))) [(and (pair? ret-layout) (use-stret? (vector-ref types 0)))
;; Structure return type: msgSend_stret]
(let* ([pre-m (function-ptr msgSend_stret [(or (eq? ret-layout 'float) (eq? ret-layout 'double) (eq? ret-layout 'double*))
(_cprocedure msgSend_fpret]
#:blocking? blocking? [else msgSend])
(list* _pointer first-arg-type _SEL (cdr (vector->list types))) (_cprocedure
_void))] #:blocking? blocking?
[m (lambda args (list* first-arg-type _SEL (cdr (vector->list types)))
(let ([v (malloc (vector-ref types 0))]) (vector-ref types 0)))])
(apply pre-m v args) (as-atomic (hash-set! msgSends types m))
(ptr-ref v (vector-ref types 0))))]) m))))
(as-atomic (hash-set! msgSends types m))
m)
;; Non-structure return type:
(let ([m (function-ptr (if (memq ret-layout
'(float double double*))
msgSend_fpret
msgSend)
(_cprocedure
#:blocking? blocking?
(list* first-arg-type _SEL (cdr (vector->list types)))
(vector-ref types 0)))])
(as-atomic (hash-set! msgSends types m))
m)))))
(define msgSends (make-weak-hash)) (define msgSends (make-weak-hash))
(define (objc_msgSend/typed types) (define (objc_msgSend/typed types)