From 32e12fded4daa60edcf4a41d0f24ad4447764316 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Sun, 28 Jan 2018 08:00:15 -0700
Subject: [PATCH] ffi/objc: improve caching for objc_send foreign-procedure
 variants

Reduce the generation of foreign-function wrappers by `ffi/objc`
by caching type vectors when all of the types refer to module-level
constant bindigs.

Includes an optimizer-validation repair, where improved generation
creates a reference to a variable that would normally be replaced
by constant propagation.
---
 racket/collects/ffi/unsafe/objc.rkt | 46 +++++++++++++++++++++++++----
 racket/src/racket/src/eval.c        |  3 +-
 racket/src/racket/src/fun.c         |  3 ++
 3 files changed, 45 insertions(+), 7 deletions(-)

diff --git a/racket/collects/ffi/unsafe/objc.rkt b/racket/collects/ffi/unsafe/objc.rkt
index 0d4f362038..7fcf0eb2fd 100644
--- a/racket/collects/ffi/unsafe/objc.rkt
+++ b/racket/collects/ffi/unsafe/objc.rkt
@@ -553,7 +553,10 @@
 
 (define-for-syntax liftable-type?
   (let ([prims 
-         (syntax->list #'(_id _Class _SEL _void _int _long _float _double _double* _BOOL))])
+         (syntax->list #'(_id _Class _SEL
+                              _void _short _ushort _int _uint _long _ulong _intptr _uintptr
+                              _float _double _double*
+                              _BOOL))])
     (lambda (t)
       (and (identifier? t)
            (ormap (lambda (p) (free-identifier=? t p))
@@ -561,11 +564,36 @@
 
 (define-syntax (type-vector stx)
   (let ([types (cdr (syntax->list stx))])
-    ((if (andmap liftable-type? (cdr (syntax->list stx)))
-         (lambda (e)
-           (syntax-local-lift-expression #`(intern-type-vector #,e)))
-         values)
-     (quasisyntax/loc stx (vector . #,types)))))
+    (let ([vec-exp (quasisyntax/loc stx (vector . #,types))]
+          [type-exprs (cdr (syntax->list stx))])
+      (cond
+        [(andmap liftable-type? type-exprs)
+         ;; Recognized types => simple lift
+         (syntax-local-lift-expression #`(intern-type-vector #,vec-exp))]
+        [(andmap (lambda (type-expr)
+                   (and (identifier? type-expr)
+                        (pair? (identifier-binding type-expr))))
+                 type-exprs)
+         ;; Types bound as imports => lift with cache and `#%variable-reference-constant?` check
+         (let* ([expanded-type-exprs
+                 (map (lambda (type-expr)
+                        (local-expand type-expr 'expression #f))
+                      type-exprs)]
+                [expanded-vec-exp #`(vector . #,expanded-type-exprs)])
+           (cond
+             [(andmap identifier? expanded-type-exprs)
+              (let ([saved-vector-id (syntax-local-lift-expression #'(box #f))])
+                (quasisyntax/loc stx
+                  (or (unbox #,saved-vector-id)
+                      (maybe-cache-type-vector-in-box
+                       #,expanded-vec-exp
+                       #,saved-vector-id
+                       (vector #,@(for/list ([expanded-type-expr (in-list expanded-type-exprs)])
+                                    #`(variable-reference-constant? (#%variable-reference #,expanded-type-expr))))))))]
+             [else expanded-vec-exp]))]
+        [else
+         ;; General case: construct type vector every time
+         vec-exp]))))
 
 (define type-vectors (make-hash))
 (define (intern-type-vector v)
@@ -574,6 +602,12 @@
         (hash-set! type-vectors v v)
         v)))
 
+(define (maybe-cache-type-vector-in-box vec saved-vec-box const?s)
+  (when (for/and ([c? (in-vector const?s)])
+          c?)
+    (set-box! saved-vec-box vec))
+  vec)
+
 ;; ----------------------------------------
 
 (provide define-objc-class
diff --git a/racket/src/racket/src/eval.c b/racket/src/racket/src/eval.c
index f51cc82595..5fee1537fa 100644
--- a/racket/src/racket/src/eval.c
+++ b/racket/src/racket/src/eval.c
@@ -2096,7 +2096,8 @@ define_execute_with_dynamic_state(Scheme_Object *vec, int delta, int defmacro,
       
       if (SCHEME_TOPLEVEL_FLAGS(var) & SCHEME_TOPLEVEL_SEAL) {
         int flags = GLOB_IS_IMMUTATED;
-        if (scheme_is_statically_proc(vals_expr, NULL, OMITTABLE_RESOLVED))
+        if (scheme_is_statically_proc(vals_expr, NULL, OMITTABLE_RESOLVED)
+            || (SCHEME_TYPE(vals_expr) >= _scheme_values_types_))
           flags |= GLOB_IS_CONSISTENT;
         ((Scheme_Bucket_With_Flags *)b)->flags |= flags;
       }
diff --git a/racket/src/racket/src/fun.c b/racket/src/racket/src/fun.c
index bbc018c3a2..07ebba620f 100644
--- a/racket/src/racket/src/fun.c
+++ b/racket/src/racket/src/fun.c
@@ -2572,6 +2572,9 @@ Scheme_Object *scheme_get_or_check_procedure_shape(Scheme_Object *e, Scheme_Obje
   if (SAME_TYPE(SCHEME_TYPE(e), scheme_inline_variant_type))
     e = SCHEME_VEC_ELS(e)[1];
 
+  if (!SCHEME_PROCP(e) && (SCHEME_TYPE(e) >= _scheme_ir_values_types_))
+    return NULL;
+
   p = scheme_get_or_check_arity(e, -3);
 
   if (SCHEME_PAIRP(p)) {