diff --git a/collects/racket/function.rkt b/collects/racket/function.rkt
index da8648cc05..73e77b8f40 100644
--- a/collects/racket/function.rkt
+++ b/collects/racket/function.rkt
@@ -29,20 +29,12 @@
 
 (define (negate f)
   (unless (procedure? f) (raise-type-error 'negate "procedure" f))
-  (let-values ([(arity) (procedure-arity f)]
-               [(required-kws accepted-kws) (procedure-keywords f)])
-    (define negated ; simple version, optimize some cases
-      (case arity
-        [(0) (lambda () (not (f)))]
-        [(1) (lambda (x) (not (f x)))]
-        [(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))))
+  (let-values ([(arity) (procedure-arity f)] [(_ kwds) (procedure-keywords f)])
+    (case (and (null? kwds) arity) ; optimize some simple cases
+      [(0) (lambda () (not (f)))]
+      [(1) (lambda (x) (not (f x)))]
+      [(2) (lambda (x y) (not (f x y)))]
+      [else (compose1 not f)]))) ; keyworded or more args => just compose
 
 (define (make-curry right?)
   ;; The real code is here
diff --git a/collects/racket/private/list.rkt b/collects/racket/private/list.rkt
index 2fc4cdfd7b..08a3eae216 100644
--- a/collects/racket/private/list.rkt
+++ b/collects/racket/private/list.rkt
@@ -1,4 +1,3 @@
-
 (module list "pre-base.rkt"
 
   (provide foldl
@@ -27,7 +26,8 @@
            build-string
            build-list
 
-           compose)
+           compose
+           compose1)
 
   (#%require (rename "sort.rkt" raw-sort sort)
              (for-syntax "stxcase-scheme.rkt")
@@ -289,7 +289,7 @@
         (if (= i n)
             str
             (begin (string-set! str i (fcn i)) (loop (add1 i)))))))
-  
+
   (define (build-list n fcn)
     (unless (exact-nonnegative-integer? n)
       (raise-type-error 'build-list "exact-nonnegative-integer" n))
@@ -301,26 +301,101 @@
             [else (cons (fcn j)
                         (recr (add1 j) (sub1 i)))])))
 
-  (define compose
-    (case-lambda
-      [(f) (if (procedure? f)
-               f
-               (raise-type-error 'compose "procedure" f))]
-      [(f g)
-       (let ([f (compose f)]
-             [g (compose g)])
-         (if (eqv? 1 (procedure-arity f)) ; optimize: don't use call-w-values
-             (if (eqv? 1 (procedure-arity g)) ; optimize: single arity everywhere
-                 (lambda (x) (f (g x)))
-                 (lambda args (f (apply g args))))
-             (if (eqv? 1 (procedure-arity g)) ; optimize: single input
-                 (lambda (a)
-                   (call-with-values (lambda () (g a)) f))
-                 (lambda args
-                   (call-with-values (lambda () (apply g args)) f)))))]
-      [() values]
-      [(f . more)
-       (if (procedure? f)
-           (let ([m (apply compose more)])
-             (compose f m))
-           (compose f))])))
+  (define-values [compose1 compose]
+    (let ()
+      (define-syntax-rule (app1 E1 E2) (E1 E2))
+      (define-syntax-rule (app* E1 E2) (call-with-values (lambda () E2) E1))
+      (define-syntax-rule (mk-simple-compose app)
+        (lambda (f g)
+          (let*-values
+              ([(arity) (procedure-arity g)]
+               [(required-kwds allowed-kwds) (procedure-keywords g)]
+               [(composed)
+                ;; FIXME: would be nice to use `procedure-reduce-arity' and
+                ;; `procedure-reduce-keyword-arity' in the places marked below,
+                ;; but they currently add a significant overhead.
+                (if (eq? 1 arity)
+                  (lambda (x) (app f (g x)))
+                  (case-lambda          ; <--- here
+                    [(x)   (app f (g x))]
+                    [(x y) (app f (g x y))]
+                    [args  (app f (apply g args))]))])
+            (if (null? allowed-kwds)
+              composed
+              (make-keyword-procedure   ; <--- and here
+               (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)))
+
+  )
diff --git a/collects/scribblings/reference/procedures.scrbl b/collects/scribblings/reference/procedures.scrbl
index 200565bbcb..fa07bdf85d 100644
--- a/collects/scribblings/reference/procedures.scrbl
+++ b/collects/scribblings/reference/procedures.scrbl
@@ -32,20 +32,35 @@ arguments; otherwise, the @exnraise[exn:fail:contract]. The given
 (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
-last @scheme[proc] first and the first @scheme[proc] last. The
-composed functions can consume and produce any number of values, as
-long as each function produces as many values as the preceding
-function consumes.  When no @scheme[proc] arguments are given, the
-result is @scheme[values].
+Returns a procedure that composes the given functions, applying the last
+@scheme[proc] first and the first @scheme[proc] last.  @scheme[compose]
+allows the functions to consume and produce any number of values, as
+long as each function produces as many values as the preceding function
+consumes, and @scheme[compose1] restricts the internal value passing to
+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[
-((compose - sqrt) 10)
-((compose sqrt -) 10)
+((compose1 - sqrt) 10)
+((compose1 sqrt -) 10)
 ((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?]
                            [name symbol?])
diff --git a/collects/tests/racket/function.rktl b/collects/tests/racket/function.rktl
index be1effcf2b..a77844a458 100644
--- a/collects/tests/racket/function.rktl
+++ b/collects/tests/racket/function.rktl
@@ -1,31 +1,110 @@
-
 (load-relative "loadtest.rktl")
 
 (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)
-(test 2 (compose add1 (lambda () 1)))
-(test 5 (compose (lambda (a b) a) (lambda (x) (values (add1 x) x))) 4)
-(test -1 (compose (lambda (a b) (+ a b)) (lambda (x y) (values (- y) x))) 2 3)
-(test 'hi (compose (case-lambda [(x) 'bye][(y z) 'hi]) (lambda () (values 1 2))))
-(test 'ok (compose (lambda () 'ok) (lambda () (values))))
-(test 'ok (compose (lambda () 'ok) (lambda (w) (values))) 5)
-(test 0 (compose) 0)
-(test-values '(1 2 3) (lambda () ((compose (lambda (x) (values x (add1 x) (+ x 2))) (lambda (y) y)) 1)))
-
-(err/rt-test (compose 5))
-(err/rt-test (compose add1 sub1 5))
-(err/rt-test (compose add1 5 sub1))
-(err/rt-test (compose 5 add1 sub1))
-(err/rt-test ((compose add1 (lambda () (values 1 2)))) exn:application:arity?)
-(err/rt-test ((compose add1 sub1)) exn:application:arity?)
-(err/rt-test ((compose (lambda () 1) add1) 8) exn:application:arity?)
-
-(arity-test compose 0 -1)
+(let ([C #f])
+  (define-syntax-rule (def-both [name* name] ...)
+    (begin (define-syntax-rule (name* x (... ...))
+             (begin (set! C compose1) (name x (... ...))
+                    (set! C compose) (name x (... ...))
+                    (set! C #f)))
+           ...))
+  (def-both [test* test] [err/rt-test* err/rt-test] [test-values* test-values])
+  ;; Simple cases
+  (test* values C)
+  (test* car C car)
+  (test* sin C sin)
+  (err/rt-test* (C 1))
+  ;; Binary cases
+  (test* 123 (C add1 sub1) 123)
+  (test* 'composed object-name (C add1 sub1))
+  (define (f:1/2 x [y 1]) (+ (* 10 x) y))
+  (test* 52 (C add1 f:1/2) 5)
+  (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) ----------
 (let ()
@@ -47,6 +126,8 @@
 (let ()
   (test 'foo identity 'foo)
   (test 1 identity 1)
+  (define x (gensym))
+  (test x identity x)
   (err/rt-test (identity 1 2))
   (err/rt-test (identity)))
 
@@ -71,18 +152,26 @@
 
 ;; ---------- negate ----------
 (let ()
-  (define *not  (negate not))
-  (define *void (negate void))
-  (define *<    (negate <))
+  (define *not (negate not))
   (test #t *not #t)
   (test #f *not #f)
   (test #t *not 12)
+  (define *void (negate void))
   (test #f *void)
+  (define *< (negate <))
   (test #t *< 12 3)
   (test #t *< 12 12)
   (test #f *< 11 12)
   (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 ----------
 (let ()