From 082b24633ddf831f63a77661b88d97b25fd08f2b Mon Sep 17 00:00:00 2001 From: Peter Bex 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 ) 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 )), 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 ) 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 --- NEWS | 2 + batch-driver.scm | 2 +- c-backend.scm | 24 ++++++++--- c-platform.scm | 2 +- chicken.h | 6 ++- core.scm | 93 ++++++++++++++++++++++++++++++++++++++---- library.scm | 9 ++++ optimizer.scm | 32 +++++++++++++++ runtime.c | 15 +++++++ support.scm | 69 ++++++++++++++++++++++++++----- tests/syntax-tests.scm | 18 ++++++++ 11 files changed, 246 insertions(+), 26 deletions(-) diff --git a/NEWS b/NEWS index 64b8f6db..df26d6e8 100644 --- a/NEWS +++ b/NEWS @@ -35,6 +35,8 @@ (#1624, thanks to Sven Hartrumpf) - Inline files no longer refer to unexported foreign stub functions (fixes #1440, thanks to "megane"). + - In some cases, rest argument lists do not need to be reified, which + should make using optional arguments faster (#1623). - Module system - Trying to export a foreign variable, define-inlined procedure or diff --git a/batch-driver.scm b/batch-driver.scm index 82ed562e..f4393a49 100644 --- a/batch-driver.scm +++ b/batch-driver.scm @@ -146,7 +146,7 @@ ((potential-values) (set! pvals (cdar es))) ((replacable home contains contained-in use-expr closure-size rest-parameter - captured-variables explicit-rest) + captured-variables explicit-rest rest-cdr rest-null?) (printf "\t~a=~s" (caar es) (cdar es)) ) ((references) (set! refs (cdar es)) ) diff --git a/c-backend.scm b/c-backend.scm index 10134fbc..2af59829 100644 --- a/c-backend.scm +++ b/c-backend.scm @@ -181,6 +181,24 @@ (expr (car subs) i) (gen ")[" (+ (first params) 1) #\]) ) + ((##core#rest-car) + (let* ((n (lambda-literal-argument-count ll)) + (depth (second params)) + (have-av? (not (or (lambda-literal-customizable ll) + (lambda-literal-direct ll))))) + (if have-av? + (gen "C_get_rest_arg(c," (+ depth n) ",av," n ",t0)") + (gen "C_u_i_list_ref(t" (sub1 n) "," depth ")")))) + + ((##core#rest-null?) + (let* ((n (lambda-literal-argument-count ll)) + (depth (second params)) + (have-av? (not (or (lambda-literal-customizable ll) + (lambda-literal-direct ll))))) + (if have-av? + (gen "C_rest_nullp(c," (+ depth n) ")") + (gen "C_mk_bool(C_unfix(C_i_length(t" (sub1 n) ")) >= " depth ")")))) + ((##core#unbox) (gen "((C_word*)") (expr (car subs) i) @@ -632,8 +650,6 @@ (customizable (lambda-literal-customizable ll)) (empty-closure (and customizable (zero? (lambda-literal-closure-size ll)))) (varlist (intersperse (make-variable-list (if empty-closure (sub1 n) n) "t") #\,)) - (rest (lambda-literal-rest-argument ll)) - (rest-mode (lambda-literal-rest-argument-mode ll)) (direct (lambda-literal-direct ll)) (allocated (lambda-literal-allocated ll)) ) (gen #t) @@ -679,8 +695,6 @@ (let* ([id (car p)] [ll (cdr p)] [argc (lambda-literal-argument-count ll)] - [rest (lambda-literal-rest-argument ll)] - [rest-mode (lambda-literal-rest-argument-mode ll)] [customizable (lambda-literal-customizable ll)] [empty-closure (and customizable (zero? (lambda-literal-closure-size ll)))] ) (when empty-closure (set! argc (sub1 argc))) @@ -923,7 +937,7 @@ (apply gen arglist) (gen ");}")) (else - (gen #t "C_save_and_reclaim((void *)" id #\, n ",av);}"))) + (gen #t "C_save_and_reclaim((void *)" id ",c,av);}"))) (when (> demand 0) (gen #t "a=C_alloc(" demand ");"))))) (else (gen #\}))) diff --git a/c-platform.scm b/c-platform.scm index 87f36698..61a4ac87 100644 --- a/c-platform.scm +++ b/c-platform.scm @@ -502,7 +502,7 @@ (rewrite 'scheme#cdddr 2 1 "C_i_cdddr" #t) (rewrite 'scheme#cddddr 2 1 "C_i_cddddr" #t) -(rewrite 'scheme#cdr 7 1 "C_slot" 1 #f) +(rewrite 'scheme#cdr 2 1 "C_u_i_cdr" #f) (rewrite 'scheme#cdr 2 1 "C_i_cdr" #t) (rewrite 'scheme#eq? 1 2 "C_eqp") diff --git a/chicken.h b/chicken.h index dbf6f17b..a46c2428 100644 --- a/chicken.h +++ b/chicken.h @@ -634,6 +634,7 @@ void *alloca (); #define C_BAD_ARGUMENT_TYPE_NO_EXACT_INTEGER_ERROR 53 #define C_BAD_ARGUMENT_TYPE_FOREIGN_LIMITATION 54 #define C_BAD_ARGUMENT_TYPE_COMPLEX_ABS 55 +#define C_REST_ARG_OUT_OF_BOUNDS_ERROR 56 /* Platform information */ #if defined(C_BIG_ENDIAN) @@ -1244,6 +1245,8 @@ typedef void (C_ccall *C_proc)(C_word, C_word *) C_noret; #define C_offset_pointer(x, y) (C_pointer_address(x) + (y)) #define C_do_apply(c, av) ((C_proc)(void *)C_block_item((av)[0], 0))((c), (av)) #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) +#define C_get_rest_arg(c, n, av, ka, cl)((n) >= (c) ? (C_rest_arg_out_of_bounds_error_2(C_fix(c), C_fix(n), C_fix(ka), (cl)), C_SCHEME_UNDEFINED) : (av)[(n)]) +#define C_rest_nullp(c, n) (C_mk_bool((n) >= (c))) #define C_fetch_byte(x, p) (((unsigned C_byte *)C_data_pointer(x))[ p ]) #define C_poke_integer(x, i, n) (C_set_block_item(x, C_unfix(i), C_num_to_int(n)), C_SCHEME_UNDEFINED) #define C_pointer_to_block(p, x) (C_set_block_item(p, 0, (C_word)C_data_pointer(x)), C_SCHEME_UNDEFINED) @@ -1629,7 +1632,6 @@ typedef void (C_ccall *C_proc)(C_word, C_word *) C_noret; #define C_i_true2(dummy1, dummy2) ((dummy1), (dummy2), C_SCHEME_TRUE) #define C_i_true3(dummy1, dummy2, dummy3) ((dummy1), (dummy2), (dummy3), C_SCHEME_TRUE) - /* debug client interface */ typedef struct C_DEBUG_INFO { @@ -1781,6 +1783,8 @@ C_fctexport void C_no_closure_error(C_word x) C_noret; C_fctexport void C_div_by_zero_error(char *loc) C_noret; C_fctexport void C_not_an_integer_error(char *loc, C_word x) C_noret; C_fctexport void C_not_an_uinteger_error(char *loc, C_word x) C_noret; +C_fctexport void C_rest_arg_out_of_bounds_error(C_word c, C_word n, C_word ka) C_noret; +C_fctexport void C_rest_arg_out_of_bounds_error_2(C_word c, C_word n, C_word ka, C_word closure) C_noret; C_fctexport C_word C_closure(C_word **ptr, int cells, C_word proc, ...); C_fctexport C_word C_fcall C_pair(C_word **ptr, C_word car, C_word cdr) C_regparm; C_fctexport C_word C_fcall C_number(C_word **ptr, double n) C_regparm; diff --git a/core.scm b/core.scm index 9f39bb30..baeacb67 100644 --- a/core.scm +++ b/core.scm @@ -178,6 +178,9 @@ ; [##core#call { []} ...] ; [##core#callunit {} ...] ; [##core#switch {} ... ] +; [##core#rest-car {restvar depth []}] +; [##core#rest-cdr {restvar depth []}] +; [##core#rest-null? {restvar depth []} ] ; [##core#cond ] ; [##core#provide ] ; [##core#recurse {} ...] @@ -257,6 +260,8 @@ ; extended-binding -> If true: variable names an extended binding ; unused -> If true: variable is a formal parameter that is never used ; rest-parameter -> #f | 'list If true: variable holds rest-argument list +; rest-cdr -> (rvar . n) Variable references the cdr of rest list rvar after n cdrs (0 = rest list itself) +; rest-null? -> (rvar . n) Variable checks if the cdr of rest list rvar after n cdrs is empty (0 = rest list itself) ; constant -> If true: variable has fixed value ; hidden-refs -> If true: procedure that refers to hidden global variables ; inline-transient -> If true: was introduced during inlining @@ -2096,7 +2101,8 @@ (case class ((quote ##core#undefined ##core#provide ##core#proc) #f) - ((##core#variable) + ;; Uneliminated rest-cdr calls need to hang on to rest var + ((##core#variable ##core#rest-cdr) (let ((var (first params))) (ref var n) (unless (memq var localenv) @@ -2160,7 +2166,8 @@ (db-put! db var 'unknown #t) ) vars) (when rest - (db-put! db rest 'rest-parameter 'list) ) + (db-put! db rest 'rest-parameter 'list) + (db-put! db rest 'rest-cdr (cons rest 0))) (when (simple-lambda-node? n) (db-put! db id 'simple #t)) (let ([tl toplevel-scope]) (unless toplevel-lambda-id (set! toplevel-lambda-id id)) @@ -2204,10 +2211,44 @@ (for-each (lambda (x) (walk x env lenv fenv here)) xs) ) (define (assign var val env here) + ;; Propagate rest-cdr and rest-null? onto aliased variables + (and-let* (((eq? '##core#variable (node-class val))) + (v (db-get db (first (node-parameters val)) 'rest-cdr))) + (db-put! db var 'rest-cdr v) ) + + (and-let* (((eq? '##core#variable (node-class val))) + (v (db-get db (first (node-parameters val)) 'rest-null?))) + (db-put! db var 'rest-null? v) ) + (cond ((eq? '##core#undefined (node-class val)) (db-put! db var 'undefined #t) ) ((and (eq? '##core#variable (node-class val)) ; assignment to itself (eq? var (first (node-parameters val))) ) ) + + ;; Propagate info from ##core#rest-{cdr,null?} nodes to var + ((eq? '##core#rest-cdr (node-class val)) + (let ((restvar (car (node-parameters val))) + (depth (cadr (node-parameters val)))) + (db-put! db var 'rest-cdr (cons restvar (add1 depth))) ) ) + + ((eq? '##core#rest-null? (node-class val)) + (let ((restvar (car (node-parameters val))) + (depth (cadr (node-parameters val)))) + (db-put! db var 'rest-null? (cons restvar depth)) ) ) + + ;; (##core#cond (null? r) '() (cdr r)) => result is tagged as a rest-cdr var + ((and-let* ((env (match-node val '(##core#cond () + (##core#variable (test-var)) + (quote (())) + (##core#rest-cdr (rvar depth))) + '(test-var rvar depth))) + ((db-get db (alist-ref 'test-var env) 'rest-null?))) + env) + => (lambda (env) + (let ((rvar (alist-ref 'rvar env)) + (depth (alist-ref 'depth env))) + (db-put! db var 'rest-cdr (cons rvar (add1 depth))) )) ) + ((or (memq var env) (variable-mark var '##compiler#constant) (not (variable-visible? var block-compilation))) @@ -2257,8 +2298,8 @@ [assigned-locally #f] [undefined #f] [global #f] - [rest-parameter #f] [nreferences 0] + [rest-cdr #f] [ncall-sites 0] ) (set! current-analysis-database-size (fx+ current-analysis-database-size 1)) @@ -2282,7 +2323,7 @@ [(global) (set! global #t)] [(value) (set! value (cdr prop))] [(local-value) (set! local-value (cdr prop))] - [(rest-parameter) (set! rest-parameter #t)] ) ) + [(rest-cdr) (set! rest-cdr (cdr prop))] ) ) plist) (set! value (and (not unknown) value)) @@ -2397,8 +2438,10 @@ (rest (db-put! db (first lparams) 'explicit-rest #t) ) ) ) ) ) ) ) ) ) - ;; Make 'removable, if it has no references and is not assigned to, and if it - ;; has either a value that does not cause any side-effects or if it is 'undefined: + ;; Make 'removable, if it has no references and is not assigned to, and one of the following: + ;; - it has either a value that does not cause any side-effects + ;; - it is 'undefined + ;; - it holds only a 'rest-cdr reference (strictly speaking, it may bomb but we don't care) (when (and (not assigned) (null? references) (or (and value @@ -2408,7 +2451,8 @@ (variable-mark varname '##core#always-bound) (intrinsic? varname))) (not (expression-has-side-effects? value db)) )) - undefined) ) + undefined + rest-cdr) ) (quick-put! plist 'removable #t) ) ;; Make 'replacable, if @@ -2494,7 +2538,7 @@ (params (node-parameters n)) ) (case (node-class n) - ((##core#variable) + ((##core#variable ##core#rest-cdr) (let ((var (first params))) (if (memq var lexicals) (list var) @@ -2590,6 +2634,39 @@ (make-node '##core#unbox '() (list val)) val) ) ) + ((##core#rest-cdr ##core#rest-car ##core#rest-null?) + (let* ((rest-var (first params)) + (val (ref-var n here closure))) + (unless (eq? val n) + ;; If it's captured, replacement in optimizer was incorrect + (bomb "Saw rest op for captured variable. This should not happen!" class) ) + ;; If rest-cdrs have not all been eliminated, restore + ;; them as regular cdr calls on the rest list variable. + ;; This can be improved, as it can actually introduce + ;; many more cdr calls than necessary. + (cond ((eq? class '##core#rest-cdr) + (let lp ((cdr-calls (add1 (second params))) + (var (varnode rest-var))) + (if (zero? cdr-calls) + (transform var here closure) + (lp (sub1 cdr-calls) + (make-node '##core#inline (list "C_i_cdr") (list var)))))) + ;; If customizable, the list is consed up at the + ;; call site and there is no argvector. So convert + ;; back to list-ref/list-tail calls. + ((and (eq? class '##core#rest-car) + (test here 'customizable)) + (transform (make-node '##core#inline + (list "C_i_list_ref") + (list (varnode rest-var) (second params))) here closure)) + ((and (eq? class '##core#rest-null) + (test here 'customizable)) + (transform (make-node '##core#inline + (list "C_i_greater_or_equal_p") + (list (qnode (second params)) + (make-node '##core#inline (list "C_i_length") (list (varnode rest-var))))) here closure)) + (else val)) ) ) + ((if ##core#call ##core#inline ##core#inline_allocate ##core#callunit ##core#inline_ref ##core#inline_update ##core#debug-event ##core#switch ##core#cond ##core#direct_call ##core#recurse ##core#return diff --git a/library.scm b/library.scm index 29b85878..e52d1452 100644 --- a/library.scm +++ b/library.scm @@ -5453,6 +5453,15 @@ EOF ((53) (apply ##sys#signal-hook #:type-error loc "bad argument type - not an exact integer" args)) ((54) (apply ##sys#signal-hook #:type-error loc "number does not fit in foreign type" args)) ((55) (apply ##sys#signal-hook #:type-error loc "cannot compute absolute value of complex number" args)) + ((56) (let ((c (car args)) + (n (cadr args)) + (fn (caddr args))) + (apply + ##sys#signal-hook + #:bounds-error loc + (string-append "attempted rest argument access at index " (##sys#number->string n) + " but rest list length is " (##sys#number->string c) ) + (if fn (list fn) '())))) (else (apply ##sys#signal-hook #:runtime-error loc "unknown internal error" args)) ) ) ) ) ) ; chicken.condition diff --git a/optimizer.scm b/optimizer.scm index fbf60bac..b14b72f3 100644 --- a/optimizer.scm +++ b/optimizer.scm @@ -189,6 +189,35 @@ entry) ) n) ) + + (define (maybe-replace-rest-arg-calls node) + ;; Ugh, we need to match on the core inlined string instead of + ;; the call to the intrinsic itself, because rewrites will have + ;; introduced this after the first iteration. + (or (and-let* (((eq? '##core#inline (node-class node))) + (native (car (node-parameters node))) + (replacement-op (cond + ((member native '("C_i_car" "C_u_i_car")) '##core#rest-car) + ((member native '("C_i_cdr" "C_u_i_cdr")) '##core#rest-cdr) + ((member native '("C_i_nullp")) '##core#rest-null?) + (else #f))) + (arg (first (node-subexpressions node))) + ((eq? '##core#variable (node-class arg))) + (var (first (node-parameters arg))) + ((not (db-get db var 'captured))) + (info (db-get db var 'rest-cdr)) + (restvar (car info)) + (depth (cdr info)) + ((not (test var 'assigned)))) + ;; callee is intrinsic and accesses rest arg sublist + (debugging '(o x) "known list op on rest arg sublist" + (call-info (node-parameters node) replacement-op) var depth) + (touch) + (make-node replacement-op + (cons* restvar depth (cdr (node-parameters node))) + (list) ) ) + node) ) + (define (walk n fids gae) (if (memq n broken-constant-nodes) n @@ -208,6 +237,9 @@ fids gae) ) (else n1) ) ) + ((##core#inline) + (maybe-replace-rest-arg-calls n1)) + ((##core#call) (maybe-constant-fold-call n1 diff --git a/runtime.c b/runtime.c index 8a3d3d31..a3cffeb6 100644 --- a/runtime.c +++ b/runtime.c @@ -1948,6 +1948,11 @@ void barf(int code, char *loc, ...) c = 1; break; + case C_REST_ARG_OUT_OF_BOUNDS_ERROR: + msg = C_text("attempted rest argument access beyond end of list"); + c = 3; + break; + default: panic(C_text("illegal internal error code")); } @@ -2708,6 +2713,16 @@ void C_not_an_uinteger_error(char *loc, C_word x) barf(C_BAD_ARGUMENT_TYPE_NO_UINTEGER_ERROR, loc, x); } +void C_rest_arg_out_of_bounds_error(C_word c, C_word n, C_word ka) +{ + C_rest_arg_out_of_bounds_error_2(c, n, ka, C_SCHEME_FALSE); +} + +void C_rest_arg_out_of_bounds_error_2(C_word c, C_word n, C_word ka, C_word closure) +{ + barf(C_REST_ARG_OUT_OF_BOUNDS_ERROR, NULL, C_u_fixnum_difference(c, ka), C_u_fixnum_difference(n, ka), closure); +} + /* Allocate and initialize record: */ C_regparm C_word C_fcall C_string(C_word **ptr, int len, C_char *str) diff --git a/support.scm b/support.scm index 729d44aa..e5eee630 100644 --- a/support.scm +++ b/support.scm @@ -650,20 +650,32 @@ (let* ((rlist (if copy? (map gensym vars) vars)) (body (if copy? (copy-node-tree-and-rename body vars rlist db cfk) - body) ) ) + body) ) + (rarg-aliases (map (lambda (r) (gensym 'rarg)) rargs)) ) + (replace-rest-ops-in-known-call! db body rest (last rlist) rarg-aliases) (let loop ((vars (take rlist argc)) (vals largs)) (if (null? vars) (if rest - (make-node - 'let (list (last rlist)) - (list (if (null? rargs) - (qnode '()) - (make-node - '##core#inline_allocate - (list "C_a_i_list" (* 3 (length rargs))) - rargs) ) - body) ) + ;; NOTE: If contraction happens before rest-op + ;; detection, we might needlessly build a list. + (let loop2 ((rarg-values rargs) + (rarg-aliases rarg-aliases)) + (if (null? rarg-aliases) + (if (null? (db-get-list db rest 'references)) + body + (make-node + 'let (list (last rlist)) + (list (if (null? rargs) + (qnode '()) + (make-node + '##core#inline_allocate + (list "C_a_i_list" (* 3 (length rargs))) + rargs) ) + body) )) + (make-node 'let (list (car rarg-aliases)) + (list (car rarg-values) + (loop2 (cdr rarg-values) (cdr rarg-aliases)))))) body) (make-node 'let (list (car vars)) (list (car vals) @@ -718,6 +730,43 @@ (map (cut walk <> rl) subs))) ) ) ) (walk node rlist) ) ) +;; Replace rest-{car,cdr,null?} with equivalent code which accesses +;; the rest argument directly. +(define (replace-rest-ops-in-known-call! db node rest-var rest-alias rest-args) + (define (walk n) + (let ((subs (node-subexpressions n)) + (params (node-parameters n)) + (class (node-class n)) ) + (case class + ((##core#rest-null?) + (if (eq? rest-var (first params)) + (copy-node! (qnode (<= (length rest-args) (second params))) n) + n)) + ((##core#rest-car) + (if (eq? rest-var (first params)) + (let ((depth (second params)) + (len (length rest-args))) + (if (> len depth) + (copy-node! (varnode (list-ref rest-args depth)) n) + (copy-node! (make-node '##core#inline + (list "C_rest_arg_out_of_bounds_error") + (list (qnode len) (qnode depth) (qnode 0) (qnode #f))) + n))) + n)) + ((##core#rest-cdr) + (cond ((eq? rest-var (first params)) + (collect! db rest-var 'references n) ; Restore this reference + (let lp ((i (add1 (second params))) + (new-node (varnode rest-alias))) + (if (zero? i) + (copy-node! new-node n) + (lp (sub1 i) + (make-node '##core#inline (list "C_i_cdr") (list new-node)))))) + (else n))) + (else (for-each walk subs)) ) ) ) + + (walk node) ) + ;; Maybe move to scrutinizer. It's generic enough to keep it here though (define (tree-copy t) (let rec ([t t]) diff --git a/tests/syntax-tests.scm b/tests/syntax-tests.scm index 1c98d94c..68c08483 100644 --- a/tests/syntax-tests.scm +++ b/tests/syntax-tests.scm @@ -864,6 +864,24 @@ (assert (equal? '(3 4 5 (6 7)) (test-optional&rest 3 4 5 6 7))) +(define (test-optional&rest-cdrs x y #!optional z #!rest r) + (list x y z (cdr (cdr r)))) + +(assert (equal? '(3 4 5 ()) (test-optional&rest-cdrs 3 4 5 6 7))) + +;; Ensure that rest conversion is not applied too aggressively. +;; (only when the consequence is () should it be applied) +(define (rest-nonnull-optimization . rest) + (let ((x (if (null? (cdr rest)) + '(foo) + (cdr rest)))) + (null? x))) + +(assert (not (rest-nonnull-optimization 1))) +(assert (not (rest-nonnull-optimization 1 2))) + +(assert (equal? '(3 4 5 ()) (test-optional&rest-cdrs 3 4 5 6 7))) + (define (test-optional&key x y #!optional z #!key i (j 1)) (list x y z i: i j: j)) -- 2.20.1