From fd17fcd99c4b83d12684d683b3a20f61f025c6a2 Mon Sep 17 00:00:00 2001
From: Jesse McDonald <nybble41@gmail.com>
Date: Wed, 14 Apr 2010 00:23:22 -0500
Subject: [PATCH] Update compiler description (now a working Scheme program).

Maps lexical variables, decodes argument lists, and flattens procedures
to simple lists of primitive operations, but does not yet convert to
CPS or perform register (gN, iN, fN) allocation, much less optimization.
---
 doc/compiler.txt | 256 ++++++++++++++++++++++++++++++++++++++---------
 1 file changed, 210 insertions(+), 46 deletions(-)

diff --git a/doc/compiler.txt b/doc/compiler.txt
index 348d60c..4fc0c0f 100644
--- a/doc/compiler.txt
+++ b/doc/compiler.txt
@@ -1,24 +1,114 @@
-(let ...)
-(let* ...)
-(letrec ...)
+(define (simplify-form form)
+  (if (pair? form)
+    (case (car form)
+      [(let) (simplify-let form)]
+      [(let*) (simplify-let* form)]
+      [(letrec) (simplify-letrec form)]
+      [(if) (simplify-if form)]
+      [(lambda) (simplify-lambda form)]
+      [(begin) `(%bind () ,@(map simplify-form (cdr form)))]
+      [(set!) (simplify-set! form)]
+      [(car cdr)
+       (if (pair? (second form))
+           (let ([x (gensym)])
+             `(%bind (,x)
+                ,(simplify-form `(set! ,x ,(second form)))
+                (,(if (eq? (first form) 'car) '%car '%cdr) ,x)))
+           `(,(if (eq? (first form) 'car) '%car '%cdr) ,(second form)))]
+      [(%bind %if %tail-call %apply %lambda %set! %cons %car %cdr) form]
+      [else (simplify-funcall form)])
+    form))
 
-; (if cond-expr true-expr false-expr)
-;    => (let ([cond-val cond-expr])
-;         (let ([next-fn (%if cond-val
-;                             (lambda () true-expr)
-;                             (lambda () false-expr))])
-;           (next-fn)))
+(define (simplify-set! form)
+  (let ([value-form (simplify-form (third form))])
+    (if (and (pair? value-form) (eq? (first value-form) '%bind))
+        `(%bind ,(second value-form)
+           ,@(foldr (lambda (x s)
+                      (if (pair? s)
+                          (cons x s)
+                          (list (simplify-set! `(set! ,(second form) ,x)))))
+                    '()
+                    (cddr value-form)))
+        `(%set! ,(second form) ,value-form))))
 
-(define (transform-if form)
-   (define cond-val (gensym))
-   (define next-fn (gensym))
-   (define-values (cond-expr true-expr false-expr)
-                  (apply values (cdr form)))
-   `(let ([,cond-val ,cond-expr])
-      (let ([,next-fn (%if ,cond-val
-                           (lambda () ,true-expr)
-                           (lambda () ,false-expr))])
-        (,next-fn))))
+; (let ([var expr]...) bodyexpr...)  ; first eval exprs, then assign bindings in parallel
+;    => (%bind (tmp...)
+;         (%set! tmp ,(simplify-form expr))...
+;         (%bind (var...)
+;           (%set! var tmp)...
+;           bodyexpr...))
+
+(define (simplify-let form)
+   (define bindings (second form))
+   (define bodyexprs (cdr (cdr form)))
+   (define vars (map (lambda (x) (if (pair? x) (first x) x)) bindings))
+   (define temp-bindings
+     (append-map
+       (lambda (x) (if (pair? x)
+                       (let ([tmp (gensym)])
+                         `((,tmp
+                            ,(simplify-form `(set! ,tmp ,(second x)))
+                            (%set! ,(first x) ,tmp))))
+                         '()))
+       bindings))
+   (if (pair? bindings)
+       (if (pair? (cdr bindings))
+           `(%bind ,(map first temp-bindings)
+              ,@(map second temp-bindings)
+              (%bind ,vars
+                ,@(map third temp-bindings)
+                ,@(map simplify-form bodyexprs)))
+           `(%bind (,(first vars))
+              ,@(if (pair? (first bindings))
+                  `(,(simplify-form `(set! ,(first vars) ,(second (first bindings)))))
+                  '())
+              ,@(map simplify-form bodyexprs)))
+       `(%bind () ,@bodyexprs)))
+
+; (let* ...)   ; eval exprs & bind variables serially
+;    => (let ([var-0 expr-0])
+;         (let ([var-1 expr-1])
+;           (...
+;             bodyexprs...)))
+
+(define (simplify-let* form)
+   (define bindings (second form))
+   (define bodyexprs (cdr (cdr form)))
+   (define (add-binding bind bodyexpr)
+      `(let (,bind) ,bodyexpr))
+   (simplify-form (foldr add-binding `(begin ,@bodyexprs) bindings)))
+
+; (letrec ...) ; init bindings to undefined, then assign values in series
+;    => (let (var...)
+;         (set! var expr)...
+;         bodyexprs)
+
+(define (simplify-letrec form)
+  (define bindings (second form))
+  (define bodyexprs (cdr (cdr form)))
+  (simplify-form
+  `(%bind (,@(map (lambda (x) (if (pair? x) (first x) x)) bindings))
+     ,@(append-map
+         (lambda (x)
+           (if (pair? x)
+               `((set! ,(first x) ,(simplify-form (second x))))
+               '()))
+         bindings)
+     ,@(map simplify-form bodyexprs))))
+
+(define (simplify-if form)
+  (define cond-val (gensym))
+  (define next-fn (gensym))
+  (define true-fn (gensym))
+  (define false-fn (gensym))
+  (define-values (cond-expr true-expr false-expr)
+                 (apply values (cdr form)))
+  (simplify-form
+    `(let ([,cond-val ,cond-expr]
+           [,true-fn  (%lambda ,(simplify-form true-expr))]
+           [,false-fn (%lambda ,(simplify-form false-expr))])
+       (let ([,next-fn (%if ,cond-val ,true-fn ,false-fn)])
+         (%apply ,next-fn %nil)))))
 
 ; (lambda (required... [optional default-expr]... . rest) bodyexpr...)
 ;    => (lambda argv
@@ -29,12 +119,12 @@
 ;               (set! argv-temp (cdr argv-temp)))
 ;               (...
 ;                 (let (optional-0)
-;                   (if (eq? argv-temp nil)
+;                   (if (eq? argv-temp %nil)
 ;                       (set! optional-0 default-expr-0)
 ;                       (set! optional-0 (car argv-temp)))
 ;                   (set! argv-temp (cdr argv-temp))
 ;                   (let (optional-1)
-;                     (if (eq? argv-temp nil)
+;                     (if (eq? argv-temp %nil)
 ;                         (set! optional-1 default-expr-1)
 ;                         (set! optional-1 (car argv-temp)))
 ;                     (set! argv-temp (cdr argv-temp))
@@ -42,55 +132,129 @@
 ;                       (let ([rest argv-temp])
 ;                         bodyexpr...)...)))...)))
 
-(define (transform-lambda-arglist form)
+(define (simplify-lambda form)
    (define arglist (car (cdr form)))
    (define bodyexprs (cdr (cdr form)))
    (define (split-arglist arglist)
       (define (split-optional arglist)
          (if (pair? arglist)
              (let-values ([(opt rst) (split-optional (cdr arglist))])
-               (values opt rst)) 
-             (values nil arglist)))
-      (if (eq? arglist nil)
-          (values nil nil #f)
+               (values (cons (car arglist) opt) rst)) 
+             (values '() arglist)))
+      (if (pair? arglist)
           (if (pair? (car arglist))
             (let-values ([(opt rst) (split-optional arglist)])
-               (values nil opt rst))
+               (values '() opt rst))
             (let-values ([(req opt rst) (split-arglist (cdr arglist))])
-               (values (cons (car arglist) req) opt rst)))))
+               (values (cons (car arglist) req) opt rst)))
+          (values '() '() #f)))
 
    (define-values (requireds optionals rest) (split-arglist arglist))
    (define argv-temp (gensym))
+   (define k (gensym))
+   (define rval (gensym))
 
    (define (add-req req inner) `(let ([,req (car ,argv-temp)])
                                   (set! ,argv-temp (cdr ,argv-temp))
                                   ,inner))
    (define (add-opt opt-list inner) `(let (,(car opt-list))
-                                       (if (eq? ,argv-temp nil)
-                                           (set! ,(car opt-list) ,(cdr opt-list))
-                                           (set! ,(car opt-list) (car ,argv-temp)))
+                                       (if (pair? ,argv-temp)
+                                           (begin
+                                             (set! ,(first opt-list) (car ,argv-temp))
+                                             (set! ,argv-temp (cdr ,argv-temp)))
+                                           (set! ,(first opt-list) ,(second opt-list)))
                                        ,inner))
    (define rest+bodyexprs (if rest `(let ([,rest ,argv-temp]) ,@bodyexprs)
                                    `(begin ,@bodyexprs)))
-   `(lambda ,argv-temp
-      ,(foldr add-req (foldr add-opt rest+bodyexprs optionals) requireds)))
+   `(%lambda 
+      (%bind (,rval ,k)
+        (%set! ,k %k)
+        ,(simplify-form
+           `(set! ,rval (let ([,argv-temp %argv])
+                          ,(foldr add-req (foldr add-opt rest+bodyexprs optionals) requireds))))
+        (%set! ,rval (%cons ,rval %nil))
+        (%tail-call ,k ,rval))))
 
 ; (fn-expr arg-expr...)
 ;    => (let ([fn-var fn-expr] arg-var... argv)
 ;         (set! fn-var fn-expr)
 ;         (set! arg-var arg-expr)...
-;         (set! argv nil)
+;         (set! argv %nil)
 ;         (set! argv (cons arg-var argv))... [reversed]
-;         (apply fn-var argv))
+;         (%apply fn-var argv))
 
-(define (transform-funcall form)
-   (define fn-expr (car form))
-   (define arg-exprs (cdr form))
-   (define fn-var (gensym))
-   (define arg-vars (map (lambda (x) (gensym)) arg-exprs))
-   (define argv (gensym))
-   `(let ([,fn-var ,fn-expr] ,@arg-vars ,argv)
-      ,@(map (lambda (x y) `(set! ,x ,y)) arg-vars arg-exprs)
-      (set! ,argv nil)
-      ,@(reverse (map (lambda (x) `(set! ,argv (cons ,x ,argv))) arg-vars))
-      (apply ,fn-var ,argv)))
+(define (simplify-funcall form)
+  (define fn-expr (car form))
+  (define arg-exprs (cdr form))
+  (define fn-var (gensym))
+  (define arg-vars (map (lambda (x) (gensym)) arg-exprs))
+  (define argv (gensym))
+  (simplify-form
+    `(%bind (,fn-var ,@arg-vars ,argv)
+       ,(simplify-form `(set! ,fn-var ,fn-expr))
+       ,@(map (lambda (x y) (simplify-form `(set! ,x ,y))) arg-vars arg-exprs)
+       (%set! ,argv %nil)
+       ,@(reverse (map (lambda (x) `(%set! ,argv (%cons ,x ,argv))) arg-vars))
+       (%apply ,fn-var ,argv))))
+
+(define (subst-var old-var new-var form)
+  (define (recurse form)
+    (subst-var old-var new-var form))
+  (if (pair? form)
+    (case (car form)
+      [(%bind)
+       (if (memq old-var (second form))
+           form
+           `(%bind ,(second form) ,@(map recurse (cddr form))))]
+      [(%if %tail-call %apply %lambda %set! %cons %car %cdr)
+       `(,(first form) ,@(map recurse (cdr form)))]
+      [else (error "Unsimplified form:" form)])
+    (if (eq? form old-var)
+        new-var
+        form)))
+
+(define (make-bindings-unique form)
+  (if (pair? form)
+    (case (car form)
+      [(%bind)
+       (let ([new-vars (map (lambda _ (gensym)) (second form))])
+         `(%bind ,new-vars
+            ,@(map (lambda (frm)
+                     (foldl (lambda (pair s)
+                              (subst-var (car pair)
+                                         (cdr pair)
+                                         s))
+                            (make-bindings-unique frm)
+                            (map cons (second form) new-vars)))
+                   (cddr form))))]
+      [(%if %tail-call %apply %lambda %set! %cons %car %cdr)
+       `(,(first form) ,@(map make-bindings-unique (cdr form)))]
+      [else (error "Unsimplified form:" form)])
+    form))
+
+(define (flatten-binds form)
+  ;(pretty-print form) (write-char #\Newline)
+  (if (pair? form)
+    (case (car form)
+      [(%bind)
+       (let* ([bound-vars (second form)]
+              [subforms (append-map (lambda (form)
+                                      (let ([new-form (flatten-binds form)])
+                                        (if (and (pair? new-form) (eq? (car new-form) '%bind))
+                                          (begin
+                                            (set! bound-vars (append bound-vars (second new-form)))
+                                            (cddr new-form))
+                                          (list new-form))))
+                                    (cddr form))])
+         `(%bind ,bound-vars ,@subforms))]
+      [(%if %tail-call %apply %lambda %set! %cons %car %cdr)
+       `(,(first form) ,@(map flatten-binds (cdr form)))]
+      [else (error "Unsimplified form:" form)])
+    form))
+
+(define (compile form)
+  (flatten-binds
+      (make-bindings-unique
+        (simplify-form `(lambda () ,form)))))
+
+; vim:set sw=2 expandtab: