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

revise keyword implementation to reduce overhead

Browse Source 
svn: r15368
This commit is contained in:
Matthew Flatt 2009-07-03 03:10:25 +00:00
parent 6d3481a927
commit 6d8c6e4f09
1 changed files with 229 additions and 92 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

171
collects/scheme/private/kw.ss
View File

@ -22,7 +22,7 @@
;; ----------------------------------------
(-define-struct keyword-procedure (proc required allowed))
(-define-struct keyword-procedure (proc required allowed checker))
(define-values (struct:keyword-method make-km keyword-method? km-ref km-set!)
(make-struct-type 'procedure
struct:keyword-procedure
@ -138,6 +138,7 @@
proc
null
#f
(make-keyword-checker null #f (procedure-arity proc))
plain-proc)])])
make-keyword-procedure))
@ -188,7 +189,7 @@
(if (null? kws)
(apply proc normal-args)
(apply
(keyword-procedure-extract kws (+ 2 (length normal-args)) proc)
(keyword-procedure-extract/method kws (+ 2 (length normal-args)) proc 0)
kws
kw-vals
normal-args)))))
@ -373,8 +374,11 @@
[make-okp (if method?
#'make-optional-keyword-method
#'make-optional-keyword-procedure)]
[method? method?])
[method? method?]
[with-kw-min-args (+ 2 (length plain-ids))]
[with-kw-max-arg (if (null? (syntax-e #'rest))
(+ 2 (length plain-ids) (length opts))
#f)])
(let ([with-core
(lambda (result)
;; body of procedure, where all keyword and optional
@ -464,6 +468,9 @@
with-kws
null
'kws
(lambda (given-kws given-argc)
(and (in-range?/static given-argc with-kw-min-args with-kw-max-arg)
(subset?/static given-kws 'kws)))
no-kws))))]
[else
;; just the keywords part dispatches to core,
@ -481,13 +488,16 @@
(mk-id
with-kws
'needed-kws
'kws))))]))))))])
'kws
(lambda (given-kws given-argc)
(and (in-range?/static given-argc with-kw-min-args with-kw-max-arg)
(subsets?/static 'needed-kws given-kws 'kws)))))))]))))))])
#`(#%expression #,stx)))])
(values new-lambda new-lambda)))
(define (missing-kw proc . args)
(apply
(keyword-procedure-extract null 0 proc)
(keyword-procedure-extract/method null 0 proc 0)
null
null
args))
@ -505,6 +515,11 @@
(syntax-rules ()
[(_ kws kw-args () . body)
(begin . body)]
[(_ kws kw-args ([kw arg arg? #f]) . body)
;; last optional argument doesn't need to check as much or take as many cdrs
(let ([arg? (pair? kws)])
(let ([arg (if arg? (car kw-args) (void))])
. body))]
[(_ kws kw-args ([kw arg arg? #f] . rest) . body)
(let ([arg? (and (pair? kws)
(eq? 'kw (car kws)))])
@ -512,6 +527,10 @@
[kws (if arg? (cdr kws) kws)]
[kw-args (if arg? (cdr kw-args) kw-args)])
(let-kws kws kw-args rest . body)))]
[(_ kws kw-args ([kw arg arg? #t]) . body)
;; last required argument doesn't need to take cdrs
(let ([arg (car kw-args)])
. body)]
[(_ kws kw-args ([kw arg arg? #t] . rest) . body)
(let ([arg (car kw-args)]
[kws (cdr kws)]
@ -618,6 +637,49 @@
[(_ (id) () () () () (req-id) . body)
(let ([id req-id]) . body)]))
;; ----------------------------------------
;; Helper macros:
;; Generate arity and keyword-checking procedure statically
;; as much as is reasonable.
(define-syntax (in-range?/static stx)
(syntax-case stx ()
[(_ v min #f)
#'(v . >= . min)]
[(_ v min max)
(if (equal? (syntax-e #'min) (syntax-e #'max))
#'(= v min)
#'(and (v . >= . min) (v . <= . max)))]))
(define-syntax (subset?/static stx)
(syntax-case stx (quote)
[(_ l1-expr '()) #'(null? l1-expr)]
[(_ '() l2-expr) #'#t]
[(_ l1-expr l2-expr) #'(subset? l1-expr l2-expr)]))
(define-syntax (subsets?/static stx)
(syntax-case stx (quote)
[(_ '() l2-expr l3-expr)
#'(subset?/static l2-expr l3-expr)]
[(_ l1-expr l2-expr '())
#'(subset?/static l1-expr l2-expr)]
[(_ 'l1-elems l2-expr 'l3-elems)
(if (equal? (map syntax-e (syntax->list #'l1-elems))
(map syntax-e (syntax->list #'l3-elems)))
;; l2 must be equal to l1/l3:
#'(equal?/static 'l1-elems l2-expr)
#'(subsets? 'l1-elems l2-expr 'l3-elems))]))
(define-syntax (equal?/static stx)
;; Unroll loop at expansion time
(syntax-case stx (quote)
[(_ '() l2-expr) #'(null? l2-expr)]
[(_ '(kw . kw-rest) l2-expr)
#'(let ([l2 l2-expr])
(and (pair? l2)
(eq? (car l2) 'kw)
(equal?/static 'kw-rest (cdr l2))))]))
;; ----------------------------------------
;; `define' with keyword arguments
@ -701,7 +763,7 @@
[cnt (+ 1 (length args))])
(quasisyntax/loc stx
(let #,(reverse bind-accum)
((keyword-procedure-extract '#,(map car sorted-kws) #,cnt #,(car args))
((keyword-procedure-extract/method '#,(map car sorted-kws) #,cnt #,(car args) 0)
'#,(map car sorted-kws)
(list #,@(map cdr sorted-kws))
. #,(cdr args)))))]
@ -741,14 +803,88 @@
(loop kws required (cdr allowed)))]
[else (values #f (car kws))])))
;; Generates a keyword an arity checker dynamically:
(define (make-keyword-checker req-kws allowed-kws arity)
;; If min-args is #f, then max-args is an arity value.
;; If max-args is #f, then >= min-args is accepted.
(define-syntax (arity-check-lambda stx)
(syntax-case stx ()
[(_ (kws) kw-body)
#'(cond
[(integer? arity)
(lambda (kws a) (and kw-body (= a arity)))]
[(arity-at-least? arity)
(let ([arity (arity-at-least-value arity)])
(lambda (kws a) (and kw-body (a . >= . arity))))]
[else
(lambda (kws a) (and kw-body (arity-includes? arity a)))])]))
(cond
[(not allowed-kws)
;; All allowed
(cond
[(null? req-kws)
;; None required
(arity-check-lambda (kws) #t)]
[else
(arity-check-lambda (kws) (subset? req-kws kws))])]
[(null? allowed-kws)
;; None allowed
(arity-check-lambda (kws) (null? kws))]
[else
(cond
[(null? req-kws)
;; None required, just allowed
(arity-check-lambda (kws) (subset? kws allowed-kws))]
[else
;; Some required, some allowed
(if (equal? req-kws allowed-kws)
(arity-check-lambda
(kws)
;; All allowed are required, so check equality
(let loop ([kws kws][req-kws req-kws])
(if (null? req-kws)
(null? kws)
(and (eq? (car kws) (car req-kws))
(loop (cdr kws) (cdr req-kws))))))
(arity-check-lambda
(kws)
;; Required is a subset of allowed
(subsets? req-kws kws allowed-kws)))])]))
(define (arity-includes? arity a)
(cond
[(integer? arity) (= arity a)]
[(arity-at-least? arity)
(a . >= . (arity-at-least-value a))]
[else
(ormap (lambda (ar) (arity-includes? ar a)) arity)]))
(define (subset? l1 l2)
;; l1 and l2 are sorted
(cond
[(null? l1) #t]
[(null? l2) #f]
[(eq? (car l1) (car l2)) (subset? (cdr l1) (cdr l2))]
[else (subset? l1 (cdr l2))]))
(define (subsets? l1 l2 l3)
;; l1, l2, and l3 are sorted, and l1 is a subset of l3
(cond
[(null? l1) (subset? l2 l3)]
[(null? l2) #f]
[(null? l3) #f]
[else (let ([v2 (car l2)])
(cond
[(eq? (car l1) v2) (subsets? (cdr l1) (cdr l2) (cdr l3))]
[(eq? v2 (car l3)) (subsets? l1 (cdr l2) (cdr l3))]
[else (subsets? l1 l2 (cdr l3))]))]))
;; Extracts the procedure using the keyword-argument protocol.
;; If `p' doesn't accept keywords, make up a procedure that
;; reports an error.
(define (keyword-procedure-extract/method kws n p method-n)
(if (and (keyword-procedure? p)
(procedure-arity-includes? (keyword-procedure-proc p) n)
(let-values ([(missing-kw extra-kw) (check-kw-args p kws)])
(and (not missing-kw) (not extra-kw))))
((keyword-procedure-checker p) kws n))
;; Ok:
(keyword-procedure-proc p)
;; Not ok, so far:
@ -780,8 +916,7 @@
(if (and (null? args) (null? kws))
"no arguments supplied"
;; Hack to format arguments:
(with-handlers
([exn:fail?
(with-handlers ([exn:fail?
(lambda (exn)
;; the message can end with:
;; ..., given: x; given 117 arguments total
@ -877,15 +1012,17 @@
(raise-mismatch-error 'procedure-reduce-keyword-arity
"cannot allow keywords not in original allowed set: "
old-allowed))))
(make-optional-keyword-procedure
(procedure-reduce-arity (keyword-procedure-proc proc)
(let loop ([a arity])
(let ([new-arity (let loop ([a arity])
(cond
[(integer? a) (+ a 2)]
[(arity-at-least? a)
(make-arity-at-least (+ (arity-at-least-value a) 2))]
[else
(map loop a)])))
(map loop a)]))])
(make-optional-keyword-procedure
(procedure-reduce-arity (keyword-procedure-proc proc)
new-arity)
req-kw
allowed-kw
plain-proc))))
(make-keyword-checker req-kw allowed-kw new-arity)
plain-proc)))))