Step 11: Complex Constants

1 files changed, 129 insertions, 35 deletions

diff --git a/compiler.scm b/compiler.scm
index 14160bb..ff7b280 100644
--- a/compiler.scm
+++ b/compiler.scm
@@ -63,7 +63,8 @@
                eq? char=?
                cons car cdr
                make-vector vector vector-length vector-ref vector-set!
-               make-string string string-length string-ref string-set!))))
+               make-string string string-length string-ref string-set!
+               constant-init constant-ref))))
 
 (define (labels? x)
   (op-eq? x 'labels))
@@ -71,6 +72,9 @@
 (define (code? x)
   (op-eq? x 'code))
 
+(define (datum? x)
+  (op-eq? x 'datum))
+
 (define (closure? x)
   (op-eq? x 'closure))
 
@@ -83,6 +87,9 @@
 (define (lambda? x)
   (op-eq? x 'lambda))
 
+(define (quote? x)
+  (op-eq? x 'quote))
+
 (define (primcall-op x)
   (first x))
 
@@ -144,6 +151,9 @@
 (define (code-body x)
   (fourth x))
 
+(define (quote-data x)
+  (second x))
+
 (define unique-counter (make-parameter 0))
 
 (define (unique-number)
@@ -155,6 +165,10 @@
   (string->symbol
    (format #f "f~a" (unique-number))))
 
+(define (unique-constant) ; global constant
+  (string->symbol
+   (format #f "t~a" (unique-number))))
+
 (define (unique-label)
   (format #f "L~a" (unique-number)))
 
@@ -500,6 +514,15 @@
      (emit-shr (immediate char-shift) rax) ; untag char
      (emit-andq (immediate -255) (offset 0 rbx)) ; clear LSB
      (emit-or rax (offset 0 rbx))) ; copy char
+    ((constant-init)
+     (let ((label (lookup (primcall-operand1 x) env)))
+       (emit-expr (primcall-operand2 x) si env)
+       (emit-lea (offset label rip) rbx)
+       (emit-mov rax (offset 0 rbx))))
+    ((constant-ref)
+     (let ((label (lookup (primcall-operand1 x) env)))
+       (emit-lea (offset label rip) rax)
+       (emit-mov (offset 0 rax) rax)))
     (else
      (error "unknown primcall op" (primcall-op x)))))
 
@@ -526,7 +549,12 @@
     (emit-expr altern si env)
     (emit-label L1)))
 
+(define (emit-datum label)
+  (display ".data\n")
+  (emit-label label))
+
 (define (emit-code label vars free-vars body env)
+  (display ".text\n")
   (emit-label label)
   ;; Extend environment to include all procedure variables
   (let loop ((vars vars)
@@ -653,7 +681,7 @@
    (else
     (error "unknown expression" x))))
 
-(define (emit-labels lvars body-exp si env)
+(define (emit-labels lvars body-exps si env)
   (let* ((lvars* (map (lambda (lvar)
                         (cons (unique-label) lvar))
                       lvars))
@@ -664,14 +692,21 @@
                      env lvars*)))
     (for-each (lambda (lvar)
                 (let ((label (first lvar))
-                      (code (third lvar)))
-                  (if (code? code)
-                      (emit-code label (code-vars code) (code-free-vars code)
-                                 (code-body code) env*)
-                      (error "expected a code expression" code))))
+                      (x (third lvar)))
+                  (cond
+                   ((datum? x)
+                    (emit-datum label))
+                   ((code? x)
+                    (emit-code label (code-vars x) (code-free-vars x)
+                               (code-body x) env*))
+                   (else
+                    (error "unknown label expression" x)))))
               lvars*)
+    (display ".text\n")
     (emit-label "scheme_entry")
-    (emit-expr body-exp si env*)
+    (for-each (lambda (body-exp)
+                (emit-expr body-exp si env*))
+              body-exps)
     (emit-ret)))
 
 ;; Perform free variable analysis and transform 'lambda' forms into
@@ -688,6 +723,7 @@
              (x (third x)))
     (cond
      ((immediate? x) '())
+     ((quote? x) '())
      ((variable? x)
       (if (memq x vars)
           '()
@@ -713,6 +749,7 @@
 (define (annotate-free-variables x)
   (cond
    ((immediate? x) x)
+   ((quote? x) x)
    ((variable? x) x)
    ((if? x)
     `(if ,(annotate-free-variables (test x))
@@ -734,52 +771,104 @@
    ((pair? x)
     `(funcall ,@(map annotate-free-variables x)))))
 
-(define (replace-lambdas-with-closures-and-funcalls x)
+;; Transforms a quote form into code.
+(define (expand-quote x)
+  (cond
+   ((immediate? x) x)
+   ((string? x)
+    `(string ,@(string->list x)))
+   ((vector? x)
+    `(vector ,@(map expand-quote (vector->list x))))
+   ((pair? x)
+    `(cons ,(expand-quote (car x))
+           ,(expand-quote (cdr x))))
+   ((null? x)
+    '())
+   ;; The compiler doesn't support symbols yet...
+   (else
+    (error "unknown quoted thing" x))))
+
+;; 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 (iter x)
     (cond
-     ((immediate? x) (values x '()))
-     ((variable? x) (values x '()))
+     ((immediate? x)
+      (values x '() '()))
+     ;; String literals and vectors are self-quoting.
+     ((or (string? x) (vector? x))
+      (iter `(quote x)))
+     ;; Quoted forms are complex constant values that must be
+     ;; evaluated exactly once and referred to by a global label.
+     ((quote? x)
+      (let ((quoted (expand-quote (quote-data x))))
+        ;; Skip label generation if the quoted form expands to an
+        ;; immediate value.
+        (if (immediate? quoted)
+            (values quoted '() '())
+            (let ((const (unique-constant)))
+                 (values `(constant-ref ,const)
+                         (list (list const '(datum)))
+                         (list `(constant-init ,const ,(expand-quote (quote-data x)))))))))
+     ((variable? x)
+      (values x '() '()))
      ((if? x)
-      (let-values (((test* labels0) (iter (test x)))
-                   ((consequent* labels1) (iter (consequent x)))
-                   ((alternate* labels2) (iter (alternate x))))
+      (let-values (((test* labels0 init0) (iter (test x)))
+                   ((consequent* labels1 init1) (iter (consequent x)))
+                   ((alternate* labels2 init2) (iter (alternate x))))
         (values `(if ,test* ,consequent* ,alternate*)
-                (append labels0 labels1 labels2))))
+                (append labels0 labels1 labels2)
+                (append init0 init1 init2))))
      ((let? x)
       (let-values (((bindings*)
                     (map (lambda (binding)
-                           (let-values (((rhs* labels) (iter (rhs binding))))
-                             (list (list (lhs binding) rhs*) labels)))
+                           (let-values (((rhs* labels initializers)
+                                         (iter (rhs binding))))
+                             (list (list (lhs binding) rhs*)
+                                   labels
+                                   initializers)))
                          (bindings x)))
-                   ((body* body-labels) (iter (body x))))
+                   ((body* body-labels body-initializers) (iter (body x))))
         (values `(let ,(map first bindings*)
                    ,body*)
                 (append (concatenate (map second bindings*))
-                        body-labels))))
+                        body-labels)
+                (append (concatenate (map third bindings*))
+                        body-initializers))))
      ((primcall? x)
       (let ((operands (map (lambda (operand)
-                             (let-values (((operand* labels) (iter operand)))
-                               (list operand* labels)))
+                             (let-values (((operand* labels initializers)
+                                           (iter operand)))
+                               (list operand* labels initializers)))
                            (cdr x))))
         (values (cons (primcall-op x)
                       (map first operands))
-                (concatenate (map second operands)))))
+                (concatenate (map second operands))
+                (concatenate (map third operands)))))
+     ;; Convert procedure calls to 'funcall' form that refers to a
+     ;; closure.
      ((funcall? x)
       (let ((args (map (lambda (arg)
-                         (let-values (((arg* labels) (iter arg)))
-                           (list arg* labels)))
+                         (let-values (((arg* labels initializers)
+                                       (iter arg)))
+                           (list arg* labels initializers)))
                        (cdr x))))
         (values `(funcall ,@(map first args))
-                (concatenate (map second args)))))
+                (concatenate (map second args))
+                (concatenate (map third args)))))
+     ;; Perform closure conversion.
      ((lambda? x)
-      (let-values (((body* labels) (iter (fourth x))))
+      (let-values (((body* labels initializers)
+                    (iter (fourth x))))
         (let ((name (unique-lvar)))
           (values `(closure ,name ,@(third x))
                   (cons (list name
                               `(code ,(second x) ,(third x) ,body*))
-                        labels)))))))
-  (let-values (((new-x labels) (iter x)))
-    `(labels ,labels ,new-x)))
+                        labels)
+                  initializers))))))
+  (let-values (((new-x labels initializers) (iter x)))
+    `(labels ,labels ,@(append initializers (list new-x)))))
 
 (define (mark-tail-calls x)
   (define (maybe-mark x)
@@ -807,29 +896,30 @@
     `(funcall ,@(map mark-tail-calls (cdr x))))
    ((code? x)
     `(code ,(code-vars x) ,(code-free-vars x) ,(mark-tail-calls (fourth x))))
+   ((datum? x)
+    '(datum))
    ((labels? x)
     `(labels ,(map (lambda (binding)
                      (list (lhs binding)
                            (mark-tail-calls (rhs binding))))
                    (bindings x))
-             ,(mark-tail-calls (body x))))))
+             ,@(map mark-tail-calls (drop x 2))))))
 
 (define (expand x)
   (parameterize ((unique-counter 0))
     (mark-tail-calls
-     (replace-lambdas-with-closures-and-funcalls
+     (labelify
       (annotate-free-variables x)))))
 
 (define (compile-program x)
   (let ((x* (expand x)))
     (parameterize ((unique-counter 0))
-      (emit-labels (second x*) (third x*) (- wordsize) '()))))
+      (emit-labels (second x*) (drop x* 2) (- wordsize) '()))))
 
 (define (compile-and-run x)
   (with-output-to-file "scheme_entry.s"
     (lambda ()
-      (display ".text
-.p2align 4
+      (display ".p2align 4
 .globl	scheme_entry
 .type	scheme_entry, @function
 ")
@@ -929,4 +1019,8 @@
                              789
                              (f (add1 x) f)))))
                 (f 0 f))
-             "789"))
+             "789")
+  ;; complex constants
+  (test-case '(let ((f (lambda () (quote (1 . "H")))))
+              (eq? (f) (f)))
+           "#t"))