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

cs: faster internal procedure-arity-includes/c

Browse Source
This commit is contained in:
Matthew Flatt 2019-10-24 06:25:20 -06:00
parent 487277ad02
commit 5345fd294c
2 changed files with 20 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
racket/src/cs/rumble/check.ss
View File

@ -45,9 +45,9 @@
(and (integer? n) (and (integer? n)
(exact? n) (exact? n)
(not (negative? n)))) (not (negative? n))))
#'(lambda (p) (with-syntax ([n-mask (bitwise-arithmetic-shift-left 1 (syntax->datum #'m))])
(and (procedure? p) #'(lambda (p)
(procedure-arity-includes? p n)))])) (unsafe-procedure-and-arity-includes? p n)))]))
(define (check-space who what d-start d-len s-len) (define (check-space who what d-start d-len s-len)
(unless (fx<= (fx+ d-start s-len) d-len) (unless (fx<= (fx+ d-start s-len) d-len)

28
racket/src/cs/rumble/procedure.ss
View File

@ -163,7 +163,7 @@
(define/who procedure-arity-includes? (define/who procedure-arity-includes?
(case-lambda (case-lambda
[(f n incomplete-ok?) [(f n incomplete-ok?)
(let ([mask (get-procedure-arity-mask who f incomplete-ok?)]) (let ([mask (get-procedure-arity-mask who f incomplete-ok? #f)])
(check who exact-nonnegative-integer? n) (check who exact-nonnegative-integer? n)
(bitwise-bit-set? mask n))] (bitwise-bit-set? mask n))]
[(f n) (procedure-arity-includes? f n #f)])) [(f n) (procedure-arity-includes? f n #f)]))
@ -171,18 +171,24 @@
(define (chez:procedure-arity-includes? proc n) (define (chez:procedure-arity-includes? proc n)
(bitwise-bit-set? (#%procedure-arity-mask proc) n)) (bitwise-bit-set? (#%procedure-arity-mask proc) n))
;; assumes that `n` is an exact nonnegative integer
(define (unsafe-procedure-and-arity-includes? p n)
(if (#%procedure? p)
(chez:procedure-arity-includes? p n)
(bitwise-bit-set? (get-procedure-arity-mask #f p #f 0) n)))
(define (procedure-arity orig-f) (define (procedure-arity orig-f)
(mask->arity (get-procedure-arity-mask 'procedure-arity orig-f #t))) (mask->arity (get-procedure-arity-mask 'procedure-arity orig-f #t #f)))
(define/who (procedure-arity-mask orig-f) (define/who (procedure-arity-mask orig-f)
(get-procedure-arity-mask who orig-f #t)) (get-procedure-arity-mask who orig-f #t #f))
(define (get-procedure-arity-mask who orig-f incomplete-ok?) (define (get-procedure-arity-mask who orig-f incomplete-ok? fail-v)
(cond (cond
[(#%procedure? orig-f) [(#%procedure? orig-f)
(#%procedure-arity-mask orig-f)] (#%procedure-arity-mask orig-f)]
[else [else
(let proc-arity-mask ([f orig-f] [shift 0]) (let proc-arity-mask ([f orig-f] [shift 0] [fail-v fail-v])
(cond (cond
[(#%procedure? f) [(#%procedure? f)
(bitwise-arithmetic-shift-right (#%procedure-arity-mask f) shift)] (bitwise-arithmetic-shift-right (#%procedure-arity-mask f) shift)]
@ -200,14 +206,14 @@
(let ([v (struct-property-ref prop:procedure rtd #f)]) (let ([v (struct-property-ref prop:procedure rtd #f)])
(cond (cond
[(fixnum? v) [(fixnum? v)
(proc-arity-mask (unsafe-struct-ref f v) shift)] (proc-arity-mask (unsafe-struct-ref f v) shift 0)]
[(eq? v 'unsafe) [(eq? v 'unsafe)
(proc-arity-mask (impersonator-next f) shift)] (proc-arity-mask (impersonator-next f) shift 0)]
[else [else
(proc-arity-mask v (add1 shift))]))]))]))] (proc-arity-mask v (add1 shift) 0)]))]))]))]
[(eq? f orig-f) [else
(raise-argument-error who "procedure?" orig-f)] (or fail-v
[else 0]))])) (raise-argument-error who "procedure?" orig-f))]))]))
(define (procedure-incomplete-arity? f) (define (procedure-incomplete-arity? f)
(cond (cond