Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

checkpoint: add +2 fast paths for simple-result-> #1295

Draft
wants to merge 1 commit into
base: master
Choose a base branch
from
Draft

checkpoint: add +2 fast paths for simple-result-> #1295

Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
136 changes: 85 additions & 51 deletions typed-racket-lib/typed-racket/utils/simple-result-arrow.rkt
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -10,6 +10,8 @@

(provide simple-result->)

(define-logger tr:simpleresult)

(define-syntax-rule (the-contract n pred arity arg ...)
(make-chaperone-contract
#:name `(-> ,@(for/list ([i arity]) 'any/c) ,n)
Expand All @@ -30,57 +32,57 @@
(format "a procedure that accepts ~a non-keyword argument"
arity)
'given: (~s v))))
;; We could have separate kinda-fast paths for when one of these conditions
;; is true, but that is unlikely to be an important case in practice.
(if (and (equal? arity (procedure-arity v))
(equal? 1 (procedure-result-arity v)))
(unsafe-chaperone-procedure
v
(λ (arg ...)
(define res (v arg ...))
(unless (with-contract-continuation-mark (cons blm neg) (pred res))
(raise-blame-error
#:missing-party neg
blm #f
(list 'expected: (~s n) 'given: (~s res))))
res))
(unsafe-chaperone-procedure
v
;; use `make-keyword-procedure` to cover cases
;; where a keyword-accepting procedure is imported with a type that
;; doesn't mention the keywords
(make-keyword-procedure
(λ (kws vals . args) (raise-blame-error
#:missing-party neg
blm #f
(list 'expected: "one non-keyword argument"
'given: (~a (length args) " arguments and " (length vals)
" keyword arguments"))))
(case-lambda
[(arg ...)
(call-with-values (λ () (v arg ...))
(case-lambda [(res)
(unless (with-contract-continuation-mark
(cons blm neg)
(pred res))
(raise-blame-error
#:missing-party neg
blm #f
(list 'expected: (~s n) 'given: (~s res))))
res]
[results
(raise-blame-error
#:missing-party neg
blm results
(list 'expected "one value"
'given (~a (length results)
" values")))]))]
[args
(raise-blame-error
#:missing-party neg
blm #f
(list 'expected: "one argument"
'given: (~a (length args) " arguments")))]))))))))
(define simple-arity? (equal? arity (procedure-arity v)))
(define one-result? (equal? 1 (procedure-result-arity v)))
(cond
[(and simple-arity? one-result?)
(log-tr:simpleresult-info "+D +C")
(unsafe-chaperone-procedure
v
(λ (arg ...)
(define res (v arg ...))
(unless (with-contract-continuation-mark (cons blm neg) (pred res))
(raise-blame-error
#:missing-party neg
blm #f
(list 'expected: (~s n) 'given: (~s res))))
res))]
[simple-arity?
(log-tr:simpleresult-info "+D -C")
(unsafe-chaperone-procedure
v
(λ (arg ...)
(check-single-result (λ () (v arg ...)) pred blm neg n)))]
[one-result?
(log-tr:simpleresult-info "-D +C")
(unsafe-chaperone-procedure
v
(seal-kwargs blm neg
(λ (arg ...)
(define res (v arg ...))
(unless (with-contract-continuation-mark (cons blm neg) (pred res))
(raise-blame-error
#:missing-party neg
blm #f
(list 'expected: (~s n) 'given: (~s res))))
res)))]
[else
(log-tr:simpleresult-info "-D -C")
(unsafe-chaperone-procedure
v
;; use `make-keyword-procedure` to cover cases
;; where a keyword-accepting procedure is imported with a type that
;; doesn't mention the keywords
(seal-kwargs blm neg
(case-lambda
[(arg ...)
(check-single-result (λ () (v arg ...)) pred blm neg n)]
[args
(raise-blame-error
#:missing-party neg
blm #f
(list 'expected: "one argument"
'given: (~a (length args) " arguments")))])))])))))

;; arity is how many any/c arguments the function expects
(begin-encourage-inline
Expand All @@ -95,6 +97,38 @@
[(3) (the-contract n pred 3 arg1 arg2 arg3)]
[else (raise-argument-error 'simple-result-> "arity 0, 1, 2, or 3" arity)])))

(define (check-single-result thunk pred blm neg result-ctc)
(call-with-values thunk
(case-lambda [(res)
(unless (with-contract-continuation-mark
(cons blm neg)
(pred res))
(raise-blame-error
#:missing-party neg
blm #f
(list 'expected: (~s result-ctc) 'given: (~s res))))
res]
[results
(raise-blame-error
#:missing-party neg
blm results
(list 'expected "one value"
'given (~a (length results)
" values")))])))

(define (seal-kwargs plain-proc blm neg)
;; use `make-keyword-procedure` to cover cases
;; where a keyword-accepting procedure is imported with a type that
;; doesn't mention the keywords
(make-keyword-procedure
(λ (kws vals . args) (raise-blame-error
#:missing-party neg
blm #f
(list 'expected: "one non-keyword argument"
'given: (~a (length args) " arguments and " (length vals)
" keyword arguments"))))
plain-proc))

(module+ test
(struct m (x))
(define val (m 1))
Expand Down