From: Taylor R Campbell <campbell@mumble.net>
Date: Fri, 25 Jan 2019 03:56:51 +0000 (+0000)
Subject: Add some basic compiler tests.
X-Git-Tag: mit-scheme-pucked-10.1.20~11^2~66^2~20
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=540dea32a046b816977129e772ad36473971437c;p=mit-scheme.git

Add some basic compiler tests.

For use when bringing up a compiler or back end that can't yet run
the normal test suite.
---

diff --git a/src/compiler/tests/README b/src/compiler/tests/README
new file mode 100644
index 000000000..7bf5c2960
--- /dev/null
+++ b/src/compiler/tests/README
@@ -0,0 +1,34 @@
+Compiler tests
+
+This directory contains rudimentary test programs for developing the
+compiler or a compiler back end.  Each one exercises some edge case,
+invokes only primitives or procedures that USUAL-INTEGRATIONS assumes
+to be defined to be primitives, and is therefore fit to run as a cold
+load with `scheme --fasl foo.com'.
+
+Except for empty.scm, datum.scm, declempty.scm, and decldatum.scm,
+these all print no output and return an exit status of 0 on success;
+the exceptions don't have any code in them and so don't call exit and
+so the microcode prints the return value.
+
+The script tests.sf sets up some macros for use by the tests:
+
+- (ucode-primitive <name>) expands to the microcode primitive <name>
+
+- (identity <x>) expands to an expression evaluating to <x> without
+  letting the compiler assume anything about <x>.
+
+  Currently, it creates a one-element vector with vector-cons holding x
+  and returns the first element with vector-ref; this will have to
+  change if we ever teach the compiler about vector-cons.
+
+- (prelude) expands to a definition of define-multiple, as used in code
+  generated by the compiler for multiple top-level definitions.
+
+Usage:
+
+1. Compile the tests.
+   % scheme --load tests.sf --load tests.cbf
+
+2. Run the tests.
+   % for t in *.com; do scheme --fasl $t || echo $t failed; done
diff --git a/src/compiler/tests/clogc.scm b/src/compiler/tests/clogc.scm
new file mode 100644
index 000000000..28392bbdd
--- /dev/null
+++ b/src/compiler/tests/clogc.scm
@@ -0,0 +1,8 @@
+; Test of creating a closure before GC and then using it after.
+
+(declare (usual-integrations))
+
+(let ((x (let ((y 5)) (identity (lambda () y)))))
+  ((ucode-primitive garbage-collect 1) #x1000)
+  ((ucode-primitive exit-with-value 1)
+   (fix:- (x) 5)))
diff --git a/src/compiler/tests/closure.scm b/src/compiler/tests/closure.scm
new file mode 100644
index 000000000..52f37d0ae
--- /dev/null
+++ b/src/compiler/tests/closure.scm
@@ -0,0 +1,7 @@
+; Trivial test to confirm closures work.
+
+(declare (usual-integrations))
+
+(let ((x (let ((y 5)) (identity (lambda () y)))))
+  ((ucode-primitive exit-with-value 1)
+   (fix:- (x) 5)))
diff --git a/src/compiler/tests/datum.scm b/src/compiler/tests/datum.scm
new file mode 100644
index 000000000..2088b6f6b
--- /dev/null
+++ b/src/compiler/tests/datum.scm
@@ -0,0 +1,3 @@
+; Pathological case: file contains only a datum.
+
+0
diff --git a/src/compiler/tests/decldatum.scm b/src/compiler/tests/decldatum.scm
new file mode 100644
index 000000000..75e8416f8
--- /dev/null
+++ b/src/compiler/tests/decldatum.scm
@@ -0,0 +1,5 @@
+; Pathological case: file contains only a declaration and a datum.
+
+(declare (usual-integrations))
+
+0
diff --git a/src/compiler/tests/declempty.scm b/src/compiler/tests/declempty.scm
new file mode 100644
index 000000000..929c0e716
--- /dev/null
+++ b/src/compiler/tests/declempty.scm
@@ -0,0 +1,3 @@
+; Pathological case: empty file except for declarations.
+
+(declare (usual-integrations))
diff --git a/src/compiler/tests/dlink-tail1.scm b/src/compiler/tests/dlink-tail1.scm
new file mode 100644
index 000000000..cc91905ee
--- /dev/null
+++ b/src/compiler/tests/dlink-tail1.scm
@@ -0,0 +1,27 @@
+; Test for INVOCATION-PREFIX:DYNAMIC-LINK with a small frame.
+
+(declare (usual-integrations))
+
+(let ()
+  (define (filter-map-if p f l)
+    (let loop ((l l))
+      (if (pair? l)
+	  (let ((x (car l)))
+	    (if (p x)
+		(let ((y (f x)))
+		  (if y
+		      (cons y (loop (cdr l)))
+		      (loop (cdr l))))
+		(loop (cdr l))))
+	  '())))
+  (let ((result
+	 ((identity filter-map-if)
+	  (lambda (x)
+	    (fix:zero? (fix:remainder x 2)))
+	  (lambda (x)
+	    (and (fix:zero? (fix:remainder x 3))
+		 (fix:quotient x 6)))
+	  '(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15))))
+    ((ucode-primitive exit-with-value 1)
+     (fix:or (fix:- (car result) 1)
+	     (fix:- (car (cdr result)) 2)))))
diff --git a/src/compiler/tests/dlink-tail8.scm b/src/compiler/tests/dlink-tail8.scm
new file mode 100644
index 000000000..feed1739e
--- /dev/null
+++ b/src/compiler/tests/dlink-tail8.scm
@@ -0,0 +1,31 @@
+; Test for INVOCATION-PREFIX:DYNAMIC-LINK with a large frame.
+
+(declare (usual-integrations))
+
+(let ()
+  (define (filter-map-if p f l on-tail)
+    (let loop
+	((l l) (a 0) (b 1) (c 2) (u 3) (v 4) (w 5) (n 6))
+      (if (pair? l)
+	  (let ((x (car l)))
+	    (if (p x)
+		(let ((y (f x)))
+		  (if y
+		      (cons y (loop (cdr l) b c u v w n a))
+		      (loop (cdr l) b c u v w n a)))
+		(loop (cdr l) b c u v w n a)))
+	  (on-tail '() a b c u v w n))))
+  (let ((result
+	 ((identity filter-map-if)
+	  (lambda (x)
+	    (fix:zero? (fix:remainder x 2)))
+	  (lambda (x)
+	    (and (fix:zero? (fix:remainder x 3))
+		 (fix:quotient x 6)))
+	  '(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15)
+	  (lambda (tail a b c u v w n)
+	    a b c u v w n
+	    tail))))
+    ((ucode-primitive exit-with-value 1)
+     (fix:or (fix:- (car result) 1)
+	     (fix:- (car (cdr result)) 2)))))
diff --git a/src/compiler/tests/dlink.scm b/src/compiler/tests/dlink.scm
new file mode 100644
index 000000000..a105b6277
--- /dev/null
+++ b/src/compiler/tests/dlink.scm
@@ -0,0 +1,18 @@
+; Test for dynamic links.
+;
+; The LOOP procedure doesn't statically know whether it has to pop L
+; off the stack, or only L1, when it returns, so it uses a dynamic
+; link, a pointer to the caller's stack frame.
+
+(declare (usual-integrations))
+
+(let ()
+  (declare (no-type-checks))
+  (define (list-copy l)
+    (let loop ((l1 l))
+      (if (pair? l1)
+	  (cons (car l1) (loop (cdr l1)))
+	  '())))
+  ((ucode-primitive exit-with-value 1)
+   (fix:- (car ((identity list-copy) '(42 123 456 789)))
+	  42)))
diff --git a/src/compiler/tests/dslink.scm b/src/compiler/tests/dslink.scm
new file mode 100644
index 000000000..170c1521b
--- /dev/null
+++ b/src/compiler/tests/dslink.scm
@@ -0,0 +1,19 @@
+; Test for static and dynamic links.
+;
+; The LOOP procedure doesn't statically know whether it has to pop F
+; and L off the stack, or only L1, when it returns, so it uses a
+; dynamic link -- a pointer to the parent stack frame.  It also doesn't
+; know where F was on the stack originally, so it passes around a
+; static link to its own stack environment to get at F.
+
+(declare (usual-integrations))
+
+(let ()
+  (define (map f l)
+    (let loop ((l1 l))
+      (if (pair? l1)
+	  (cons (f (car l1)) (loop (cdr l1)))
+	  '())))
+  ((ucode-primitive exit-with-value 1)
+   (fix:- (car ((identity map) (lambda (x) x) '(42 123 456 789)))
+	  42)))
diff --git a/src/compiler/tests/empty.scm b/src/compiler/tests/empty.scm
new file mode 100644
index 000000000..a003b0f4b
--- /dev/null
+++ b/src/compiler/tests/empty.scm
@@ -0,0 +1 @@
+; Pathological case: empty file.
diff --git a/src/compiler/tests/gc.scm b/src/compiler/tests/gc.scm
new file mode 100644
index 000000000..092a92e3d
--- /dev/null
+++ b/src/compiler/tests/gc.scm
@@ -0,0 +1,7 @@
+; Run the garbage collector once.
+
+(declare (usual-integrations))
+
+((ucode-primitive garbage-collect 1) #x1000)
+
+((ucode-primitive exit-with-value) 0)
diff --git a/src/compiler/tests/identity.scm b/src/compiler/tests/identity.scm
new file mode 100644
index 000000000..f47585290
--- /dev/null
+++ b/src/compiler/tests/identity.scm
@@ -0,0 +1,6 @@
+; Test to confirm that the identity hack and exiting work.
+
+(declare (usual-integrations))
+
+((identity (ucode-primitive exit-with-value 1))
+ (identity 0))
diff --git a/src/compiler/tests/link1.scm b/src/compiler/tests/link1.scm
new file mode 100644
index 000000000..f37bd8698
--- /dev/null
+++ b/src/compiler/tests/link1.scm
@@ -0,0 +1,7 @@
+(declare (usual-integrations))
+
+(prelude)
+
+(define x 0)
+
+((ucode-primitive exit-with-value 1) x)
diff --git a/src/compiler/tests/link2.scm b/src/compiler/tests/link2.scm
new file mode 100644
index 000000000..a637259d0
--- /dev/null
+++ b/src/compiler/tests/link2.scm
@@ -0,0 +1,10 @@
+(declare (usual-integrations))
+
+(prelude)
+
+(define x 0)
+
+(define (f) x)
+
+((ucode-primitive exit-with-value 1)
+ (f))
diff --git a/src/compiler/tests/link3.scm b/src/compiler/tests/link3.scm
new file mode 100644
index 000000000..f8757bd9c
--- /dev/null
+++ b/src/compiler/tests/link3.scm
@@ -0,0 +1,12 @@
+(declare (usual-integrations))
+
+(prelude)
+
+(define x 0)
+
+(define (f) x)
+
+(define (g) x)
+
+((ucode-primitive exit-with-value 1)
+ (fix:or (f) (g)))
diff --git a/src/compiler/tests/map-reduce.scm b/src/compiler/tests/map-reduce.scm
new file mode 100644
index 000000000..77e2fe626
--- /dev/null
+++ b/src/compiler/tests/map-reduce.scm
@@ -0,0 +1,15 @@
+; A vaguely nontrivial program involving a recursive procedure.
+
+(declare (usual-integrations))
+
+(let ()
+  (define (map-reduce kons f nil l)
+    (let g ((l l))
+      (if (pair? l)
+	  (kons (f (car l)) (g (cdr l)))
+	  nil)))
+  ((ucode-primitive exit-with-value 1)
+   (map-reduce (identity (lambda (x y) (fix:+ x y)))
+	       (identity (lambda (z) (fix:- 0 z)))
+	       0
+	       (identity '(1 -2 3 -4 2)))))
diff --git a/src/compiler/tests/mfu-dlink1.scm b/src/compiler/tests/mfu-dlink1.scm
new file mode 100644
index 000000000..9c6bd3a38
--- /dev/null
+++ b/src/compiler/tests/mfu-dlink1.scm
@@ -0,0 +1,18 @@
+; Test for INVOCATION-PREFIX:MOVE-FRAME-UP with dynamic link and small frame.
+;
+; The LOOP procedure doesn't statically know whether it must pop off
+; the arguments to COPY or only the argument to LOOP when it performs
+; tail calls to IF-PROPER or IF-IMPROPER.
+
+(declare (usual-integrations))
+
+(let ()
+  (define (copy list if-proper if-improper)
+    (let loop ((list list))
+      (cond ((pair? list) (cons (car list) (loop (cdr list))))
+	    ((null? list) (if-proper))
+	    (else (if-improper list)))))
+  ((identity copy)
+   (identity '(1 2 3 . 0))
+   (lambda () ((ucode-primitive exit-with-value 1) 1))
+   (ucode-primitive exit-with-value 1)))
diff --git a/src/compiler/tests/mfu-dlink8.scm b/src/compiler/tests/mfu-dlink8.scm
new file mode 100644
index 000000000..904fcb8c6
--- /dev/null
+++ b/src/compiler/tests/mfu-dlink8.scm
@@ -0,0 +1,23 @@
+; Test for INVOCATION-PREFIX:MOVE-FRAME-UP with dynamic link and large frame.
+;
+; The LOOP procedure doesn't statically know whether it must pop off
+; the arguments to COPY or only the argument to LOOP when it performs
+; tail calls to IF-PROPER or IF-IMPROPER.  When it calls IF-IMPROPER,
+; it creates a large frame and then moves it up to where the dynamic
+; link specified the parent started.
+
+(declare (usual-integrations))
+
+(let ()
+  (define (copy list if-proper if-improper)
+    (let loop ((list list))
+      (cond ((pair? list) (cons (car list) (loop (cdr list))))
+	    ((null? list) (if-proper))
+	    (else (if-improper list list list list list list list list)))))
+  ((identity copy)
+   (identity '(1 2 3 . 0))
+   (lambda () ((ucode-primitive exit-with-value 1) 0))
+   (lambda (a b c d e f g h)
+     ((ucode-primitive exit-with-value 1)
+      (fix:or (fix:or (fix:or a b) (fix:or c d))
+	      (fix:or (fix:or e f) (fix:or g h)))))))
diff --git a/src/compiler/tests/mfu-static.scm b/src/compiler/tests/mfu-static.scm
new file mode 100644
index 000000000..b0f0a2abe
--- /dev/null
+++ b/src/compiler/tests/mfu-static.scm
@@ -0,0 +1,24 @@
+; Test for INVOCATION-PREFIX:MOVE-FRAME-UP with a known parent.
+;
+; The LOOP procedure knows how much it has to pop when making a tail
+; call to itself; however, the stack frame it creates is so large that
+; the compiler chooses not to reuse the parent frame but instead use
+; INVOCATION-PREFIX:MOVE-FRAME-UP to replace it.
+
+(declare (usual-integrations))
+
+(let ()
+  (define (fib n x y z f)
+    (let loop
+	((a 0) (b 1)
+	 (x x) (y y) (z z) (p x) (q y) (r z) (u x) (v y) (w z)
+	 (i 0))
+      (if (< i n)
+	  (let ((p (f y z p))
+		(q (f z x q))
+		(r (f x y r)))
+	    (loop b (+ a b) u v w p q r x y z (+ i 1)))
+	  (cons b (vector x y z)))))
+  ((ucode-primitive exit-with-value 1)
+   (fix:- (car ((identity fib) 20 0 1 2 (lambda (a b c) b c a)))
+	  10946)))
diff --git a/src/compiler/tests/slink.scm b/src/compiler/tests/slink.scm
new file mode 100644
index 000000000..65fd2ffdb
--- /dev/null
+++ b/src/compiler/tests/slink.scm
@@ -0,0 +1,23 @@
+; Test for static links.
+;
+; The LOOP procedure doesn't know how far up the stack F will be, so
+; the generated code passes an extra stack environment pointer
+; `argument' on the stack.  The extra (let ((x ...)) x) frame obviates
+; the need for a dynamic link, because LOOP never has to pop MAP's
+; arguments off the stack -- only its own argument.
+
+(declare (usual-integrations))
+
+(let ()
+  (define (map f l)
+    (let ((x
+	   (let loop ((l1 l))
+	     (if (pair? l1)
+		 (cons (f (car l1)) (loop (cdr l1)))
+		 '()))))
+      x))
+  (let ((l ((identity map) (lambda (x) (fix:- 0 x)) '(1 2 3))))
+    ((ucode-primitive exit-with-value 1)
+     (fix:or (fix:+ (car l) 1)
+	     (fix:or (fix:+ (cadr l) 2)
+		     (fix:+ (caddr l) 3))))))
diff --git a/src/compiler/tests/tests.cbf b/src/compiler/tests/tests.cbf
new file mode 100644
index 000000000..09b915542
--- /dev/null
+++ b/src/compiler/tests/tests.cbf
@@ -0,0 +1,9 @@
+; -*- Mode: Scheme -*-
+
+(declare (usual-integrations))
+
+(fluid-let ((compiler:generate-rtl-files? #t)
+            (compiler:generate-lap-files? #t)
+            (compiler:generate-type-checks? #f)
+            (compiler:generate-range-checks? #f))
+  (compile-directory "."))
diff --git a/src/compiler/tests/tests.sf b/src/compiler/tests/tests.sf
new file mode 100644
index 000000000..fba6ffc02
--- /dev/null
+++ b/src/compiler/tests/tests.sf
@@ -0,0 +1,45 @@
+; -*- Mode: Scheme -*-
+
+(declare (usual-integrations))
+
+(let ((environment (make-top-level-environment)))
+  (eval '(begin
+           (define-syntax ucode-primitive
+             (sc-macro-transformer
+              (lambda (form environment)
+                environment
+                (apply make-primitive-procedure (cdr form)))))
+           (define-syntax identity
+             (sc-macro-transformer
+              (lambda (form environment)
+                `((UCODE-PRIMITIVE VECTOR-REF 2)
+                  ((UCODE-PRIMITIVE VECTOR-CONS 2)
+                   1
+                   ,(close-syntax (cadr form) environment))
+                  0))))
+           (define-syntax prelude
+             (sc-macro-transformer
+              (lambda (form environment)
+                '((ucode-primitive local-assignment)
+                  #f                    ;global environment
+                  'define-multiple
+                  (lambda (env names values)
+                    (if (or (not (vector? names))
+                            (not (vector? values))
+                            (not (fix:= (vector-length names)
+                                        (vector-length values))))
+                        (error "DEFINE-MULTIPLE: Invalid arguments"
+                               names
+                               values))
+                    (let ((len (vector-length names)))
+                      (let loop ((i 0) (val unspecific))
+                        (if (fix:< i len)
+                            (loop (fix:+ i 1)
+                                  ((ucode-primitive local-assignment)
+                                   env
+                                   (vector-ref names i)
+                                   (vector-ref values i)))
+                            val)))))))))
+        environment)
+  (fluid-let ((sf/default-syntax-table environment))
+    (sf-directory ".")))
diff --git a/src/compiler/tests/uuo.scm b/src/compiler/tests/uuo.scm
new file mode 100644
index 000000000..7503ce97f
--- /dev/null
+++ b/src/compiler/tests/uuo.scm
@@ -0,0 +1,15 @@
+; Test of uuo links.
+
+(declare (usual-integrations))
+
+(prelude)
+
+(define (f x)
+  (fix:* x 2))
+
+(define (g x)
+  (f (car (cdr x))))
+
+((ucode-primitive exit-with-value 1)
+ (fix:- (g (cons 1 (cons 2 '())))
+	4))
diff --git a/src/compiler/tests/uuoclo.scm b/src/compiler/tests/uuoclo.scm
new file mode 100644
index 000000000..269499669
--- /dev/null
+++ b/src/compiler/tests/uuoclo.scm
@@ -0,0 +1,19 @@
+; Test of uuo links with closure values.
+
+(declare (usual-integrations))
+
+(prelude)
+
+(define (f x)
+  (lambda (y)
+    (fix:* x y)))
+
+(define g
+  (f 5))
+
+(define (h x)
+  (g (car (cdr x))))
+
+((ucode-primitive exit-with-value 1)
+ (fix:- (h (cons 1 (cons 2 '())))
+	10))
diff --git a/src/compiler/tests/uuoclogc.scm b/src/compiler/tests/uuoclogc.scm
new file mode 100644
index 000000000..73cc544e9
--- /dev/null
+++ b/src/compiler/tests/uuoclogc.scm
@@ -0,0 +1,21 @@
+; Test of uuo links with closure values before/after GC.
+
+(declare (usual-integrations))
+
+(prelude)
+
+(define (f x)
+  (lambda (y)
+    (fix:* x y)))
+
+(define g
+  (f 5))
+
+(define (h x)
+  (g (car (cdr x))))
+
+(let ((x ((f 3) 5)))
+  ((ucode-primitive garbage-collect 1) #x1000)
+  ((ucode-primitive exit-with-value 1)
+   (fix:- (h (cons 1 (cons 3 '())))
+	  x)))
diff --git a/src/compiler/tests/uuogc.scm b/src/compiler/tests/uuogc.scm
new file mode 100644
index 000000000..be8179825
--- /dev/null
+++ b/src/compiler/tests/uuogc.scm
@@ -0,0 +1,17 @@
+; Test of uuo links, before/after garbage collection.
+
+(declare (usual-integrations))
+
+(prelude)
+
+(define (f x)
+  (fix:* x 2))
+
+(define (g x)
+  (f (car (cdr x))))
+
+(let ((x (f 2)))
+  ((ucode-primitive garbage-collect 1) #x1000)
+  ((ucode-primitive exit-with-value 1)
+   (fix:- (g (cons 1 (cons 2 '())))
+	  x)))