suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

cs: cache foriegn call and callable wrappers

Browse Source 
Generating the code for a `_fun` type takes hundreds ot thousands
of times as long as in the traditional Racket VM, to cache results
to reduce the cost.
This commit is contained in:
Matthew Flatt 2018-07-01 20:53:59 -06:00
parent a1098bdb46
commit eea40a6350
1 changed files with 36 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

52
racket/src/cs/rumble/foreign.ss
View File

@ -471,12 +471,12 @@
[(types abi alignment) [(types abi alignment)
(let ([make-decls (let ([make-decls
(escapes-ok (escapes-ok
(lambda (id) (lambda (id next!-id)
(let-values ([(reps decls) (types->reps types)]) (let-values ([(reps decls) (types->reps types next!-id)])
(append decls (append decls
`((define-ftype ,id `((define-ftype ,id
(struct ,@(map (lambda (rep) (struct ,@(map (lambda (rep)
`[,(gensym) ,rep]) `[,(next!-id) ,rep])
reps))))))))]) reps))))))))])
(let-values ([(size alignment) (ctypes-sizeof+alignof types alignment)]) (let-values ([(size alignment) (ctypes-sizeof+alignof types alignment)])
(create-compound-ctype 'struct (create-compound-ctype 'struct
@ -493,12 +493,12 @@
types) types)
(let ([make-decls (let ([make-decls
(escapes-ok (escapes-ok
(lambda (id) (lambda (id next!-id)
(let-values ([(reps decls) (types->reps types)]) (let-values ([(reps decls) (types->reps types next!-id)])
(append decls (append decls
`((define-ftype ,id `((define-ftype ,id
(union ,@(map (lambda (rep) (union ,@(map (lambda (rep)
`[,(gensym) ,rep]) `[,(next!-id) ,rep])
reps))))))))] reps))))))))]
[size (apply max (map ctype-sizeof types))] [size (apply max (map ctype-sizeof types))]
[alignment (apply max (map ctype-alignof types))]) [alignment (apply max (map ctype-alignof types))])
@ -516,8 +516,8 @@
(check who exact-nonnegative-integer? count) (check who exact-nonnegative-integer? count)
(let ([make-decls (let ([make-decls
(escapes-ok (escapes-ok
(lambda (id) (lambda (id next!-id)
(let-values ([(reps decls) (types->reps (list type))]) (let-values ([(reps decls) (types->reps (list type) next!-id)])
(append decls (append decls
`((define-ftype ,id `((define-ftype ,id
(array ,count ,(car reps))))))))] (array ,count ,(car reps))))))))]
@ -1286,6 +1286,10 @@
(define (set-foreign-eval! proc) (define (set-foreign-eval! proc)
(set! eval/foreign proc)) (set! eval/foreign proc))
;; Cache generated code for an underlying foreign call or callable shape:
(define ffi-expr->code (make-weak-hash)) ; expr to weak cell of code
(define ffi-code->expr (make-weak-eq-hashtable)) ; keep exprs alive as long as code lives
(define/who ffi-call (define/who ffi-call
(case-lambda (case-lambda
[(p in-types out-type) [(p in-types out-type)
@ -1343,22 +1347,29 @@
(if (eq? host-rep 'array) (if (eq? host-rep 'array)
'void* 'void*
host-rep))] host-rep))]
[next!-id (let ([counter 0])
;; Like `gensym`, but deterministic --- and doesn't
;; have to be totally unique, as long as it doesn't
;; collide with other code that we generate
(lambda ()
(set! counter (add1 counter))
(string->symbol (string-append "type_" (number->string counter)))))]
[ids (map (lambda (in-type) [ids (map (lambda (in-type)
(and (by-value? in-type) (and (by-value? in-type)
(gensym))) (next!-id)))
in-types)] in-types)]
[ret-id (and (by-value? out-type) [ret-id (and (by-value? out-type)
(gensym))] (next!-id))]
[decls (let loop ([in-types in-types] [ids ids] [decls '()]) [decls (let loop ([in-types in-types] [ids ids] [decls '()])
(cond (cond
[(null? in-types) decls] [(null? in-types) decls]
[(car ids) [(car ids)
(let ([id-decls ((compound-ctype-get-decls (car in-types)) (car ids))]) (let ([id-decls ((compound-ctype-get-decls (car in-types)) (car ids) next!-id)])
(loop (cdr in-types) (cdr ids) (append decls id-decls)))] (loop (cdr in-types) (cdr ids) (append decls id-decls)))]
[else [else
(loop (cdr in-types) (cdr ids) decls)]))] (loop (cdr in-types) (cdr ids) decls)]))]
[ret-decls (if ret-id [ret-decls (if ret-id
((compound-ctype-get-decls out-type) ret-id) ((compound-ctype-get-decls out-type) ret-id next!-id)
'())] '())]
[ret-size (and ret-id (ctype-sizeof out-type))] [ret-size (and ret-id (ctype-sizeof out-type))]
[gen-proc+ret-maker+arg-makers [gen-proc+ret-maker+arg-makers
@ -1392,7 +1403,16 @@
(make-ftype-pointer ,id p)))) (make-ftype-pointer ,id p))))
ids) ids)
'())))]) '())))])
(eval/foreign expr (if call? 'comp-ffi 'comp-ffi-back)))] (let* ([wb (with-interrupts-disabled
(weak-hash-ref ffi-expr->code expr #f))]
[code (if wb (car wb) #!bwp)])
(if (eq? code #!bwp)
(let ([code (eval/foreign expr (if call? 'comp-ffi 'comp-ffi-back))])
(hashtable-set! ffi-code->expr (car code) expr)
(with-interrupts-disabled
(weak-hash-set! ffi-expr->code expr (weak-cons code #f)))
code)
code)))]
[gen-proc (car gen-proc+ret-maker+arg-makers)] [gen-proc (car gen-proc+ret-maker+arg-makers)]
[ret-maker (cadr gen-proc+ret-maker+arg-makers)] [ret-maker (cadr gen-proc+ret-maker+arg-makers)]
[arg-makers (cddr gen-proc+ret-maker+arg-makers)] [arg-makers (cddr gen-proc+ret-maker+arg-makers)]
@ -1480,15 +1500,15 @@
[(void*) (cpointer-address v)] [(void*) (cpointer-address v)]
[else v]))))))]))) [else v]))))))])))
(define (types->reps types) (define (types->reps types next!-id)
(let loop ([types types] [reps '()] [decls '()]) (let loop ([types types] [reps '()] [decls '()])
(cond (cond
[(null? types) (values (reverse reps) decls)] [(null? types) (values (reverse reps) decls)]
[else [else
(let ([type (car types)]) (let ([type (car types)])
(if (compound-ctype? type) (if (compound-ctype? type)
(let* ([id (gensym)] (let* ([id (next!-id)]
[id-decls ((compound-ctype-get-decls type) id)]) [id-decls ((compound-ctype-get-decls type) id next!-id)])
(loop (cdr types) (cons id reps) (append id-decls decls))) (loop (cdr types) (cons id reps) (append id-decls decls)))
(loop (cdr types) (cons (ctype-host-rep type) reps) decls)))]))) (loop (cdr types) (cons (ctype-host-rep type) reps) decls)))])))