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

Rewrite compose' and add compose1'.

Browse Source 
The new version fixes some problems with the previous one, most notably
it can create a keyworded function when the last input is is keyworded.
`compose1' is a restricted variant that requires single values in the
composed pipeline -- besides being potentially faster (probably more
if/when there is cross module inlining), it has a semantical
justification, similar to the restricting function call arguments to
return single values, with similar robustness benefits.  The
implementation of both is done in a generalized way, and the results can
be faster for both `compose' and `compose1'.  (Not by much -- 20% and
30% resp.)

One thing that it could do is to reduce the resulting arity to match the
last given function.  I didn't do this since it adds a significant
overhead to the result.  (No strong opinion on doing that...)
This commit is contained in:
Eli Barzilay 2011-06-14 13:13:28 -04:00
parent e80308aa15
commit be84425bd0
4 changed files with 247 additions and 76 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
collects/racket/function.rkt
View File

@ -29,20 +29,12 @@
(define (negate f) (define (negate f)
(unless (procedure? f) (raise-type-error 'negate "procedure" f)) (unless (procedure? f) (raise-type-error 'negate "procedure" f))
(let-values ([(arity) (procedure-arity f)] (let-values ([(arity) (procedure-arity f)] [(_ kwds) (procedure-keywords f)])
[(required-kws accepted-kws) (procedure-keywords f)]) (case (and (null? kwds) arity) ; optimize some simple cases
(define negated ; simple version, optimize some cases [(0) (lambda () (not (f)))]
(case arity [(1) (lambda (x) (not (f x)))]
[(0) (lambda () (not (f)))] [(2) (lambda (x y) (not (f x y)))]
[(1) (lambda (x) (not (f x)))] [else (compose1 not f)]))) ; keyworded or more args => just compose
[(2) (lambda (x y) (not (f x y)))]
[else (lambda xs (not (apply f xs)))]))
(if (and (null? required-kws) (null? accepted-kws))
negated
;; keyworded function
(make-keyword-procedure (lambda (kws kvs . args)
(not (keyword-apply f kws kvs args)))
negated))))
(define (make-curry right?) (define (make-curry right?)
;; The real code is here ;; The real code is here

127
collects/racket/private/list.rkt
View File

@ -1,4 +1,3 @@
(module list "pre-base.rkt" (module list "pre-base.rkt"
(provide foldl (provide foldl
@ -27,7 +26,8 @@
build-string build-string
build-list build-list
compose) compose
compose1)
(#%require (rename "sort.rkt" raw-sort sort) (#%require (rename "sort.rkt" raw-sort sort)
(for-syntax "stxcase-scheme.rkt") (for-syntax "stxcase-scheme.rkt")
@ -289,7 +289,7 @@
(if (= i n) (if (= i n)
str str
(begin (string-set! str i (fcn i)) (loop (add1 i))))))) (begin (string-set! str i (fcn i)) (loop (add1 i)))))))
(define (build-list n fcn) (define (build-list n fcn)
(unless (exact-nonnegative-integer? n) (unless (exact-nonnegative-integer? n)
(raise-type-error 'build-list "exact-nonnegative-integer" n)) (raise-type-error 'build-list "exact-nonnegative-integer" n))
@ -301,26 +301,101 @@
[else (cons (fcn j) [else (cons (fcn j)
(recr (add1 j) (sub1 i)))]))) (recr (add1 j) (sub1 i)))])))
(define compose (define-values [compose1 compose]
(case-lambda (let ()
[(f) (if (procedure? f) (define-syntax-rule (app1 E1 E2) (E1 E2))
f (define-syntax-rule (app* E1 E2) (call-with-values (lambda () E2) E1))
(raise-type-error 'compose "procedure" f))] (define-syntax-rule (mk-simple-compose app)
[(f g) (lambda (f g)
(let ([f (compose f)] (let*-values
[g (compose g)]) ([(arity) (procedure-arity g)]
(if (eqv? 1 (procedure-arity f)) ; optimize: don't use call-w-values [(required-kwds allowed-kwds) (procedure-keywords g)]
(if (eqv? 1 (procedure-arity g)) ; optimize: single arity everywhere [(composed)
(lambda (x) (f (g x))) ;; FIXME: would be nice to use `procedure-reduce-arity' and
(lambda args (f (apply g args)))) ;; `procedure-reduce-keyword-arity' in the places marked below,
(if (eqv? 1 (procedure-arity g)) ; optimize: single input ;; but they currently add a significant overhead.
(lambda (a) (if (eq? 1 arity)
(call-with-values (lambda () (g a)) f)) (lambda (x) (app f (g x)))
(lambda args (case-lambda ; <--- here
(call-with-values (lambda () (apply g args)) f)))))] [(x) (app f (g x))]
[() values] [(x y) (app f (g x y))]
[(f . more) [args (app f (apply g args))]))])
(if (procedure? f) (if (null? allowed-kwds)
(let ([m (apply compose more)]) composed
(compose f m)) (make-keyword-procedure ; <--- and here
(compose f))]))) (lambda (kws kw-args . xs)
(app f (keyword-apply g kws kw-args xs)))
composed)))))
(define-syntax-rule (can-compose* name n g f fs)
(unless (null? (let-values ([(req _) (procedure-keywords g)]) req))
(apply raise-type-error 'name "procedure (no required keywords)"
n f fs)))
(define-syntax-rule (can-compose1 name n g f fs)
(begin (unless (procedure-arity-includes? g 1)
(apply raise-type-error 'name "procedure (arity 1)" n f fs))
;; need to check this too (see PR 11978)
(can-compose* name n g f fs)))
(define-syntax-rule (mk name app can-compose pipeline)
(define name
(let ([simple-compose (mk-simple-compose app)])
(case-lambda
[(f)
(if (procedure? f) f (raise-type-error 'name "procedure" 0 f))]
[(f g)
(unless (procedure? f)
(raise-type-error 'name "procedure" 0 f g))
(unless (procedure? g)
(raise-type-error 'name "procedure" 1 f g))
(can-compose name 0 f f '())
(simple-compose f g)]
[() values]
[(f0 . fs0)
(let loop ([f f0] [fs fs0] [i 0] [rfuns '()])
(unless (procedure? f)
(apply raise-type-error 'name "procedure" i f0 fs0))
(if (pair? fs)
(begin (can-compose name i f f0 fs0)
(loop (car fs) (cdr fs) (add1 i) (cons f rfuns)))
(simple-compose (pipeline (car rfuns) (cdr rfuns)) f)))]))))
(define (pipeline1 f rfuns)
;; (very) slightly slower alternative:
;; (if (null? rfuns)
;; f
;; (pipeline1 (let ([fst (car rfuns)]) (lambda (x) (fst (f x))))
;; (cdr rfuns)))
(lambda (x)
(let loop ([x x] [f f] [rfuns rfuns])
(if (null? rfuns)
(f x)
(loop (f x) (car rfuns) (cdr rfuns))))))
(define (pipeline* f rfuns)
;; use the other composition style in this case, to optimize an
;; occasional arity-1 procedure in the pipeline
(if (eqv? 1 (procedure-arity f))
;; if `f' is single arity, then going in reverse they will *all* be
;; single arities
(let loop ([f f] [rfuns rfuns])
(if (null? rfuns)
f
(loop (let ([fst (car rfuns)])
(if (eqv? 1 (procedure-arity fst))
(lambda (x) (fst (f x)))
(lambda (x) (app* fst (f x)))))
(cdr rfuns))))
;; otherwise, going in reverse means that they're all n-ary, which
;; means that the list of arguments will be built for each stage, so
;; to avoid that go forward in this case
(let ([funs (reverse (cons f rfuns))])
(let loop ([f (car funs)] [funs (cdr funs)])
(if (null? funs)
f
(loop (let ([fst (car funs)])
(if (eqv? 1 (procedure-arity fst))
(lambda (x) (app* f (fst x)))
(lambda xs (app* f (apply fst xs)))))
(cdr funs)))))))
(mk compose1 app1 can-compose1 pipeline1)
(mk compose app* can-compose* pipeline*)
(values compose1 compose)))
)

35
collects/scribblings/reference/procedures.scrbl
View File

@ -32,20 +32,35 @@ arguments; otherwise, the @exnraise[exn:fail:contract]. The given
(apply sort (list (list '(2) '(1)) <) #:key car) (apply sort (list (list '(2) '(1)) <) #:key car)
]} ]}
@defproc[(compose [proc procedure?] ...) procedure?]{ @deftogether[(@defproc[(compose [proc procedure?] ...) procedure?]
@defproc[(compose1 [proc procedure?] ...) procedure?])]{
Returns a procedure that composes the given functions, applying the Returns a procedure that composes the given functions, applying the last
last @scheme[proc] first and the first @scheme[proc] last. The @scheme[proc] first and the first @scheme[proc] last. @scheme[compose]
composed functions can consume and produce any number of values, as allows the functions to consume and produce any number of values, as
long as each function produces as many values as the preceding long as each function produces as many values as the preceding function
function consumes. When no @scheme[proc] arguments are given, the consumes, and @scheme[compose1] restricts the internal value passing to
result is @scheme[values]. a single value. In both cases the input arity of the last function and
the output arity of the first are unrestricted, and become the
corresponding arity of the resulting composition (including keyword
arguments for the input side).
When no @scheme[proc] arguments are given, the result is
@scheme[values]. When exactly one is given, it is returned.
@mz-examples[ @mz-examples[
((compose - sqrt) 10) ((compose1 - sqrt) 10)
((compose sqrt -) 10) ((compose1 sqrt -) 10)
((compose list split-path) (bytes->path #"/a" 'unix)) ((compose list split-path) (bytes->path #"/a" 'unix))
]} ]
Note that in many cases @scheme[compose1] is preferred. For example,
using @scheme[compose] with two library functions may lead to problems
when one function is extended to return two values, and the preceding
one has an optional input with different semantics. In addition,
@scheme[compose1] may create faster compositions.
}
@defproc[(procedure-rename [proc procedure?] @defproc[(procedure-rename [proc procedure?]
[name symbol?]) [name symbol?])

141
collects/tests/racket/function.rktl
View File

@ -1,31 +1,110 @@
(load-relative "loadtest.rktl") (load-relative "loadtest.rktl")
(Section 'function) (Section 'function)
(require scheme/function mzlib/etc) (require racket/function mzlib/etc)
;; stuff from scheme/base ;; stuff from racket/base
(test 0 (compose add1 sub1) 0) (let ([C #f])
(test 2 (compose add1 (lambda () 1))) (define-syntax-rule (def-both [name* name] ...)
(test 5 (compose (lambda (a b) a) (lambda (x) (values (add1 x) x))) 4) (begin (define-syntax-rule (name* x (... ...))
(test -1 (compose (lambda (a b) (+ a b)) (lambda (x y) (values (- y) x))) 2 3) (begin (set! C compose1) (name x (... ...))
(test 'hi (compose (case-lambda [(x) 'bye][(y z) 'hi]) (lambda () (values 1 2)))) (set! C compose) (name x (... ...))
(test 'ok (compose (lambda () 'ok) (lambda () (values)))) (set! C #f)))
(test 'ok (compose (lambda () 'ok) (lambda (w) (values))) 5) ...))
(test 0 (compose) 0) (def-both [test* test] [err/rt-test* err/rt-test] [test-values* test-values])
(test-values '(1 2 3) (lambda () ((compose (lambda (x) (values x (add1 x) (+ x 2))) (lambda (y) y)) 1))) ;; Simple cases
(test* values C)
(err/rt-test (compose 5)) (test* car C car)
(err/rt-test (compose add1 sub1 5)) (test* sin C sin)
(err/rt-test (compose add1 5 sub1)) (err/rt-test* (C 1))
(err/rt-test (compose 5 add1 sub1)) ;; Binary cases
(err/rt-test ((compose add1 (lambda () (values 1 2)))) exn:application:arity?) (test* 123 (C add1 sub1) 123)
(err/rt-test ((compose add1 sub1)) exn:application:arity?) (test* 'composed object-name (C add1 sub1))
(err/rt-test ((compose (lambda () 1) add1) 8) exn:application:arity?) (define (f:1/2 x [y 1]) (+ (* 10 x) y))
(test* 52 (C add1 f:1/2) 5)
(arity-test compose 0 -1) (test* 16 (C add1 f:1/2) 1 5)
(test 21 (compose f:1/2 quotient/remainder) 7 3)
(let ([foo (compose1 f:1/2 quotient/remainder)]) (err/rt-test (foo 7 3)))
(test* 61 (C f:1/2 +) 1 2 3)
(define (f:kwd x #:y y #:z [z 0]) (list x y z))
(test* '((1 2 3)) (C list f:kwd) 1 #:z 3 #:y 2)
(test* '((1 2 0)) (C list f:kwd) 1 #:y 2)
(err/rt-test* ((C list f:kwd) 1))
(err/rt-test* (C 1 +))
(err/rt-test* (C + 1))
(err/rt-test* (C (lambda (#:x x) x) +))
(err/rt-test* (C (lambda (x #:y y) x) +))
(test* 3 (C length list) 1 2 3)
(test* 2 (C length list) 1 2)
(test* 1 (C length list) 1)
(test* 0 (C length list))
(err/rt-test (compose1 (lambda (x y) x) +))
(let ([foo (compose (lambda (x y) x) +)]) ; no error here...
(err/rt-test (foo 1))) ; ...only when running it
;; More than two
(err/rt-test* (C 1 add1 add1))
(err/rt-test* (C add1 1 add1))
(err/rt-test* (C add1 add1 1))
(test* 4 (C add1 add1 add1) 1)
(test* 4 (C + add1 add1 add1) 1)
(test* 4 (C add1 + add1 add1) 1)
(test* 4 (C add1 add1 + add1) 1)
(test* 4 (C add1 add1 add1 +) 1)
(test* 9 (C add1 add1 add1 +) 1 2 3)
(err/rt-test* (C add1 (lambda (x #:y y) x) add1 add1))
(err/rt-test (compose1 add1 (lambda (x y) x) add1 add1))
(test #t procedure? (compose add1 (lambda (x y) x) add1 add1))
(define (+-1 x) (values (add1 x) (sub1 x)))
(test* #t procedure? (C list +-1 car list add1))
(test '(7 5) (compose list +-1 car list add1) 5)
(err/rt-test ((compose1 list +-1 car list add1) 5))
(test* 10 (C car list sub1 car list add1) 10) ; fwd pipeline
(test* 10 (C car list sub1 car list (lambda (x) x) add1) 10) ; rev pipeline
;; any input arity on the RHS
(test* 4 (C add1 add1 add1 (lambda () 1)))
(test* 3 (C add1 add1 (lambda () 1)))
(test* 2 (C add1 (lambda () 1)))
(test* 1 (C (lambda () 1)))
(test* '(1 2 3) (C car list list) 1 2 3)
(test* '(1 2) (C car list list) 1 2)
(test* '(1) (C car list list) 1)
(test* '() (C car list list))
(test* '(1 2 3) (C car list f:kwd) 1 #:z 3 #:y 2)
(test* '(1 2 0) (C car list f:kwd) 1 #:y 2)
;; any output arity on the LHS
(test-values* '(2 0) (lambda () ((C +-1 add1) 0)))
(test-values* '(3 1) (lambda () ((C +-1 add1 add1) 0)))
(test-values* '() (lambda () ((C (lambda (_) (values)) add1) 0)))
(test-values* '() (lambda () ((C (lambda (_) (values)) add1 add1) 0)))
;; some older `compose' tests (a bit extended)
(test -1 (compose (lambda (a b) (+ a b))
(lambda (x y) (values (- y) x)))
2 3)
(test -1 (compose (lambda (a b) (+ a b))
(lambda (x y) (values (- y) x))
(lambda (x y) (values x y)))
2 3)
(test -1 (compose (lambda (a b) (+ a b))
(lambda (x y) (values (- y) x))
values)
2 3)
(test -1 (compose (lambda (a b) (+ a b))
values
(lambda (x y) (values (- y) x))
values)
2 3)
(test 'hi (compose (case-lambda [(x) 'bye] [(y z) 'hi])
(lambda () (values 1 2))))
(test 'hi (compose (case-lambda [(x) 'bye] [(y z) 'hi])
values
(lambda () (values 1 2))))
(err/rt-test* ((C add1 (lambda () (values 1 2)))) exn:fail:contract:arity?)
(err/rt-test* ((C add1 sub1)) exn:fail:contract:arity?)
(err/rt-test ((compose (lambda () 1) add1) 8) exn:fail:contract:arity?)
(arity-test compose1 0 -1)
(arity-test compose 0 -1))
;; ---------- rec (from mzlib/etc) ---------- ;; ---------- rec (from mzlib/etc) ----------
(let () (let ()
@ -47,6 +126,8 @@
(let () (let ()
(test 'foo identity 'foo) (test 'foo identity 'foo)
(test 1 identity 1) (test 1 identity 1)
(define x (gensym))
(test x identity x)
(err/rt-test (identity 1 2)) (err/rt-test (identity 1 2))
(err/rt-test (identity))) (err/rt-test (identity)))
@ -71,18 +152,26 @@
;; ---------- negate ---------- ;; ---------- negate ----------
(let () (let ()
(define *not (negate not)) (define *not (negate not))
(define *void (negate void))
(define *< (negate <))
(test #t *not #t) (test #t *not #t)
(test #f *not #f) (test #f *not #f)
(test #t *not 12) (test #t *not 12)
(define *void (negate void))
(test #f *void) (test #f *void)
(define *< (negate <))
(test #t *< 12 3) (test #t *< 12 3)
(test #t *< 12 12) (test #t *< 12 12)
(test #f *< 11 12) (test #f *< 11 12)
(test #t *< 14 13 12 11) (test #t *< 14 13 12 11)
(test #f *< 11 12 13 14)) (test #f *< 11 12 13 14)
(define (bigger? n #:than [than 0]) (> n than))
(define smaller? (negate bigger?))
(test #t smaller? -5)
(test #f smaller? 5)
(test #t smaller? 5 #:than 10)
(test #f smaller? 15 #:than 10)
(test #t smaller? #:than 10 5)
(test #f smaller? #:than 10 15))
;; ---------- curry/r ---------- ;; ---------- curry/r ----------
(let () (let ()