define-inline: better handling of misapplication

When a function from `define-inline` is applied to the wrong number of
arguments or the wrong keyword arguments, then leave it as a runtime
error (with a compile-time warning) instead of a badly reported
compile-time error.

Closes #3402
This commit is contained in:
Matthew Flatt 2021-05-05 20:00:41 -06:00
parent 808ea5f303
commit 9410a90a8b
3 changed files with 58 additions and 29 deletions

View File

@ -3047,12 +3047,15 @@ which has fewer dependencies than @racketmodname[racket/performance-hint].
(code:line keyword [arg-id default-expr])])]{ (code:line keyword [arg-id default-expr])])]{
Like @racket[define], but ensures that the definition will be inlined at its Like @racket[define], but ensures that the definition will be inlined at its
call sites. Recursive calls are not inlined, to avoid infinite inlining. call sites. Recursive calls are not inlined, to avoid infinite inlining.
Higher-order uses are supported, but also not inlined. Higher-order uses are supported, but also not inlined. Misapplication (by
supplying the wrong number of arguments or incorrect keyword arguments) is
also not inlined and left as a run-time error.
@racket[define-inline] may interfere with the Racket compiler's own inlining The @racket[define-inline] form may interfere with the Racket compiler's own inlining
heuristics, and should only be used when other inlining attempts (such as heuristics, and should only be used when other inlining attempts (such as
@racket[begin-encourage-inline]) fail. @racket[begin-encourage-inline]) fail.
}
@history[#:changed "8.1.0.5" @elem{Changed to treat misapplication as a run-time error.}]}
@;------------------------------------------------------------------------ @;------------------------------------------------------------------------

View File

@ -5896,6 +5896,11 @@
1 "") 1 "")
(test/output (sub #:b 1 #:a 2) (test/output (sub #:b 1 #:a 2)
1 "") 1 "")
;; a bad call is a runtime error, not a compile-time error
(test #t procedure? (lambda () (sub 'oops)))
(test #t procedure? (lambda () (sub #:oops 77)))
(test #t procedure? sub)
) )

View File

@ -61,9 +61,9 @@
(define-syntax (define-inline-helper stx) (define-syntax (define-inline-helper stx)
(syntax-parse stx (syntax-parse stx
[(_ (name:id . args:formals) . body) [(_ (name:id . args:formals) . body)
(with-syntax* ([internal-name (format-id #'name "~a-internal" #'name)] (with-syntax* ([internal-name (format-id #'here "~a-internal" #'name)]
[inline-name (format-id #'name "~a-inline" #'name)] [inline-name (format-id #'here "~a-inline" #'name)]
[function-aux (format-id #'name "~a-aux" #'name)] [function-aux (format-id #'here "~a-aux" #'name)]
[(arg-id ...) #'args.ids] [(arg-id ...) #'args.ids]
[(rest-arg-id ...) #'args.rest-arg] [(rest-arg-id ...) #'args.rest-arg]
[(tmp-arg-id ...) (generate-temporaries #'(arg-id ...))] [(tmp-arg-id ...) (generate-temporaries #'(arg-id ...))]
@ -76,7 +76,9 @@
#`(begin #`(begin
;; define a function version that recursive calls fall back to, to ;; define a function version that recursive calls fall back to, to
;; avoid infinite expansion ;; avoid infinite expansion
(define (internal-name . args) body*) (define internal-name
(let ([name (lambda args body*)])
name))
(define-syntax-parameter name (define-syntax-parameter name
(syntax-id-rules () (syntax-id-rules ()
[(_ . rest) (inline-name . rest)] [(_ . rest) (inline-name . rest)]
@ -97,6 +99,25 @@
(... (...
(syntax-parse stx* (syntax-parse stx*
[(_ arg*:actual ...) [(_ arg*:actual ...)
;; BEWARE! Catching all contract failures here, on the
;; grounds that the only possible error *should* be
;; an application of the inlined function to bad arguments:
(with-handlers ([exn:fail:contract?
;; If the arity or keywords are wrong, turn that
;; into a run-time error
(lambda (exn)
(let ([loc (srcloc->string (srcloc (syntax-source stx*)
(syntax-line stx*)
(syntax-column stx*)
(syntax-position stx*)
(syntax-span stx*)))])
(log-warning "~aincorrect call to would-be-inlined function: ~s"
(if loc (format "~a: " loc) "")
(syntax-e #'name)))
(syntax-parse stx*
[(_ arg ...)
(syntax/loc stx*
(internal-name arg ...))]))])
;; let*-bind the actuals, to ensure that they're evaluated ;; let*-bind the actuals, to ensure that they're evaluated
;; only once, and in order ;; only once, and in order
#`(let* ([arg*.tmp arg*.arg] ...) #`(let* ([arg*.tmp arg*.arg] ...)
@ -118,4 +139,4 @@
(map (lambda (x) (syntax-e (car x))) (map (lambda (x) (syntax-e (car x)))
sorted-keyword-entries) sorted-keyword-entries)
(map cadr sorted-keyword-entries) (map cadr sorted-keyword-entries)
(map cadr positional-entries)))))])))))])) (map cadr positional-entries))))))])))))]))