From 8a64fcd881ee5b7806ba24a4d188e603089069a3 Mon Sep 17 00:00:00 2001
From: David Thompson <dthompson@vistahigherlearning.com>
Date: Thu, 6 Oct 2022 17:29:06 -0400
Subject: Refactor, reorganize, allow let to have multiple body expressions.

---
 compiler.scm | 165 ++++++++++++++++++++++++++++++++++++++++-------------------
 1 file changed, 111 insertions(+), 54 deletions(-)

diff --git a/compiler.scm b/compiler.scm
index ff7b280..170bddd 100644
--- a/compiler.scm
+++ b/compiler.scm
@@ -4,23 +4,10 @@
              (srfi srfi-1)
              (srfi srfi-11))
 
-;; Assuming a 64 bit intel machine here.
-(define wordsize 8)
-(define fixnum-mask 3)
-(define fixnum-shift 2)
-(define fixnum-tag 0)
-(define char-mask 255)
-(define char-shift 8)
-(define char-tag 15)
-(define boolean-mask 127)
-(define boolean-shift 7)
-(define boolean-tag 31)
-(define empty-list 47) ;; #b00101111
-;; 3 bit tags for heap allocated values.
-(define pair-tag 1)
-(define vector-tag 2)
-(define string-tag 3)
-(define closure-tag 6)
+
+;;;
+;;; Syntax predicates and accessors
+;;;
 
 (define (immediate-rep x)
   (cond
@@ -93,6 +80,9 @@
 (define (primcall-op x)
   (first x))
 
+(define (primcall-operands x)
+  (cdr x))
+
 (define (primcall-operand1 x)
   (second x))
 
@@ -109,11 +99,17 @@
 (define (extend-env name si-or-label env)
   (cons (cons name si-or-label) env))
 
-(define (bindings x)
+(define (let-bindings x)
   (second x))
 
-(define (body x)
-  (third x))
+(define (let-body x)
+  (cddr x))
+
+(define (label-bindings x)
+  (second x))
+
+(define (label-body x)
+  (cddr x))
 
 (define (lhs b)
   (first b))
@@ -130,6 +126,18 @@
 (define (alternate x)
   (fourth x))
 
+(define (closure-lvar x)
+  (second x))
+
+(define (closure-vars x)
+  (cddr x))
+
+(define (lambda-args x)
+  (second x))
+
+(define (lambda-body x)
+  (third x))
+
 (define (funcall-proc x)
   (second x))
 
@@ -165,10 +173,33 @@
   (string->symbol
    (format #f "f~a" (unique-number))))
 
-(define (unique-constant) ; global constant
+(define (unique-variable)
   (string->symbol
    (format #f "t~a" (unique-number))))
 
+
+;;;
+;;; Native code compilation
+;;;
+
+;; Assuming a 64 bit intel machine here.
+(define wordsize 8)
+(define fixnum-mask 3)
+(define fixnum-shift 2)
+(define fixnum-tag 0)
+(define char-mask 255)
+(define char-shift 8)
+(define char-tag 15)
+(define boolean-mask 127)
+(define boolean-shift 7)
+(define boolean-tag 31)
+(define empty-list 47) ;; #b00101111
+;; 3 bit tags for heap allocated values.
+(define pair-tag 1)
+(define vector-tag 2)
+(define string-tag 3)
+(define closure-tag 6)
+
 (define (unique-label)
   (format #f "L~a" (unique-number)))
 
@@ -529,7 +560,9 @@
 (define (emit-let bindings body si env)
   (let loop ((b* bindings) (new-env env) (si si))
     (if (null? b*)
-        (emit-expr body si new-env)
+        (for-each (lambda (x)
+                    (emit-expr x si new-env))
+                  body)
         (let ((b (first b*)))
           (emit-expr (rhs b) si env)
           (emit-mov rax (offset si rsp))
@@ -667,13 +700,13 @@
    ((if? x)
     (emit-if (test x) (consequent x) (alternate x) si env))
    ((let? x)
-    (emit-let (bindings x) (body x) si env))
+    (emit-let (let-bindings x) (let-body x) si env))
    ((primcall? x)
     (emit-primitive-call x si env))
    ((labels? x)
-    (emit-labels (bindings x) (body x) si env))
+    (emit-labels (label-bindings x) (label-body x) si env))
    ((closure? x)
-    (emit-closure (second x) (cddr x) si env))
+    (emit-closure (closure-lvar x) (closure-vars x) si env))
    ((funcall? x)
     (emit-funcall (funcall-proc x) (funcall-arguments x) si env))
    ((tail-call? x)
@@ -709,9 +742,12 @@
               body-exps)
     (emit-ret)))
 
-;; Perform free variable analysis and transform 'lambda' forms into
-;; closure/funcall forms and generate top-level labels for all
-;; procedures.
+
+;;;
+;;; Source to source program transformations
+;;;
+
+;; Find all free variables in an expression.
 (define (free-variables x)
   (define (add-variables vars more-vars)
     (fold (lambda (new-var prev)
@@ -734,18 +770,23 @@
                (loop vars (consequent x))
                (loop vars (alternate x)))))
      ((let? x)
-      (loop (add-variables vars (map lhs (bindings x))) (body x)))
+      (append-map (lambda (y)
+                    (loop (add-variables vars (map lhs (let-bindings x))) y))
+                  (let-body x)))
      ((primcall? x)
       (append-map (lambda (operand)
                     (loop vars operand))
                   (cdr x)))
      ((lambda? x)
-      (loop (add-variables vars (second x)) (third x)))
+      (loop (add-variables vars (lambda-args x)) (lambda-body x)))
      ((pair? x)
       (append-map (lambda (arg)
                     (loop vars arg))
                   x)))))
 
+;; Perform free variable analysis and transform 'lambda' forms into
+;; closure/funcall forms and generate top-level labels for all
+;; procedures.
 (define (annotate-free-variables x)
   (cond
    ((immediate? x) x)
@@ -759,15 +800,15 @@
     `(let ,(map (lambda (binding)
                   (list (lhs binding)
                         (annotate-free-variables (rhs binding))))
-                (bindings x))
-       ,(annotate-free-variables (body x))))
+                (let-bindings x))
+       ,@(map annotate-free-variables (let-body x))))
    ((primcall? x)
     (cons (primcall-op x)
           (map annotate-free-variables (cdr x))))
    ((lambda? x)
-    `(lambda ,(second x)
+    `(lambda ,(lambda-args x)
        ,(free-variables x)
-       ,(annotate-free-variables (third x))))
+       ,(annotate-free-variables (lambda-body x))))
    ((pair? x)
     `(funcall ,@(map annotate-free-variables x)))))
 
@@ -791,7 +832,7 @@
 ;; Extracts certain forms to global program labels.  Lambdas are
 ;; converted to closures and given a label.  Quoted expressions are
 ;; initialized at the start of program execution and given a label.
-(define (labelify x)
+(define (convert-closures-and-constants x)
   (define (iter x)
     (cond
      ((immediate? x)
@@ -807,7 +848,7 @@
         ;; immediate value.
         (if (immediate? quoted)
             (values quoted '() '())
-            (let ((const (unique-constant)))
+            (let ((const (unique-variable)))
                  (values `(constant-ref ,const)
                          (list (list const '(datum)))
                          (list `(constant-init ,const ,(expand-quote (quote-data x)))))))))
@@ -821,21 +862,25 @@
                 (append labels0 labels1 labels2)
                 (append init0 init1 init2))))
      ((let? x)
-      (let-values (((bindings*)
-                    (map (lambda (binding)
-                           (let-values (((rhs* labels initializers)
-                                         (iter (rhs binding))))
-                             (list (list (lhs binding) rhs*)
-                                   labels
-                                   initializers)))
-                         (bindings x)))
-                   ((body* body-labels body-initializers) (iter (body x))))
+      (let ((bindings*
+             (map (lambda (binding)
+                    (let-values (((rhs* labels initializers)
+                                  (iter (rhs binding))))
+                      (list (list (lhs binding) rhs*)
+                            labels
+                            initializers)))
+                  (let-bindings x)))
+            (body*
+             (map (lambda (y)
+                    (let-values (((y* labels initializers) (iter y)))
+                      (list y* labels initializers)))
+                  (let-body x))))
         (values `(let ,(map first bindings*)
-                   ,body*)
+                   ,@(map first body*))
                 (append (concatenate (map second bindings*))
-                        body-labels)
+                        (concatenate (map second body*)))
                 (append (concatenate (map third bindings*))
-                        body-initializers))))
+                        (concatenate (map third body*))))))
      ((primcall? x)
       (let ((operands (map (lambda (operand)
                              (let-values (((operand* labels initializers)
@@ -887,8 +932,8 @@
     `(let ,(map (lambda (binding)
                   (list (lhs binding)
                         (mark-tail-calls (rhs binding))))
-                (bindings x))
-       ,(maybe-mark (body x))))
+                (let-bindings x))
+       ,@(map maybe-mark (let-body x))))
    ((primcall? x)
     (cons (primcall-op x)
           (map mark-tail-calls (cdr x))))
@@ -902,17 +947,24 @@
     `(labels ,(map (lambda (binding)
                      (list (lhs binding)
                            (mark-tail-calls (rhs binding))))
-                   (bindings x))
+                   (label-bindings x))
              ,@(map mark-tail-calls (drop x 2))))))
 
-(define (expand x)
+;; Apply all compiler passes to transform the input program into a
+;; form that it is suitable for compilation to native assembly code.
+(define (transform x)
   (parameterize ((unique-counter 0))
     (mark-tail-calls
-     (labelify
+     (convert-closures-and-constants
       (annotate-free-variables x)))))
 
+
+;;;
+;;; Compiler frontend
+;;;
+
 (define (compile-program x)
-  (let ((x* (expand x)))
+  (let ((x* (transform x)))
     (parameterize ((unique-counter 0))
       (emit-labels (second x*) (drop x* 2) (- wordsize) '()))))
 
@@ -935,6 +987,11 @@
     (close pipe)
     output))
 
+
+;;;
+;;; Tests
+;;;
+
 (define (test-case x expected-output)
   (let ((result (compile-and-run x)))
     (if (and (not (eof-object? result))
-- 
cgit v1.2.3