From 0f78dded117af2e416357ca857015b2a13ae113f Mon Sep 17 00:00:00 2001 From: David Thompson Date: Tue, 16 Aug 2022 14:46:00 -0400 Subject: Step 8: Procedure Calls --- compiler.scm | 123 ++++++++++++++++++++++++++++++++++++++++++++++++++++------- 1 file changed, 109 insertions(+), 14 deletions(-) (limited to 'compiler.scm') diff --git a/compiler.scm b/compiler.scm index ab76e20..f890276 100644 --- a/compiler.scm +++ b/compiler.scm @@ -40,6 +40,10 @@ (define (variable? x) (symbol? x)) +(define (if? x) + (and (pair? x) + (eq? (first x) 'if))) + (define (let? x) (and (pair? x) (eq? (first x) 'let))) @@ -57,9 +61,17 @@ make-vector vector vector-length vector-ref vector-set! make-string string string-length string-ref string-set!)))) -(define (if? x) +(define (labels? x) (and (pair? x) - (eq? (first x) 'if))) + (eq? (first x) 'labels))) + +(define (code? x) + (and (pair? x) + (eq? (first x) 'code))) + +(define (labelcall? x) + (and (pair? x) + (eq? (first x) 'labelcall))) (define (primcall-op x) (first x)) @@ -77,8 +89,8 @@ (or (assq-ref env name) (error "unbound variable:" name))) -(define (extend-env name si env) - (cons (cons name si) env)) +(define (extend-env name si-or-label env) + (cons (cons name si-or-label) env)) (define (bindings x) (second x)) @@ -86,6 +98,12 @@ (define (body x) (third x)) +(define (lhs b) + (first b)) + +(define (rhs b) + (second b)) + (define (test x) (second x)) @@ -95,6 +113,12 @@ (define (alternate x) (fourth x)) +(define (lvar x) + (second x)) + +(define (arguments x) + (drop x 2)) + (define unique-counter (make-parameter 0)) (define (unique-label) @@ -179,6 +203,12 @@ (define (emit-jmp label) (emit "jmp ~a" label)) +(define (emit-call label) + (emit "call ~a" label)) + +(define (emit-ret) + (emit "ret")) + (define (emit-label label) (format #t "~a:\n" label)) @@ -437,10 +467,6 @@ (error "unknown primcall op" (primcall-op x))))) (define (emit-let bindings body si env) - (define (lhs b) - (first b)) - (define (rhs b) - (second b)) (let loop ((b* bindings) (new-env env) (si si)) (if (null? b*) (emit-expr body si new-env) @@ -463,25 +489,90 @@ (emit-expr altern si env) (emit-label L1))) +(define (emit-code label vars body env) + (emit-label label) + (let loop ((vars vars) + (env env) + (si (- wordsize))) + (if (null? vars) + (begin + (emit-expr body si env) + (emit-ret)) + (loop (cdr vars) + (extend-env (first vars) si env) + (- si wordsize))))) + +(define (emit-labels lvars body-exp si env) + (let* ((lvars* (map (lambda (lvar) + (cons (unique-label) lvar)) + lvars)) + (env* (fold (lambda (lvar env) + (let ((label (first lvar)) + (name (second lvar))) + (extend-env name label env))) + env lvars*))) + (for-each (lambda (lvar) + (let ((label (first lvar)) + (code (third lvar))) + (if (code? code) + (emit-code label (bindings code) (body code) env*) + (error "expected a code expression" code)))) + lvars*) + (emit-label "scheme_entry") + (emit-expr body-exp si env*) + (emit-ret))) + +(define (emit-labelcall lvar args si env) + (let ((label (lookup lvar env))) + (let loop ((args args) + (si* (- si wordsize))) + (if (null? args) + ;; The stack pointer needs to be advanced to one word below + ;; the return point of the upcoming call. Our stack index + ;; value starts at (- wordsize). The 'call' instruction + ;; automatically increments the stack pointer by a word. + ;; So, if we incremented by the stack index, we'd be moving + ;; too far. We need to advance by one less word. In the + ;; case where nothing has been allocated to the stack before + ;; the call, it means not incrementing the stack pointer at + ;; all! Took me awhile to wrap my head around this! + (let ((stack-start (+ si wordsize))) + (unless (zero? stack-start) + (emit-add (immediate stack-start) rsp)) + (emit-call label) + (unless (zero? stack-start) + (emit-sub (immediate stack-start) rsp))) + (begin + (emit-expr (first args) si* env) + (emit-mov rax (offset si* rsp)) + (loop (cdr args) + (- si* wordsize))))))) + (define (emit-expr x si env) (cond ((immediate? x) (emit-mov (immediate (immediate-rep x)) rax)) ((variable? x) (emit-mov (offset (lookup x env) rsp) rax)) + ((if? x) + (emit-if (test x) (consequent x) (alternate x) si env)) ((let? x) (emit-let (bindings x) (body x) si env)) ((primcall? x) (emit-primitive-call x si env)) - ((if? x) - (emit-if (test x) (consequent x) (alternate x) si env)) + ((labels? x) + (emit-labels (bindings x) (body x) si env)) + ((labelcall? x) + (emit-labelcall (lvar x) (arguments x) si env)) (else (error "unknown expression" x)))) (define (compile-program x) (parameterize ((unique-counter 0)) - (emit-expr x (- wordsize) '()) - (emit "ret"))) + (let ((x* (if (labels? x) + x + `(labels () ,x)))) + (emit-expr x* (- wordsize) '())))) (define (compile-and-run x) (with-output-to-file "scheme_entry.s" @@ -490,7 +581,6 @@ .p2align 4 .globl scheme_entry .type scheme_entry, @function -scheme_entry: ") (compile-program x))) (unless (zero? (system* "gcc" "-c" "scheme_entry.s")) @@ -570,4 +660,9 @@ scheme_entry: (test-case '(vector-length (make-vector 3)) "3") (test-case '(vector-ref (vector 1 2 3) 1) "2") (test-case '(string-length (make-string 5)) "5") - (test-case '(string-ref (string #\a #\b #\c) 1) "b")) + (test-case '(string-ref (string #\a #\b #\c) 1) "b") + (test-case '(labels ((perimeter (code (length width) + (+ (* length 2) + (* width 2))))) + (labelcall perimeter 4 3)) + "14")) -- cgit v1.2.3