~ chicken-core (chicken-5) db972113ad6e28bffd89a6075c4fadc6e6ef68a2
commit db972113ad6e28bffd89a6075c4fadc6e6ef68a2
Author: Peter Bex <peter@more-magic.net>
AuthorDate: Sun Dec 15 20:39:20 2019 +0100
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Tue Dec 17 15:44:54 2019 +0100
Fix remaining rest-argument bug #1658
After contracting/inlining a procedure, the database would still
contain information about rest-cdr variables, and the optimizations
for rest argument accessors would be incorrectly applied, because the
rest argument no longer is a rest argument but an explicitly consed
list in a local variable.
The rest cdr information on the variables is now cleared after
inlining. To make this work, we keep track of all the derived rest
cdr notes in the database so that when a rest argument is moved
around, we can find all its aliases/derived cdrs.
Also add a new file containing test cases for this specific
optimization because it is trickier than it seems at first.
Signed-off-by: felix <felix@call-with-current-continuation.org>
diff --git a/batch-driver.scm b/batch-driver.scm
index f4393a49..f22f0646 100644
--- a/batch-driver.scm
+++ b/batch-driver.scm
@@ -122,11 +122,12 @@
internal-bindings) ) )
(hash-table-for-each
(lambda (sym plist)
- (let ([val #f]
+ (let ((val #f)
(lval #f)
- [pvals #f]
- [csites '()]
- [refs '()] )
+ (pvals #f)
+ (csites '())
+ (refs '())
+ (derived-rvars '()))
(unless (memq sym omit)
(write sym)
(let loop ((es plist))
@@ -148,6 +149,8 @@
((replacable home contains contained-in use-expr closure-size rest-parameter
captured-variables explicit-rest rest-cdr rest-null?)
(printf "\t~a=~s" (caar es) (cdar es)) )
+ ((derived-rest-vars)
+ (set! derived-rvars (cdar es)))
((references)
(set! refs (cdar es)) )
((call-sites)
@@ -155,6 +158,7 @@
(else (bomb "Illegal property" (car es))) )
(loop (cdr es)) ) ) )
(when (pair? refs) (printf "\trefs=~s" (length refs)))
+ (when (pair? derived-rvars) (printf "\tdrvars=~s" (length derived-rvars)))
(when (pair? csites) (printf "\tcss=~s" (length csites)))
(cond [(and val (not (eq? val 'unknown)))
(printf "\tval=~s" (cons (node-class val) (node-parameters val))) ]
diff --git a/core.scm b/core.scm
index 39d0a8d1..bdc657a3 100644
--- a/core.scm
+++ b/core.scm
@@ -263,6 +263,7 @@
; 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)
+; derived-rest-vars -> (v1 v2 ...) Other variables aliasing or referencing cdrs of a rest variable
; constant -> <boolean> If true: variable has fixed value
; hidden-refs -> <boolean> If true: procedure that refers to hidden global variables
; inline-transient -> <boolean> If true: was introduced during inlining
@@ -2211,15 +2212,23 @@
(define (walkeach xs env lenv fenv here)
(for-each (lambda (x) (walk x env lenv fenv here)) xs) )
+ (define (mark-rest-cdr var rvar depth)
+ (db-put! db var 'rest-cdr (cons rvar depth))
+ (collect! db rvar 'derived-rest-vars var))
+
+ (define (mark-rest-null? var rvar depth)
+ (db-put! db var 'rest-null? (cons rvar depth))
+ (collect! db rvar 'derived-rest-vars var))
+
(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) )
+ (mark-rest-cdr var (car v) (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) )
+ (mark-rest-null? var (car v) (cdr v)) )
(cond ((eq? '##core#undefined (node-class val))
(db-put! db var 'undefined #t) )
@@ -2230,12 +2239,12 @@
((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))) ) )
+ (mark-rest-cdr var 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)) ) )
+ (mark-rest-null? var restvar depth) ) )
;; (##core#cond (null? r) '() (cdr r)) => result is tagged as a rest-cdr var
((and-let* ((env (match-node val '(##core#cond ()
@@ -2248,7 +2257,7 @@
=> (lambda (env)
(let ((rvar (alist-ref 'rvar env))
(depth (alist-ref 'depth env)))
- (db-put! db var 'rest-cdr (cons rvar (add1 depth))) )) )
+ (mark-rest-cdr var rvar (add1 depth)) ) ) )
((or (memq var env)
(variable-mark var '##compiler#constant)
diff --git a/distribution/manifest b/distribution/manifest
index 5089cd4f..9d43de14 100644
--- a/distribution/manifest
+++ b/distribution/manifest
@@ -113,6 +113,7 @@ build-version.scm
build-version.c
buildid
tests/clustering-tests.scm
+tests/rest-arg-tests.scm
tests/csc-tests.scm
tests/c-id-valid.scm
tests/data-structures-tests.scm
diff --git a/support.scm b/support.scm
index b238741d..c430160b 100644
--- a/support.scm
+++ b/support.scm
@@ -653,6 +653,17 @@
body) )
(rarg-aliases (map (lambda (r) (gensym 'rarg)) rargs)) )
(replace-rest-ops-in-known-call! db body rest (last rlist) rarg-aliases)
+
+ ;; Make sure rest ops aren't replaced after inlining (#1658)
+ ;; argvector does not belong to the same procedure anymore.
+ (when rest
+ (for-each (lambda (v)
+ (db-put! db v 'rest-cdr #f)
+ (db-put! db v 'rest-null? #f) )
+ (db-get-list db rest 'derived-rest-vars) )
+ (db-put! db rest 'rest-cdr #f)
+ (db-put! db rest 'derived-rest-vars '()) )
+
(let loop ((vars (take rlist argc))
(vals largs))
(if (null? vars)
diff --git a/tests/rest-arg-tests.scm b/tests/rest-arg-tests.scm
new file mode 100644
index 00000000..152ac484
--- /dev/null
+++ b/tests/rest-arg-tests.scm
@@ -0,0 +1,31 @@
+;; Test rest argument optimizations
+
+;; Check that rest args are correctly fetched from a closure
+(assert (equal? 1 ((lambda f0
+ (let ((v0 f0))
+ (let ((failure0
+ (lambda ()
+ (if (pair? v0)
+ (car v0)))))
+ (failure0))))
+ 1)))
+
+;; Check that rest arg optimizations aren't applied after inlining
+;; (#1658), slightly different from the above
+(assert (equal? 1 ((lambda f0
+ (let ((v0 f0))
+ (if (pair? v0)
+ (car v0))))
+ 1)))
+
+;; 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)))
+
diff --git a/tests/runtests.bat b/tests/runtests.bat
index accaa7d0..c4505853 100644
--- a/tests/runtests.bat
+++ b/tests/runtests.bat
@@ -84,6 +84,11 @@ if errorlevel 1 exit /b 1
a.out
if errorlevel 1 exit /b 1
+%compile% rest-arg-tests.scm -specialize
+if errorlevel 1 exit /b 1
+a.out
+if errorlevel 1 exit /b 1
+
echo ======================================== profiler tests ...
%compile% null.scm -profile -profile-name TEST.profile
if errorlevel 1 exit /b 1
diff --git a/tests/runtests.sh b/tests/runtests.sh
index 950b6c09..5556ace6 100755
--- a/tests/runtests.sh
+++ b/tests/runtests.sh
@@ -105,6 +105,9 @@ echo "======================================== optimizer tests ..."
$compile clustering-tests.scm -clustering
./a.out
+$compile rest-arg-tests.scm -specialize
+./a.out
+
echo "======================================== profiler tests ..."
$compile null.scm -profile -profile-name TEST.profile
./a.out
diff --git a/tests/syntax-tests.scm b/tests/syntax-tests.scm
index 68c08483..a788469a 100644
--- a/tests/syntax-tests.scm
+++ b/tests/syntax-tests.scm
@@ -869,19 +869,6 @@
(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))
Trap