From 9d55443e23b93575e8ab6c10bb7f94bd6d84dac4 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Mon, 17 Jun 2019 06:33:35 -0600
Subject: [PATCH] cs: force inline of applicable-struct support

When the schemify pass cannot determine that a call is to a primitive
procedure, it generates an `#%app` form that expands to

  ((extract-procedure rator) rand ...)

Force `extract-procedure` to be inlined (by making it a macro), so the
expansion is

  (let ([tmp rator])
    ((if (#%procedure? tmp) tmp (slow-extract-procedure tmp)) rand ...))

which is usefully faster in the common case that `rator` turns out to
be a primitive procedure.
---
 racket/src/cs/expander.sls                    |  5 +++++
 racket/src/cs/primitive/internal.ss           |  1 -
 racket/src/cs/rumble/procedure.ss             |  9 +++++----
 racket/src/schemify/constructed-procedure.rkt | 15 +++++++++++++++
 racket/src/schemify/infer-known.rkt           |  3 +++
 5 files changed, 28 insertions(+), 5 deletions(-)
 create mode 100644 racket/src/schemify/constructed-procedure.rkt

diff --git a/racket/src/cs/expander.sls b/racket/src/cs/expander.sls
index 5b5ab46375..de172b6f3f 100644
--- a/racket/src/cs/expander.sls
+++ b/racket/src/cs/expander.sls
@@ -177,6 +177,11 @@
                [(_ rator rand ...)
                 (with-syntax ([n-args (length #'(rand ...))])
                   #'((extract-procedure rator n-args) rand ...))])))
+    (eval '(define-syntax-rule (extract-procedure f n-args)
+             (let ([tmp f])
+               (if (#%procedure? tmp)
+                   tmp
+                   (slow-extract-procedure tmp n-args)))))
     (eval '(define-syntax (|#%name| stx)
              (syntax-case stx ()
                [(_ name val) #`(let ([name val]) name)])))
diff --git a/racket/src/cs/primitive/internal.ss b/racket/src/cs/primitive/internal.ss
index 54aabd258a..d77abd4873 100644
--- a/racket/src/cs/primitive/internal.ss
+++ b/racket/src/cs/primitive/internal.ss
@@ -3,7 +3,6 @@
 ;; can be used in a linklet:
 
 (define-primitive-table internal-table
-  [extract-procedure (known-constant)]
   [set-ctl-c-handler! (known-constant)]
   [impersonator-val (known-constant)]
   [impersonate-ref (known-constant)]
diff --git a/racket/src/cs/rumble/procedure.ss b/racket/src/cs/rumble/procedure.ss
index b4a6ed140a..9c30fd9099 100644
--- a/racket/src/cs/rumble/procedure.ss
+++ b/racket/src/cs/rumble/procedure.ss
@@ -72,10 +72,11 @@
            receiver
            (lambda args (apply receiver args)))))))
 
-(define (extract-procedure f n-args)
-  (cond
-   [(#%procedure? f) f]
-   [else (slow-extract-procedure f n-args)]))
+(define-syntax-rule (extract-procedure f n-args)
+  (let ([tmp f])
+    (if (#%procedure? tmp)
+        tmp
+        (slow-extract-procedure tmp n-args))))
 
 (define (slow-extract-procedure f n-args)
   (pariah ; => don't inline enclosing procedure
diff --git a/racket/src/schemify/constructed-procedure.rkt b/racket/src/schemify/constructed-procedure.rkt
new file mode 100644
index 0000000000..4b64e70bbd
--- /dev/null
+++ b/racket/src/schemify/constructed-procedure.rkt
@@ -0,0 +1,15 @@
+#lang racket/base
+(require "match.rkt")
+
+;; Recognize functions whose result is always a core procedure of a
+;; known arity
+
+(provide constructed-procedure-arity-mask)
+
+(define (constructed-procedure-arity-mask v)
+  (match v
+    [`(make-struct-field-accessor . ,_)
+     1]
+    [`(make-struct-field-mutator . ,_)
+     2]
+    [`,_ #f]))
diff --git a/racket/src/schemify/infer-known.rkt b/racket/src/schemify/infer-known.rkt
index 6fba40d6ad..c31ed891cb 100644
--- a/racket/src/schemify/infer-known.rkt
+++ b/racket/src/schemify/infer-known.rkt
@@ -5,6 +5,7 @@
          "import.rkt"
          "simple.rkt"
          "pthread-parameter.rkt"
+         "constructed-procedure.rkt"
          "literal.rkt"
          "inline.rkt"
          "mutated-state.rkt"
@@ -61,6 +62,8 @@
        [else (known-copy rhs)])]
     [(pthread-parameter? rhs prim-knowns knowns mutated)
      (known-procedure 3)]
+    [(constructed-procedure-arity-mask rhs)
+     => (lambda (m) (known-procedure m))]
     [(and defn
           (simple? rhs prim-knowns knowns imports mutated simples))
      a-known-constant]