From 88f59eb242d23f5523e5d954e772d327ad42ed56 Mon Sep 17 00:00:00 2001 From: Peter Bex 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