From fed28363fb60266c030a0f6b30d5a9d697774ee0 Mon Sep 17 00:00:00 2001
From: Rose Hogenson <rhogenson@posteo.net>
Date: Tue, 28 Jun 2022 15:58:36 -0700
Subject: Improve CPS.

Goodbye soup. Thanks to "Compiling with Continuations" by Appel.
---
 csc/cps-test.csc | 242 ++++++++++++++++++++++++-------------------------------
 1 file changed, 107 insertions(+), 135 deletions(-)

(limited to 'csc/cps-test.csc')

diff --git a/csc/cps-test.csc b/csc/cps-test.csc
index d51d10c..d3cfb6d 100644
--- a/csc/cps-test.csc
+++ b/csc/cps-test.csc
@@ -1,13 +1,10 @@
 (import (scheme base)
-        (only (csc hash-map)
-          map->alist)
         (only (csc ir1)
           make-call
           make-constant
           make-define-syntax
           make-if
           make-lambda
-          make-lambda-case
           make-letrec
           make-lexical-ref
           make-lexical-set
@@ -15,6 +12,8 @@
           make-sequence)
         (only (csc ir2)
           ir2=?
+          make-apply
+          make-fix
           make-atom
           make-branch
           make-call-closure
@@ -22,170 +21,143 @@
           make-kargs
           make-klabel
           make-ktail
-          make-lambda-args
           make-update)
-        (only (csc loop)
-          loop
-          return)
-        (only (csc sort) sort)
         (only (csc testing)
           assert-equal
           test)
         (csc cps))
 
 
