Hi all, The attached patches fix #1756 by detecting when a procedure with a rest argument is converted into a regular procedure with the last argument being a list which is consed up at the call sites (aka an "explicitly consed rest argument"). When this happens, we "undo" the argvector-based rest operations by replacing them with regular car/cdr/length list operations, like we also already do in closure conversion when the rest arg has been reified into a list and stored inside the current closure.
To avoid code duplication, there's a commit which first moves that code into a procedure in support.scm, followed by a commit which calls this new procedure in the situation described above. The first commit simply adds tracking of the situation so that we know when a rest argument variable has become an explicitly consed parameter. So, while this is a medium-sized change, hopefully the way the commits are structured should make it easy to review. Cheers, Peter
From bf48a7f9dbb26e3461d1090da63ca9496d902287 Mon Sep 17 00:00:00 2001 From: Peter Bex <[email protected]> Date: Wed, 16 Jun 2021 08:32:28 +0200 Subject: [PATCH 1/3] Add information to the db for rest args which are explicitly consed Before, this would only be stored as an "explicit-rest" property on the procedure variable. In contexts where you only have the variable it was difficult to find out whether the rest arg was explicitly consed. Rest-ops only hold a reference to the rest arg variable, not the procedure. --- batch-driver.scm | 2 +- core.scm | 4 +++- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/batch-driver.scm b/batch-driver.scm index 78296c9d..3f456531 100644 --- a/batch-driver.scm +++ b/batch-driver.scm @@ -147,7 +147,7 @@ ((potential-values) (set! pvals (cdar es))) ((replacable home contains contained-in use-expr closure-size rest-parameter - captured-variables explicit-rest rest-cdr rest-null?) + captured-variables explicit-rest rest-cdr rest-null? consed-rest-arg) (printf "\t~a=~s" (caar es) (cdar es)) ) ((derived-rest-vars) (set! derived-rvars (cdar es))) diff --git a/core.scm b/core.scm index 2a380f03..c484071c 100644 --- a/core.scm +++ b/core.scm @@ -263,6 +263,7 @@ ; extended-binding -> <boolean> If true: variable names an extended binding ; unused -> <boolean> If true: variable is a formal parameter that is never used ; rest-parameter -> #f | 'list If true: variable holds rest-argument list +; consed-rest-arg -> <boolean> If true: variable is a rest variable in a procedure called with consed rest 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) ; derived-rest-vars -> (v1 v2 ...) Other variables aliasing or referencing cdrs of a rest variable @@ -2435,7 +2436,8 @@ (cond ((and has (not (rassoc sym callback-names eq?))) (db-put! db (first lparams) 'has-unused-parameters #t) ) (rest - (db-put! db (first lparams) 'explicit-rest #t) ) ) ) ) ) ) ) ) ) + (db-put! db (first lparams) 'explicit-rest #t) + (db-put! db rest 'consed-rest-arg #t) ) ) ) ) ) ) ) ) ) ;; 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 -- 2.20.1
From ed34e4857f319f3654f37680ebd4c358c494f286 Mon Sep 17 00:00:00 2001 From: Peter Bex <[email protected]> Date: Wed, 16 Jun 2021 08:35:33 +0200 Subject: [PATCH 2/3] Refactor replacing of rest args to make it reusable This moves the replacing of rest args with corresponding list ops into a procedure in support.scm --- core.scm | 37 ++++++------------------------------- support.scm | 26 +++++++++++++++++++++++++- 2 files changed, 31 insertions(+), 32 deletions(-) diff --git a/core.scm b/core.scm index c484071c..630bfd04 100644 --- a/core.scm +++ b/core.scm @@ -2649,37 +2649,12 @@ ;; 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 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. - ;; - ;; Alternatively, if n isn't val, this node was - ;; processed and the variable got replaced by a - ;; closure access. - ((or (test here 'customizable) - (not (eq? val n))) - (case class - ((##core#rest-car) - (transform (make-node '##core#inline - (list "C_i_list_ref") - (list rest-var (qnode (second params)))) here closure)) - ((##core#rest-null?) - (transform (make-node '##core#inline - (list "C_i_greater_or_equalp") - (list (qnode (second params)) - (make-node '##core#inline (list "C_i_length") (list rest-var)))) here closure)) - ((##core#rest-length) - (transform (make-node '##core#inline - (list "C_i_length") - (list rest-var (qnode (second params)))) here closure)) - (else (bomb "Unknown rest op node class while converting to closure. This shouldn't happen!" class)))) + (transform (replace-rest-op-with-list-ops class rest-var params) here closure)) + + ;; If n isn't val, this node was processed and the + ;; variable got replaced by a closure access. + ((not (eq? val n)) + (transform (replace-rest-op-with-list-ops class rest-var params) here closure)) (else val)) ) ) diff --git a/support.scm b/support.scm index b93fb8ef..b56b7d00 100644 --- a/support.scm +++ b/support.scm @@ -34,7 +34,7 @@ debugging-chicken with-debugging-output quit-compiling emit-syntax-trace-info check-signature build-lambda-list c-ify-string valid-c-identifier? read-expressions - bytes->words words->bytes + bytes->words words->bytes replace-rest-op-with-list-ops check-and-open-input-file close-checked-input-file fold-inner constant? collapsable-literal? immediate? basic-literal? canonicalize-begin-body string->expr llist-length llist-match? @@ -779,6 +779,30 @@ (walk node) ) +(define (replace-rest-op-with-list-ops class rest-var-node params) + (case class + ((##core#rest-car) + (make-node '##core#inline + (list "C_i_list_ref") + (list rest-var-node (qnode (second params))))) + ((##core#rest-cdr) + (let lp ((cdr-calls (add1 (second params))) + (var rest-var-node)) + (if (zero? cdr-calls) + var + (lp (sub1 cdr-calls) + (make-node '##core#inline (list "C_i_cdr") (list var)))))) + ((##core#rest-null?) + (make-node '##core#inline + (list "C_i_greater_or_equalp") + (list (qnode (second params)) + (make-node '##core#inline (list "C_i_length") (list rest-var-node))))) + ((##core#rest-length) + (make-node '##core#inline + (list "C_i_length") + (list rest-var-node (qnode (second params))))) + (else (bomb "Unknown rest op node class while undoing rest op for explicitly consed rest arg. This shouldn't happen!" class)))) + ;; Maybe move to scrutinizer. It's generic enough to keep it here though (define (tree-copy t) (let rec ([t t]) -- 2.20.1
From 88f59eb242d23f5523e5d954e772d327ad42ed56 Mon Sep 17 00:00:00 2001 From: Peter Bex <[email protected]> Date: Wed, 16 Jun 2021 08:36:22 +0200 Subject: [PATCH 3/3] Replace rest ops with list ops on explicitly consed rest args When the optimizer detects a "rest op" for a rest parameter which has been replaced by an explicitly consed list at the call site, the rest op is replaced by car/cdr/length list operations on the now-explicit argument. This is needed because the argvector will not contain those extra arguments anymore, so attempting to read them is an access outside the argvector's bounds. This is sometimes detected by the runtime with an error like "attempted rest argument access at index 0 but rest list length is 0", but in other situations it will cause a segmentation fault, as has been reported in #1756. --- NEWS | 3 +++ manual/Acknowledgements | 10 +++++----- optimizer.scm | 19 ++++++++++++++++++- tests/rest-arg-tests.scm | 10 ++++++++++ 4 files changed, 36 insertions(+), 6 deletions(-) diff --git a/NEWS b/NEWS index 7c20c0a0..e06914c7 100644 --- a/NEWS +++ b/NEWS @@ -57,6 +57,9 @@ - An `emit-types-file` declaration has been added, which corresponds to the compiler flag of the same name (#1644, thanks to Marco Maggi for the suggestion). + - Fixed a bug caused by a bad interaction between two optimizations: + argvector rest ops would be applied even if a procedure already got + its rest arg consed at the call site (#1756, thanks to Sandra Snan). - Build system - Auto-configure at build time on most platforms. Cross-compilation diff --git a/manual/Acknowledgements b/manual/Acknowledgements index e466b2ae..a7743e82 100644 --- a/manual/Acknowledgements +++ b/manual/Acknowledgements @@ -47,11 +47,11 @@ Oskar Schirmer, Vasilij Schneidermann, Reed Sheridan, Ronald Schröder, Spencer Schumann, Ivan Shcheklein, Alexander Shendi, Alex Shinn, Ivan Shmakov, "Shmul", Tony Sidaway, Jeffrey B. Siegal, Andrey Sidorenko, Michele Simionato, Iruata Souza, Volker Stolz, Jon Strait, Dorai -Sitaram, Robert Skeels, Jason Songhurst, Clifford Stein, David Steiner, -"Sunnan", Zbigniew Szadkowski, Rick Taube, Nathan Thern, Mike Thomas, Minh -Thu, Christian Tismer, Andre van Tonder, John Tobey, Henrik Tramberend, -Vladimir Tsichevsky, James Ursetto, Neil van Dyke, Sam Varner, -Taylor Venable, Sander Vesik, Jaques Vidrine, Panagiotis Vossos, +Sitaram, Robert Skeels, Sandra Snan, Jason Songhurst, Clifford Stein, +David Steiner, "Sunnan", Zbigniew Szadkowski, Rick Taube, Nathan Thern, +Mike Thomas, Minh Thu, Christian Tismer, Andre van Tonder, John Tobey, +Henrik Tramberend, Vladimir Tsichevsky, James Ursetto, Neil van Dyke, +Sam Varner, Taylor Venable, Sander Vesik, Jaques Vidrine, Panagiotis Vossos, Shawn Wagner, Peter Wang, Ed Watkeys, Brad Watson, Thomas Weidner, Göran Weinholt, Matthew Welland, Drake Wilson, Jörg Wittenberger, Peter Wright, Mark Wutka, Adam Young, Richard Zidlicky, Houman Zolfaghari and diff --git a/optimizer.scm b/optimizer.scm index c5bbd50c..76a55ae9 100644 --- a/optimizer.scm +++ b/optimizer.scm @@ -206,6 +206,7 @@ ((eq? '##core#variable (node-class arg))) (var (first (node-parameters arg))) ((not (db-get db var 'captured))) + ((not (db-get db var 'consed-rest-arg))) (info (db-get db var 'rest-cdr)) (restvar (car info)) (depth (cdr info)) @@ -570,7 +571,23 @@ gae) n2))))) - (else (walk-generic n class params subs fids gae #f)) ) ) ) + ((##core#rest-cdr ##core#rest-car ##core#rest-null? ##core#rest-length) + (let ((rest-var (first params))) + ;; If rest-arg has been replaced with regular arg which + ;; is explicitly consed at call sites, restore rest ops + ;; as regular car/cdr calls on the rest list variable. + ;; This can be improved, as it can actually introduce + ;; many more cdr calls than necessary. + (cond + ((or (test rest-var 'consed-rest-arg)) + (touch) + (debugging 'o "resetting rest op for explicitly consed rest parameter" rest-var class) + + (replace-rest-op-with-list-ops class (varnode rest-var) params)) + + (else (walk-generic n class params subs fids gae #f))) ) ) + + (else (walk-generic n class params subs fids gae #f)) ) ) ) (define (walk-generic n class params subs fids gae invgae) (let lp ((same? #t) diff --git a/tests/rest-arg-tests.scm b/tests/rest-arg-tests.scm index 152ac484..54749a15 100644 --- a/tests/rest-arg-tests.scm +++ b/tests/rest-arg-tests.scm @@ -29,3 +29,13 @@ (assert (not (rest-nonnull-optimization 1))) (assert (not (rest-nonnull-optimization 1 2))) +;; Regression test to make sure explicitly consed rest args don't get +;; rest argvector ops for them (#1756) +(let () + (define mdplus + (lambda args + (let ((args args)) + (if (pair? args) + (car args))))) + (mdplus '1 '2) + (mdplus '3 '4)) -- 2.20.1
signature.asc
Description: PGP signature
