cs: faster path for simple foreign calls

pkgs/racket-doc/scribblings/foreign/unexported.scrbl

@@ -14,7 +14,7 @@ the Racket built-in @racketmodname['#%foreign] module.  The
 @racketmodname['#%foreign] module is not intended for direct use, but
 it exports the following procedures (among others).
 
-@defproc[(ffi-obj [objname (or/c string? bytes? symbol?)]
+@defproc[(ffi-obj [objname bytes?]
                   [lib (or/c ffi-lib? path-string? #f)])
          ffi-obj?]{
 
@@ -25,7 +25,7 @@ then @racket[ffi-lib] is used to create a library object.}
 
 @defproc*[([(ffi-obj? [x any/c]) boolean?]
            [(ffi-obj-lib [obj ffi-obj?]) ffi-lib?]
-           [(ffi-obj-name [obj ffi-obj?]) string?])]{
+           [(ffi-obj-name [obj ffi-obj?]) bytes?])]{
 
 A predicate for objects returned by @racket[ffi-obj], and accessor
 functions that return its corresponding library object and name.

racket/src/cs/rumble/foreign.ss

@@ -121,6 +121,11 @@
   (and (authentic-cpointer? p)
        (#%vector? (cpointer-memory p))))
 
+;; Works on unwrapped cpointers:
+(define (cpointer->name proc-p)
+  (and (ffi-obj? proc-p)
+       (string->symbol (utf8->string (cpointer/ffi-obj-name proc-p)))))
+
 ;; ----------------------------------------
 
 ;; Hack: use `s_fxmul` as an identity function
@@ -167,6 +172,12 @@
     (raise-arguments-error 'internal-error "bad case extracting a cpointer address"
                            "value" p)]))
 
+(define (cpointer-needs-lock? p)
+  (cond
+   [(bytes? p) #t]
+   [(authentic-cpointer? p) (not (integer? (cpointer-memory p)))]
+   [else #f]))
+
 ;; Like `cpointer-address`, but allows a raw foreign
 ;; address to pass through:
 (define (cpointer*-address p) ; call with GC disabled
@@ -1531,8 +1542,76 @@
          [async-callback-queue (and (procedure? async-apply) (current-async-callback-queue))])
     (cond
      [call?
+      (cond
+       [(and (not ret-id)
+             (not blocking?)
+             (not save-errno)
+             (#%andmap (lambda (in-type)
+                         (case (ctype-host-rep in-type)
+                           [(scheme-object struct union) #f]
+                           [else #t]))
+                       in-types))
+        (lambda (to-wrap)
+          (let* ([proc-p (unwrap-cpointer 'ffi-call to-wrap)]
+                 [proc (and (not (cpointer-needs-lock? proc-p))
+                            (gen-proc (cpointer-address proc-p)))]
+                 [unwrap (lambda (arg in-type)
+                           (let ([c (s->c in-type arg)])
+                             (if (cpointer? c)
+                                 (unwrap-cpointer 'ffi-call c)
+                                 c)))]
+                 [unpack (lambda (arg in-type)
+                           (case (array-rep-to-pointer-rep (ctype-host-rep in-type))
+                             [(void*) (cpointer-address arg)]
+                             [else arg]))])
+            (do-procedure-reduce-arity-mask
+             (cond
+              [proc
+               (case-lambda
+                [()
+                 (c->s out-type (with-interrupts-disabled (proc)))]
+                [(a)
+                 (let ([a (unwrap a (car in-types))])
+                   (c->s out-type (with-interrupts-disabled (proc (unpack a (car in-types))))))]
+                [(a b)
+                 (let ([a (unwrap a (car in-types))]
+                       [b (unwrap b (cadr in-types))])
+                   (c->s out-type (with-interrupts-disabled
+                                   (proc (unpack a (car in-types)) (unpack b (cadr in-types))))))]
+                [(a b c)
+                 (let ([a (unwrap a (car in-types))]
+                       [b (unwrap b (cadr in-types))]
+                       [c (unwrap c (caddr in-types))])
+                   (c->s out-type (with-interrupts-disabled
+                                   (proc (unpack a (car in-types))
+                                         (unpack b (cadr in-types))
+                                         (unpack c (caddr in-types))))))]
+                [(a b c d)
+                 (let ([a (unwrap a (car in-types))]
+                       [b (unwrap b (cadr in-types))]
+                       [c (unwrap c (caddr in-types))]
+                       [d (unwrap d (cadddr in-types))])
+                   (c->s out-type (with-interrupts-disabled
+                                   (proc (unpack a (car in-types))
+                                         (unpack b (cadr in-types))
+                                         (unpack c (caddr in-types))
+                                         (unpack d (cadddr in-types))))))]
+                [args
+                 (let ([args (map (lambda (a t) (unwrap a t)) args in-types)])
+                   (c->s out-type (with-interrupts-disabled
+                                   (#%apply proc (map (lambda (a t) (unpack a t)) args in-types)))))])]
+              [else
+               (lambda args
+                 (let ([args (map (lambda (a t) (unwrap a t)) args in-types)])
+                   (c->s out-type (with-interrupts-disabled
+                                   (#%apply (gen-proc (cpointer-address proc-p))
+                                            (map (lambda (a t) (unpack a t)) args in-types))))))])
+             (fxsll 1 (length in-types))
+             (cpointer->name proc-p))))]
+       [else
         (lambda (to-wrap)
           (let* ([proc-p (unwrap-cpointer 'ffi-call to-wrap)])
+            (do-procedure-reduce-arity-mask
              (lambda args
                (let* ([args (map (lambda (orig-arg in-type)
                                    (let ([arg (s->c in-type orig-arg)])
@@ -1574,7 +1653,9 @@
                                [(eq? (ctype-our-rep out-type) 'gcpointer)
                                 (addr->gcpointer-memory r)]
                                [else r]))))])
-              (c->s out-type r)))))]
+                 (c->s out-type r)))
+             (fxsll 1 (length in-types))
+             (cpointer->name proc-p))))])]
      [else ; callable
       (lambda (to-wrap)
         (gen-proc (lambda args ; if ret-id, includes an extra initial argument to receive the result
@@ -1634,8 +1715,7 @@
 (define (disallow-nonatomic-pointer what arg proc-p)
   (raise-arguments-error 'foreign-call "cannot pass non-atomic pointer to a function"
                          "pointer" arg
-                         "function" (or (and (ffi-obj? proc-p)
+                         "function" (or (cpointer->name proc-p)
-                                             (cpointer/ffi-obj-name proc-p))
                                         'unknown)))
 
 ;; Rely on the fact that a virtual register defaults to 0 to detect a