Ticket #1623: 0001-Replace-car-cdr-null-on-rest-args-with-direct-argvec.patch

File 0001-Replace-car-cdr-null-on-rest-args-with-direct-argvec.patch, 21.3 KB (added by sjamaan, 4 years ago)

Final version including explanatory commit message sent to the mailing list

  • batch-driver.scm 

    From b0f618859980703cc37b49bca0309b1b6e6b456a Mon Sep 17 00:00:00 2001
From: Peter Bex <peter@more-magic.net>
Date: Sat, 17 Aug 2019 13:30:09 +0200
Subject: [PATCH] Replace car/cdr/null? on rest args with direct argvector
 references where possible

In the generated C code, we don't need C_build_rest() to dynamically
build a list containing everything in the argvector beyond the named
arguments.  Instead, we can try to detect references to positional
list accesses of the rest argument and convert those directly into
accesses of the argvector.  This means we build up less stack, causing
less GC pressure, which should reduce the number of minor GCs in tight
loops involving procedures with rest arguments.

The change introduces three new forms into the core language,
specifically for accessing rest arguments: ##core#rest-{car,cdr,null?}

These new forms represent a chain of calls to (cd...dr <rest-var>)
culminating in either a car, cdr or null? call.

When traversing a chain of rest-cdr calls, variables holding
intermediate cdrs may be eliminated, because only the final rest-cdr
or rest-car or rest-null? call matters.

