~ chicken-core (chicken-5) da39e738821488c545d17ca2d89db0ad6f65769f

commit da39e738821488c545d17ca2d89db0ad6f65769f
Author:     Peter Bex <peter@more-magic.net>
AuthorDate: Wed Sep 16 13:02:46 2020 +0200
Commit:     felix <felix@call-with-current-continuation.org>
CommitDate: Wed Sep 16 13:26:43 2020 +0200

    Don't re-use argvector when the CPS call's arguments use rest-ops (#1703)
    
    Code using restops can be compiled to C code essentially like this:
    
    av2 = av;
    av2[0]=*((C_word*)lf[0]+1);
    av2[1]=t1;
    av2[2]=t2;
    av2[3]=C_get_rest_arg(c,2,av,2,t0);
    tp(4,av2);
    
    But this means the get_rest_arg is taking the newly-written value from
    av2 instead of from the original av.
    
    It would be better if we could assign the argument to a temporary
    instead so that it precedes the call, but that would require a
    restructure of the CPS call itself, which is quite complicated.  For
    now this workaround should be fine, as the situation is relatively
    rare anyway.
    
    Signed-off-by: felix <felix@call-with-current-continuation.org>

diff --git a/NEWS b/NEWS
index 7164df42..87587eeb 100644
--- a/NEWS
+++ b/NEWS
@@ -34,6 +34,10 @@
   - At program cleanup, finalizers are only forced when the live
     finalizer count is non-zero
 
+- Compiler
+  - Avoid re-using argvector when inline rest operations are being
+    used in CPS calls (#1703, thanks to Jakob L. Keuze).
+
 - Build system
   - Auto-configure at build time on most platforms. Cross-compilation
     still requires PLATFORM to be set, and it can still be provided
diff --git a/c-backend.scm b/c-backend.scm
index 1753fea5..67f83691 100644
--- a/c-backend.scm
+++ b/c-backend.scm
@@ -553,6 +553,16 @@
 	    (expr (car xs) i)
 	    (loop (cdr xs)))))
 
+      (define (contains-restop? args)
+	(let loop ((args args))
+	  (if (null? args)
+	      #f
+	      (let ((node (car args)))
+		;; Only rest-car accesses av
+		(or (eq? (node-class node) '##core#rest-car)
+		    (contains-restop? (node-subexpressions node))
+		    (loop (cdr args)))))))
+
       (define (push-args args i selfarg)
 	(let* ((n (length args))
 	       (avl (+ n (if selfarg 1 0)))
@@ -567,7 +577,8 @@
 	  (cond
 	   ((or (not caller-has-av?)	     ; Argvec missing or
 		(and (< caller-argcount avl) ; known to be too small?
-		     (eq? caller-rest-mode 'none)))
+		     (eq? caller-rest-mode 'none))
+		(contains-restop? args))     ; Restops work on original av
 	    (gen #t "C_word av2[" avl "];"))
 	   ((>= caller-argcount avl)   ; Argvec known to be re-usable?
 	    (gen #t "C_word *av2=av;")) ; Re-use our own argvector
diff --git a/tests/compiler-tests.scm b/tests/compiler-tests.scm
index 53275a62..9cda75ef 100644
--- a/tests/compiler-tests.scm
+++ b/tests/compiler-tests.scm
@@ -461,4 +461,11 @@
   (append-map (lambda (a b) (assert (and (= a 3) (= b 4))))
     x y))
 (outer 3 4)
-  
+
+; #1703: argvector re-use interfered with rest-arg optimization
+(define reduce (lambda (_l ini) (+ ini 1)))
+
+(print ((lambda xs (reduce xs (car xs))) 1 2 3)) ;; prints 2
+
+(define fold- (lambda xs (reduce xs (car xs))))
+(print (fold- 1 2 3))