From f95723e70ecc4855b08136b90fc8e18dd6540025 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Fri, 24 Aug 2018 20:22:01 -0600
Subject: [PATCH] cs: speed up calls to applicable structs

---
 racket/src/cs/rumble/procedure.ss | 65 ++++++++++++++++++-------------
 1 file changed, 37 insertions(+), 28 deletions(-)

diff --git a/racket/src/cs/rumble/procedure.ss b/racket/src/cs/rumble/procedure.ss
index d4da99d8b2..92f85b9b6b 100644
--- a/racket/src/cs/rumble/procedure.ss
+++ b/racket/src/cs/rumble/procedure.ss
@@ -67,45 +67,54 @@
 
 (define (extract-procedure f n-args)
   (cond
-   [(chez:procedure? f) f]
-   [else (or (try-extract-procedure/check-arity f n-args)
-             (not-a-procedure f))]))
+   [(#%procedure? f) f]
+   [else (slow-extract-procedure f n-args)]))
 
-;; returns #f or a host-Scheme procedure, and checks arity so that
-;; checking and reporting use the right top-level function
-(define (try-extract-procedure/check-arity f n-args)
-  (let ([v (try-extract-procedure f)])
-    (cond
-     [(not v) #f]
-     [(procedure-arity-includes? f n-args) v]
-     [else (wrong-arity-wrapper f)])))
+(define (slow-extract-procedure f n-args)
+  (pariah ; => don't inline enclosing procedure
+   (do-extract-procedure f f n-args #f)))
 
-(define (try-extract-procedure f)
+;; Returns a host-Scheme procedure, but first checks arity so that
+;; checking and reporting use the right top-level function, and
+;; the returned procedure may just report a not-a-procedure error
+(define (do-extract-procedure f orig-f n-args success-k)
   (cond
-   [(chez:procedure? f) f]
+   [(#%procedure? f)
+    (if (chez:procedure-arity-includes? f n-args)
+        (if success-k
+            (success-k f)
+            f)
+        (wrong-arity-wrapper orig-f))]
    [(record? f)
     (let ([v (struct-property-ref prop:procedure (record-rtd f) none)])
       (cond
-       [(eq? v none) #f]
+       [(eq? v none) (not-a-procedure orig-f)]
        [(fixnum? v)
-        (try-extract-procedure (unsafe-struct-ref f v))]
+        (do-extract-procedure (unsafe-struct-ref f v) orig-f n-args success-k)]
        [(eq? v 'unsafe)
-        (try-extract-procedure
+        (do-extract-procedure
          (if (chaperone? f)
              (unsafe-procedure-chaperone-replace-proc f)
-             (unsafe-procedure-impersonator-replace-proc f)))]
+             (unsafe-procedure-impersonator-replace-proc f))
+         orig-f
+         n-args
+         success-k)]
        [else
-        (let ([v (try-extract-procedure v)])
-          (cond
-           [(not v) (case-lambda)]
-           [else
-            (case-lambda
-             [() (v f)]
-             [(a) (v f a)]
-             [(a b) (v f a b)]
-             [(a b c) (v f a b c)]
-             [args (chez:apply v f args)])]))]))]
-   [else #f]))
+        (do-extract-procedure
+         v
+         orig-f
+         (fx+ n-args 1)
+         (lambda (v)
+           (cond
+            [(not v) (case-lambda)]
+            [else
+             (case-lambda
+              [() (v f)]
+              [(a) (v f a)]
+              [(a b) (v f a b)]
+              [(a b c) (v f a b c)]
+              [args (chez:apply v f args)])])))]))]
+   [else (not-a-procedure orig-f)]))
 
 (define (extract-procedure-name f)
   (cond