From c9efff30de4cf3faf1124e5e3b79d17f961f59e9 Mon Sep 17 00:00:00 2001
From: Andy Wingo <wingo@pobox.com>
Date: Wed, 27 Dec 2017 11:06:25 +0100
Subject: [PATCH] CPS conversion avoids residualizing unknown primcalls

* module/language/tree-il/compile-cps.scm: Avoid residualizing "apply"
  or "abort-to-prompt" primcalls; instead, these are just calls to
  $prim.
---
 module/language/tree-il/compile-cps.scm | 21 +++++++++++++++------
 1 file changed, 15 insertions(+), 6 deletions(-)

diff --git a/module/language/tree-il/compile-cps.scm b/module/language/tree-il/compile-cps.scm
index 843c9e395..e690a406c 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -864,13 +864,15 @@
                        (build-term ($continue kbody (tree-il-src body)
                                      ($prompt #f tag khargs))))))))
            (with-cps cps
-             (letv prim vals)
+             (letv prim vals apply)
              (let$ hbody (convert hbody k subst))
              (let$ hbody (box-bound-vars hnames hsyms hbody))
              (letk khbody ($kargs hnames bound-vars ,hbody))
              (letk khargs ($kreceive hreq hrest khbody))
+             (letk kapp ($kargs ('apply) (apply)
+                          ($continue k src ($call apply (prim vals)))))
              (letk kprim ($kargs ('prim) (prim)
-                           ($continue k src ($primcall 'apply #f (prim vals)))))
+                           ($continue kapp src ($prim 'apply))))
              (letk kret ($kargs () ()
                           ($continue kprim src ($prim 'values))))
              (letk kpop ($kargs ('rest) (vals)
@@ -883,17 +885,24 @@
      (convert-args cps (cons tag args)
        (lambda (cps args*)
          (with-cps cps
+           (letv abort)
+           (letk kabort ($kargs ('abort) (abort)
+                          ($continue k src ($call abort args*))))
            (build-term
-             ($continue k src ($primcall 'abort-to-prompt #f args*)))))))
+             ($continue kabort src ($prim 'abort-to-prompt)))))))
 
     (($ <abort> src tag args tail)
      (convert-args cps
-         (append (list (make-primitive-ref #f 'abort-to-prompt) tag)
+         (append (list (make-primitive-ref #f 'apply)
+                       (make-primitive-ref #f 'abort-to-prompt)
+                       tag)
                  args
                  (list tail))
        (lambda (cps args*)
-         (with-cps cps
-           (build-term ($continue k src ($primcall 'apply #f args*)))))))
+         (match args*
+           ((apply . apply-args)
+            (with-cps cps
+              (build-term ($continue k src ($call apply apply-args)))))))))
 
     (($ <conditional> src test consequent alternate)
      (define (convert-test cps test kt kf)