-(define (soup->alist s)
-  (sort (lambda (x y) (< (car x) (car y))) (map->alist s)))
-
-
-(define (soup=? x y)
-  (and (= (length x) (length y))
-       (loop for x* in x
-             for y* in y
-             unless (and (= (car x*) (car y*))
-                         (ir2=? (cdr x*) (cdr y*)))
-               return #f
-             finally (return #t))))
+(define (tail x)
+  (make-apply (make-lexical-ref 'tail #f) (list x)))
 
 
 (test atom-const
-  (assert-equal soup=?
-    (list
-      (cons 0 (make-klabel
-                (make-atom (make-constant 5) 1)))
-      (cons 1 (make-ktail)))
-    (soup->alist (ir1->ir2 (make-constant 5)))))
+  (assert-equal ir2=?
+    (make-apply (make-lexical-ref 'tail #f) (list (make-constant 5)))
+    (ir1->ir2 (make-constant 5) tail)))
 
 
 (test atom-lexical-ref
-  (assert-equal soup=?
-    (list
-      (cons 0 (make-klabel
-                (make-atom (make-lexical-ref 'var #f) 1)))
-      (cons 1 (make-ktail)))
-    (soup->alist (ir1->ir2 (make-lexical-ref 'var #f)))))
+  (assert-equal ir2=?
+    (make-apply (make-lexical-ref 'tail #f) (list (make-lexical-ref 'var #f)))
+    (ir1->ir2 (make-lexical-ref 'var #f) tail)))
 
 
 (test atom-library-ref
-  (assert-equal soup=?
-    (list
-      (cons 0 (make-klabel
-                (make-atom (make-library-ref 'var '(csc builtins)) 1)))
-      (cons 1 (make-ktail)))
-    (soup->alist (ir1->ir2 (make-library-ref 'var '(csc builtins))))))
+  (assert-equal ir2=?
+    (make-apply (make-lexical-ref 'tail #f)
+      (list (make-library-ref 'var '(csc builtins))))
+    (ir1->ir2 (make-library-ref 'var '(csc builtins)) tail)))
 
 
 (test lexical-set
-  (assert-equal soup=?
-    (list
-      (cons 0 (make-klabel
-                (make-atom (make-constant 5) 2)))
-      (cons 1 (make-ktail))
-      (cons 2 (make-kargs (list (make-lexical-ref 'generated-symbol #f))
-                (make-update (make-lexical-ref 'var #f)
-                             (make-lexical-ref 'generated-symbol #f) 1))))
-    (soup->alist (ir1->ir2 (make-lexical-set (make-lexical-ref 'var #f) (make-constant 5))))))
+  (assert-equal ir2=?
+    (make-update (make-lexical-ref 'var #f) (make-constant 5)
+                 (make-apply (make-lexical-ref 'tail #f) (list (make-constant #f))))
+    (ir1->ir2 (make-lexical-set (make-lexical-ref 'var #f) (make-constant 5))
+              tail)))
 
 
 (test no-op-define-syntax
-  (assert-equal soup=?
-    (list
-      (cons 0 (make-klabel (make-atom (make-constant #f) 1)))
-      (cons 1 (make-ktail)))
-    (soup->alist (ir1->ir2 (make-define-syntax 'name '(transformer))))))
+  (assert-equal ir2=?
+    (make-apply (make-lexical-ref 'tail #f) (list (make-constant #f)))
+    (ir1->ir2 (make-define-syntax 'name '(transformer))
+              tail)))
 
 
 (test branch
-  (assert-equal soup=?
-    (list
-      (cons 0 (make-klabel (make-atom (make-constant #t) 4)))
-      (cons 1 (make-ktail))
-      (cons 2 (make-klabel (make-atom (make-constant 1) 1)))
-      (cons 3 (make-klabel (make-atom (make-constant 2) 1)))
-      (cons 4 (make-kargs (list (make-lexical-ref 'generated-symbol #f))
-                (make-branch (make-lexical-ref 'generated-symbol #f)
-                  2 3))))
-    (soup->alist (ir1->ir2 (make-if (make-constant #t)
-                             (make-constant 1)
-                             (make-constant 2))))))
+  (assert-equal ir2=?
+    (make-fix
+      (list
+        (make-closure (make-lexical-ref 'generated-symbol #f) (list (make-lexical-ref 'generated-symbol #f)) #f
+          (make-apply (make-lexical-ref 'tail #f) (list (make-lexical-ref 'generated-symbol #f)))))
+      (make-branch (make-constant #t)
+        (make-apply (make-lexical-ref 'generated-symbol #f) (list (make-constant 1)))
+        (make-apply (make-lexical-ref 'generated-symbol #f) (list (make-constant 2)))))
+    (ir1->ir2 (make-if (make-constant #t)
+                (make-constant 1)
+                (make-constant 2))
+              tail)))
 
 
 (test call-closure
-  (assert-equal soup=?
-    (list
-      (cons 0 (make-klabel (make-atom (make-lexical-ref 'f #f) 4)))
-      (cons 1 (make-ktail))
-      (cons 2 (make-kargs (list (make-lexical-ref 'generated-symbol #f))
-                (make-call-closure (make-lexical-ref 'generated-symbol #f)
-                  (list (make-lexical-ref 'generated-symbol #f)
-                        (make-lexical-ref 'generated-symbol #f))
-                  1)))
-      (cons 3 (make-kargs (list (make-lexical-ref 'generated-symbol #f))
-                (make-atom (make-constant 2) 2)))
-      (cons 4 (make-kargs (list (make-lexical-ref 'generated-symbol #f))
-                (make-atom (make-constant 1) 3))))
-    (soup->alist (ir1->ir2 (make-call (make-lexical-ref 'f #f) (list (make-constant 1) (make-constant 2)))))))
+  (assert-equal ir2=?
+    (make-fix
+      (list
+        (make-closure (make-lexical-ref 'generated-symbol #f) (list (make-lexical-ref 'generated-symbol #f)) #f
+          (make-apply (make-lexical-ref 'tail #f) (list (make-lexical-ref 'generated-symbol #f)))))
+      (make-apply (make-lexical-ref 'f #f) (list (make-lexical-ref 'generated-symbol #f)
+                                                 (make-constant 1)
+                                                 (make-constant 2))))
+    (ir1->ir2 (make-call (make-lexical-ref 'f #f) (list (make-constant 1) (make-constant 2)))
+              tail)))
 
 
 (test sequence
-  (assert-equal soup=?
-    (list
-      (cons 0 (make-klabel (make-atom (make-constant 1) 2)))
-      (cons 1 (make-ktail))
-      (cons 2 (make-klabel (make-atom (make-constant 2) 1))))
-    (soup->alist (ir1->ir2 (make-sequence (make-constant 1)
-                                          (make-constant 2))))))
+  (assert-equal ir2=?
+    (make-update (make-lexical-ref 'a #f) (make-constant 5)
+      (make-update (make-lexical-ref 'b #f) (make-constant 6)
+        (make-apply (make-lexical-ref 'tail #f) (list (make-constant #f)))))
+    (ir1->ir2 (make-sequence (make-lexical-set (make-lexical-ref 'a #f) (make-constant 5))
+                             (make-lexical-set (make-lexical-ref 'b #f) (make-constant 6)))
+              tail)))
 
 
 (test closure
-  (assert-equal soup=?
-    (list
-      (cons 0 (make-klabel
-                (make-closure
-                  (list (make-lambda-args 2 #t 3))
-                  1)))
-      (cons 1 (make-ktail))
-      (cons 2 (make-ktail))
-      (cons 3 (make-kargs (list (make-lexical-ref 'a #f)
-                                (make-lexical-ref 'b #f)
-                                (make-lexical-ref 'c #f))
-                (make-atom (make-constant 5) 2))))
-    (soup->alist (ir1->ir2 (make-lambda
-                             (make-lambda-case
-                               '(a b)
-                               'c
-                               '(#f #f #f)
-                               (make-constant 5)
-                               #f))))))
-
-
-(test letrec-to-lambda
-  (assert-equal soup=?
-    (list
-      ; God help you when it's time to debug this test.
-      (cons 0 (make-klabel
-                (make-closure
+  (assert-equal ir2=?
+    (make-fix
+      (list
+        (make-closure (make-lexical-ref 'generated-symbol #f)
+                      (list (make-lexical-ref 'generated-symbol #f)
+                            (make-lexical-ref 'a #f)
+                            (make-lexical-ref 'b #f))
+                      (make-lexical-ref 'c #f)
+          (make-apply (make-lexical-ref 'generated-symbol #f) (list (make-constant 5)))))
+      (make-apply (make-lexical-ref 'tail #f) (list (make-lexical-ref 'generated-symbol #f))))
+    (ir1->ir2 (make-lambda
+                (list (make-lexical-ref 'a #f) (make-lexical-ref 'b #f))
+                (make-lexical-ref 'c #f)
+                (make-constant 5))
+              tail)))
+
+
+(test letrec-in-order
+  (assert-equal ir2=?
+    (make-fix
+      (list
+        (make-closure (make-lexical-ref 'f #f) (list (make-lexical-ref 'generated-symbol #f)
+                                                     (make-lexical-ref 'x #f)) #f
+          (make-apply (make-lexical-ref 'generated-symbol #f) (list (make-constant 5)))))
+      (make-fix
+        (list
+          (make-closure (make-lexical-ref 'generated-symbol #f) (list (make-lexical-ref 'generated-symbol #f)) #f
+            (make-apply (make-lexical-ref 'tail #f) (list (make-lexical-ref 'generated-symbol #f)))))
+        (make-fix
+          (list
+            (make-closure (make-lexical-ref 'generated-symbol #f) (list (make-lexical-ref 'generated-symbol #f)
+                                                                        (make-lexical-ref 'a #f)) #f
+              (make-fix
+                (list
+                  (make-closure (make-lexical-ref 'generated-symbol #f) (list (make-lexical-ref 'generated-symbol #f)) #f
+                    (make-apply (make-lexical-ref 'generated-symbol #f) (list (make-lexical-ref 'generated-symbol #f)))))
+                (make-fix
                   (list
-                    (make-lambda-args 1 #f 7))
-                  3)))
-      (cons 1 (make-ktail))
-      (cons 2 (make-kargs (list (make-lexical-ref 'generated-symbol #f))
-                (make-call-closure
-                  (make-lexical-ref 'generated-symbol #f)
-                  (list (make-lexical-ref 'generated-symbol #f))
-                  1)))
-      (cons 3 (make-kargs (list (make-lexical-ref 'generated-symbol #f))
-                (make-atom (make-constant #f) 2)))
-      (cons 4 (make-ktail))
-      (cons 5 (make-klabel
-                (make-atom (make-constant 2) 4)))
-      (cons 6 (make-kargs (list (make-lexical-ref 'generated-symbol #f))
-                (make-update (make-lexical-ref 'a #f) (make-lexical-ref 'generated-symbol #f) 5)))
-      (cons 7 (make-kargs (list (make-lexical-ref 'a #f))
-                 (make-atom (make-constant 1) 6))))
-    (soup->alist (ir1->ir2 (make-letrec
-                             #t
-                             '(a)
-                             '(#f)
-                             (list (make-constant 1))
-                             (make-constant 2))))))
+                    (make-closure (make-lexical-ref 'generated-symbol #f) (list (make-lexical-ref 'generated-symbol #f)
+                                                                                (make-lexical-ref 'b #f)) #f
+                      (make-apply (make-lexical-ref 'generated-symbol #f) (list (make-constant 10)))))
+                  (make-apply (make-lexical-ref 'generated-symbol #f)
+                              (list (make-lexical-ref 'generated-symbol #f)
+                                    (make-constant 2)))))))
+          (make-apply (make-lexical-ref 'generated-symbol #f)
+                      (list (make-lexical-ref 'generated-symbol #f)
+                            (make-constant 1))))))
+    (ir1->ir2 (make-letrec
+                #t
+                '(a f b)
+                '(#f #f #f)
+                (list (make-constant 1)
+                      (make-lambda (list (make-lexical-ref 'x #f)) #f (make-constant 5))
+                      (make-constant 2))
+                (make-constant 10))
+              tail)))
-- 
cgit v1.3.1