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

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

Browse Source 
This reverts commit c24ddb4a7c.

This optimization was bogus, as shown by the test case in 393d72f153

(Thanks to Sam again for the test case.)
This commit is contained in:
Robby Findler 2016-01-07 22:13:38 -06:00
parent 393d72f153
commit 32a79a22ec
3 changed files with 10 additions and 100 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1,27 +0,0 @@
#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)))

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,8 +13,7 @@ a valid-app-shape.
|#
(provide (struct-out valid-app-shapes)
valid-argument-list?
generate-medium-speed-wrapper)
valid-argument-list?)
;; valid-arities : (or/c (listof nat) (improper-listof nat))
;; -- if improper, then the last nat indicates that any number
@ -64,42 +63,6 @@ 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,8 +88,7 @@
(saved-ho-id-table
partially-applied-id
extra-neg-party-argument-fn
valid-argument-lists
ex-id)
valid-argument-lists)
#:property
prop:set!-transformer
(λ (self stx)
@ -97,9 +96,8 @@
[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)]
[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)])
[valid-arg-lists (provide/contract-arrow-transformer-valid-argument-lists self)]
[rename-id (provide/contract-info-rename-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))
@ -126,15 +124,7 @@
(add-rename-id rename-id
(syntax-local-lift-expression
(add-lifted-property
(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))))))))
#'(partially-applied-id lifted-neg-party))))))))
(when key (hash-set! saved-ho-id-table key lifted-ctc-val))
(adjust-location (syntax-local-introduce lifted-ctc-val)))
(syntax-case stx (set!)
@ -148,7 +138,7 @@
stx #'id)]
[(name more ...)
(with-syntax ([app (datum->syntax stx '#%app)])
(if (valid-argument-list? stx the-valid-arg-shapes)
(if (valid-argument-list? stx valid-arg-lists)
(with-syntax ([lifted-neg-party (syntax-local-introduce lifted-neg-party)])
(adjust-location
#`(app #,(add-neg-party (add-rename-id
@ -219,27 +209,12 @@
#`(app #,id args ...))]
[x (identifier? #'x) id])))))
(define (make-provide/contract-arrow-transformer rename-id contract-id id pai enpfn val ex-id)
(define (make-provide/contract-arrow-transformer rename-id contract-id id pai enpfn val)
(provide/contract-arrow-transformer rename-id
contract-id id
(make-hasheq)
pai enpfn val ex-id)))
pai enpfn val)))
(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,
@ -342,8 +317,7 @@
(quote-syntax contract-id) (quote-syntax id)
(quote-syntax partially-applied-id)
(quote-syntax extra-neg-party-argument-fn)
#,the-valid-app-shapes
'#,ex-id)
#,the-valid-app-shapes)
#`(make-provide/contract-transformer
(quote-syntax #,id-rename)
(quote-syntax contract-id) (quote-syntax id)