From 4a353e5cee3986fa4f138171ef3141408d82300c Mon Sep 17 00:00:00 2001
From: Peter Bex <address@hidden>
Date: Fri, 18 Mar 2016 20:27:09 +0100
Subject: [PATCH] Don't shortcut pure calls in the optimiser

When we notice a node represents a call to a pure (side effect-free)
procedure, we attempt to drop the call completely, if the result is
unused.  However, if the result _is_ used, we shouldn't just give up.
In fact, if the callee is of type explicit-rest, we *must* finish the
optimisation by tweaking the caller.

This fixes a bug reported by Joerg Wittenberger which got triggered
rather easily when adding profiler instrumentation to procedures,
because those always use rest args.
---
 optimizer.scm            | 43 +++++++++++++++++++++----------------------
 tests/compiler-tests.scm | 17 +++++++++++++++++
 2 files changed, 38 insertions(+), 22 deletions(-)

diff --git a/optimizer.scm b/optimizer.scm
index 9fad7b7..ac1224c 100644
--- a/optimizer.scm
+++ b/optimizer.scm
@@ -329,28 +329,27 @@
 			     llist args (first (node-subexpressions lval)) #f db
 			     void)
 			    fids gae) ) )
-			((variable-mark var '##compiler#pure)
-			 ;; callee is side-effect free
-			 (or (and-let* ((k (car args))
-					((eq? '##core#variable (node-class k)))
-					(kvar (first (node-parameters k)))
-					(lval (and (not (test kvar 'unknown)) 
-						   (test kvar 'value))) 
-					((eq? '##core#lambda (node-class lval)))
-					(llist (third (node-parameters lval)))
-					((or (test (car llist) 'unused)
-					     (and (not (test (car llist) 'references))
-						  (not (test (car llist) 'assigned)))))
-					((not (any (cut expression-has-side-effects? <> db)
-						   (cdr args) ))))
-			       (debugging 
-				'o
-				"removed call to pure procedure with unused result"
-				info)
-			       (make-node
-				'##core#call (list #t)
-				(list k (make-node '##core#undefined '() '())) ) ) 
-			     (walk-generic n class params subs fids gae #f)) )
+			((and-let* (((variable-mark var '##compiler#pure))
+				    ((eq? '##core#variable (node-class (car args))))
+				    (kvar (first (node-parameters (car args))))
+				    (lval (and (not (test kvar 'unknown))
+					       (test kvar 'value)))
+				    ((eq? '##core#lambda (node-class lval)))
+				    (llist (third (node-parameters lval)))
+				    ((or (test (car llist) 'unused)
+					 (and (not (test (car llist) 'references))
+					      (not (test (car llist) 'assigned))))))
+			   ;; callee is side-effect free
+			   (not (any (cut expression-has-side-effects? <> db)
+				     (cdr args) )))
+			 (debugging
+			  'o
+			  "removed call to pure procedure with unused result"
+			  info)
+			 (make-node
+			  '##core#call (list #t)
+			  (list (car args)
+				(make-node '##core#undefined '() '())) ) )
 			((and lval
 			      (eq? '##core#lambda (node-class lval)))
 			 ;; callee is a lambda
diff --git a/tests/compiler-tests.scm b/tests/compiler-tests.scm
index 078cb0d..250ff51 100644
--- a/tests/compiler-tests.scm
+++ b/tests/compiler-tests.scm
@@ -302,3 +302,20 @@
 (assert (= 12.0 (s4v-sum "float" f64vector '#f64(1.5 2.5 3.5 4.5))))
 (assert (= 12.0 (s4v-sum "float" nonnull-f32vector '#f32(1.5 2.5 3.5 4.5))))
 (assert (= 12.0 (s4v-sum "float" nonnull-f64vector '#f64(1.5 2.5 3.5 4.5))))
+
+
+;; Reported by Jörg Wittenberger: in some cases, -profile would
+;; generate calls to procedures.  This was due to calls to pure
+;; procedures not getting replaced with explicitly consed rest
+;; list when the procedures themselves were hidden.
+(module explicitly-consed-rest-args-bug (do-it also-do-it)
+ (import scheme chicken)
+
+ (: get-value (* * #!rest * --> *))
+ (define (get-value x y . rest)
+   (apply x y rest))
+ (define (do-it arg)
+   (get-value arg 2))
+ (define (also-do-it arg)
+   (get-value arg 3))
+)
-- 
2.1.4