Add define-inline.
Drop-in replacement for define that guarantees inlining.
This commit is contained in:
Vincent St-Amour
parent
ec673fd58d
commit
b715a6fed5
|
|
@ -1512,10 +1512,12 @@ path/s is either such a string or a list of them.
|
|||
"collects/unstable/automata" responsible (jay)
|
||||
"collects/unstable/debug.rkt" responsible (samth)
|
||||
"collects/unstable/hash.rkt" responsible (samth)
|
||||
"collects/unstable/inline.rkt" responsible (stamourv) drdr:command-line (raco "test" *)
|
||||
"collects/unstable/logging.rkt" responsible (stamourv)
|
||||
"collects/unstable/match.rkt" responsible (samth)
|
||||
"collects/unstable/scribblings/debug.scrbl" responsible (samth)
|
||||
"collects/unstable/scribblings/hash.scrbl" responsible (samth)
|
||||
"collects/unstable/scribblings/inline.scrbl" responsible (stamourv)
|
||||
"collects/unstable/scribblings/logging.scrbl" responsible (stamourv)
|
||||
"collects/unstable/scribblings/match.scrbl" responsible (samth)
|
||||
"collects/unstable/scribblings/sequence.scrbl" responsible (samth)
|
||||
|
|
|
|||
219
collects/unstable/inline.rkt
Normal file
219
collects/unstable/inline.rkt
Normal file
|
|
@ -0,0 +1,219 @@
|
|||
#lang racket/base
|
||||
|
||||
(require (for-syntax syntax/parse syntax/define
|
||||
racket/syntax racket/base)
|
||||
racket/stxparam)
|
||||
|
||||
(provide define-inline)
|
||||
|
||||
(begin-for-syntax
|
||||
|
||||
(define-splicing-syntax-class actual
|
||||
(pattern (~seq (~optional kw:keyword) arg:expr)
|
||||
#:with tmp (generate-temporary #'arg)
|
||||
#:attr for-aux (list (attribute kw) (attribute tmp))))
|
||||
|
||||
(define-syntax-class formals
|
||||
(pattern () ; done
|
||||
#:with aux-args #'()
|
||||
#:with ids #'()
|
||||
#:with rest-arg #'()) ; rest-arg is () for no rest arg or (id)
|
||||
(pattern rest:id
|
||||
#:with aux-args #'rest
|
||||
#:with ids #'()
|
||||
#:with rest-arg #'(rest))
|
||||
(pattern (x:id . rest:formals)
|
||||
#:with aux-args #'(x . rest.aux-args)
|
||||
#:with ids #'(x . rest.ids)
|
||||
#:with rest-arg #'rest.rest-arg)
|
||||
(pattern ([x:id default:expr] . rest:formals)
|
||||
;; for aux-args, wrap defaults in syntax
|
||||
#:with aux-args #'([x #'default] . rest.aux-args)
|
||||
#:with ids #'(x . rest.ids)
|
||||
#:with rest-arg #'rest.rest-arg)
|
||||
(pattern (kw:keyword x:id . rest:formals)
|
||||
#:with aux-args #'(kw x . rest.aux-args)
|
||||
#:with ids #'(x . rest.ids)
|
||||
#:with rest-arg #'rest.rest-arg)
|
||||
(pattern (kw:keyword [x:id default:expr] . rest:formals)
|
||||
#:with aux-args #'(kw [x #'default] . rest.aux-args)
|
||||
#:with ids #'(x . rest.ids)
|
||||
#:with rest-arg #'rest.rest-arg)))
|
||||
|
||||
(define-syntax (define-inline stx)
|
||||
(syntax-parse stx
|
||||
[(_ (name . formals) . body)
|
||||
(define-values (name lam) (normalize-definition stx #'lambda #t #t))
|
||||
(syntax-parse lam
|
||||
[(_ args . body)
|
||||
#`(define-inline-helper (#,name . args) . body)])]
|
||||
[_
|
||||
(raise-syntax-error
|
||||
'define-inline "only supports definitions with function headers" stx)]))
|
||||
|
||||
(define-syntax (define-inline-helper stx)
|
||||
(syntax-parse stx
|
||||
[(_ (name:id . args:formals) . body)
|
||||
(with-syntax* ([internal-name (format-id #'name "~a-internal" #'name)]
|
||||
[inline-name (format-id #'name "~a-inline" #'name)]
|
||||
[function-aux (format-id #'name "~a-aux" #'name)]
|
||||
[(arg-id ...) #'args.ids]
|
||||
[(rest-arg-id ...) #'args.rest-arg]
|
||||
[(tmp-arg-id ...) (generate-temporaries #'(arg-id ...))]
|
||||
[(tmp-rest-arg-id ...)
|
||||
(generate-temporaries #'(rest-arg-id ...))]
|
||||
[body*
|
||||
#'(let-syntax ([name (make-rename-transformer
|
||||
(quote-syntax internal-name))])
|
||||
. body)])
|
||||
#`(begin
|
||||
;; define a function version that recursive calls fall back to, to
|
||||
;; avoid infinite expansion
|
||||
(define (internal-name . args) body*)
|
||||
(define-syntax-parameter name
|
||||
(syntax-id-rules ()
|
||||
[(_ . rest) (inline-name . rest)]
|
||||
[_ internal-name])) ; higher-order use
|
||||
(define-syntax (inline-name stx*)
|
||||
;; generate a compile-time function that takes care of linking
|
||||
;; formals and actuals (so we don't have to handle keyword
|
||||
;; arguments manually)
|
||||
(define (function-aux . args.aux-args)
|
||||
;; default values for optional arguments can refer to previous
|
||||
;; arguments, which makes things tricky
|
||||
(with-syntax* ([tmp-arg-id arg-id] ...
|
||||
[tmp-rest-arg-id rest-arg-id] ...)
|
||||
#'(let* ([arg-id tmp-arg-id] ...
|
||||
[rest-arg-id
|
||||
(list . tmp-rest-arg-id)] ...)
|
||||
body*)))
|
||||
(...
|
||||
(syntax-parse stx*
|
||||
[(_ arg*:actual ...)
|
||||
;; let*-bind the actuals, to ensure that they're evaluated
|
||||
;; only once, and in order
|
||||
#`(syntax-parameterize
|
||||
([name (make-rename-transformer #'internal-name)])
|
||||
(let* ([arg*.tmp arg*.arg] ...)
|
||||
#,(let* ([arg-entries (attribute arg*.for-aux)]
|
||||
[keyword-entries (filter car arg-entries)]
|
||||
[positional-entries
|
||||
(filter (lambda (x) (not (car x)))
|
||||
arg-entries)]
|
||||
[sorted-keyword-entries
|
||||
(sort keyword-entries
|
||||
string<?
|
||||
#:key (lambda (kw)
|
||||
(keyword->string
|
||||
(syntax-e kw))))])
|
||||
(keyword-apply
|
||||
function-aux
|
||||
(map (lambda (x) (syntax-e (car x)))
|
||||
sorted-keyword-entries)
|
||||
(map cadr sorted-keyword-entries)
|
||||
(map cadr positional-entries)))))])))))]))
|
||||
|
||||
|
||||
(module+ test
|
||||
(require rackunit)
|
||||
|
||||
;; Compares output to make sure that things are evaluated the right number of
|
||||
;; times, and in the right order.
|
||||
(define-syntax-rule (test/output expr res out)
|
||||
(let ()
|
||||
(define str (open-output-string))
|
||||
(check-equal? (parameterize ([current-output-port str]) expr) res)
|
||||
(check-equal? (get-output-string str) out)))
|
||||
|
||||
(define-inline (f x)
|
||||
(+ x x))
|
||||
(test/output (f (begin (display "arg1") 1)) 2 "arg1")
|
||||
|
||||
(define-inline (f2 x y)
|
||||
(+ x y))
|
||||
(test/output (f2 (begin (display "arg1") 1) (begin (display "arg2") 1))
|
||||
2 "arg1arg2")
|
||||
|
||||
(define-inline (g #:x [x 0])
|
||||
(f x))
|
||||
(test/output (g #:x (begin (display "arg1") 1)) 2 "arg1")
|
||||
(test/output (g) 0 "")
|
||||
|
||||
(define-inline (h #:x x)
|
||||
(f x))
|
||||
(test/output (h #:x (begin (display "arg1") 1)) 2 "arg1")
|
||||
|
||||
(define-inline (i [x 0])
|
||||
(f x))
|
||||
(test/output (i (begin (display "arg1") 1)) 2 "arg1")
|
||||
(test/output (i) 0 "")
|
||||
|
||||
(define-inline (j x #:y [y 0])
|
||||
(+ x y))
|
||||
(test/output (j (begin (display "arg1") 1) #:y (begin (display "arg2") 2))
|
||||
3 "arg1arg2")
|
||||
(test/output (j #:y (begin (display "arg1") 2) (begin (display "arg2") 1))
|
||||
3 "arg1arg2")
|
||||
(test/output (j (begin (display "arg1") 1)) 1 "arg1")
|
||||
|
||||
(define-inline (k x [y x])
|
||||
(+ x y))
|
||||
(test/output (k (begin (display "arg1") 1) (begin (display "arg2") 2))
|
||||
3 "arg1arg2")
|
||||
(test/output (k (begin (display "arg1") 1)) 2 "arg1")
|
||||
|
||||
(define-inline (l . x)
|
||||
(+ (apply + x) (apply + x)))
|
||||
(test/output (l (begin (display "arg1") 1) (begin (display "arg2") 2))
|
||||
6 "arg1arg2")
|
||||
|
||||
(define-inline (l2 y . x)
|
||||
(+ y y (apply + x) (apply + x)))
|
||||
(test/output (l2 (begin (display "arg0") 3)
|
||||
(begin (display "arg1") 1)
|
||||
(begin (display "arg2") 2))
|
||||
12 "arg0arg1arg2")
|
||||
|
||||
(define-inline (l3 y [z 0] . x)
|
||||
(+ y y z z z (apply + x) (apply + x)))
|
||||
(test/output (l3 (begin (display "arg0") 3)
|
||||
(begin (display "arg1") 1)
|
||||
(begin (display "arg2") 2))
|
||||
13 "arg0arg1arg2")
|
||||
(test/output (l3 (begin (display "arg0") 3))
|
||||
6 "arg0")
|
||||
|
||||
(define-inline (l4 #:x [x 0] . y)
|
||||
(+ x x x (apply + y) (apply + y)))
|
||||
(test/output (l4 #:x (begin (display "arg1") 1))
|
||||
3 "arg1")
|
||||
(test/output (l4 #:x (begin (display "arg1") 1)
|
||||
(begin (display "arg2") 2)
|
||||
(begin (display "arg3") 3))
|
||||
13 "arg1arg2arg3")
|
||||
(test/output (l4 (begin (display "arg2") 2)
|
||||
(begin (display "arg3") 3))
|
||||
10 "arg2arg3")
|
||||
|
||||
;; test for function fallback (recursion)
|
||||
(define-inline (sum . l)
|
||||
(if (null? l) 0 (+ (car l) (apply sum (cdr l)))))
|
||||
(check-equal? (sum 1 2 3 4) 10)
|
||||
|
||||
;; higher-order use
|
||||
(define-inline (add2 x)
|
||||
(+ x 2))
|
||||
(check-equal? (add2 3) 5)
|
||||
(check-equal? (map add2 '(1 2 3)) '(3 4 5))
|
||||
|
||||
;; currying syntax
|
||||
(define-inline ((adder x) y) (+ x y))
|
||||
(test/output (let ([add2 (adder (begin (display "arg1") 2))])
|
||||
(+ (add2 (begin (display "arg2") 1))
|
||||
(add2 (begin (display "arg2") 2))))
|
||||
7 "arg1arg2arg2")
|
||||
|
||||
(define-inline (even? x) (if (zero? x) #t (odd? (sub1 x))))
|
||||
(define-inline (odd? x) (if (zero? x) #f (even? (sub1 x))))
|
||||
(check-equal? (odd? 2) #f)
|
||||
)
|
||||
34
collects/unstable/scribblings/inline.scrbl
Normal file
34
collects/unstable/scribblings/inline.scrbl
Normal file
|
|
@ -0,0 +1,34 @@
|
|||
#lang scribble/doc
|
||||
@(require scribble/base
|
||||
scribble/manual
|
||||
"utils.rkt"
|
||||
(for-label unstable/inline
|
||||
racket/contract
|
||||
racket/base
|
||||
racket/performance-hint))
|
||||
|
||||
@title[#:tag "inline"]{Inlining}
|
||||
@unstable-header[]
|
||||
|
||||
@defmodule[unstable/inline]
|
||||
|
||||
@addition{Vincent St-Amour}
|
||||
|
||||
@defform*/subs[[(define-inline id expr)
|
||||
(define-inline (head args) body ...+)]
|
||||
([head id
|
||||
(head args)]
|
||||
[args (code:line arg ...)
|
||||
(code:line arg ... @#,racketparenfont{.} rest-id)]
|
||||
[arg arg-id
|
||||
[arg-id default-expr]
|
||||
(code:line keyword arg-id)
|
||||
(code:line keyword [arg-id default-expr])])]{
|
||||
Like @racket[define], but ensures that the definition will be inlined at its
|
||||
call sites. Recursive calls are not inlined, to avoid infinite inlining.
|
||||
Higher-order uses are supported, but also not inlined.
|
||||
|
||||
@racket[define-inline] may interfere with the Racket compiler's own inlining
|
||||
heuristics, and should only be used when other inlining attempts (such as
|
||||
@racket[begin-encourage-inline]) fail.
|
||||
}
|
||||
|
|
@ -87,6 +87,7 @@ Keep documentation and tests up to date.
|
|||
@include-section["future.scrbl"]
|
||||
@include-section["function.scrbl"]
|
||||
@include-section["hash.scrbl"]
|
||||
@include-section["inline.scrbl"]
|
||||
@include-section["class-iop.scrbl"] ;; Interface-oriented Programming
|
||||
@include-section["lazy-require.scrbl"]
|
||||
@include-section["list.scrbl"]
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user