Test cps->rtlwip-rtl-cps

* module/language/cps/compile-rtl.scm: bugfixes.
* module/language/cps/primitives: a new table for primitive properties,
  used to represent variable arities.
* module/language/cps/util.scm: add `maybe-append'.
* test-suite/tests/compile-rtl.test: tests for compile-rtl.

4 files changed, 197 insertions, 147 deletions

diff --git a/module/language/cps/compile-rtl.scm b/module/language/cps/compile-rtl.scm
index a9d8192bb..be0edb0f2 100644
--- a/module/language/cps/compile-rtl.scm
+++ b/module/language/cps/compile-rtl.scm
@@ -12,7 +12,8 @@
   #:use-module (language tree-il compile-cps)
   #:use-module (system vm assembler)
   #:export (cps->rtl generate-rtl cps-compile
-                     calculate-free-values cps-eval))
+                     calculate-free-values cps-eval
+                     generate-primitive-call))
 
 ;; currently, the only way we have to run RTL code is to package it up
 ;; into a program and call that program. Therefore, all code that we
@@ -139,119 +140,124 @@
 
   free-vals)
 
-;; generate-rtl compiles a CPS form to RTL.
-(define (generate-rtl cps name-defn register call-frame-start
-                      rest-args-start nlocals label next-label!)
-  ;; generate-primitive-call: generate a call to primitive prim with the
-  ;; given args, placing the result in register(s) dsts. rest is either
-  ;; #f or the location of the rest arguments of the destination
-  ;; continuation (if it has rest arguments). This is its own function
-  ;; because it is called twice in visit - once in the tail case and
-  ;; once in the non-tail case.
-  (define (generate-primitive-call dsts rest prim args)
-    ;; some of the primitives have special handling. this probably
-    ;; points to a bad abstraction, but I don't know where yet. the
-    ;; distinction is whether the primitives require information that is
-    ;; part of the CPS or not. A "regular" primitive takes Scheme values
-    ;; from registers and returns Scheme values to registers. These
-    ;; primitives are handled in the primitive instruction tables in
-    ;; (language cps primitives). However, other primitives are
-    ;; different, in different ways:
+;; the next few functions define special cases for certain VM
+;; instructions. it's usually because they need special arguments.
 
-    ;; ref and set need to know if they're handling a module variable or
-    ;; not. The most elegant thing from the CPS point of view is to
-    ;; forget about the module-ref and module-set VM instructions and
-    ;; just use resolve for everything, but that might be slow until we
-    ;; have a tiling code generator.
+;; ref and set need to know if they're handling a module variable or
+;; not. The most elegant thing from the CPS point of view is to forget
+;; about the module-ref and module-set VM instructions and just use
+;; resolve for everything, but that might be slow until we have a tiling
+;; code generator.
+(define (generate-ref dst args name-defn register)
+  (let* ((var-value (car args))
+         ;; var-value is the value holding the variable object, var is
+         ;; the actual variable object
+         (var (name-defn var-value)))
+    (if (module-var? var)
+        ;; the scope is 'foo because we don't meaningfully
+        ;; distinguish scopes yet.
+        (if (eq? (module-var-module var) 'toplevel)
+            ;; we should really just cache the current module
+            ;; once per procedure.
+            `((cache-current-module! ,dst foo)
+              (cached-toplevel-ref ,dst foo
+                                   ,(module-var-name var)))
+            `((cached-module-ref ,dst
+                                 ,(module-var-module var)
+                                 ,(module-var-public? var)
+                                 ,(module-var-name var))))
+        `((box-ref ,dst ,(register var-value))))))
 
