From 3db7e471eb605fece59609b26e4212456a12878f Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Wed, 4 Nov 2020 16:33:18 -0700
Subject: [PATCH] cs: faster path for a foreign call with a lock

The call is only slightly faster, but since it affects text drawing
with `racket/draw`, a slight improvement can be worthwhile for
DrRacket.
---
 racket/src/cs/rumble/foreign.ss | 39 ++++++++++++++++++++-------------
 1 file changed, 24 insertions(+), 15 deletions(-)

diff --git a/racket/src/cs/rumble/foreign.ss b/racket/src/cs/rumble/foreign.ss
index 8f59d3e617..2060f593fc 100644
--- a/racket/src/cs/rumble/foreign.ss
+++ b/racket/src/cs/rumble/foreign.ss
@@ -1658,7 +1658,6 @@
              (not blocking?)
              (not orig-place?)
              (not save-errno)
-             (not lock)
              (#%andmap (lambda (in-type)
                          (case (ctype-host-rep in-type)
                            [(scheme-object struct union) #f]
@@ -1686,15 +1685,22 @@
                                         [(_ id ...)
                                          (with-syntax ([(type ...) (generate-temporaries #'(id ...))]
                                                        [(orig ...) (generate-temporaries #'(id ...))])
-                                           #'(let*-values ([(type in-types) (values (car in-types) (cdr in-types))]
-                                                           ...)
-                                               (lambda (orig ...)
-                                                 (let ([id (unwrap orig type)] ...)
-                                                   (c->s out-type
-                                                         (retain
-                                                          orig ...
-                                                          (with-interrupts-disabled*
-                                                           (proc (unpack id type) ...))))))))]))])
+                                           (let ([make-proc
+                                                  (lambda (lock)
+                                                    #`(lambda (orig ...)
+                                                        (let ([id (unwrap orig type)] ...)
+                                                          (when #,lock (mutex-acquire #,lock))
+                                                          (let ([r (retain
+                                                                    orig ...
+                                                                    (with-interrupts-disabled*
+                                                                     (proc (unpack id type) ...)))])
+                                                            (when #,lock (mutex-release #,lock))
+                                                            (c->s out-type r)))))])
+                                             #`(let*-values ([(type in-types) (values (car in-types) (cdr in-types))]
+                                                             ...)
+                                                 (if lock
+                                                     #,(make-proc #'lock)
+                                                     #,(make-proc #'#f)))))]))])
                     (case arity-mask
                       [(1) (gen)]
                       [(2) (gen a)]
@@ -1715,11 +1721,14 @@
                  [else
                   (lambda orig-args
                     (let ([args (map (lambda (a t) (unwrap a t)) orig-args in-types)])
-                      (c->s out-type (with-interrupts-disabled*
-                                      (retain
-                                       orig-args
-                                       (#%apply (gen-proc (cpointer-address proc-p))
-                                                (map (lambda (a t) (unpack a t)) args in-types)))))))])
+                      (when lock (mutex-acquire lock))
+                      (let ([r (with-interrupts-disabled*
+                                (retain
+                                 orig-args
+                                 (#%apply (gen-proc (cpointer-address proc-p))
+                                          (map (lambda (a t) (unpack a t)) args in-types))))])
+                        (when lock (mutex-release lock))
+                        (c->s out-type r))))])
                arity-mask
                (cpointer->name proc-p)))))]
        [else