From e50f53e9908a1167c80ad89b50206a9ab4bb3afb Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 4 Nov 2020 15:22:41 -0700 Subject: [PATCH] cs: reduce allocation on foreign calls with 5-8 arguments Extend a fast path for up to 4 arguments to work on up to 8 arguments. --- racket/src/cs/rumble/foreign.ss | 127 +++++++++++++++----------------- racket/src/cs/schemified/io.scm | 3 +- 2 files changed, 60 insertions(+), 70 deletions(-) diff --git a/racket/src/cs/rumble/foreign.ss b/racket/src/cs/rumble/foreign.ss index 95a07d5994..8f59d3e617 100644 --- a/racket/src/cs/rumble/foreign.ss +++ b/racket/src/cs/rumble/foreign.ss @@ -1664,75 +1664,64 @@ [(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)))] - [(orig-a) - (let ([a (unwrap orig-a (car in-types))]) - (c->s out-type (retain - orig-a - (with-interrupts-disabled* (proc (unpack a (car in-types)))))))] - [(orig-a orig-b) - (let ([a (unwrap orig-a (car in-types))] - [b (unwrap orig-b (cadr in-types))]) - (c->s out-type (retain - orig-a orig-b - (with-interrupts-disabled* - (proc (unpack a (car in-types)) (unpack b (cadr in-types)))))))] - [(orig-a orig-b orig-c) - (let ([a (unwrap orig-a (car in-types))] - [b (unwrap orig-b (cadr in-types))] - [c (unwrap orig-c (caddr in-types))]) - (c->s out-type (with-interrupts-disabled* - (retain - orig-a orig-b orig-c - (proc (unpack a (car in-types)) - (unpack b (cadr in-types)) - (unpack c (caddr in-types)))))))] - [(orig-a orig-b orig-c orig-d) - (let ([a (unwrap orig-a (car in-types))] - [b (unwrap orig-b (cadr in-types))] - [c (unwrap orig-c (caddr in-types))] - [d (unwrap orig-d (cadddr in-types))]) - (c->s out-type (retain - orig-a orig-b orig-c orig-d - (with-interrupts-disabled* - (proc (unpack a (car in-types)) - (unpack b (cadr in-types)) - (unpack c (caddr in-types)) - (unpack d (cadddr in-types)))))))] - [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 proc (map (lambda (a t) (unpack a t)) args in-types))))))])] - [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)))))))]) - (fxsll 1 (length in-types)) - (cpointer->name proc-p))))] + (let ([arity-mask (bitwise-arithmetic-shift-left 1 (length 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 + (let-syntax ([gen (lambda (stx) + (syntax-case stx () + [(_ 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) ...))))))))]))]) + (case arity-mask + [(1) (gen)] + [(2) (gen a)] + [(4) (gen a b)] + [(8) (gen a b c)] + [(16) (gen a b c d)] + [(32) (gen a b c d e)] + [(64) (gen a b c d e f)] + [(128) (gen a b c d e f g)] + [(256) (gen a b c d e f g h)] + [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 proc (map (lambda (a t) (unpack a t)) args in-types)))))))]))] + [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)))))))]) + arity-mask + (cpointer->name proc-p)))))] [else (lambda (to-wrap) (let* ([proc-p (unwrap-cpointer 'ffi-call to-wrap)] diff --git a/racket/src/cs/schemified/io.scm b/racket/src/cs/schemified/io.scm index 3586604018..0cd38601f4 100644 --- a/racket/src/cs/schemified/io.scm +++ b/racket/src/cs/schemified/io.scm @@ -32624,7 +32624,8 @@ (lambda (s_0 up?_0) (if (if (equal? (1/current-locale) "") (not - (zero? + (fx= + 0 (fxand (|#%app| rktio_convert_properties