-    ;; closure-ref needs to know the value of its argument at compile
-    ;; time, so it has to look that up in the name-defn table.
+(define (generate-set dst args name-defn register)
+  (let* ((var-value (car args))
+         (new-value (cadr args))
+         (var (name-defn var-value)))
+    (if (module-var? var)
+        (if (eq? (module-var-module var) 'toplevel)
+            `((cache-current-module! ,dst foo)
+              (cached-toplevel-set! ,(register new-value) foo
+                                    ,(module-var-name var))
+              (mov ,dst ,(register new-value)))
+            `((cached-module-set! ,(register new-value)
+                                  ,(module-var-module var)
+                                  ,(module-var-public? var)
+                                  ,(module-var-name var))
+              (mov ,dst ,(register new-value))))
+        `((box-set!
+           ,(register var-value)
+           ,(register new-value))
+          (mov ,dst ,(register new-value))))))
 
-    ;; make-closure's first argument is a label, not a register.
+;; closure-ref needs to know the value of its argument at compile time,
+;; so it has to look that up in the name-defn table.
+(define (generate-closure-ref dst args name-defn)
+  (let ((defn (name-defn (car args))))
+    (when (not (const? defn))
+      (error
+       "closure-ref must be called with a constant argument"))
+    `((free-ref
+       ,dst
+       ,(const-value defn)))))
 
-    ;; in the future, things like prompt and dynwind will take arguments
-    ;; that are lambdas in Scheme, but are actually continuations in CPS
-    ;; world, so they'll have to know how to turn them into
-    ;; continuations.
+;; make-closure's first argument is a label, not a register.
+(define (generate-make-closure dst args label register)
+  (let ((func (car args))
+        (vals (cdr args)))
+    `((make-closure
+       ,dst
+       ,(label func)
+       ,(map register vals)))))
 
-    (case prim
-      ((ref) (let* ((var-value (car args))
-                    ;; var-value is the value holding the variable
-                    ;; object
-                    (var (name-defn var-value))
-                    ;; var is the actual variable object
-                    (dst (if (pair? dsts)
-                             (car dsts)
-                             rest)))
-               (if (module-var? var)
-                   ;; the scope is 'foo because we don't meaningfully
-                   ;; distinguish scopes yet.
-                   (if (eq? (module-var-module var) 'toplevel)
-                       ;; we should really just cache the current module
-                       ;; once per procedure.
-                       `((cache-current-module! ,dst foo)
-                         (cached-toplevel-ref ,dst foo
-                                              ,(module-var-name var)))
-                       `((cached-module-ref ,dst
-                                            ,(module-var-module var)
-                                            ,(module-var-public? var)
-                                            ,(module-var-name var))))
-                   `((box-ref ,dst ,(register var-value))))))
-      ((set) (let* ((var-value (car args))
-                    (new-value (cadr args))
-                    (var (name-defn var-value))
-                    (dst (if (pair? dsts)
-                             (car dsts)
-                             rest)))
-               (if (module-var? var)
-                   (if (eq? (module-var-module var) 'toplevel)
-                       `((cache-current-module! ,dst foo)
-                         (cached-toplevel-set! ,(register new-value) foo
-                                               ,(module-var-name var))
-                         (mov ,dst ,(register new-value)))
-                       `((cached-module-set! ,(register new-value)
-                                             ,(module-var-module var)
-                                             ,(module-var-public? var)
-                                             ,(module-var-name var))
-                         (mov ,dst ,(register new-value))))
-                   `((box-set!
-                      ,(register var-value)
-                      ,(register new-value))
-                     (mov ,dst ,(register new-value))))))
+;; generate-primitive-call: generate a call to primitive prim with the
+;; given args, placing the result in register(s) dsts. rest is either
+;; #f or the location of the rest arguments of the destination
+;; continuation (if it has rest arguments).
+(define (generate-primitive-call dsts rest prim args
+                                 name-defn label register)
+  (define (has-prop? primitive prop)
+    (memq prop (hashq-ref *primitive-props-table* primitive)))
 
-      ((closure-ref) (let* ((dst (if (pair? dsts)
-                                     (car dsts)
-                                     rest))
-                            (defn (name-defn (car args))))
-                       (when (not (const? defn))
-                         (error
-                          "closure-ref must be called with a constant argument"))
-                       `((free-ref
-                          ,dst
-                          ,(const-value defn)))))
+  ;; TO DO: let primitives indicate the type of their arguments, with
+  ;; options 'register and 'label, and maybe more. That would let us
+  ;; remove the special handling for some of them, and implement things
+  ;; like prompt and dynwind.
 
-      ((make-closure) (let ((dst (if (pair? dsts)
-                                     (car dsts)
-                                     rest))
-                            (func (car args))
-                            (vals (cdr args)))
-                        `((make-closure
-                           ,dst
-                           ,(label func)
-                           ,(map register vals)))))
-      (else
-       (let ((insn (hashq-ref *primitive-insn-table* prim))
-             (in-arity (hashq-ref *primitive-in-arity-table* prim))
-             (out-arity (hashq-ref *primitive-out-arity-table* prim))
-             (dst (if (pair? dsts)
-                      (car dsts)
-                      rest)))
-         (if (and insn
-                  (= in-arity (length args))
-                  (= out-arity 1)) ;; we don't support n-ary outputs yet
-             `((,insn ,dst ,@(map register args)))
-             (error "malformed primitive call" (cons prim args)))))))
-  
+  (catch 'bad-primitive
+    (lambda () 
+      (let ((dst (if (pair? dsts) (car dsts) rest)))
+        ;; if out-arity is 0, dst will be junk, but it shouldn't error.
+        (case prim
+          ((ref) (generate-ref dst args name-defn register))
+          ((set) (generate-set dst args name-defn register))
+          ((closure-ref) (generate-closure-ref dst args name-defn))
+          ((make-closure) (generate-make-closure dst args label register))
+          (else
+           (let ((insn (hashq-ref *primitive-insn-table* prim))
+                 (in-arity (hashq-ref *primitive-in-arity-table* prim))
+                 (out-arity (hashq-ref *primitive-out-arity-table* prim)))
+             (unless insn
+               (throw 'bad-primitive))
+             (unless (or (has-prop? prim 'variable)
+                         (= in-arity (length args)))
+               (throw 'bad-primitive))
+
+             (let ((fix-args (list-head args in-arity))
+                   (var-args (list-tail args in-arity)))
+               (list
+                (maybe-append
+                 (list insn)
+                 (and (= out-arity 1)
+                      (list dst))
+                 (map register fix-args)
+                 (and (has-prop? prim 'variable)
+                      (list (map register var-args)))))))))))
+    (lambda (key)
+      (error "malformed primitive call" (cons prim args)))))
+
+
+;; generate-rtl compiles a CPS form to RTL.
+(define (generate-rtl cps name-defn register call-frame-start
+                      rest-args-start nlocals label next-label!)
   (define (visit cps)
     ;; cps is either a let expression or a call
     (match cps
@@ -276,7 +282,8 @@
        (let ((return-reg
               (+ 1 (apply max (map register args)))))
          `(,@(generate-primitive-call
-              (list return-reg) #f (primitive-name proc) args)
+              (list return-reg) #f (primitive-name proc) args
+              name-defn label register)
            (return ,return-reg))))
 
        (($ <call> proc 'return args)
@@ -317,7 +324,8 @@
                (perm-label (next-label!)))
           (if (primitive? proc)
               `(,@(generate-primitive-call
-                   dsts rest (primitive-name proc) args)
+                   dsts rest (primitive-name proc) args
+                   name-defn label register)
                 (br ,(label cont)))
               `((call ,(call-frame-start cps) ,(register proc)
                       ,(map register args))
diff --git a/module/language/cps/primitives.scm b/module/language/cps/primitives.scm
index 7a93138c8..5a1176e5f 100644
--- a/module/language/cps/primitives.scm
+++ b/module/language/cps/primitives.scm
@@ -1,43 +1,44 @@
 (define-module (language cps primitives)
   #:export (*primitive-insn-table*
             *primitive-in-arity-table*
-            *primitive-out-arity-table*))
+            *primitive-out-arity-table*
+            *primitive-props-table*))
 
-;; the "primitives" in this file are the operations which are supported
-;; by VM opcodes. Each primitive has more than one name - there is its
-;; name in the (guile) module, its name in a <primitive> record (which
-;; is always the same as its name in (guile), for simplicity) and its
-;; name as a VM instruction, which may be different from the first two.
-
-;; this list holds information about the primitive VM operations. The
-;; current fields are (Scheme name, VM name, in-arity). We don't handle
-;; folds, reductions, or variable-arity instructions yet.
 (define *primitive-insn-data*
-  '((string-length string-length 1)
-    (string-ref string-ref 2)
-    (string->number string->number 1)
-    (string->symbol string->symbol 1)
-    (symbol->keyword symbol->keyword 1)
-    (cons cons 2)
-    (car car 1)
-    (cdr cdr 1)
-    (+ add 2)
-    (1+ add1 1)
-    (- sub 2)
-    (1- sub1 1)
-    (* mul 2)
-    (/ div 2)
+  ;; fields:
+  ;; (Scheme name, VM name, in arity, out arity, props ...)
+
+  ;; "Scheme name" is what will appear in CPS <primitive> records, and
+  ;; also the corresponding procedure's name in the (guile) module if it
+  ;; has one. "out arity" must be 0 or 1. "in arity" is the minimum in
+  ;; arity. if the primitive accepts more than that, it should have the
+  ;; "variable" property.
+  '((string-length string-length 1 1)
+    (string-ref string-ref 2 1)
+    (string->number string->number 1 1)
+    (string->symbol string->symbol 1 1)
+    (symbol->keyword symbol->keyword 1 1)
+    (cons cons 2 1)
+    (car car 1 1)
+    (cdr cdr 1 1)
+    (+ add 2 1)
+    (1+ add1 1 1)
+    (- sub 2 1)
+    (1- sub1 1 1)
+    (* mul 2 1)
+    (/ div 2 1)
     ;; quo isn't here because I don't know which of our many types of
     ;; division it's supposed to be. same for rem and mod.
-    (ash ash 2)
-    (logand logand 2)
-    (logior logior 2)
-    (logxor logxor 2)
-    (vector-length vector-length 1)
-    (vector-ref vector-ref 2)
-    (struct-vtable struct-vtable 1)
-    (struct-ref struct-ref 2)
-    (class-of class-of 1)))
+    (ash ash 2 1)
+    (logand logand 2 1)
+    (logior logior 2 1)
+    (logxor logxor 2 1)
+    (vector-length vector-length 1 1)
+    (vector-ref vector-ref 2 1)
+    (struct-vtable struct-vtable 1 1)
+    (struct-ref struct-ref 2 1)
+    (class-of class-of 1 1)
+    (fix-closure fix-closure 1 0 variable)))
 
 ;; this table maps our names for primitives (which are the Scheme names)
 ;; to the corresponding VM instructions. It also does double duty as the
@@ -54,11 +55,12 @@
 ;; this table holds the number of inputs each primitive function takes
 (define *primitive-in-arity-table* (make-hash-table))
 
-;; and this one holds the number of outputs. this will always be 1 right
-;; now, but there are cases where that won't be true - for instance,
-;; divmod.
+;; and this one holds the number of outputs.
 (define *primitive-out-arity-table* (make-hash-table))
 
+;; this is for miscellaneous properties
+(define *primitive-props-table* (make-hash-table))
+
 (define (fill-insn-tables!)
   (for-each
    (lambda (entry)
@@ -67,7 +69,9 @@
      (hashq-set! *primitive-in-arity-table*
                  (car entry) (caddr entry))
      (hashq-set! *primitive-out-arity-table*
-                 (car entry) 1))
+                 (car entry) (cadddr entry))
+     (hashq-set! *primitive-props-table*
+                 (car entry) (cddddr entry)))
    *primitive-insn-data*))
 
 (fill-insn-tables!)
diff --git a/module/language/cps/util.scm b/module/language/cps/util.scm
index 8fa6591b3..a5de59341 100644
--- a/module/language/cps/util.scm
+++ b/module/language/cps/util.scm
@@ -1,7 +1,7 @@
 (define-module (language cps util)
   #:use-module (ice-9 q)
   #:use-module (srfi srfi-1)
-  #:export (append-qs! int-range generate-shuffle))
+  #:export (append-qs! int-range maybe-append generate-shuffle))
 
 ;; The functions in this file are not directly related to CPS or
 ;; compilation; they're here because the CPS compiler needs them and
@@ -19,6 +19,15 @@
       (cons start (int-range (+ start 1) end))
       '()))
 
+;; this is a totally generic utility
+(define (maybe-append . args)
+  (cond ((null? args) '())
+        ((eq? (car args) #f)
+         (apply maybe-append (cdr args)))
+        (else
+         (append (car args)
+                 (apply maybe-append (cdr args))))))
+
 ;; this function returns a list of `mov' instructions that accomplish a
 ;; shuffle in the stack. each tail argument is a pair (from . to) that
 ;; indicates how a value should move. the first argument is the number
diff --git a/test-suite/tests/compile-rtl.test b/test-suite/tests/compile-rtl.test
new file mode 100644
index 000000000..51fda7d64
--- /dev/null
+++ b/test-suite/tests/compile-rtl.test
@@ -0,0 +1,29 @@
+(use-modules
+ (test-suite lib)
+ (language cps)
+ (language cps compile-rtl))
+
+(with-test-prefix "generate-primitive-call"
+  (pass-if-equal "arity: 1 -> 1"
+    '((string-length 1 0))
+    (let ((regs (make-object-property)))
+      (set! (regs 'a) 0)
+      (generate-primitive-call '(1) #f 'string-length '(a)
+                               #f #f regs)))
+
+  (pass-if-equal "arity: 2 -> 1"
+    '((cons 2 0 1))
+    (let ((regs (make-object-property)))
+      (set! (regs 'a) 0)
+      (set! (regs 'b) 1)
+      (generate-primitive-call '(2) #f 'cons '(a b)
+                               #f #f regs)))
+
+  (pass-if-equal "arity: variable -> 0"
+    '((fix-closure 0 (1 2)))
+    (let ((regs (make-object-property)))
+      (set! (regs 'a) 0)
+      (set! (regs 'b) 1)
+      (set! (regs 'c) 2)
+      (generate-primitive-call '() #f 'fix-closure '(a b c)
+                               #f #f regs))))