From fb2f7b4e5fc50c3cf42d4d4906060bd99d56cb05 Mon Sep 17 00:00:00 2001
From: Andy Wingo <wingo@pobox.com>
Date: Sun, 3 Jan 2016 18:18:51 +0100
Subject: [PATCH] Better CPS conversion for tests in tests

* module/language/tree-il/compile-cps.scm (convert): Tests in tests have
  their consequents and alternates also converted in test context.
---
 module/language/tree-il/compile-cps.scm | 11 +++++++++--
 1 file changed, 9 insertions(+), 2 deletions(-)

diff --git a/module/language/tree-il/compile-cps.scm b/module/language/tree-il/compile-cps.scm
index 5fa60109a..419cb336b 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -773,7 +773,7 @@
            (build-term ($continue k src ($primcall 'apply args*)))))))
 
     (($ <conditional> src test consequent alternate)
-     (define (convert-test cps kt kf)
+     (define (convert-test cps test kt kf)
        (match test
          (($ <primcall> src (? branching-primitive? name) args)
           (convert-args cps args
@@ -781,6 +781,13 @@
               (with-cps cps
                 (build-term ($continue kf src
                               ($branch kt ($primcall name args))))))))
+         (($ <conditional> src test consequent alternate)
+          (with-cps cps
+            (let$ t (convert-test consequent kt kf))
+            (let$ f (convert-test alternate kt kf))
+            (letk kt* ($kargs () () ,t))
+            (letk kf* ($kargs () () ,f))
+            ($ (convert-test test kt* kf*))))
          (_ (convert-arg cps test
               (lambda (cps test)
                 (with-cps cps
@@ -791,7 +798,7 @@
        (let$ f (convert alternate k subst))
        (letk kt ($kargs () () ,t))
        (letk kf ($kargs () () ,f))
-       ($ (convert-test kt kf))))
+       ($ (convert-test test kt kf))))
 
     (($ <lexical-set> src name gensym exp)
      (convert-arg cps exp