From af34cce1815a496a5bc98d83b88bebbe21f14f9b Mon Sep 17 00:00:00 2001 From: Peter Bex Date: Sun, 15 Dec 2019 20:39:20 +0100 Subject: [PATCH] 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. --- batch-driver.scm | 12 ++++++++---- core.scm | 19 ++++++++++++++----- distribution/manifest | 1 + support.scm | 11 +++++++++++ tests/rest-arg-tests.scm | 31 +++++++++++++++++++++++++++++++ tests/runtests.bat | 5 +++++ tests/runtests.sh | 3 +++ tests/syntax-tests.scm | 13 ------------- 8 files changed, 73 insertions(+), 22 deletions(-) create mode 100644 tests/rest-arg-tests.scm 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 -> 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 @@ -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)) -- 2.20.1