From 1e8ace33d17a3156c184e8121eb291a7c9324ccc Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Tue, 13 Sep 2011 14:31:18 +0200
Subject: [PATCH] peval: Add tests for inlining with both static & dynamic
 arguments.

* module/language/tree-il/optimize.scm (peval): Improve comment on the
  inlining heuristics.

* test-suite/tests/tree-il.test ("partial evaluation"): Add two tests.
---
 module/language/tree-il/optimize.scm |  7 ++++---
 test-suite/tests/tree-il.test        | 31 ++++++++++++++++++++++++++++
 2 files changed, 35 insertions(+), 3 deletions(-)

diff --git a/module/language/tree-il/optimize.scm b/module/language/tree-il/optimize.scm
index 15b8ec0c3..4453df3a3 100644
--- a/module/language/tree-il/optimize.scm
+++ b/module/language/tree-il/optimize.scm
@@ -251,9 +251,10 @@ it should be called before `fix-letrec'."
                   (args  (map (cut loop <> env calls) orig-args))
                   (args* (map maybe-unconst orig-args args))
                   (app   (make-application src proc args*)))
-             ;; If ARGS are constants and this call hasn't already been
-             ;; expanded before (to avoid infinite recursion), then
-             ;; expand it (todo: emit an infinite recursion warning.)
+             ;; If at least one of ARGS is static (to avoid infinite
+             ;; inlining) and this call hasn't already been expanded
+             ;; before (to avoid infinite recursion), then expand it
+             ;; (todo: emit an infinite recursion warning.)
              (if (and (any const*? args)
                       (not (member (cons proc args) calls)))
                  (match proc
diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index cffd3ac49..a8a5e33c4 100644
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -943,6 +943,37 @@
            (apply (toplevel frob!) (lexical x _))
            (lexical x _))))
 
+  (pass-if-peval
+    ;; Inlining stops at recursive calls with dynamic arguments.
+    (let loop ((x x))
+      (if (< x 0) x (loop (1- x))))
+    (letrec (loop) (_) ((lambda (_)
+                          (lambda-case
+                           (((x) #f #f #f () (_))
+                            (if _ _
+                                (apply (lexical loop _)
+                                       (apply (primitive 1-)
+                                              (lexical x _))))))))
+            (apply (lexical loop _) (toplevel x))))
+
+  (pass-if-peval
+    ;; Inlining stops at recursive calls (mixed static/dynamic arguments).
+    (let loop ((x x) (y 0))
+      (if (> y 0)
+          (loop (1+ x) (1+ y))
+          (if (< x 0) x (loop (1- x)))))
+    (letrec (loop) (_) ((lambda (_)
+                          (lambda-case
+                           (((x y) #f #f #f () (_ _))
+                            (if (apply (primitive >)
+                                       (lexical y _) (const 0))
+                                _ _)))))
+            ;; call to (loop x 0) is inlined & specialized
+            (if (apply (primitive <) (toplevel x) (const 0))
+                (toplevel x)
+                (apply (lexical loop _)
+                       (apply (primitive 1-) (toplevel x))))))
+
   (pass-if-peval
     ;; Infinite recursion: `peval' gives up and leaves it as is.
     (letrec ((f (lambda (x) (g (1- x))))