From 15ab674ef8b1a61b70ccbf5c30f375be2b0ebe35 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Tue, 22 Dec 2020 10:51:54 -0700
Subject: [PATCH] ffi/unsafe/objc: repair use of `objc_msgSendSuper_stret`

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.)
---
 racket/collects/ffi/unsafe/objc.rkt | 47 +++++++++++------------------
 1 file changed, 17 insertions(+), 30 deletions(-)

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