When we see (if (null? <rest-cdr>) '() (rest-cdr <rest-cdr>)), the
variable which holds the result is marked as a rest-cdr variable.
This allows us to eventually eliminate any intermediate cdr calls on
the rest list.  This pattern is common in hand-rolled code, but it is
also generated by let-optionals*, which is in turn used by #!optional.
This catches the majority of rest arg usages.

In analyze-expression, the rest variable in ##core#rest-cdr nodes is
marked as captured to avoid total elimination of it.  This is
necessary, so that in closure conversion we still know that its home
closure is one that accepts rest arguments, and when inlining (see
below).

We also need to propagate rest-cdr to aliased variables, so that extra
"let"s don't block rest-cdr optimizations from happening.

One complicating factor is that the optimizer replaces calls to
scheme#{car,cdr,null?} with ##core#inline forms very early on.
This happens after the very first analysis.  So, we cannot match
directly on scheme#{car,cdr,null?}, but need to mark calls that look
like (##core#inline "C_i_{car,cdr,nullp}") instead.

Another tricky thing is that procedures with rest args may be inlined
or contracted.  When this happens, the "home" procedure of the rest arg
changes, so we can't replace references to rest arg cdrs with direct
argvector references anymore.  Therefore, we must rewrite the procedure
body when inlining it and potentially even re-introduce the rest
variable in a let binding.

To illustrate, let's look at an example with optional arguments and
how it will be optimized:

(lambda (#!optional (a 1) (b 2) (c 3))
  (print a b c))

this is equivalent to:

(lambda rest
  (let-optionals* rest ((a 1)
                        (b 2)
                        (c 3))
    (print a b c)))

and this is equivalent to and will get optimized as follows:

(lambda rest
  (let* ((a (if (null? rest) 1 (car rest)))
         (pre-b (if (null? rest) '() (cdr rest)))
	 (b (if (null? pre-b) 2 (car pre-b)))
	 (pre-c (if (null? pre-b) '() (cdr pre-b)))
	 (c (if (null? pre-c) 3 (car pre-c))))
    (print a b c)))

=={track rest-cdr call chain and replace with ##core#rest-... nodes}==>

(lambda rest
  (let* ((a (if (##core#rest-null? rest 0) 1 (##core#rest-car rest 0)))
         (pre-b (if (##core#rest-null? rest 1) '() (##core#rest-cdr rest 1)))
	 (b (if (##core#rest-null? rest 1) 2 (##core#rest-car rest 1)))
	 (pre-c (if (##core#rest-null? rest 2) '() (##core#rest-cdr rest 2)))
	 (c (if (##core#rest-null? rest 2) 3 (##core#rest-car rest 2))))
    (print a b c)))

=={eliminate unreferenced variables}==>

(lambda rest
  (let* ((a (if (##core#rest-null? rest 0) 1 (##core#rest-car rest 0)))
	 (b (if (##core#rest-null? rest 1) 2 (##core#rest-car rest 1)))
	 (c (if (##core#rest-null? rest 2) 3 (##core#rest-car rest 2))))
    (print a b c)))

Which, in C, basically translates to
(print <C_get_rest_arg(0)> <C_get_rest_arg(1)> <C_get_rest_arg(2)>)

This is how it's supposed to work conceptually.  The actual expansion
involves more LET variables, and the replacement happens in multiple
steps.

Also note that incorrect code like (null? (cdr (cdr (cdr rest)))) which
will normally crash with an error if rest does not contain at least 3
items will now simply return #t.  This is unfortunate but not a huge
deal considering this should be rare and also allowed by the spec I
think ("it is an error" doesn't mean "has to raise an exception").
Any other accesses of car or cdr beyond the list's end *are* translated
to code which will result in a runtime error, though.

This change should go a long way to improving #1623
---
 batch-driver.scm       |  2 +-
 c-backend.scm          | 16 ++++++---
 chicken.h              |  3 +-
 core.scm               | 82 +++++++++++++++++++++++++++++++++++++-----
 optimizer.scm          | 32 +++++++++++++++++
 support.scm            | 71 ++++++++++++++++++++++++++++++------
 tests/syntax-tests.scm | 18 ++++++++++
 7 files changed, 199 insertions(+), 25 deletions(-)

diff --git a/batch-driver.scm b/batch-driver.scm
index 82ed562e..f4393a49 100644
    a b  
    146146                       ((potential-values)
    147147                        (set! pvals (cdar es)))
    148148                       ((replacable home contains contained-in use-expr closure-size rest-parameter
    149                                     captured-variables explicit-rest)
     149                                    captured-variables explicit-rest rest-cdr rest-null?)
    150150                        (printf "\t~a=~s" (caar es) (cdar es)) )
    151151                       ((references)
    152152                        (set! refs (cdar es)) )

  • c-backend.scm 

    diff --git a/c-backend.scm b/c-backend.scm
index 10134fbc..c3d3b1f0 100644
    a b  
    181181             (expr (car subs) i)
    182182             (gen ")[" (+ (first params) 1) #\]) )
    183183
     184            ((##core#rest-car)
     185             (let* ((n (lambda-literal-argument-count ll))
     186                    (idx (+ (second params) n)))
     187               (gen "C_get_rest_arg(c," idx ",av)")))
     188
     189            ((##core#rest-null?)
     190             (let* ((n (lambda-literal-argument-count ll))
     191                    (idx (+ (second params) n)))
     192               (gen "C_rest_nullp(c, " idx ")")))
     193
    184194            ((##core#unbox)
    185195             (gen "((C_word*)")
    186196             (expr (car subs) i)
    … …  
    632642                (customizable (lambda-literal-customizable ll))
    633643                (empty-closure (and customizable (zero? (lambda-literal-closure-size ll))))
    634644                (varlist (intersperse (make-variable-list (if empty-closure (sub1 n) n) "t") #\,))
    635                 (rest (lambda-literal-rest-argument ll))
    636                 (rest-mode (lambda-literal-rest-argument-mode ll))
    637645                (direct (lambda-literal-direct ll))
    638646                (allocated (lambda-literal-allocated ll)) )
    639647           (gen #t)
    … …  
    679687           (let* ([id (car p)]
    680688                  [ll (cdr p)]
    681689                  [argc (lambda-literal-argument-count ll)]
    682                   [rest (lambda-literal-rest-argument ll)]
    683                   [rest-mode (lambda-literal-rest-argument-mode ll)]
    684690                  [customizable (lambda-literal-customizable ll)]
    685691                  [empty-closure (and customizable (zero? (lambda-literal-closure-size ll)))] )
    686692             (when empty-closure (set! argc (sub1 argc)))
    … …  
    923929                                (apply gen arglist)
    924930                                (gen ");}"))
    925931                               (else
    926                                 (gen #t "C_save_and_reclaim((void *)" id #\, n ",av);}")))
     932                                (gen #t "C_save_and_reclaim((void *)" id ",c,av);}")))
    927933                         (when (> demand 0)
    928934                           (gen #t "a=C_alloc(" demand ");")))))
    929935                 (else (gen #\})))

  • chicken.h 

    diff --git a/chicken.h b/chicken.h
index dbf6f17b..f6a46ed5 100644
    a b typedef void (C_ccall *C_proc)(C_word, C_word *) C_noret; 
    12441244#define C_offset_pointer(x, y)          (C_pointer_address(x) + (y))
    12451245#define C_do_apply(c, av)               ((C_proc)(void *)C_block_item((av)[0], 0))((c), (av))
    12461246#define C_kontinue(k, r)                do { C_word avk[ 2 ]; avk[ 0 ] = (k); avk[ 1 ] = (r); ((C_proc)(void *)C_block_item((k),0))(2, avk); } while(0)
     1247#define C_get_rest_arg(c, n, av)        ((n) >= (c) ? ((n) == (c) ? C_i_car(C_SCHEME_END_OF_LIST) : C_i_cdr(C_SCHEME_END_OF_LIST)) : (av)[(n)])
     1248#define C_rest_nullp(c, n)              (C_mk_bool((n) >= (c)))
    12471249#define C_fetch_byte(x, p)              (((unsigned C_byte *)C_data_pointer(x))[ p ])
    12481250#define C_poke_integer(x, i, n)         (C_set_block_item(x, C_unfix(i), C_num_to_int(n)), C_SCHEME_UNDEFINED)
    12491251#define C_pointer_to_block(p, x)        (C_set_block_item(p, 0, (C_word)C_data_pointer(x)), C_SCHEME_UNDEFINED)
    … … typedef void (C_ccall *C_proc)(C_word, C_word *) C_noret; 
    16291631#define C_i_true2(dummy1, dummy2)      ((dummy1), (dummy2), C_SCHEME_TRUE)
    16301632#define C_i_true3(dummy1, dummy2, dummy3)  ((dummy1), (dummy2), (dummy3), C_SCHEME_TRUE)
    16311633
    1632 
    16331634/* debug client interface */
    16341635
    16351636typedef struct C_DEBUG_INFO {

  • core.scm 

    diff --git a/core.scm b/core.scm
index 9f39bb30..f9768954 100644
    a b  
    178178; [##core#call {<safe-flag> [<debug-info>]} <exp-f> <exp>...]
    179179; [##core#callunit {<unitname>} <exp>...]
    180180; [##core#switch {<count>} <exp> <const1> <body1> ... <defaultbody>]
     181; [##core#rest-car {restvar depth [<debug-info>]}]
     182; [##core#rest-cdr {restvar depth [<debug-info>]}]
     183; [##core#rest-null? {restvar depth [<debug-info>]} <restvar>]
    181184; [##core#cond <exp> <exp> <exp>]
    182185; [##core#provide <id>]
    183186; [##core#recurse {<tail-flag>} <exp1> ...]
    … …  
    257260;   extended-binding -> <boolean>            If true: variable names an extended binding
    258261;   unused -> <boolean>                      If true: variable is a formal parameter that is never used
    259262;   rest-parameter -> #f | 'list             If true: variable holds rest-argument list
     263;   rest-cdr -> (rvar . n)                   Variable references the cdr of rest list rvar after n cdrs (0 = rest list itself)
     264;   rest-null? -> (rvar . n)                 Variable checks if the cdr of rest list rvar after n cdrs is empty (0 = rest list itself)
    260265;   constant -> <boolean>                    If true: variable has fixed value
    261266;   hidden-refs -> <boolean>                 If true: procedure that refers to hidden global variables
    262267;   inline-transient -> <boolean>            If true: was introduced during inlining
    … …  
    20962101        (case class
    20972102          ((quote ##core#undefined ##core#provide ##core#proc) #f)
    20982103
    2099           ((##core#variable)
     2104          ;; Uneliminated rest-cdr calls need to hang on to rest var
     2105          ((##core#variable ##core#rest-cdr)
    21002106           (let ((var (first params)))
    21012107             (ref var n)
    21022108             (unless (memq var localenv)
    … …  
    21602166                   (db-put! db var 'unknown #t) )
    21612167                 vars)
    21622168                (when rest
    2163                   (db-put! db rest 'rest-parameter 'list) )
     2169                  (db-put! db rest 'rest-parameter 'list)
     2170                  (db-put! db rest 'rest-cdr (cons rest 0)))
    21642171                (when (simple-lambda-node? n) (db-put! db id 'simple #t))
    21652172                (let ([tl toplevel-scope])
    21662173                  (unless toplevel-lambda-id (set! toplevel-lambda-id id))
    … …  
    22042211      (for-each (lambda (x) (walk x env lenv fenv here)) xs) )
    22052212
    22062213    (define (assign var val env here)
     2214      ;; Propagate rest-cdr and rest-null? onto aliased variables
     2215      (and-let* (((eq? '##core#variable (node-class val)))
     2216                 (v (db-get db (first (node-parameters val)) 'rest-cdr)))
     2217        (db-put! db var 'rest-cdr v) )
     2218
     2219      (and-let* (((eq? '##core#variable (node-class val)))
     2220                 (v (db-get db (first (node-parameters val)) 'rest-null?)))
     2221        (db-put! db var 'rest-null? v) )
     2222
    22072223      (cond ((eq? '##core#undefined (node-class val))
    22082224             (db-put! db var 'undefined #t) )
    22092225            ((and (eq? '##core#variable (node-class val)) ; assignment to itself
    22102226                  (eq? var (first (node-parameters val))) ) )
     2227
     2228            ;; Propagate info from ##core#rest-{cdr,null?} nodes to var
     2229            ((eq? '##core#rest-cdr (node-class val))
     2230             (let ((restvar (car (node-parameters val)))
     2231                   (depth (cadr (node-parameters val))))
     2232               (db-put! db var 'rest-cdr (cons restvar (add1 depth))) ) )
     2233
     2234            ((eq? '##core#rest-null? (node-class val))
     2235             (let ((restvar (car (node-parameters val)))
     2236                   (depth (cadr (node-parameters val))))
     2237               (db-put! db var 'rest-null? (cons restvar depth)) ) )
     2238
     2239            ;; (##core#cond (null? r) '() (cdr r)) => result is tagged as a rest-cdr var
     2240            ((and-let* (((eq? '##core#cond (node-class val)))
     2241                        (subs (node-subexpressions val))
     2242                        ((eq? '##core#variable (node-class (car subs))))
     2243                        ((db-get db (first (node-parameters (car subs))) 'rest-null?))
     2244                        (node-when-null (cadr subs))
     2245                        ((eq? 'quote (node-class node-when-null)))
     2246                        ((eq? '() (first (node-parameters node-when-null))))
     2247                        (rest-cdr-node (caddr subs))
     2248                        ((eq? '##core#rest-cdr (node-class rest-cdr-node))))
     2249               rest-cdr-node)
     2250             => (lambda (rest-cdr-node)
     2251                 (let ((restvar (car (node-parameters rest-cdr-node)))
     2252                       (depth (cadr (node-parameters rest-cdr-node))))
     2253                   (db-put! db var 'rest-cdr (cons restvar (add1 depth))) )) )
     2254
    22112255            ((or (memq var env)
    22122256                 (variable-mark var '##compiler#constant)
    22132257                 (not (variable-visible? var block-compilation)))
    … …  
    22572301             [assigned-locally #f]
    22582302             [undefined #f]
    22592303             [global #f]
    2260              [rest-parameter #f]
    22612304             [nreferences 0]
     2305             [rest-cdr #f]
    22622306             [ncall-sites 0] )
    22632307
    22642308         (set! current-analysis-database-size (fx+ current-analysis-database-size 1))
    … …  
    22822326              [(global) (set! global #t)]
    22832327              [(value) (set! value (cdr prop))]
    22842328              [(local-value) (set! local-value (cdr prop))]
    2285               [(rest-parameter) (set! rest-parameter #t)] ) )
     2329              [(rest-cdr) (set! rest-cdr (cdr prop))] ) )
    22862330          plist)
    22872331
    22882332         (set! value (and (not unknown) value))
    … …  
    23972441                            (rest
    23982442                             (db-put! db (first lparams) 'explicit-rest #t) ) ) ) ) ) ) ) ) )
    23992443
    2400          ;; Make 'removable, if it has no references and is not assigned to, and if it
    2401          ;; has either a value that does not cause any side-effects or if it is 'undefined:
     2444         ;; Make 'removable, if it has no references and is not assigned to, and one of the following:
     2445         ;; - it has either a value that does not cause any side-effects
     2446         ;; - it is 'undefined
     2447         ;; - it holds only a 'rest-cdr reference (strictly speaking, it may bomb but we don't care)
    24022448         (when (and (not assigned)
    24032449                    (null? references)
    24042450                    (or (and value
    … …  
    24082454                                       (variable-mark varname '##core#always-bound)
    24092455                                       (intrinsic? varname)))
    24102456                                 (not (expression-has-side-effects? value db)) ))
    2411                         undefined) )
     2457                        undefined
     2458                        rest-cdr) )
    24122459           (quick-put! plist 'removable #t) )
    24132460
    24142461         ;; Make 'replacable, if
    … …  
    24942541            (params (node-parameters n)) )
    24952542        (case (node-class n)
    24962543
    2497           ((##core#variable)
     2544          ((##core#variable ##core#rest-cdr)
    24982545           (let ((var (first params)))
    24992546             (if (memq var lexicals)
    25002547                 (list var)
    … …  
    25902637                 (make-node '##core#unbox '() (list val))
    25912638                 val) ) )
    25922639
     2640          ((##core#rest-cdr ##core#rest-car ##core#rest-null?)
     2641           (let* ((rest-var (first params))
     2642                  (val (ref-var n here closure)))
     2643             (unless (eq? val n)
     2644               ;; If it's captured, replacement in optimizer was incorrect
     2645               (quit-compiling "Saw rest op `~s' for captured variable.  This should not happen!" class) )
     2646             ;; If rest-cdrs have not all been eliminated, restore
     2647             ;; them as regular cdr calls on the rest list variable.
     2648             ;; This can be improved, as it can actually introduce
     2649             ;; many more cdr calls than necessary.
     2650             (if (eq? class '##core#rest-cdr)
     2651                 (let lp ((cdr-calls (add1 (second params)))
     2652                          (var (varnode rest-var)))
     2653                   (if (zero? cdr-calls)
     2654                       (transform var here closure)
     2655                       (lp (sub1 cdr-calls)
     2656                           (make-node '##core#inline (list "C_i_cdr") (list var)))))
     2657                 val) ) )
     2658
    25932659          ((if ##core#call ##core#inline ##core#inline_allocate ##core#callunit
    25942660               ##core#inline_ref ##core#inline_update ##core#debug-event
    25952661               ##core#switch ##core#cond ##core#direct_call ##core#recurse ##core#return

  • optimizer.scm 

    diff --git a/optimizer.scm b/optimizer.scm
index fbf60bac..3b390d8e 100644
    a b  
    189189                 entry) )
    190190          n) )
    191191
     192
     193    (define (maybe-replace-rest-arg-calls node)
     194      ;; Ugh, we need to match on the core inlined string instead of
     195      ;; the call to the intrinsic itself, because rewrites will have
     196      ;; introduced this after the first iteration.
     197      (or (and-let* (((eq? '##core#inline (node-class node)))
     198                     (native (->string (car (node-parameters node)))) ;; NOTE: should always be string?
     199                     (replacement-op (cond
     200                                      ((string=? native "C_i_car") '##core#rest-car)
     201                                      ((string=? native "C_i_cdr") '##core#rest-cdr)
     202                                      ((string=? native "C_i_nullp") '##core#rest-null?)
     203                                      (else #f)))
     204                     (arg (first (node-subexpressions node)))
     205                     ((eq? '##core#variable (node-class arg)))
     206                     (var (first (node-parameters arg)))
     207                     ((not (db-get db var 'captured)))
     208                     (info (db-get db var 'rest-cdr))
     209                     (restvar (car info))
     210                     (depth (cdr info))
     211                     ((not (test var 'assigned))))
     212            ;; callee is intrinsic and accesses rest arg sublist
     213            (debugging 'o "known list op on rest arg sublist"
     214                       (call-info (node-parameters node) replacement-op) var depth)
     215            (touch)
     216            (make-node replacement-op
     217                       (cons* restvar depth (cdr (node-parameters node)))
     218                       (list) ) )
     219          node) )
     220
    192221    (define (walk n fids gae)
    193222      (if (memq n broken-constant-nodes)
    194223          n
    … …  
    208237                             fids gae) )
    209238                      (else n1) ) )
    210239
     240               ((##core#inline)
     241                (maybe-replace-rest-arg-calls n1))
     242
    211243               ((##core#call)
    212244                (maybe-constant-fold-call
    213245                 n1

  • support.scm 

    diff --git a/support.scm b/support.scm
index 729d44aa..64882012 100644
    a b  
    650650       (let* ((rlist (if copy? (map gensym vars) vars))
    651651              (body (if copy?
    652652                        (copy-node-tree-and-rename body vars rlist db cfk)
    653                         body) ) )
     653                        body) )
     654              (rarg-aliases (map (lambda (r) (gensym 'rarg)) rargs)) )
     655         (replace-rest-ops-in-known-call! db body rest (last rlist) rarg-aliases)
    654656         (let loop ((vars (take rlist argc))
    655657                    (vals largs))
    656658           (if (null? vars)
    657659               (if rest
    658                    (make-node
    659                     'let (list (last rlist))
    660                     (list (if (null? rargs)
    661                               (qnode '())
    662                               (make-node
    663                                '##core#inline_allocate
    664                                (list "C_a_i_list" (* 3 (length rargs)))
    665                                rargs) )
    666                           body) )
     660                   ;; NOTE: If contraction happens before rest-op
     661                   ;; detection, we might needlessly build a list.
     662                   (let loop2 ((rarg-values rargs)
     663                               (rarg-aliases rarg-aliases))
     664                     (if (null? rarg-aliases)
     665                         (if (null? (db-get-list db rest 'references))
     666                             body
     667                             (make-node
     668                              'let (list (last rlist))
     669                              (list (if (null? rargs)
     670                                        (qnode '())
     671                                        (make-node
     672                                         '##core#inline_allocate
     673                                         (list "C_a_i_list" (* 3 (length rargs)))
     674                                         rargs) )
     675                                    body) ))
     676                         (make-node 'let (list (car rarg-aliases))
     677                                    (list (car rarg-values)
     678                                          (loop2 (cdr rarg-values) (cdr rarg-aliases))))))
    667679                   body)
    668680               (make-node 'let (list (car vars))
    669681                          (list (car vals)
    … …  
    718730                           (map (cut walk <> rl) subs))) ) ) )
    719731    (walk node rlist) ) )
    720732
     733;; Replace rest-{car,cdr,null?} with equivalent code which accesses
     734;; the rest argument directly.
     735(define (replace-rest-ops-in-known-call! db node rest-var rest-alias rest-args)
     736  (define (walk n)
     737    (let ((subs (node-subexpressions n))
     738          (params (node-parameters n))
     739          (class (node-class n)) )
     740      (case class
     741        ((##core#rest-null?)
     742         (if (eq? rest-var (first params))
     743             (copy-node! (qnode (<= (length rest-args) (second params))) n)
     744             n))
     745        ((##core#rest-car)
     746         (if (eq? rest-var (first params))
     747             (let ((depth (second params))
     748                   (len (length rest-args)))
     749               (if (> len depth)
     750                   (copy-node! (varnode (list-ref rest-args depth)) n)
     751                   ;; Emit code which will crash at runtime, because
     752                   ;; there aren't enough arguments...
     753                   (copy-node! (make-node '##core#inline
     754                                          (list (if (= len depth) "C_i_car" "C_i_cdr"))
     755                                          (list (qnode '())))
     756                               n)))
     757             n))
     758        ((##core#rest-cdr)
     759         (cond ((eq? rest-var (first params))
     760                (collect! db rest-var 'references n) ; Restore this reference
     761                (let lp ((i (add1 (second params)))
     762                         (new-node (varnode rest-alias)))
     763                  (if (zero? i)
     764                      (copy-node! new-node n)
     765                      (lp (sub1 i)
     766                          (make-node '##core#inline (list "C_i_cdr") (list new-node))))))
     767               (else n)))
     768        (else (for-each walk subs)) ) ) )
     769
     770  (walk node)  )
     771
    721772;; Maybe move to scrutinizer.  It's generic enough to keep it here though
    722773(define (tree-copy t)
    723774  (let rec ([t t])

  • tests/syntax-tests.scm 

    diff --git a/tests/syntax-tests.scm b/tests/syntax-tests.scm
index 1c98d94c..68c08483 100644
    a b  
    864864
    865865(assert (equal? '(3 4 5 (6 7)) (test-optional&rest 3 4 5 6 7)))
    866866
     867(define (test-optional&rest-cdrs x y #!optional z #!rest r)
     868  (list x y z (cdr (cdr r))))
     869
     870(assert (equal? '(3 4 5 ()) (test-optional&rest-cdrs 3 4 5 6 7)))
     871
     872;; Ensure that rest conversion is not applied too aggressively.
     873;; (only when the consequence is () should it be applied)
     874(define (rest-nonnull-optimization . rest)
     875  (let ((x (if (null? (cdr rest))
     876               '(foo)
     877               (cdr rest))))
     878    (null? x)))
     879
     880(assert (not (rest-nonnull-optimization 1)))
     881(assert (not (rest-nonnull-optimization 1 2)))
     882
     883(assert (equal? '(3 4 5 ()) (test-optional&rest-cdrs 3 4 5 6 7)))
     884
    867885(define (test-optional&key x y #!optional z #!key i (j 1))
    868886  (list x y z i: i j: j))
    869887