From 275e2efdcec18b8b4c3f3d9ed7235dcdd0c058a6 Mon Sep 17 00:00:00 2001 From: David Thompson Date: Thu, 22 Sep 2022 16:30:16 -0400 Subject: Step 11: Complex Constants --- compiler.scm | 164 ++++++++++++++++++++++++++++++++++++++++++++++------------- 1 file 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")) -- cgit v1.2.3