574 lines
17 KiB
Scheme
574 lines
17 KiB
Scheme
; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
|
|
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
|
|
|
|
|
|
; This is file comp.scm.
|
|
|
|
;;;; The byte-code compiler
|
|
|
|
; This is a two-phase compiler. The first phase does macro expansion,
|
|
; variable resolution, and instruction selection, and computes the
|
|
; size of the code vector. The second phase (assembly) creates the
|
|
; code vector, "template" (literals vector), and debugging data
|
|
; structures.
|
|
|
|
; The output of the first phase (the COMPILE- and INSTRUCTION-
|
|
; routines) and the input to the second phase (SEGMENT->TEMPLATE) is a
|
|
; "segment." A segment is a pair (size . proc) where size is the size
|
|
; of the code segment in bytes, and proc is a procedure that during
|
|
; phase 2 will store the segment's bytes into the code vector.
|
|
|
|
; A "cenv" maps lexical variables to <level, offset> pairs. Level is
|
|
; the variable's distance from the root of the environment; 0 means
|
|
; outermost level, and higher numbers mean deeper lexical levels. The
|
|
; offset is the position of the variable within its level's
|
|
; environment vector.
|
|
|
|
; Optimizations are marked with +++, and may be flushed if desired.
|
|
|
|
|
|
(define (compile-top exp cenv depth cont)
|
|
(compile exp (initial-cenv cenv) depth cont))
|
|
|
|
|
|
; Main dispatch for compiling a single expression.
|
|
|
|
(define (compile exp cenv depth cont)
|
|
(let ((node (type-check (classify exp cenv) cenv)))
|
|
((operator-table-ref compilators (node-operator-id node))
|
|
node
|
|
cenv
|
|
depth
|
|
cont)))
|
|
|
|
; Specialists
|
|
|
|
(define compilators
|
|
(make-operator-table (lambda (node cenv depth cont)
|
|
(generate-trap cont
|
|
"not valid in expression context"
|
|
(schemify node cenv)))
|
|
(lambda (frob) ;for let-syntax, with-aliases, etc.
|
|
(lambda (node cenv depth cont)
|
|
(call-with-values (lambda () (frob node cenv))
|
|
(lambda (form cenv)
|
|
(compile form cenv depth cont)))))))
|
|
|
|
(define (define-compilator name type proc)
|
|
(operator-define! compilators name type proc))
|
|
|
|
(define-compilator 'literal #f
|
|
(lambda (node cenv depth cont)
|
|
(let ((obj (node-form node)))
|
|
(if (eq? obj #f)
|
|
;; +++ hack for bootstrap from Schemes that don't distinguish #f/()
|
|
(deliver-value (instruction (enum op false)) cont)
|
|
(compile-constant obj depth cont)))))
|
|
|
|
(define-compilator 'quote syntax-type
|
|
(lambda (node cenv depth cont)
|
|
(let ((exp (node-form node)))
|
|
cenv ;ignored
|
|
(let ((obj (cadr exp)))
|
|
(compile-constant obj depth cont)))))
|
|
|
|
(define (compile-constant obj depth cont)
|
|
(if (ignore-values-cont? cont)
|
|
empty-segment ;+++ dead code
|
|
(deliver-value (instruction-with-literal (enum op literal) obj)
|
|
cont)))
|
|
|
|
; Variable reference
|
|
|
|
(define-compilator 'name #f
|
|
(lambda (node cenv depth cont)
|
|
(let* ((binding (name-node-binding node cenv))
|
|
(name (node-form node)))
|
|
(deliver-value (if (and (binding? binding)
|
|
(pair? (binding-place binding)))
|
|
(let* ((level+over (binding-place binding))
|
|
(back (- (environment-level cenv)
|
|
(car level+over)))
|
|
(over (cdr level+over)))
|
|
(case back
|
|
((0) (instruction (enum op local0) over)) ;+++
|
|
((1) (instruction (enum op local1) over)) ;+++
|
|
((2) (instruction (enum op local2) over)) ;+++
|
|
(else (instruction (enum op local) back over))))
|
|
(instruction-with-location
|
|
(enum op global)
|
|
(get-location binding cenv name value-type)))
|
|
cont))))
|
|
|
|
; Assignment
|
|
|
|
(define-compilator 'set! syntax-type
|
|
(lambda (node cenv depth cont)
|
|
(let* ((exp (node-form node))
|
|
(lhs-node (classify (cadr exp) cenv))
|
|
(name (node-form lhs-node))
|
|
;; Error if not a name node...
|
|
(binding (name-node-binding lhs-node cenv)))
|
|
(sequentially
|
|
(compile (caddr exp) cenv depth (named-cont name))
|
|
(deliver-value
|
|
(if (and (binding? binding) (pair? (binding-place binding)))
|
|
(let ((level+over (binding-place binding)))
|
|
(instruction (enum op set-local!)
|
|
(- (environment-level cenv) (car level+over))
|
|
(cdr level+over)))
|
|
(instruction-with-location (enum op set-global!)
|
|
(get-location binding cenv name usual-variable-type)))
|
|
cont)))))
|
|
|
|
; Conditional
|
|
|
|
(define-compilator 'if syntax-type
|
|
(lambda (node cenv depth cont)
|
|
(let ((exp (node-form node))
|
|
(alt-label (make-label))
|
|
(join-label (make-label)))
|
|
(sequentially
|
|
;; Test
|
|
(compile (cadr exp) cenv depth (fall-through-cont node 1))
|
|
(instruction-using-label (enum op jump-if-false) alt-label)
|
|
;; Consequent
|
|
(compile (caddr exp) cenv depth cont)
|
|
(if (fall-through-cont? cont)
|
|
(instruction-using-label (enum op jump) join-label)
|
|
empty-segment)
|
|
;; Alternate
|
|
(attach-label alt-label
|
|
(compile (cadddr exp) cenv depth cont))
|
|
(attach-label join-label
|
|
empty-segment)))))
|
|
|
|
|
|
(define-compilator 'begin syntax-type
|
|
(lambda (node cenv depth cont)
|
|
(let ((exp (node-form node)))
|
|
(compile-begin (cdr exp) cenv depth cont))))
|
|
|
|
(define compile-begin
|
|
(let ((operator/begin (get-operator 'begin)))
|
|
(lambda (exp-list cenv depth cont)
|
|
(if (null? exp-list)
|
|
(generate-trap cont "null begin")
|
|
(let ((dummy
|
|
(make-node operator/begin ;For debugging database
|
|
`(begin ,@exp-list))))
|
|
(let loop ((exp-list exp-list) (i 1))
|
|
(if (null? (cdr exp-list))
|
|
(compile (car exp-list) cenv depth cont)
|
|
(careful-sequentially
|
|
(compile (car exp-list) cenv depth
|
|
(ignore-values-cont dummy i))
|
|
(loop (cdr exp-list) (+ i 1))
|
|
depth
|
|
cont))))))))
|
|
|
|
|
|
; Compile a call
|
|
|
|
(define (compile-call node cenv depth cont)
|
|
(if (node-ref node 'type-error)
|
|
(compile-unknown-call node cenv depth cont)
|
|
(let ((proc-node (classify (car (node-form node)) cenv)))
|
|
(if (and (lambda-node? proc-node)
|
|
(not (n-ary? (cadr (node-form proc-node)))))
|
|
(compile-redex proc-node (cdr (node-form node)) cenv depth cont)
|
|
(let ((new-node (maybe-transform-call proc-node node cenv)))
|
|
(if (eq? new-node node)
|
|
(compile-unknown-call node cenv depth cont)
|
|
(compile new-node cenv depth cont)))))))
|
|
|
|
(define-compilator 'call #f compile-call)
|
|
|
|
|
|
; A redex is a call of the form ((lambda (x1 ... xn) body ...) e1 ... en).
|
|
|
|
(define lambda-node? (node-predicate 'lambda))
|
|
|
|
(define (compile-redex proc-node args cenv depth cont)
|
|
(let* ((proc-exp (node-form proc-node))
|
|
(formals (cadr proc-exp))
|
|
(body (cddr proc-exp)))
|
|
(if (null? formals)
|
|
(compile-body body cenv depth cont) ;+++
|
|
(maybe-push-continuation
|
|
(sequentially
|
|
(push-all-with-names args formals cenv 0)
|
|
(compile-lambda-code formals body cenv (cont-name cont)))
|
|
depth
|
|
cont))))
|
|
|
|
; Compile a call to a computed procedure.
|
|
|
|
(define (compile-unknown-call node cenv depth cont)
|
|
(let ((exp (node-form node)))
|
|
(let ((call (sequentially (push-arguments node cenv 0)
|
|
(compile (car exp)
|
|
cenv
|
|
(length (cdr exp))
|
|
(fall-through-cont node 0))
|
|
(instruction (enum op call) (length (cdr exp))))))
|
|
(maybe-push-continuation call depth cont))))
|
|
|
|
(define (maybe-push-continuation code depth cont)
|
|
(if (return-cont? cont)
|
|
code
|
|
(let ((label (make-label)))
|
|
(sequentially (instruction-using-label (enum op make-cont)
|
|
label
|
|
depth)
|
|
(note-source-code (cont-source-info cont)
|
|
code)
|
|
(attach-label label
|
|
(cont-segment cont))))))
|
|
|
|
; Continuation is implicitly fall-through.
|
|
|
|
(define (push-arguments node cenv depth)
|
|
(let recur ((args (cdr (node-form node))) (depth depth) (i 1))
|
|
(if (null? args)
|
|
empty-segment
|
|
(sequentially (compile (car args) cenv depth
|
|
(fall-through-cont node i))
|
|
(instruction (enum op push))
|
|
(recur (cdr args) (+ depth 1) (+ i 1))))))
|
|
|
|
(define (push-all-with-names exp-list names cenv depth)
|
|
(if (null? exp-list)
|
|
empty-segment
|
|
(sequentially (compile (car exp-list)
|
|
cenv depth
|
|
(named-cont (car names)))
|
|
(instruction (enum op push))
|
|
(push-all-with-names (cdr exp-list)
|
|
(cdr names)
|
|
cenv
|
|
(+ depth 1)))))
|
|
|
|
; OK, now that you've got all that under your belt, here's LAMBDA.
|
|
|
|
(define-compilator 'lambda syntax-type
|
|
(lambda (node cenv depth cont)
|
|
(let ((exp (node-form node))
|
|
(name (cont-name cont)))
|
|
(deliver-value
|
|
(instruction-with-template (enum op closure)
|
|
(compile-lambda exp
|
|
cenv
|
|
;; Hack for constructors.
|
|
;; Cf. disclose method
|
|
;; (if name #t #f)
|
|
#f)
|
|
name)
|
|
cont))))
|
|
|
|
(define (compile-lambda exp cenv body-name)
|
|
(let* ((formals (cadr exp))
|
|
(nargs (number-of-required-args formals)))
|
|
(sequentially
|
|
;; Check number of arguments
|
|
(if (n-ary? formals)
|
|
(if (pair? formals)
|
|
(instruction (enum op check-nargs>=) nargs)
|
|
empty-segment) ;+++ (lambda x ...) needs no check
|
|
(instruction (enum op check-nargs=) nargs))
|
|
(compile-lambda-code formals (cddr exp) cenv body-name))))
|
|
|
|
; name isn't the name of the procedure, it's the name to be given to
|
|
; the value that the procedure will return.
|
|
|
|
(define (compile-lambda-code formals body cenv name)
|
|
(if (null? formals)
|
|
(compile-body body ;+++ Don't make null environment
|
|
cenv
|
|
0
|
|
(return-cont name))
|
|
;; (if (node-ref node 'no-inferior-lambdas) ...)
|
|
(sequentially
|
|
(let ((nargs (number-of-required-args formals)))
|
|
(if (n-ary? formals)
|
|
(sequentially
|
|
(instruction (enum op make-rest-list) nargs)
|
|
(instruction (enum op push))
|
|
(instruction (enum op make-env) (+ nargs 1)))
|
|
(instruction (enum op make-env) nargs)))
|
|
(let* ((vars (normalize-formals formals))
|
|
(cenv (bind-vars (reverse vars) cenv)))
|
|
(note-environment
|
|
vars
|
|
(compile-body body
|
|
cenv
|
|
0
|
|
(return-cont name)))))))
|
|
|
|
(define compile-letrec
|
|
(let ((operator/lambda (get-operator 'lambda syntax-type))
|
|
(operator/set! (get-operator 'set! syntax-type))
|
|
(operator/call (get-operator 'call))
|
|
(operator/unassigned (get-operator 'unassigned)))
|
|
(lambda (node cenv depth cont)
|
|
;; (if (node-ref node 'pure-letrec) ...)
|
|
(let* ((exp (node-form node))
|
|
(specs (cadr exp))
|
|
(body (cddr exp)))
|
|
(compile-redex (make-node operator/lambda
|
|
`(lambda ,(map car specs)
|
|
,@(map (lambda (spec)
|
|
(make-node operator/set!
|
|
`(set! ,@spec)))
|
|
specs)
|
|
,(make-node
|
|
operator/call
|
|
`(,(make-node operator/lambda
|
|
`(lambda () ,@body))))))
|
|
(map (lambda (spec)
|
|
(make-node operator/unassigned
|
|
`(unassigned)))
|
|
specs)
|
|
cenv depth cont)))))
|
|
|
|
(define-compilator 'letrec syntax-type compile-letrec)
|
|
|
|
; --------------------
|
|
; Deal with internal defines (ugh)
|
|
|
|
(define (compile-body body cenv depth cont)
|
|
(scan-body body
|
|
cenv
|
|
(lambda (defs exps)
|
|
(if (null? defs)
|
|
(compile-begin exps cenv depth cont)
|
|
(compile-letrec
|
|
(make-node operator/letrec
|
|
`(letrec ,(map (lambda (node)
|
|
(cdr (node-form node)))
|
|
defs)
|
|
,@exps))
|
|
cenv depth cont)))))
|
|
|
|
(define operator/letrec (get-operator 'letrec))
|
|
|
|
; --------------------
|
|
; Compile-time continuations
|
|
;
|
|
; A compile-time continuation is a pair (segment . name). Segment is
|
|
; one of the following:
|
|
; a return instruction - invoke the current full continuation.
|
|
; empty-segment - fall through to subsequent instructions.
|
|
; an ignore-values instruction - ignore values, then fall through.
|
|
; If name is non-#f, then the value delivered to subsequent
|
|
; instructions will be assigned to a variable. If the value being
|
|
; assigned is a lambda, we can give that lambda that name, for
|
|
; debugging purposes.
|
|
|
|
(define (make-cont seg source-info) (cons seg source-info))
|
|
(define cont-segment car)
|
|
(define cont-source-info cdr)
|
|
|
|
; Eventually we may be able to optimize jumps to jumps. Can't yet.
|
|
;(define (make-jump-cont jump cont)
|
|
; (if (fall-through-cont? cont)
|
|
; (make-cont jump (cont-name cont))
|
|
; cont))
|
|
|
|
(define return-cont-segment (instruction (enum op return)))
|
|
|
|
(define (return-cont name)
|
|
(make-cont return-cont-segment name))
|
|
|
|
(define (return-cont? cont)
|
|
(eq? (cont-segment cont) return-cont-segment))
|
|
|
|
; Fall through into next instruction
|
|
|
|
(define (fall-through-cont node i)
|
|
(make-cont empty-segment (cons i node)))
|
|
|
|
(define (fall-through-cont? cont)
|
|
(not (return-cont? cont)))
|
|
|
|
; Ignore return value, then fall through
|
|
|
|
(define ignore-values-segment
|
|
(instruction (enum op ignore-values)))
|
|
|
|
(define (ignore-values-cont node i)
|
|
(make-cont ignore-values-segment (cons i node)))
|
|
|
|
(define (ignore-values-cont? cont)
|
|
(eq? (cont-segment cont) ignore-values-segment))
|
|
|
|
; Value is in *val*; deliver it to its continuation.
|
|
; No need to generate an ignore-values instruction in this case.
|
|
|
|
(define (deliver-value segment cont)
|
|
(if (ignore-values-cont? cont) ;+++
|
|
segment
|
|
(sequentially segment (cont-segment cont))))
|
|
|
|
; For putting names to lambda expressions:
|
|
|
|
(define (named-cont name)
|
|
(make-cont empty-segment name))
|
|
|
|
(define (cont-name cont)
|
|
(if (pair? (cont-source-info cont))
|
|
#f
|
|
(cont-source-info cont)))
|
|
|
|
; --------------------
|
|
; Compile-time environments
|
|
|
|
(define (bind-vars names cenv)
|
|
(let ((level (+ (environment-level cenv) 1)))
|
|
(lambda (name)
|
|
(if (eq? name funny-name/lexical-level)
|
|
level
|
|
(let loop ((over 1) (names names))
|
|
(cond ((null? names)
|
|
(lookup cenv name))
|
|
((eq? name (car names))
|
|
(make-binding usual-variable-type (cons level over) #f))
|
|
(else (loop (+ over 1) (cdr names)))))))))
|
|
|
|
(define (initial-cenv cenv)
|
|
(bind1 funny-name/lexical-level -1 cenv))
|
|
|
|
(define (environment-level cenv)
|
|
(lookup cenv funny-name/lexical-level))
|
|
|
|
(define funny-name/lexical-level (string->symbol "Lexical nesting level"))
|
|
|
|
; Find lookup result that was cached by classifier
|
|
|
|
(define (name-node-binding node cenv)
|
|
(or (node-ref node 'binding)
|
|
(node-form node))) ; = (lookup cenv (node-form node))
|
|
|
|
|
|
; --------------------
|
|
; Utilities
|
|
|
|
; Produce something for source code that contains a compile-time error.
|
|
|
|
(define (generate-trap cont . stuff)
|
|
(apply warn stuff)
|
|
(sequentially (instruction-with-literal (enum op literal)
|
|
(cons 'error stuff))
|
|
(deliver-value (instruction (enum op trap))
|
|
cont)))
|
|
|
|
; Make a segment smaller, if it seems necessary, by introducing an
|
|
; extra template. A segment is "too big" if it accesses more literals
|
|
; than the size of the operand in a literal-accessing instruction.
|
|
; The number of literals is unknowable given current representations,
|
|
; so we conservatively shrink the segment when its size exceeds 2
|
|
; times the largest admissible operand value, figuring that it takes
|
|
; at least 2 instruction bytes to use a literal.
|
|
|
|
(define (careful-sequentially seg1 seg2 depth cont)
|
|
(if (and (= depth 0)
|
|
(> (+ (segment-size seg1) (segment-size seg2))
|
|
large-segment-size))
|
|
(if (> (segment-size seg1) (segment-size seg2))
|
|
(sequentially (shrink-segment seg1 (fall-through-cont #f #f))
|
|
seg2)
|
|
(sequentially seg1
|
|
(shrink-segment seg2 cont)))
|
|
(sequentially seg1 seg2)))
|
|
|
|
(define large-segment-size (* byte-limit 2))
|
|
|
|
(define (shrink-segment seg cont)
|
|
(maybe-push-continuation
|
|
(sequentially (instruction-with-template
|
|
(enum op closure)
|
|
(if (return-cont? cont)
|
|
seg
|
|
(sequentially seg
|
|
(instruction (enum op return))))
|
|
#f)
|
|
(instruction (enum op call) 0))
|
|
0
|
|
cont))
|
|
|
|
; --------------------
|
|
; Type checking. This gets called on all nodes.
|
|
|
|
(define (type-check node cenv)
|
|
(if *type-check?*
|
|
(let ((form (node-form node)))
|
|
(if (pair? form)
|
|
(let ((proc-node (car form)))
|
|
(if (node? proc-node)
|
|
(let ((proc-type (node-type proc-node cenv)))
|
|
(cond ((procedure-type? proc-type)
|
|
(if (restrictive? proc-type)
|
|
(let* ((args (if (eq? *type-check?* 'heavy)
|
|
(map (lambda (exp)
|
|
(classify exp cenv))
|
|
(cdr form))
|
|
(cdr form)))
|
|
(args-type (make-some-values-type
|
|
(map (lambda (arg)
|
|
(meet-type
|
|
(node-type arg cenv)
|
|
value-type))
|
|
args)))
|
|
(node (make-similar-node node
|
|
(cons proc-node
|
|
args))))
|
|
(if (not (meet? args-type
|
|
(procedure-type-domain proc-type)))
|
|
(diagnose-call-error node proc-type cenv))
|
|
node)
|
|
node))
|
|
((not (meet? proc-type any-procedure-type))
|
|
;; Could also check args for one-valuedness.
|
|
(let ((message "non-procedure in operator position"))
|
|
(warn message
|
|
(schemify node cenv)
|
|
`(procedure: ,proc-type))
|
|
(node-set! node 'type-error message))
|
|
node)
|
|
(else node)))
|
|
node))
|
|
node))
|
|
node))
|
|
|
|
(define (set-type-check?! check?)
|
|
(set! *type-check?* check?))
|
|
|
|
(define *type-check?* 'heavy)
|
|
|
|
|
|
(define (diagnose-call-error node proc-type cenv)
|
|
(let ((message
|
|
(cond ((not (fixed-arity-procedure-type? proc-type))
|
|
"invalid arguments")
|
|
((= (procedure-type-arity proc-type)
|
|
(length (cdr (node-form node))))
|
|
"argument type error")
|
|
(else
|
|
"wrong number of arguments"))))
|
|
(warn message
|
|
(schemify node cenv)
|
|
`(procedure wants:
|
|
,(rail-type->sexp (procedure-type-domain proc-type)
|
|
#f))
|
|
`(arguments are: ,(map (lambda (arg)
|
|
(type->sexp (node-type arg cenv) #t))
|
|
(cdr (node-form node)))))
|
|
(node-set! node 'type-error message)))
|
|
|
|
|
|
; Type system loophole
|
|
|
|
(define-compilator 'loophole syntax-type
|
|
(lambda (node cenv depth cont)
|
|
(compile (caddr (node-form node)) cenv depth cont)))
|