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

improve the way plus-one arity functions fall back when they can't see the application site

Browse Source 
In particular, instead of going directly back to the chaperone, handle
the case where the function doesn't accept keyword arguments with a
less expensive fallback.

The less expensive fallback uses a case-lambda wrapper (wrapped inside
a make-keyword-procedure) to close over the neg-party and avoid the
chaperone creation. With this commit, the program below gets about 3x
faster, and is only about 20% slower than the version that replaces
the "(let ([f f]) ...)" with its body

  #lang racket/base
  (module m racket/base
    (require racket/contract/base)
    (provide (contract-out [f (-> integer? integer?)]))
    (define (f x) x))
  (require 'm)
  (collect-garbage)
  (time (for ([x (in-range 5000000)]) (let ([f f]) (f 1))))

  Thanks, @samth!
This commit is contained in:
Robby Findler 2016-01-07 09:58:01 -06:00
parent 578b42fc2b
commit c24ddb4a7c
4 changed files with 154 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

27
pkgs/racket-doc/scribblings/reference/contract-util.rkt Normal file
View File

@ -0,0 +1,27 @@
#lang racket/base
(require scribble/manual)
(provide add-use-sources declare-exporting-ctc)
(define-syntax-rule
(add-use-sources (x y ...))
(x y ...
#:use-sources
(racket/contract/private/base
racket/contract/private/misc
racket/contract/private/provide
racket/contract/private/guts
racket/contract/private/prop
racket/contract/private/blame
racket/contract/private/ds
racket/contract/private/opt
racket/contract/private/basic-opters
racket/contract/private/box
racket/contract/private/hash
racket/contract/private/vector
racket/contract/private/struct-dc)))
(define-syntax-rule
(declare-exporting-ctc mod)
(add-use-sources (declare-exporting mod racket/contract racket)))

54
pkgs/racket-test/tests/racket/contract/contract-out.rkt
View File

@ -996,6 +996,60 @@
(provide a)))
(eval '(dynamic-require ''provide/contract51-m2 'a)))
'(1 2 3 4))
(test/spec-passed/result
'provide/contract52
'(let ()
(eval '(module provide/contract52-m1 racket/base
(require racket/contract/base)
(provide (contract-out
[f (->* (integer?) (boolean? char? any/c) any)]))
(define (f x [y #f] [z #\a] [w 0]) (list x y z w))))
(eval '(module provide/contract52-m2 racket/base
(require 'provide/contract52-m1)
(provide a)
(define a
(let ([f f])
(list (f 1 #t #\x)
(f 1))))))
(eval '(dynamic-require ''provide/contract52-m2 'a)))
'((1 #t #\x 0) (1 #f #\a 0)))
(test/spec-passed/result
'provide/contract53
'(let ()
(eval '(module provide/contract53-m1 racket/base
(require racket/contract/base)
(provide (contract-out
[f (->* (integer?) (boolean? char? any/c) #:rest any/c any)]))
(define (f x [y #f] [z #\a] [w 0] . rest) (list* x y z w rest))))
(eval '(module provide/contract53-m2 racket/base
(require 'provide/contract53-m1)
(provide a)
(define a
(let ([f f])
(list (f 1 #t #\x 11 22 33 44 55 66)
(f 1))))))
(eval '(dynamic-require ''provide/contract53-m2 'a)))
'((1 #t #\x 11 22 33 44 55 66) (1 #f #\a 0)))
(test/spec-passed/result
'provide/contract54
'(let ()
(eval '(module provide/contract54-m1 racket/base
(require racket/contract/base)
(provide (contract-out
[f (->* (#:x integer?) (#:y boolean? #:z char? #:w any/c) any)]))
(define (f #:x x #:y [y #f] #:z [z #\a] #:w [w 0]) (list x y z w))))
(eval '(module provide/contract54-m2 racket/base
(require 'provide/contract54-m1)
(provide a)
(define a
(let ([f f])
(list (f #:x 1 #:y #t #:z #\x)
(f #:x 1))))))
(eval '(dynamic-require ''provide/contract54-m2 'a)))
'((1 #t #\x 0) (1 #f #\a 0)))
(contract-error-test
'contract-error-test8

41
racket/collects/racket/contract/private/application-arity-checking.rkt
View File

@ -1,5 +1,5 @@
#lang racket/base
(require (for-template racket/base))
#|
Used to check an application site of a well-known
@ -13,7 +13,8 @@ a valid-app-shape.
|#
(provide (struct-out valid-app-shapes)
valid-argument-list?)
valid-argument-list?
generate-medium-speed-wrapper)
;; valid-arities : (or/c (listof nat) (improper-listof nat))
;; -- if improper, then the last nat indicates that any number
@ -63,6 +64,42 @@ a valid-app-shape.
ans?]
[else #t]))
;; called in the case that the identifier isn't used directly in an
;; application. Try to generate a case-lambda that can still avoid
;; the chaperone creation
(define (generate-medium-speed-wrapper the-valid-app-shape
chaperone-expr
extra-arg-function
neg-party-id
add-medium-speed-kwd-wrapper-id
expected-name)
(cond
[(and the-valid-app-shape
(null? (valid-app-shapes-mandatory-kwds the-valid-app-shape))
(null? (valid-app-shapes-optional-kwds the-valid-app-shape)))
(define chaperone-expr-id (car (generate-temporaries '(medium-speed-wrapper))))
(define (mk-n-ids n) (generate-temporaries (build-list n (λ (x) 'medium-speed-wrapper-arg))))
(define case-lambda-clauses
(let loop ([valid-arities (valid-app-shapes-valid-arities the-valid-app-shape)])
(cond
[(null? valid-arities)
(list #`[args (apply #,chaperone-expr-id args)])]
[(number? valid-arities)
(with-syntax ([(x ...) (mk-n-ids valid-arities)]
[(rest-arg) (generate-temporaries '(medium-speed-wrapper-dot-arg))])
(list
#`[(x ... . rest-arg) (apply #,extra-arg-function #,neg-party-id x ... rest-arg)]))]
[else
(with-syntax ([(x ...) (mk-n-ids (car valid-arities))])
(cons #`[(x ...) (#,extra-arg-function #,neg-party-id x ...)]
(loop (cdr valid-arities))))])))
#`(let ([#,chaperone-expr-id #,chaperone-expr])
(#,add-medium-speed-kwd-wrapper-id
#,chaperone-expr-id
(let ([#,expected-name (case-lambda #,@case-lambda-clauses)])
#,expected-name)))]
[else chaperone-expr]))
(define-logger optimizer)
(define (log-problem stx)
(log-optimizer-warning

42
racket/collects/racket/contract/private/provide.rkt
View File

@ -88,7 +88,8 @@
(saved-ho-id-table
partially-applied-id
extra-neg-party-argument-fn
valid-argument-lists)
valid-argument-lists
ex-id)
#:property
prop:set!-transformer
(λ (self stx)
@ -96,8 +97,9 @@
[saved-ho-id-table (provide/contract-arrow-transformer-saved-ho-id-table self)]
[extra-neg-party-argument-fn
(provide/contract-arrow-transformer-extra-neg-party-argument-fn self)]
[valid-arg-lists (provide/contract-arrow-transformer-valid-argument-lists self)]
[rename-id (provide/contract-info-rename-id self)])
[the-valid-arg-shapes (provide/contract-arrow-transformer-valid-argument-lists self)]
[rename-id (provide/contract-info-rename-id self)]
[ex-id (provide/contract-arrow-transformer-ex-id self)])
(with-syntax ([partially-applied-id partially-applied-id]
[extra-neg-party-argument-fn extra-neg-party-argument-fn])
(if (eq? 'expression (syntax-local-context))
@ -124,7 +126,15 @@
(add-rename-id rename-id
(syntax-local-lift-expression
(add-lifted-property
#'(partially-applied-id lifted-neg-party))))))))
(generate-medium-speed-wrapper
the-valid-arg-shapes
#'(partially-applied-id lifted-neg-party)
(add-neg-party (add-rename-id
rename-id
#'extra-neg-party-argument-fn))
#'lifted-neg-party
#'add-medium-speed-kwd-wrapper
ex-id))))))))
(when key (hash-set! saved-ho-id-table key lifted-ctc-val))
(adjust-location (syntax-local-introduce lifted-ctc-val)))
(syntax-case stx (set!)
@ -138,7 +148,7 @@
stx #'id)]
[(name more ...)
(with-syntax ([app (datum->syntax stx '#%app)])
(if (valid-argument-list? stx valid-arg-lists)
(if (valid-argument-list? stx the-valid-arg-shapes)
(with-syntax ([lifted-neg-party (syntax-local-introduce lifted-neg-party)])
(adjust-location
#`(app #,(add-neg-party (add-rename-id
@ -209,12 +219,27 @@
#`(app #,id args ...))]
[x (identifier? #'x) id])))))
(define (make-provide/contract-arrow-transformer rename-id contract-id id pai enpfn val)
(define (make-provide/contract-arrow-transformer rename-id contract-id id pai enpfn val ex-id)
(provide/contract-arrow-transformer rename-id
contract-id id
(make-hasheq)
pai enpfn val)))
pai enpfn val ex-id)))
(define (add-medium-speed-kwd-wrapper chapone-contracted-proc no-keywords-path)
(make-keyword-procedure
(λ (kwds kwd-args . args)
(keyword-apply chapone-contracted-proc kwds kwd-args args))
no-keywords-path))
(define-syntax (maybe-add-name stx)
(syntax-case stx ()
[(_ expr)
(let ()
(define name (syntax-local-name))
(printf "name! ~s\n" name)
(if (symbol? name)
#`(let ([#,name expr]) #,name)
#'expr))]))
;; tl-code-for-one-id/new-name : syntax syntax syntax (union syntax #f) -> (values syntax syntax)
;; given the syntax for an identifier and a contract,
@ -317,7 +342,8 @@
(quote-syntax contract-id) (quote-syntax id)
(quote-syntax partially-applied-id)
(quote-syntax extra-neg-party-argument-fn)
#,the-valid-app-shapes)
#,the-valid-app-shapes
'#,ex-id)
#`(make-provide/contract-transformer
(quote-syntax #,id-rename)
(quote-syntax contract-id) (quote-syntax id)