vx-scheme/src/compiler.scm

972 lines
32 KiB
Scheme
Raw Permalink Normal View History

;; Compiler for Vx-Scheme
;;
;; Copyright (c) 2003,2006 and onwards Colin Smith
;;
;; You may distribute under the terms of the Artistic License,
;; as specified in the LICENSE file.
;;
;; Based on ideas from [PAIP]: "Paradigms of Artificial Intelligence
;; Programming: Case Studies in Common Lisp," 1992, Peter Norvig, and
;; [SICP]: "Structure and Interpretation of Computer Programs," 2ed.,
;; 1996, Harold Abelson and Gerald Jay Sussman with Julie Sussman, MIT
;; Press,
; =========
; ASSEMBLER
; =========
(define (assemble insns)
(define (branch? opcode)
(memq opcode '(goto false? false?p true? true?p save)))
(let ((nonlabels '())
(labelmap '())
(counter 0))
;; pass 1: count non label instructions and memorize label positions.
(let pass1 ((insn insns))
(let* ((i (car insn))
(opcode (car i)))
(if (eq? opcode 'label)
(set! labelmap (cons (cons (cadr i) counter) labelmap))
(set! counter (+ counter 1)))
(if (not (null? (cdr insn)))
(pass1 (cdr insn)))))
;; pass 2: pack instructions into vector, while replacing labels with
;; indices.
(let pass2 ((outseq (make-vector counter))
(insn insns)
(ix 0))
(let* ((i (car insn))
(opcode (car i)))
(if (not (eq? opcode 'label))
(begin
(cond
((branch? opcode)
(vector-set! outseq ix
(list opcode (cdr (assq (cadr i) labelmap)))))
(else
(vector-set! outseq ix i)))
(if (not (null? (cdr insn)))
(pass2 outseq (cdr insn) (+ ix 1))))
(if (not (null? (cdr insn)))
(pass2 outseq (cdr insn) ix))))
outseq)))
;;; ========
;;; COMPILER
;;; ========
;; This is an association list of macro definitions:
;; ((name . (arglist . body))...)
(define __macro_table '())
(define (compile form)
(define *inline-procedures* '(+ * - quotient remainder
vector-ref vector-set! car cdr
zero? not null? eq? pair? cons))
(define (builtin? proc)
(memq proc '(if quote cond begin lambda or and let set! define letrec
let* do case quasiquote delay defmacro define-macro)))
;; We provide two simplified replacements for the library function map
;; (one for one arguments, the other for two), neither of which uses
;; the 'apply' primitive. The reason: map must apply its procedure
;; argument to the input list(s). While the interpreter knows how to
;; apply a compiled procedure, compiled Scheme code cannot invoke a
;; procedure in the interpreter, as this would reenter the interpreter
;; when the compiler compiles itself. We avoid this by supplying
;; two apply-less map substitutes here.
(define (_map func lst)
(let loop ((result '())
(rest lst))
(if (null? rest)
result
(loop (append result (list (func (car rest)))) (cdr rest)))))
(define (_map2 func lst1 lst2)
(let loop ((result '())
(rest1 lst1)
(rest2 lst2))
(if (null? rest1)
result
(loop (append result
(list (func (car rest1) (car rest2))))
(cdr rest1) (cdr rest2)))))
;; starts-with: frequently used in [PAIP]; we define it here.
;;
;; Return #t if l is a list whose first element is x.
(define (starts-with l x)
(and (pair? l) (eq? (car l) x)))
(define unspecified (if #f #f))
(define make-label
(let ((label-counter 0))
(lambda (name)
(set! label-counter (+ label-counter 1))
(string->symbol (string-append
(symbol->string name)
(number->string label-counter))))))
(define (extend-environment env args)
(cons args env))
(define (form-returning value more? val? . args)
(append
args
(if val?
(cond
((null? value) '((nil)))
((eq? value (if #f #f)) '((unspc)))
((eq? value #f) '((false)))
((eq? value #t) '((true)))
((integer? value) `((int ,value)))
;; ((symbol? value) `((const ,value)))
(else `((const ,value))))
'())
(if (not more?) `((return)) '())))
; emit insns if condition? is true.
;
(define (code-if condition? . insns)
(if condition? insns '()))
(define (compile-compound form env more? val?)
(let ((proc (car form))
(args (cdr form)))
(cond
((builtin? proc)
;; SPECIAL FORM
(compile-builtin proc args env more? val?))
((assq proc __macro_table)
;; MACRO
=> (lambda (macro) (compile-macro macro args env more? val?)))
(else
;; PROCEDURE APPLICATION
(compile-apply proc args env more? val?)))))
(define (locate-local-variable env var)
(define (locate-within env var)
(let var-loop ((v env)
(nv 0))
(if (null? v) #f
(if (eq? (car v) var)
nv
(var-loop (cdr v) (+ nv 1))))))
(let env-loop ((e env)
(ne 0))
(if (null? e) #f ; game over: ran out of environments without finding it.
(let ((location (locate-within (car e) var)))
(if location
(cons ne location)
(env-loop (cdr e) (+ ne 1)))))))
;; -------------------------
;; THE BUILTIN SPECIAL FORMS
;; -------------------------
(define (compile-builtin proc args env more? val?)
(cond
((eq? proc 'quote)
(form-returning (car args) more? val?))
((eq? proc 'if)
(let* ((test (car args))
(then-part (cadr args))
(have-else-part (not (null? (cddr args))))
(else-part (if have-else-part (caddr args) #f))
(label1 (make-label 'if))
(rendezvous (if more? (make-label 'if) #f)))
(append
(compile-exp test env #t #t)
(list `(false?p ,label1))
(compile-exp then-part env more? val?)
(code-if rendezvous `(goto ,rendezvous))
(list `(label ,label1))
(if have-else-part
(compile-exp else-part env more? val?)
(form-returning unspecified more? val?))
(code-if rendezvous `(label ,rendezvous)))))
((eq? proc 'cond)
(let ((rendezvous (make-label 'cond-x)))
(append
(let clause-loop ((clauses args)
(code '()))
(if (null? clauses)
;; if we get here, there was no else clause. We need to
;; arrange it so a evaluating a cond none of whose tests
;; are satisfied returns an unspecified value.
(append code (form-returning unspecified more? val?))
;; Continue compiling clauses.
(clause-loop
(cdr clauses)
(append
code
;; Generate the code for one clause.
(let* ((clause (car clauses))
(test (car clause))
(actions (cdr clause))
(skip-label (make-label 'cond)))
(append
(if (eq? test 'else)
;; An else clause is always executed.
(begin
(if (not (null? (cdr clauses)))
(error "else must be the last clause of a cond"))
(compile-sequence actions env more? val?))
;; Consider the action list. Look for => in the
;; first slot.
(if (starts-with actions '=>)
;; a => clause.
(let ((t-label (make-label 'cond-t))
(continuation (and more? (make-label 'cont))))
(append
(compile-exp test env #t #t)
`((true? ,t-label)
(pop)
(goto ,skip-label)
(label ,t-label))
;; XXX We now have the magic number '3'
;; to apologize for here.
(code-if continuation
`(save ,continuation)
'(take 3)) ; cont goes before argument
(compile-exp (cadr actions) env #t #t)
`((apply 1))
(code-if continuation `(label ,continuation))
(code-if (not val?) '(pop))
(code-if (and more? (not (null? (cdr clauses))))
`(goto ,rendezvous))))
;; a regular clause.
(begin
(append
(compile-exp test env #t #t)
`((false?p ,skip-label))
(compile-sequence actions env more? val?)))))
;; Now we have the value.
(code-if more? `(goto ,rendezvous))
`((label ,skip-label))))))))
(code-if rendezvous `(label ,rendezvous)))))
((eq? proc 'case)
;; Accomplished by rewriting:
;;
;; (case m -> (let ((value m))
;; ((u1 u2...) x1 x2...)... -> (cond ((member? m (u1 u2...)) x1 x2...)
;; (else y1 y2...)) -> (else y1 y2...))
;;
(let* ((selector (car args))
(clauses (cdr args))
(value (make-label 'case-var))
(cond-clauses (let loop ((code '())
(rest clauses))
(if (null? rest)
code
(loop
(append code
(if (eq? (caar rest) 'else)
`((else ,@(cdar rest)))
`(((member ,value ',(caar rest)) ,@(cdar rest)))))
(cdr rest)))))
(augmented-code `(let ((,value ,selector))
(cond ,@cond-clauses))))
(compile-exp augmented-code env more? val?)))
;; (let [name]? ((u1 v1) (u2 v2)...) x1 x2...)
((eq? proc 'let)
(let* ((named (and (symbol? (car args))
(car args))) ; if named let, record name
(args (if named (cdr args) args))) ; and advance to bindings
(let* ((bindings (car args))
(variables (_map car bindings))
(initializers (_map cadr bindings))
(body (cdr args)))
(compile-let named variables initializers body env more? val?))))
((eq? proc 'letrec)
(let* ((bindings (car args))
(variables (_map car bindings))
(initializers (_map cadr bindings))
(body (cdr args)))
(compile-letrec variables initializers body env more? val?)))
((eq? proc 'let*)
;; Accomplished by rewriting:
;;
;; (let* ((u1 v1) (u2 v2)...) x1 x2...) -> (let ((u1 v1))
;; (let* ((u2 v2)...)
;; x1 x2...))
;; When we're down to the last binding, we just compile as a
;; simple let.
(let* ((bindings (car args))
(nbindings (length bindings))
(variables (_map car bindings))
(initializers (_map cadr bindings))
(body (cdr args)))
(cond ((= nbindings 0) ; (let* () ...) --> (begin ...)
(compile-sequence body env more? val?))
((= nbindings 1) ; only one binding (left); simple let.
(compile-let #f variables initializers body env more? val?))
(else ; reduce one step.
(compile-let #f
(list (car variables))
(list (car initializers))
`((let* ,(cdr bindings)
,@body))
env more? val?)))))
((eq? proc 'begin)
;; Note: according to R4RS, internal definitions are not recognized
;; in a begin (only lambda, let, let*, letrec, define). This is
;; why we call compile-simple-sequence instead of compile-sequence.
(compile-simple-sequence args env more? val?))
((eq? proc 'lambda)
(append (compile-procedure-body #f (car args) (cdr args) env #f #t)
'((proc))
(code-if (not val?) '(pop))
(code-if (not more?) '(return))))
((eq? proc 'or)
(if (null? args)
(form-returning #f more? val?)
(let ((end-label (make-label 'or)))
(append
(let or-loop ((rest args)
(code '()))
(if (null? (cdr rest))
(append code (compile-exp (car rest) env more? val?))
(or-loop (cdr rest)
(append code
(compile-exp (car rest) env #t #t)
`((true? ,end-label)
(pop))))))
`((label ,end-label))
(code-if (not val?) '(pop))
(code-if (not more?) '(return))))))
((eq? proc 'and)
(if (null? args)
(form-returning #t more? val?)
(let ((end-label (make-label 'and)))
(append
(let and-loop ((rest args)
(code '()))
(if (null? (cdr rest))
(append code (compile-exp (car rest) env more? val?))
(and-loop (cdr rest)
(append code
(compile-exp (car rest) env #t #t)
`((false? ,end-label)
(pop))))))
`((label ,end-label))
(code-if (not val?) '(pop))
(code-if (not more?) '(return))))))
((eq? proc 'set!)
(let ((var (car args))
(value (cadr args)))
(append
(compile-exp value env #t #t)
(compile-assignment env var more? val?))))
((eq? proc 'define)
(append
(let ((target (car args)))
(cond ((symbol? target) ; (define v x...)
(append
(compile-exp (cadr args) env #t #t)
`((gset ,target))))
((pair? target) ; (define (f v...) x...)
(let ((proc (car target))
(args (cdr target))
(body (cdr args)))
(append
(compile-procedure-body #f args body env #f #t)
`((proc)
(gset ,proc)))))
(else (error "incomprehensible definition"))))
(form-returning unspecified more? val?)))
;; Defmacro. We expand the quasiquotation at compile time, and
;; then compile the result, for evaluation at runtime.
((or (eq? proc 'defmacro) ; XXX this is deprecated; or, use CL syntax
(eq? proc 'define-macro) )
(let* ((name (caar args))
(arglist (cdar args))
(body (cdr args))
(new-macro (cons arglist body)))
;; Find out if we already have a definition for this macro, and
;; if so, supersede it; else prepend the new definition to the
;; list.
(cond ((assq name __macro_table) => (lambda (assoc)
(set-cdr! assoc new-macro)))
(else
(set! __macro_table (cons (cons name new-macro)
__macro_table)))))
;;
(form-returning unspecified more? val?))
((eq? proc 'do)
(compile-do args env more? val?))
((eq? proc 'quasiquote)
;; expand quasiquotation and compile result.
(let ((expansion (expand-quasiquotation (car args))))
(compile-exp expansion env more? val?)))
((eq? proc 'delay)
;; (delay X) is a bit like (lambda () X). Compile the code for X,
;; and emit an instruction to wrap it in promise form.
(append (compile-procedure-body #f '() args env #f #t)
'((promise))
(code-if (not val?) '(pop))
(code-if (not more?) '(return))))
(else
(error "unknown builtin"))))
(define (compile-assignment env var more? val?)
(let ((location (locate-local-variable env var)))
(form-returning unspecified more? val?
(if location
`(lset ,(car location) ,(cdr location))
`(gset ,var)))))
(define (compile-sequence body env more? val?)
(let* ((result (scan-out-defines body))
(definitions (car result))
(simple-body (cdr result)))
(if (not (null? definitions))
;; wrap simple-body in a letrec that establishes the
;; definitions.
(let ((items
(let clause-loop ((variables '())
(initializers '())
(rest definitions))
(if (null? rest)
(cons variables initializers)
(let ((clause (cdar rest))) ; skip past 'define
(if (pair? (car clause)) ; procedure definition
(clause-loop
(append variables (list (caar clause)))
(append initializers
(list `(lambda ,(cdar clause) ,@(cdr clause))))
(cdr rest))
(clause-loop ; scalar definition
(append variables (list (car clause)))
(append initializers (list (cadr clause)))
(cdr rest))))))))
(compile-letrec (car items) (cdr items) simple-body env more? val?))
;; if no internal definitions, immediately delegate to
;; compile-simple-sequence.
(compile-simple-sequence body env more? val?))))
;; scan-out-defines: given a sequence of forms, separate the internal
;; definitions from the body forms. Return the twain in a cons.
;; (This way of handling internal definitions comes from [SICP].
;; The compiler in [PAIP] doesn't handle internal definitions. Norvig
;; uses letrec in the examples where this would matter.)
(define (scan-out-defines body)
(let loop ((defines '())
(simple-body '())
(rest body))
(cond
((null? rest)
(cons defines simple-body))
((starts-with (car rest) 'define)
(loop (append defines (list (car rest)))
simple-body
(cdr rest)))
(else
(loop defines
(append simple-body (list (car rest)))
(cdr rest))))))
;; compile-simple-sequence: compile a body sequence (list of forms)
;; known not to contain any internal definitions (these will have
;; been removed with (scan-out-defines).
(define (compile-simple-sequence body env more? val?)
(if (null? body)
(form-returning unspecified more? val?)
(append
(let loop ((code '())
(rest body))
(if (null? (cdr rest)) ; last in sequence
(append code (compile-exp (car rest) env more? val?))
(loop (append code (compile-exp (car rest) env #t #f))
(cdr rest))))
; Q: why do we need this return?
; (code-if (not more?) '(return))
)))
(define (compile-let name variables initializers body env more? val?)
; in the event of named-let, we add a new variable binding to
; contain the procedure value itself.
(let ((let-env (if name (extend-environment env (list name)) env))
(nvars (length variables))
(continuation (and more? (make-label 'let))))
(append
; The body of the let will be in the form of a compiled procedure we
; will invoke with APPLY. If we're not in tail context, we need to
; catch that apply so that execution can proceed in line.
(if continuation `((save ,continuation)) '())
(let init-loop ((rest initializers) ; generate code for all the
(code '())) ; initializers.
(if (null? rest)
code
(init-loop (cdr rest)
(append code
; NB: for named let, the initializers
; are _not_ compiled in an evironment
; containing the procedure body.
(compile-exp (car rest) env #t #t)))))
(compile-procedure-body #f variables body let-env #f #t)
; Named-let: the closure must be created in an environment where
; the let-name is bound, but we can't bind the value until the
; closure is created.
(code-if name '(unassn)
'(extend!)) ; reserve envt space
`((proc)) ; create closure
(if name `((dup) (lset 0 0)) '()) ; install in env, if named
`((apply ,nvars)) ; invoke procedure
(code-if (not val?) `(pop)) ; discard value if it's not wanted
(code-if continuation `(label ,continuation))
(code-if (not more?) '(return)))))
; compile-letrec: letrec is tricky. We compile the form
;
; (letrec ((u1 v1) (u2 v2)...) x1 x2...)
;
; as though it were written
;
; (let ((u1 *) (u2 *)...)
; (set! u1 v1)
; (set! u2 v2)...
; x1 x2...)
;
; The *'s represent values which will signal if an lref
; instruction tries to fetch them out of the environment.
(define (compile-letrec variables initializers body env more? val?)
(let ((prologue (_map2 (lambda (var init) `(set! ,var ,init))
variables
initializers))
(continuation (and more? (make-label 'letrec))))
(append
;; We will call the letrec body with apply, so we must
;; save a continuation if we are not in tail context.
(code-if continuation `(save ,continuation))
;; push enough unspecified values to bind all the letrec
;; values
(_map (lambda (_) '(unassn)) variables)
(compile-procedure-body prologue variables body env #f #t)
`((proc)
(apply ,(length variables)))
(code-if continuation `(label ,continuation))
(code-if (not val?) '(pop))
(code-if (not more?) '(return)))))
(define (compile-arguments args env)
(let loop ((rest args)
(code '()))
(if (null? rest)
code
(loop (cdr rest)
; an argument slot cannot be tail-recursive, so we
; set more? to #t when compiling arguments. Likewise,
; their values are always needed.
(append code (compile-exp (car rest) env #t #t))))))
; Arg-shape: analyze an argument list. Returns a list; the
; first element is the number of mandatory arguments and
; the second is #t if there are optional arguments. The
; third element is the 'smoothed' list of argument names.
;
; arg list shape
; x (0 #t (x))
; (u v) (2 #f (u v))
; (u . x) (1 #t (u x))
(define (arg-shape args)
(let loop ((regular-args 0)
(rest args)
(flat '()))
(cond
((null? rest)
(list regular-args #f flat))
((pair? rest)
(loop (+ regular-args 1) (cdr rest) (append flat (list (car rest)))))
(else
(list regular-args #t (append flat (list rest)))))))
; compile-procedure-body
;
; Generate code to leave a compiled procedure on the top of the stack.
;
; Args is the argument list. This can be improper, as can the first
; argument of (lambda). Prologue contains a code sequence that should
; logically precede the execution of the body, but be evaluated in an
; environment in which all arguments and internal definitions are
; accessible (example: installation of the values of a letrec
; expression). Body is the instruction sequence itself, which can
; contain internal defines. Env, more?, val? are used in the typical
; way.
(define (compile-procedure-body prologue args body env more? val?)
(let* ((shape (arg-shape args))
(nargs (car shape))
(extender (if (cadr shape) 'extend. 'extend))
(extended-env (extend-environment env (caddr shape))))
; Do we need to scan out defines?
(list `(code ,(assemble
(append
`((,extender ,nargs))
(if prologue
(compile-simple-sequence prologue extended-env #t #f)
'())
(compile-sequence body extended-env more? val?)
; procedures end with 'return': it's just that simple!
'((return))
))))))
;; determine whether the code fragment in proc-code is merely a
;; one-instruction reference to a symbol in the global environment,
;; and that symbol is a member of the set of inline procedures
;; we wish to invoke using the subr opcode (or a dedicated opcode).
;; If so, return the invoking code, else #f.
(define (inline-procedure-exp? proc-code n-args)
(and
(= (length proc-code) 1)
(eq? (caar proc-code) 'gref)
(let ((symbol (cadar proc-code)))
(cond ((memq symbol *inline-procedures*)
`((,symbol ,n-args)))
; Check to see if the function is a primitive procedure
; in this implementation: we can use a shortcut form
; of function invocation in that case.
((and (bound? symbol)
(primitive-procedure? (symbol-value symbol)))
`((subr ,symbol ,n-args)))
(else #f)))))
(define (compile-apply proc args env more? val?)
(let* ((proc-code (compile-exp proc env #t #t))
(n-args (length args))
(inline-procedure (inline-procedure-exp? proc-code n-args))
(continuation (and more?
(not inline-procedure)
(make-label 'cont))))
(append
(code-if continuation `(save ,continuation))
(compile-arguments args env)
(or inline-procedure
(append
proc-code
`((apply ,n-args))))
(code-if continuation `(label ,continuation))
(if (not val?) `((pop)) '())
(if (not more?)
`((return))
'()))))
(define (compile-do args env more? val?)
(let* ((bindings (car args))
(test-exit (cadr args))
(test (car test-exit))
(exit (cdr test-exit))
(iterate (cddr args))
(loop-symbol 'do-loop)) ; XXX (gensym)
(let* ((increment (let loop ((rest bindings)
(code '()))
(if (null? rest)
code
(if (null? (cddar rest))
(loop (cdr rest)
; no step-expression: continue with
; variable name
(append code (list (caar rest))))
(loop (cdr rest)
; insert step expression
(append code (list (caddar rest))))))))
(augmented-body `((if ,test
(begin ,@exit)
(begin ,@iterate
(,loop-symbol ,@increment))))))
(compile-let loop-symbol
(_map car bindings)
(_map cadr bindings)
augmented-body
env more? val?))))
;;; =========================
;;; MACROS AND QUASIQUOTATION
;;; =========================
;; compile a macro: construct a let-expression which will bind the
;; formals to the unevaluated actuals, including the body of the
;; macro. Evaluate this, and then compile the resulting code.
(define (compile-macro macro args env more? val?)
(let* ((formals (cadr macro))
(body (caddr macro))
(let-bindings (let loop ((bindings '())
(rest-formals formals)
(rest-actuals args))
(if (null? rest-formals) bindings
(loop
(append bindings
`((,(car rest-formals)
(quote ,(car rest-actuals)))))
(cdr rest-formals)
(cdr rest-actuals)))))
(macro-form `(let ,let-bindings ,body))
(expansion (eval macro-form)))
(compile-exp expansion env more? val?)))
;;; This Quasiquotation expander is based on that given in [PAIP p. 824],
;;; translated into Scheme. That implementation does not keep track of the
;;; "quasiquotation depth" as required by the R4/5 standard; that's fixed
;;; in the version here.
(define (expand-quasiquotation form)
(define (quasi-q depth x)
(cond
((vector? x)
(list 'list->vector (quasi-q depth (vector->list x))))
((not (pair? x))
(if (constant? x) x (list 'quote x)))
((starts-with x 'unquote)
(if (= depth 0)
(cadr x)
(combine-quasiquote (list 'quote 'unquote)
(quasi-q (- depth 1) (cdr x)) x)))
((starts-with x 'quasiquote)
; PAIP: (quasi-q (quasi-q (cadr x))))
(combine-quasiquote (list 'quote 'quasiquote)
(quasi-q (+ depth 1) (cdr x)) x))
((starts-with (car x) 'unquote-splicing)
; XXX respect QQ depth for unquote-splicing too!
(if (null? (cdr x))
(cadr (car x))
(list 'append (cadr (car x)) (quasi-q depth (cdr x)))))
(else
(combine-quasiquote (quasi-q depth (car x))
(quasi-q depth (cdr x)) x))))
(define (combine-quasiquote left right x)
(cond ((and (constant? left) (constant? right))
(let ((eval-left (eval left))
(eval-right (eval right)))
(if (and (eqv? eval-left (car x))
(eqv? eval-right (cdr x)))
(list 'quote x)
(list 'quote (cons eval-left eval-right)))))
((null? right)
(list 'list left))
((starts-with right 'list)
(apply list 'list left (cdr right)))
(else
(list 'cons left right))))
;; Main entry point: Initiate quasiquotation expansion at depth zero.
(quasi-q 0 form))
;;; Quasi-q refers to Common Lisp's (constantp); we implement
;;; that here as (constant?).
(define (self-evaluating? form)
(not (or (pair? form)
(symbol? form))))
;; For the purposes of quasiquotation, a form is Constant if
;; it's self-evaluating but not a symbol, or is the trivially
;; constant form (quote <something>).
(define (constant? x)
(or (self-evaluating? x)
(starts-with x 'quote)))
;;; ----------------------------------------------------------------------
(define (compile-exp form env more? val?)
(cond
((pair? form)
;; we must compute a compound's value no matter what,
;; in the event there are side-effects; if the value
;; is not wanted, we discard it.
(append (compile-compound form env more? #t)
(if val? '() '((pop)))))
((symbol? form)
(append
(if val?
(let ((location (locate-local-variable env form)))
(if location
(list `(lref ,(car location) ,(cdr location)))
(list `(gref ,form))))
'())
(if (not more?)
'((return))
'())))
(else ;self-evaluating
(form-returning form more? val?))))
(assemble (compile-exp form '() #f #t)))
;; ======
;; LINKER
;; ======
;;
;; The code produced from the compiler in the form of a tree of vectors,
;; and each instruction is represented in the form '(op arg...). The
;; "linker" phase collapses the nested vectors into a single linear
;; vector, fixing up offsets as it goes. It also stores instructions
;; in a compact atom format using by calling into make-instruction.
;; The instruction-vector returned from this procedure is suitable for
;; execution by the C-language virtual machine.
;; XXX add instruction factory parameter and unify with link2.
(define (link program)
(let ((output (make-vector 0))
(output-index 0)
(procedure-queue (make-vector 1 (cons program #f)))
(literal-queue (make-vector 0)))
(define (segment-relative-operand? opcode)
(memq opcode '(save true? true?p false? false?p goto)))
(define (process-one-procedure proc)
(let* ((insns (car proc))
(n-insns (vector-length insns))
(section-offset (vector-length output))
(fixup (cdr proc)))
(if fixup
;; verify that the indicated slot has the fixup
;; token in it, then install the current output
;; index.
(if (eq? (vector-ref output fixup) 'fixup)
(vector-set! output fixup (list
'consti
(vector-length output)))
(begin
(display (vector-ref output fixup))
(error "bad fixup"))))
;; process instructions
(do ((i 0 (+ i 1)))
((= i n-insns) 'ok)
(let* ((insn (vector-ref insns i))
(opcode (car insn)))
(cond
((eq? opcode 'code)
;; we found another vector of instructions: add it
;; to the queue to be flattened, consed with this
;; instruction's address, so the address can be
;; patched later. Leave a fixup token in this insn
;; slot.
(vector-push! output 'fixup)
(vector-push! procedure-queue (cons (cadr insn)
(- (vector-length output) 1))))
((segment-relative-operand? opcode)
;; if it's a branch or save instruction, the operand
;; is an index relative to this segment, which must
;; be fixed up.
(vector-push! output (list opcode
(+ (cadr insn) section-offset))))
(else
;; ordinary instruction
(vector-push! output insn)))))))
;; while there are still procedures on the queue, process them.
(let loop ()
(if (> (vector-length procedure-queue) 0)
(begin
(process-one-procedure (vector-shift! procedure-queue))
(loop))))
output))
(define (link2 program)
(let ((output (make-vector 0))
(output-index 0)
(procedure-queue (make-vector 1 (cons program #f)))
(literal-queue (make-vector 0)))
(define (segment-relative-operand? opcode)
(memq opcode '(save true? true?p false? false?p goto)))
(define (add-literal literal-queue literal)
;; Add the given literal to the vector and return the index.
;; Re-use an entry if one is already there. XXX: linear search.
(let loop ((index 0))
(cond
((= index (vector-length literal-queue))
;; item wasn't found. Add it.
(vector-push! literal-queue literal)
(- (vector-length literal-queue) 1))
((equal? literal (vector-ref literal-queue index))
;; found item: return index
index)
(else
;; keep looking
(loop (+ index 1))))))
(define (process-one-procedure proc)
(let* ((insns (car proc))
(n-insns (vector-length insns))
(section-offset (vector-length output))
(fixup (cdr proc)))
(if fixup
;; verify that the indicated slot has the fixup
;; token in it, then install the current output
;; index.
(if (eq? (vector-ref output fixup) 'fixup)
(vector-set! output fixup
(make-instruction 'consti (vector-length output)))
(begin
(display (vector-ref output fixup))
(error "bad fixup"))))
;; process instructions
(do ((i 0 (+ i 1)))
((= i n-insns) 'ok)
(let* ((insn (vector-ref insns i))
(opcode (car insn)))
(cond
((eq? opcode 'code)
;; we found another vector of instructions: add it
;; to the queue to be flattened, consed with this
;; instruction's address, so the address can be
;; patched later. Leave a fixup token in this insn
;; slot.
(vector-push! output 'fixup)
(vector-push! procedure-queue
(cons (cadr insn)
(- (vector-length output) 1))))
((segment-relative-operand? opcode)
;; if it's a branch or save instruction, the operand
;; is an index relative to this segment, which must
;; be fixed up.
(vector-push! output (make-instruction
opcode
(+ (cadr insn) section-offset))))
((eq? opcode 'const)
;; pushing a literal value. Add the value to the literal
;; queue, and substitute and instruction that will reference
;; it.
(let* ((operand (cadr insn))
(literal-index (add-literal literal-queue operand)))
(vector-push! output (make-instruction 'lit literal-index))))
(else
;; ordinary instruction
(vector-push! output (apply make-instruction insn))))))))
;; while there are still procedures on the queue, process them.
(let loop ()
(if (> (vector-length procedure-queue) 0)
(begin
(process-one-procedure (vector-shift! procedure-queue))
(loop))))
;; The internal format of a compiled procedure is a vector
;; containing the instruction vector and the literal pool.
(make-compiled-procedure output literal-queue)))