From 0f676d8725ebc79cd166047203c5400d8c639a25 Mon Sep 17 00:00:00 2001
From: Andy Wingo <wingo@pobox.com>
Date: Wed, 23 Oct 2013 10:35:30 +0200
Subject: [PATCH] Peval: Fold `thunk?' in more cases.

* module/language/tree-il/peval.scm (peval): Better folding of the
  `thunk?' predicate.
---
 module/language/tree-il/peval.scm | 20 +++++++++++++-------
 1 file changed, 13 insertions(+), 7 deletions(-)

diff --git a/module/language/tree-il/peval.scm b/module/language/tree-il/peval.scm
index f3c016137..676ac89a8 100644
--- a/module/language/tree-il/peval.scm
+++ b/module/language/tree-il/peval.scm
@@ -1251,13 +1251,19 @@ top-level bindings from ENV and return the resulting expression."
             (make-primcall src name args))))))
 
       (($ <primcall> src 'thunk? (proc))
-       (match (for-value proc)
-         (($ <lambda> _ _ ($ <lambda-case> _ req))
-          (for-tail (make-const src (null? req))))
-         (proc
-          (case ctx
-            ((effect) (make-void src))
-            (else (make-primcall src 'thunk? (list proc)))))))
+       (case ctx
+         ((effect)
+          (for-tail (make-seq src proc (make-void src))))
+         (else
+          (match (for-value proc)
+            (($ <lambda> _ _ ($ <lambda-case> _ req))
+             (for-tail (make-const src (null? req))))
+            (proc
+             (match (find-definition proc 2)
+               (($ <lambda> _ _ ($ <lambda-case> _ req))
+                (for-tail (make-const src (null? req))))
+               (_
+                (make-primcall src 'thunk? (list proc)))))))))
 
       (($ <primcall> src (? accessor-primitive? name) args)
        (match (cons name (map for-value args))
-- 
2.20.1