scsh-0.5/bcomp/comp.scm

; -*- 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)))