Perform argument conversion.

The point of argument conversion is to validate on each function call
that the right number of arguments were passed, and to ensure that no
function has more than 1 argument. This second condition makes CPS
slightly simpler, and ensures that the arguments will all fit in locals.

We take the strategy of allocating a vector for each function call.
Ideally we would optimize away most of these allocations, but for now I
just want it to work.

1 files changed, 124 insertions, 61 deletions

diff --git a/csc/cps.csc b/csc/cps.csc
index d8cd8bd..1f58287 100644
--- a/csc/cps.csc
+++ b/csc/cps.csc
@@ -38,10 +38,15 @@
             library-define?
             library-ref?
             make-call
+            make-call-builtin
             make-constant
+            make-if
             make-lambda
+            make-letrec
             make-lexical-ref
             make-lexical-set
+            make-library-define
+            make-library-ref
             make-sequence
             sequence?)
           (only (csc ir2)
@@ -52,7 +57,6 @@
             closure-arguments
             closure-body
             closure-name
-            closure-rest
             make-apply
             make-atom
             make-branch
@@ -73,22 +77,103 @@
   (begin
 
 
+    (define (new-ref)
+      (make-lexical-ref 'generated-symbol (gensym)))
+
+
+    ; Converts an IR1 expression to an equivalent expression where every
+    ; procedure takes exactly one argument.
+    (define (argument-conversion expr)
+      (match expr
+        (_ when (or (constant? expr)
+                    (lexical-ref? expr)
+                    (library-ref? expr))
+          expr)
+        ((% %lexical-set ref arg)
+          (make-lexical-set ref (argument-conversion arg)))
+        ((% %library-define ref arg)
+          (make-library-define ref (argument-conversion arg)))
+        ((% %define-syntax _ _) expr)
+        ((% %if test consequent alternate)
+          (make-if
+            (argument-conversion test)
+            (argument-conversion consequent)
+            (argument-conversion alternate)))
+        ((% %call proc args)
+          (define argvec (new-ref))
+          (define nargs (length args))
+          (make-call
+            (make-lambda (list argvec) #f
+              (make-sequence
+                (loop for arg in args
+                      for i from 2
+                      with expr = (make-sequence
+                                    (make-call-builtin 'poke (list (make-constant 0) argvec (make-constant 0)))
+                                    (make-call-builtin 'poke (list (make-constant nargs) argvec (make-constant 1))))
+                      do (set! expr (make-sequence
+                                      expr
+                                      (make-call-builtin 'poke (list (argument-conversion arg) argvec (make-constant i)))))
+                      finally (return expr))
+                (make-call (argument-conversion proc) (list argvec))))
+            (list (make-call-builtin 'alloc (list (make-constant (+ 2 nargs)))))))
+        ((% %call-builtin op args)
+          (make-call-builtin op (map argument-conversion args)))
+        ((% %sequence head tail)
+          (make-sequence
+            (argument-conversion head)
+            (argument-conversion tail)))
+        ((% %lambda args rest body) when rest
+          (define argvec (new-ref))
+          (define nargs (length args))
+          (make-lambda (list argvec) #f
+            (make-if (make-call-builtin 'int<? (list (make-call-builtin 'peek (list argvec (make-constant 1)))
+                                                     (make-constant nargs)))
+              (make-call (make-library-ref 'wrong-number-of-arguments '(csc based)) (list argvec))
+              (loop for arg in (reverse args)
+                    for i downfrom (+ 1 nargs)
+                    with expr = (make-call (make-lambda (list rest) #f
+                                             (argument-conversion body))
+                                           (list
+                                             (argument-conversion
+                                               (make-call (make-library-ref 'vector->list '(csc based))
+                                                          (list argvec (make-constant nargs))))))
+                    ; I'm relying on beta reduction here.
+                    do (set! expr (make-call (make-lambda (list arg) #f
+                                               expr)
+                                             (list (make-call-builtin 'peek (list argvec (make-constant i))))))
+                    finally (return expr)))))
+        ((% %lambda args _ body)
+          (define argvec (new-ref))
+          (define nargs (length args))
+          (make-lambda (list argvec) #f
+            (make-if (make-call-builtin 'int=? (list (make-call-builtin 'peek (list argvec (make-constant 1)))
+                                                     (make-constant nargs)))
+              (loop for arg in (reverse args)
+                    for i downfrom (+ 1 nargs)
+                    with expr = (argument-conversion body)
+                    do (set! expr (make-call (make-lambda (list arg) #f
+                                               expr)
+                                             (list
+                                               (make-call-builtin 'peek (list argvec (make-constant i))))))
+                    finally (return expr))
+              (make-call (make-library-ref 'wrong-number-of-arguments '(csc based)) (list argvec)))))
+        ((% %letrec in-order? names gensyms exprs body)
+          (make-letrec in-order? names gensyms (map argument-conversion exprs) (argument-conversion body)))
+        (_ (error "Unexpected form in argument-conversion" expr))))
+
+
     ; Update is a CPS expression that is used internally as part of
     ; CPS conversion.
     ; Update expressions are then removed by box-conversion.
     (define-match-record-type <update>
       (make-update ref atom continuation)
       update?
-      %update
+     %update
       (ref update-ref)
       (atom update-atom)
       (continuation update-continuation))
 
 
-    (define (new-ref)
-      (make-lexical-ref 'generated-symbol (gensym)))
-
-
     (define (collect-functions-and-variables expr)
       (let ((names (letrec-names expr))
             (gensyms (letrec-gensyms expr))
@@ -98,12 +183,11 @@
               for value in vals
               if (lambda? value)
                 collect (match value
-                          ((% %lambda args rest body)
+                          ((% %lambda args _ body)
                             (define continuation (new-ref))
                             (make-closure
                               (make-lexical-ref name gensym)
                               (cons continuation args)
-                              rest
                               (to-cps
                                 body
                                 (lambda (z)
@@ -115,6 +199,9 @@
               finally (return (values functions variable-names variable-values)))))
 
 
+    ; Converts the given IR1 expression that has undergone argument conversion
+    ; into an IR2 expression in continuation passing style.
+    ; The resulting expression will include <update> forms.
     (define (to-cps expr continuation)
       (match expr
         (_ when (or (constant? expr)
@@ -141,7 +228,7 @@
               (define continuation-ref (new-ref))
               (define result-ref (new-ref))
               (make-fix
-                (list (make-closure continuation-ref (list result-ref) #f
+                (list (make-closure continuation-ref (list result-ref)
                         (continuation result-ref)))
                 (make-branch val
                   (to-cps
@@ -152,26 +239,18 @@
                     alternate
                     (lambda (result)
                       (make-apply continuation-ref (list result)))))))))
-        ((% %call proc args)
+        ((% %call proc (arg))
           (define return-address (new-ref))
           (define result (new-ref))
           (make-fix
-            (list (make-closure return-address (list result) #f (continuation result)))
+            (list (make-closure return-address (list result) (continuation result)))
             (to-cps
               proc
               (lambda (f)
-                ; Technically the order of evaluation is unspecified.
-                ; We evaluate expressions left to right.
-                (loop for arg in (reverse args)
-                      with expr = (lambda (vals)
-                                    (make-apply f (cons return-address (reverse vals))))
-                      do (set! expr (let ((e* expr)
-                                          (arg* arg)) ; make copies to avoid modifying the expr in the closure.
-                                      (lambda (vals)
-                                        (to-cps arg*
-                                          (lambda (val)
-                                            (e* (cons val vals)))))))
-                      finally (return (expr '())))))))
+                (to-cps
+                  arg
+                  (lambda (v)
+                    (make-apply f (list return-address v))))))))
         ((% %call-builtin op args)
           (define returns-value? (not (symbol=? op 'poke)))
           (loop for arg in (reverse args)
@@ -182,7 +261,7 @@
                                     (continuation result)))
                                 (make-primitive op (reverse vals) '()
                                   (continuation (make-constant #f)))))
-                do (set! expr (let ((e* expr)
+                do (set! expr (let ((e* expr)  ; make copies to avoid modifying the expr in the closure.
                                     (arg* arg))
                                 (lambda (vals)
                                   (to-cps arg*
@@ -196,12 +275,12 @@
               (to-cps
                 tail
                 continuation))))
-        ((% %lambda args rest body)
+        ((% %lambda (arg) _ body)
           (define f (new-ref))
           (define k (new-ref))
           (make-fix
             (list
-              (make-closure f (cons k args) rest
+              (make-closure f (list k arg)
                 (to-cps
                   body
                   (lambda (ret)
@@ -212,18 +291,19 @@
           (if (null? variable-names)
             (make-fix functions
               (to-cps body continuation))
-            (loop with new-expr = (make-fix functions
-                                    (loop for var in (reverse variable-names)
-                                          for val in (reverse variable-values)
-                                          with new-body = (to-cps body continuation)
-                                          do (set! new-body (to-cps val (lambda (x)
-                                                                          (make-update var x
-                                                                            new-body))))
-                                          finally (return new-body)))
-                  for var in variable-names
-                  do (set! new-expr (make-primitive 'alloc (list (make-constant 1)) (list var)
-                                      new-expr))
-                  finally (return new-expr))))
+            (let ((new-expr (loop for var in (reverse variable-names)
+                                  for val in (reverse variable-values)
+                                  with new-body = (to-cps body continuation)
+                                  do (set! new-body (to-cps val (lambda (x)
+                                                                  (make-update var x
+                                                                    new-body))))
+                                  finally (return new-body))))
+              (unless (null? functions)
+                (set! new-expr (make-fix functions new-expr)))
+              (loop for var in variable-names
+                    do (set! new-expr (make-primitive 'alloc (list (make-constant 1)) (list var)
+                                        new-expr))
+                    finally (return new-expr)))))
         (_ (error "unexpected type in to-cps" expr))))
 
 
@@ -259,14 +339,6 @@
         (_ (error "Unexpected form in get-boxed" expr))))
 
 
-    (define (all-closure-args fun)
-      (define args (closure-arguments fun))
-      (define rest (closure-rest fun))
-      (when rest
-        (set! args (cons rest args)))
-      args)
-
-
     ; Rewrites the given expression to have no more <update> forms.
     (define (box-conversion expr)
       (define boxed-refs (get-boxed expr))
@@ -321,16 +393,10 @@
                                                                                       collect (closure-name fun))))
             (define new-funs (loop for fun in funs
                                    for new-name in new-names
-                                   for rest = (closure-rest fun)
-                                   collect (let-values (((new-args boxed-args temp-args) (convert-arg-list (all-closure-args fun))))
+                                   collect (let-values (((new-args boxed-args temp-args) (convert-arg-list (closure-arguments fun))))
                                              (make-closure
                                                new-name
-                                               (if rest
-                                                 (cdr new-args)
-                                                 new-args)
-                                               (if rest
-                                                 (car new-args)
-                                                 #f)
+                                               new-args
                                                (let ((new-expr (convert (closure-body fun))))
                                                  (loop for arg in boxed-args
                                                        for var in temp-args
@@ -352,7 +418,10 @@
 
 
     (define (ir1->ir2 expr continuation)
-      (box-conversion (to-cps expr continuation)))
+      (box-conversion
+        (to-cps
+          (argument-conversion expr)
+          continuation)))
 
 
     (define (free-vars-expr expr bound-vars)
@@ -397,11 +466,8 @@
 
     (define (free-vars-closure fun bound-vars)
       (define name (closure-name fun))
-      (define rest (closure-rest fun))
       (when (lexical-ref? name)
         (set! bound-vars (insert bound-vars name #t)))
-      (when rest
-        (set! bound-vars (insert bound-vars rest #t)))
       (loop for arg in (closure-arguments fun)
             do (set! bound-vars (insert bound-vars arg #t)))
       (free-vars-expr (closure-body fun) bound-vars))
@@ -463,9 +529,6 @@
                                                         (make-closure
                                                           fn-ptr
                                                           (cons closure (map (lambda (x) (translate-ref x env*)) (closure-arguments fun)))
-                                                          (if (closure-rest fun)
-                                                            (translate (closure-rest fun))
-                                                            #f)
                                                           new-body))))
             (loop for fun in functions
                   for name = (closure-name fun)