972 lines
32 KiB
Scheme
972 lines
32 KiB
Scheme
;; 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)))
|
|
|