guile/gc-benchmarks/larceny/twobit-input-long.sch

; Complete source for Twobit and Sparc assembler in one file.
; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
;
; See 'twobit-benchmark', at end.

; Copyright 1998 Lars T Hansen.
;
; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
;
; Completely fundamental pathname manipulation.

; This takes zero or more directory components and a file name and
; constructs a filename relative to the current directory.

(define (make-relative-filename . components)

  (define (construct l)
    (if (null? (cdr l))
	l
	(cons (car l)
	      (cons "/" (construct (cdr l))))))

  (if (null? (cdr components))
      (car components)
      (apply string-append (construct components))))

; This takes one or more directory components and constructs a 
; directory name with proper termination (a crock -- we can finess 
; this later).

(define (pathname-append . components)

  (define (construct l)
    (cond ((null? (cdr l))
	   l)
	  ((string=? (car l) "")
	   (construct (cdr l)))
          ((char=? #\/ (string-ref (car l) (- (string-length (car l)) 1)))
           (cons (car l) (construct (cdr l))))
	  (else
	   (cons (car l)
		 (cons "/" (construct (cdr l)))))))

  (let ((n (if (null? (cdr components))
	       (car components)
	       (apply string-append (construct components)))))
    (if (not (char=? #\/ (string-ref n (- (string-length n) 1))))
	(string-append n "/")
	n)))

; eof
; Copyright 1998 Lars T Hansen.
;
; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
;
; Nbuild parameters for SPARC Larceny.

(define (make-nbuild-parameter dir source? verbose? hostdir hostname)
  (let ((parameters 
	 `((compiler       . ,(pathname-append dir "Compiler"))
	   (util           . ,(pathname-append dir "Util"))
	   (build          . ,(pathname-append dir "Rts" "Build"))
	   (source         . ,(pathname-append dir "Lib"))
           (common-source  . ,(pathname-append dir "Lib" "Common"))
           (repl-source    . ,(pathname-append dir "Repl"))
           (interp-source  . ,(pathname-append dir "Eval"))
           (machine-source . ,(pathname-append dir "Lib" "Sparc"))
	   (common-asm     . ,(pathname-append dir "Asm" "Common"))
	   (sparc-asm      . ,(pathname-append dir "Asm" "Sparc"))
	   (target-machine . SPARC)
	   (endianness     . big)
	   (word-size      . 32)
	   (always-source? . ,source?)
	   (verbose-load?  . ,verbose?)
	   (compatibility  . ,(pathname-append dir "Compat" hostdir))
	   (host-system    . ,hostname)
	   )))
    (lambda (key)
      (let ((probe (assq key parameters)))
	(if probe 
	    (cdr probe)
	    #f)))))

(define nbuild-parameter
  (make-nbuild-parameter "" #f #f "Larceny" "Larceny"))

; eof
; Copyright 1998 Lars T Hansen.
;
; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
;
; Useful list functions.
;
; Notes:
; * Reduce, reduce-right, fold-right, fold-left are compatible with MIT Scheme.
; * Make-list is compatible with MIT Scheme and Chez Scheme.
; * These are not (yet) compatible with Shivers's proposed list functions.
; * remq, remv, remove, remq!, remv!, remov!, every?, and some? are in the 
;   basic library.

; Destructively remove all associations whose key matches `key' from `alist'.

(define (aremq! key alist)
  (cond ((null? alist) alist)
	((eq? key (caar alist))
	 (aremq! key (cdr alist)))
	(else
	 (set-cdr! alist (aremq! key (cdr alist)))
	 alist)))

(define (aremv! key alist)
  (cond ((null? alist) alist)
	((eqv? key (caar alist))
	 (aremv! key (cdr alist)))
	(else
	 (set-cdr! alist (aremv! key (cdr alist)))
	 alist)))

(define (aremove! key alist)
  (cond ((null? alist) alist)
	((equal? key (caar alist))
	 (aremove! key (cdr alist)))
	(else
	 (set-cdr! alist (aremove! key (cdr alist)))
	 alist)))

; Return a list of elements of `list' selected by the predicate.

(define (filter select? list)
  (cond ((null? list) list)
	((select? (car list))
	 (cons (car list) (filter select? (cdr list))))
	(else
	 (filter select? (cdr list)))))

; Return the first element of `list' selected by the predicate.

(define (find selected? list)
  (cond ((null? list) #f)
	((selected? (car list)) (car list))
	(else (find selected? (cdr list)))))

; Return a list with all duplicates (according to predicate) removed.

(define (remove-duplicates list same?)

  (define (member? x list)
    (cond ((null? list) #f)
          ((same? x (car list)) #t)
          (else (member? x (cdr list)))))

  (cond ((null? list) list)
        ((member? (car list) (cdr list))
         (remove-duplicates (cdr list) same?))
        (else
         (cons (car list) (remove-duplicates (cdr list) same?)))))

; Return the least element of `list' according to some total order.

(define (least less? list)
  (reduce (lambda (a b) (if (less? a b) a b)) #f list))

; Return the greatest element of `list' according to some total order.

(define (greatest greater? list)
  (reduce (lambda (a b) (if (greater? a b) a b)) #f list))
  
; (mappend p l) = (apply append (map p l))

(define (mappend proc l)
  (apply append (map proc l)))

; (make-list n)   => (a1 ... an) for some ai
; (make-list n x) => (a1 ... an) where ai = x

(define (make-list nelem . rest)
  (let ((val (if (null? rest) #f (car rest))))
    (define (loop n l)
      (if (zero? n)
	  l
	  (loop (- n 1) (cons val l))))
    (loop nelem '())))

; (reduce p x ()) => x
; (reduce p x (a)) => a
; (reduce p x (a b ...)) => (p (p a b) ...))

(define (reduce proc initial l)

  (define (loop val l)
    (if (null? l)
        val
        (loop (proc val (car l)) (cdr l))))

  (cond ((null? l) initial)
	((null? (cdr l)) (car l))
	(else (loop (car l) (cdr l)))))

; (reduce-right p x ()) => x
; (reduce-right p x (a)) => a
; (reduce-right p x (a b ...)) => (p a (p b ...))

(define (reduce-right proc initial l)

  (define (loop l)
    (if (null? (cdr l))
	(car l)
	(proc (car l) (loop (cdr l)))))

  (cond ((null? l) initial)
	((null? (cdr l)) (car l))
	(else (loop l))))

; (fold-left p x (a b ...)) => (p (p (p x a) b) ...)

(define (fold-left proc initial l)
  (if (null? l)
      initial
      (fold-left proc (proc initial (car l)) (cdr l))))

; (fold-right p x (a b ...)) => (p a (p b (p ... x)))

(define (fold-right proc initial l)
  (if (null? l)
      initial
      (proc (car l) (fold-right proc initial (cdr l)))))

; (iota n) => (0 1 2 ... n-1)

(define (iota n)
  (let loop ((n (- n 1)) (r '()))
    (let ((r (cons n r)))
      (if (= n 0)
	  r
	  (loop (- n 1) r)))))

; (list-head (a1 ... an) m) => (a1 ... am)   for m <= n

(define (list-head l n)
  (if (zero? n)
      '()
      (cons (car l) (list-head (cdr l) (- n 1)))))

	
; eof
; Copyright 1998 Lars T Hansen.
;
; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
;
; Larceny -- compatibility library for Twobit running under Larceny.

(define ($$trace x) #t)

(define host-system 'larceny)

; Temporary?

(define (.check! flag exn . args)
  (if (not flag)
      (apply error "Runtime check exception: " exn args)))

; The compatibility library loads Auxlib if compat:initialize is called
; without arguments.  Compat:load will load fasl files when appropriate.

(define (compat:initialize . rest)
  (if (null? rest)
      (let ((dir (nbuild-parameter 'compatibility)))
	(compat:load (string-append dir "compat2.sch"))
	(compat:load (string-append dir "../../Auxlib/list.sch"))
	(compat:load (string-append dir "../../Auxlib/pp.sch")))))

(define (with-optimization level thunk) 
  (thunk))

; Calls thunk1, and if thunk1 causes an error to be signaled, calls thunk2.

(define (call-with-error-control thunk1 thunk2) 
  (let ((eh (error-handler)))
    (error-handler (lambda args
		     (error-handler eh)
		     (thunk2)
		     (apply eh args)))
    (thunk1)
    (error-handler eh)))

(define (larc-new-extension fn ext)
  (let* ((l (string-length fn))
	 (x (let loop ((i (- l 1)))
	      (cond ((< i 0) #f)
		    ((char=? (string-ref fn i) #\.) (+ i 1))
		    (else (loop (- i 1)))))))
    (if (not x)
	(string-append fn "." ext)
	(string-append (substring fn 0 x) ext))))

(define (compat:load filename)
  (define (loadit fn)
    (if (nbuild-parameter 'verbose-load?)
	(format #t "~a~%" fn))
    (load fn))
  (if (nbuild-parameter 'always-source?)
      (loadit filename)
      (let ((fn (larc-new-extension filename "fasl")))
	(if (and (file-exists? fn)
		 (compat:file-newer? fn filename))
	    (loadit fn)
	    (loadit filename)))))

(define (compat:file-newer? a b)
  (let* ((ta    (file-modification-time a))
	 (tb    (file-modification-time b))
	 (limit (vector-length ta)))
    (let loop ((i 0))
      (cond ((= i limit)
	     #f)
	    ((= (vector-ref ta i) (vector-ref tb i))
	     (loop (+ i 1)))
	    (else
	     (> (vector-ref ta i) (vector-ref tb i)))))))

; eof
; Copyright 1998 Lars T Hansen.
;
; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
;
; Larceny -- second part of compatibility code
; This file ought to be compiled, but doesn't have to be.
;
; 12 April 1999

(define host-system 'larceny)		; Don't remove this!

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
; A well-defined sorting procedure.

(define compat:sort (lambda (list less?) (sort list less?)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
; Well-defined character codes.
; Returns the UCS-2 code for a character.

(define compat:char->integer char->integer)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
; Input and output

(define (write-lop item port)
  (lowlevel-write item port)
  (newline port)
  (newline port))

(define write-fasl-datum lowlevel-write)

; The power of self-hosting ;-)

(define (misc->bytevector x)
  (let ((bv (bytevector-like-copy x)))
    (typetag-set! bv $tag.bytevector-typetag)
    bv))

(define string->bytevector misc->bytevector)

(define bignum->bytevector misc->bytevector)

(define (flonum->bytevector x)
  (clear-first-word (misc->bytevector x)))

(define (compnum->bytevector x)
  (clear-first-word (misc->bytevector x)))

; Clears garbage word of compnum/flonum; makes regression testing much
; easier.

(define (clear-first-word bv)
  (bytevector-like-set! bv 0 0)
  (bytevector-like-set! bv 1 0)
  (bytevector-like-set! bv 2 0)
  (bytevector-like-set! bv 3 0)
  bv)

(define (list->bytevector l)
  (let ((b (make-bytevector (length l))))
    (do ((i 0 (+ i 1))
	 (l l (cdr l)))
	((null? l) b)
      (bytevector-set! b i (car l)))))

(define bytevector-word-ref 
  (let ((two^8  (expt 2 8))
	(two^16 (expt 2 16))
	(two^24 (expt 2 24)))
    (lambda (bv i)
      (+ (* (bytevector-ref bv i) two^24)
	 (* (bytevector-ref bv (+ i 1)) two^16)
	 (* (bytevector-ref bv (+ i 2)) two^8)
	 (bytevector-ref bv (+ i 3))))))

(define (twobit-format fmt . rest)
  (let ((out (open-output-string)))
    (apply format out fmt rest)
    (get-output-string out)))

; This needs to be a random number in both a weaker and stronger sense
; than `random': it doesn't need to be a truly random number, so a sequence
; of calls can return a non-random sequence, but if two processes generate
; two sequences, then those sequences should not be the same.
;
; Gross, huh?

(define (an-arbitrary-number)
  (system "echo \\\"`date`\\\" > a-random-number")
  (let ((x (string-hash (call-with-input-file "a-random-number" read))))
    (delete-file "a-random-number")
    x))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
; Miscellaneous

(define cerror error)

; eof
; Copyright 1991 Wiliam Clinger.
;
; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
;
; Sets represented as lists.
;
; 5 April 1999.

(define (empty-set) '())

(define (empty-set? x) (null? x))

(define (make-set x)
  (define (loop x y)
    (cond ((null? x) y)
          ((member (car x) y) (loop (cdr x) y))
          (else (loop (cdr x) (cons (car x) y)))))
  (loop x '()))

(define (set-equal? x y)
  (and (subset? x y) (subset? y x)))

(define (subset? x y)
  (every? (lambda (x) (member x y))
          x))

; To get around MacScheme's limit on the number of arguments.

(define apply-union)

(define union
  (letrec ((union2
            (lambda (x y)
              (cond ((null? x) y)
                    ((member (car x) y)
                     (union2 (cdr x) y))
                    (else (union2 (cdr x) (cons (car x) y)))))))
    
    (set! apply-union
          (lambda (sets)
            (do ((sets sets (cdr sets))
                 (result '() (union2 (car sets) result)))
                ((null? sets)
                 result))))
    
    (lambda args
      (cond ((null? args) '())
            ((null? (cdr args)) (car args))
            ((null? (cddr args)) (union2 (car args) (cadr args)))
            (else (union2 (union2 (car args)
                                  (cadr args))
                          (apply union (cddr args))))))))

(define intersection
  (letrec ((intersection2
            (lambda (x y)
              (cond ((null? x) '())
                    ((member (car x) y)
                     (cons (car x) (intersection2 (cdr x) y)))
                    (else (intersection2 (cdr x) y))))))
    (lambda args
      (cond ((null? args) '())
            ((null? (cdr args)) (car args))
            ((null? (cddr args)) (intersection2 (car args) (cadr args)))
            (else (intersection2 (intersection2 (car args)
                                                (cadr args))
                                 (apply intersection (cddr args))))))))

(define (difference x y)
  (cond ((null? x) '())
        ((member (car x) y)
         (difference (cdr x) y))
        (else (cons (car x) (difference (cdr x) y)))))
; Reasonably portable hashing on EQ?, EQV?, EQUAL?.
; Requires bignums, SYMBOL-HASH.
;
; Given any Scheme object, returns a non-negative exact integer
; less than 2^24.

(define object-hash (lambda (x) 0))    ; hash on EQ?, EQV?
(define equal-hash (lambda (x) 0))     ; hash on EQUAL?

(let ((n 16777216)
      (n-1 16777215)
      (adj:fixnum   9000000)
      (adj:negative 8000000)
      (adj:large    7900000)
      (adj:ratnum   7800000)
      (adj:complex  7700000)
      (adj:flonum   7000000)
      (adj:compnum  6900000)
      (adj:char     6111000)
      (adj:string   5022200)
      (adj:vector   4003330)
      (adj:misc     3000444)
      (adj:pair     2555000)
      (adj:proc     2321001)
      (adj:iport    2321002)
      (adj:oport    2321003)
      (adj:weird    2321004)
      (budget0      32))
  
  (define (combine hash adjustment)
    (modulo (+ hash hash hash adjustment) 16777216))
  
  (define (hash-on-equal x budget)
    (if (> budget 0)
        (cond ((string? x)
               (string-hash x))
              ((pair? x)
               (let ((budget (quotient budget 2)))
                 (combine (hash-on-equal (car x) budget)
                          (hash-on-equal (cdr x) budget))))
              ((vector? x)
               (let ((n (vector-length x))
                     (budget (quotient budget 4)))
                 (if (> n 0)
                     (combine
                      (combine (hash-on-equal (vector-ref x 0) budget)
                               (hash-on-equal (vector-ref x (- n 1)) budget))
                      (hash-on-equal (vector-ref x (quotient n 2))
                                     (+ budget budget)))
                     adj:vector)))
              (else
               (object-hash x)))
        adj:weird))
  
  (set! object-hash
        (lambda (x)
          (cond ((symbol? x)
                 (symbol-hash x))
                ((number? x)
                 (if (exact? x)
                     (cond ((integer? x)
                            (cond ((negative? x)
                                   (combine (object-hash (- x)) adj:negative))
                                  ((< x n)
                                   (combine x adj:fixnum))
                                  (else
                                   (combine (modulo x n) adj:large))))
                           ((rational? x)
                            (combine (combine (object-hash (numerator x))
                                              adj:ratnum)
                                     (object-hash (denominator x))))
                           ((real? x)
                            adj:weird)
                           ((complex? x)
                            (combine (combine (object-hash (real-part x))
                                              adj:complex)
                                     (object-hash (imag-part x))))
                           (else
                            adj:weird))
                     (cond (#t
                            ; We can't really do anything with inexact numbers
                            ; unless infinities and NaNs behave reasonably.
                            adj:flonum)
                           ((rational? x)
                            (combine
                             (combine (object-hash
                                       (inexact->exact (numerator x)))
                                      adj:flonum)
                             (object-hash (inexact->exact (denominator x)))))
                           ((real? x)
                            adj:weird)
                           ((complex? x)
                            (combine (combine (object-hash (real-part x))
                                              adj:compnum)
                                     (object-hash (imag-part x))))
                           (else adj:weird))))
                ((char? x)
                 (combine (char->integer x) adj:char))
                ((string? x)
                 (combine (string-length x) adj:string))
                ((vector? x)
                 (combine (vector-length x) adj:vector))
                ((eq? x #t)
                 (combine 1 adj:misc))
                ((eq? x #f)
                 (combine 2 adj:misc))
                ((null? x)
                 (combine 3 adj:misc))
                ((pair? x)
                 adj:pair)
                ((procedure? x)
                 adj:proc)
                ((input-port? x)
                 adj:iport)
                ((output-port? x)
                 adj:oport)
                (else
                 adj:weird))))
  
  (set! equal-hash
        (lambda (x)
          (hash-on-equal x budget0)))); Hash tables.
; Requires CALL-WITHOUT-INTERRUPTS.
; This code should be thread-safe provided VECTOR-REF is atomic.
;
; (make-hashtable <hash-function> <bucket-searcher> <size>)
;
;     Returns a newly allocated mutable hash table
;     using <hash-function> as the hash function
;     and <bucket-searcher>, e.g. ASSQ, ASSV, ASSOC, to search a bucket
;     with <size> buckets at first, expanding the number of buckets as needed.
;     The <hash-function> must accept a key and return a non-negative exact
;     integer.
;
; (make-hashtable <hash-function> <bucket-searcher>)
;
;     Equivalent to (make-hashtable <hash-function> <bucket-searcher> n)
;     for some value of n chosen by the implementation.
;
; (make-hashtable <hash-function>)
;
;     Equivalent to (make-hashtable <hash-function> assv).
;
; (make-hashtable)
;
;     Equivalent to (make-hashtable object-hash assv).
;
; (hashtable-contains? <hashtable> <key>)
;
;     Returns true iff the <hashtable> contains an entry for <key>.
;
; (hashtable-fetch <hashtable> <key> <flag>)
;
;     Returns the value associated with <key> in the <hashtable> if the
;     <hashtable> contains <key>; otherwise returns <flag>.
;
; (hashtable-get <hashtable> <key>)
;
;     Equivalent to (hashtable-fetch <hashtable> <key> #f)
;
; (hashtable-put! <hashtable> <key> <value>)
;
;     Changes the <hashtable> to associate <key> with <value>, replacing
;     any existing association for <key>.
;
; (hashtable-remove! <hashtable> <key>)
;
;     Removes any association for <key> within the <hashtable>.
;
; (hashtable-clear! <hashtable>)
;
;     Removes all associations from the <hashtable>.
;
; (hashtable-size <hashtable>)
;
;     Returns the number of keys contained within the <hashtable>.
;
; (hashtable-for-each <procedure> <hashtable>)
;
;     The <procedure> must accept two arguments, a key and the value
;     associated with that key.  Calls the <procedure> once for each
;     key-value association.  The order of these calls is indeterminate.
;
; (hashtable-map <procedure> <hashtable>)
;
;     The <procedure> must accept two arguments, a key and the value
;     associated with that key.  Calls the <procedure> once for each
;     key-value association, and returns a list of the results.  The
;     order of the calls is indeterminate.
;
; (hashtable-copy <hashtable>)
;
;     Returns a copy of the <hashtable>.

; These global variables are assigned new values later.

(define make-hashtable      (lambda args '*))
(define hashtable-contains? (lambda (ht key) #f))
(define hashtable-fetch     (lambda (ht key flag) flag))
(define hashtable-get       (lambda (ht key) (hashtable-fetch ht key #f)))
(define hashtable-put!      (lambda (ht key val) '*))
(define hashtable-remove!   (lambda (ht key) '*))
(define hashtable-clear!    (lambda (ht) '*))
(define hashtable-size      (lambda (ht) 0))
(define hashtable-for-each  (lambda (ht proc) '*))
(define hashtable-map       (lambda (ht proc) '()))
(define hashtable-copy      (lambda (ht) ht))

; Implementation.
; A hashtable is represented as a vector of the form
;
;     #(("HASHTABLE") <count> <hasher> <searcher> <buckets>)
;
; where <count> is the number of associations within the hashtable,
; <hasher> is the hash function, <searcher> is the bucket searcher,
; and <buckets> is a vector of buckets.
;
; The <hasher> and <searcher> fields are constant, but
; the <count> and <buckets> fields are mutable.
;
; For thread-safe operation, the mutators must modify both
; as an atomic operation.  Other operations do not require
; critical sections provided VECTOR-REF is an atomic operation
; and the operation does not modify the hashtable, does not
; reference the <count> field, and fetches the <buckets>
; field exactly once.

(let ((doc      (list "HASHTABLE"))
      (count    (lambda (ht)   (vector-ref ht 1)))
      (count!   (lambda (ht n) (vector-set! ht 1 n)))
      (hasher   (lambda (ht)   (vector-ref ht 2)))
      (searcher (lambda (ht)   (vector-ref ht 3)))
      (buckets  (lambda (ht)   (vector-ref ht 4)))
      (buckets! (lambda (ht v) (vector-set! ht 4 v)))
      (defaultn 10))
  (let ((hashtable? (lambda (ht)
                      (and (vector? ht)
                           (= 5 (vector-length ht))
                           (eq? doc (vector-ref ht 0)))))
        (hashtable-error (lambda (x)
                           (display "ERROR: Bad hash table: ")
                           (newline)
                           (write x)
                           (newline))))
    
    ; Internal operations.
    
    (define (make-ht hashfun searcher size)
      (vector doc 0 hashfun searcher (make-vector size '())))
    
    ; Substitute x for the first occurrence of y within the list z.
    ; y is known to occur within z.
    
    (define (substitute1 x y z)
      (cond ((eq? y (car z))
             (cons x (cdr z)))
            (else
             (cons (car z)
                   (substitute1 x y (cdr z))))))
    
    ; Remove the first occurrence of x from y.
    ; x is known to occur within y.
    
    (define (remq1 x y)
      (cond ((eq? x (car y))
             (cdr y))
            (else
             (cons (car y)
                   (remq1 x (cdr y))))))
    
    (define (resize ht0)
      (call-without-interrupts
       (lambda ()
         (let ((ht (make-ht (hasher ht0)
                            (searcher ht0)
                            (+ 1 (* 2 (count ht0))))))
           (ht-for-each (lambda (key val)
                          (put! ht key val))
                        ht0)
           (buckets! ht0 (buckets ht))))))
    
    ; Returns the contents of the hashtable as a vector of pairs.
    
    (define (contents ht)
      (let* ((v (buckets ht))
             (n (vector-length v))
             (z (make-vector (count ht) '())))
        (define (loop i bucket j)
          (if (null? bucket)
              (if (= i n)
                  (if (= j (vector-length z))
                      z
                      (begin (display "BUG in hashtable")
                             (newline)
                             '#()))
                  (loop (+ i 1)
                        (vector-ref v i)
                        j))
              (let ((entry (car bucket)))
                (vector-set! z j (cons (car entry) (cdr entry)))
                (loop i
                      (cdr bucket)
                      (+ j 1)))))
        (loop 0 '() 0)))
    
    (define (contains? ht key)
      (if (hashtable? ht)
          (let* ((v (buckets ht))
                 (n (vector-length v))
                 (h (modulo ((hasher ht) key) n))
                 (b (vector-ref v h)))
            (if ((searcher ht) key b)
                #t
                #f))
          (hashtable-error ht)))
    
    (define (fetch ht key flag)
      (if (hashtable? ht)
          (let* ((v (buckets ht))
                 (n (vector-length v))
                 (h (modulo ((hasher ht) key) n))
                 (b (vector-ref v h))
                 (probe ((searcher ht) key b)))
            (if probe
                (cdr probe)
                flag))
          (hashtable-error ht)))
    
    (define (put! ht key val)
      (if (hashtable? ht)
          (call-without-interrupts
           (lambda ()
             (let* ((v (buckets ht))
                    (n (vector-length v))
                    (h (modulo ((hasher ht) key) n))
                    (b (vector-ref v h))
                    (probe ((searcher ht) key b)))
               (if probe
                   ; Using SET-CDR! on the probe would make it necessary
                   ; to synchronize the CONTENTS routine.
                   (vector-set! v h (substitute1 (cons key val) probe b))
                   (begin (count! ht (+ (count ht) 1))
                          (vector-set! v h (cons (cons key val) b))
                          (if (> (count ht) n)
                              (resize ht)))))
             #f))
          (hashtable-error ht)))
    
    (define (remove! ht key)
      (if (hashtable? ht)
          (call-without-interrupts
           (lambda ()
             (let* ((v (buckets ht))
                    (n (vector-length v))
                    (h (modulo ((hasher ht) key) n))
                    (b (vector-ref v h))
                    (probe ((searcher ht) key b)))
               (if probe
                   (begin (count! ht (- (count ht) 1))
                          (vector-set! v h (remq1 probe b))
                          (if (< (* 2 (+ defaultn (count ht))) n)
                              (resize ht))))
               #f)))
          (hashtable-error ht)))
    
    (define (clear! ht)
      (if (hashtable? ht)
          (call-without-interrupts
           (lambda ()
             (begin (count! ht 0)
                    (buckets! ht (make-vector defaultn '()))
                    #f)))
          (hashtable-error ht)))
    
    (define (size ht)
      (if (hashtable? ht)
          (count ht)
          (hashtable-error ht)))
    
    ; This code must be written so that the procedure can modify the
    ; hashtable without breaking any invariants.
    
    (define (ht-for-each f ht)
      (if (hashtable? ht)
          (let* ((v (contents ht))
                 (n (vector-length v)))
            (do ((j 0 (+ j 1)))
                ((= j n))
                (let ((x (vector-ref v j)))
                  (f (car x) (cdr x)))))
          (hashtable-error ht)))
    
    (define (ht-map f ht)
      (if (hashtable? ht)
          (let* ((v (contents ht))
                 (n (vector-length v)))
            (do ((j 0 (+ j 1))
                 (results '() (let ((x (vector-ref v j)))
                                (cons (f (car x) (cdr x))
                                      results))))
                ((= j n)
                 (reverse results))))
          (hashtable-error ht)))
    
    (define (ht-copy ht)
      (if (hashtable? ht)
          (let* ((newtable (make-hashtable (hasher ht) (searcher ht) 0))
                 (v (buckets ht))
                 (n (vector-length v))
                 (newvector (make-vector n '())))
            (count! newtable (count ht))
            (buckets! newtable newvector)
            (do ((i 0 (+ i 1)))
                ((= i n))
                (vector-set! newvector i (append (vector-ref v i) '())))
            newtable)
          (hashtable-error ht)))
    
    ; External entry points.
    
    (set! make-hashtable
          (lambda args
            (let* ((hashfun (if (null? args) object-hash (car args)))
                   (searcher (if (or (null? args) (null? (cdr args)))
                                 assv
                                 (cadr args)))
                   (size (if (or (null? args) (null? (cdr args)) (null? (cddr args)))
                             defaultn
                             (caddr args))))
              (make-ht hashfun searcher size))))
    
    (set! hashtable-contains? (lambda (ht key)      (contains? ht key)))
    (set! hashtable-fetch     (lambda (ht key flag) (fetch ht key flag)))
    (set! hashtable-get       (lambda (ht key)      (fetch ht key #f)))
    (set! hashtable-put!      (lambda (ht key val)  (put! ht key val)))
    (set! hashtable-remove!   (lambda (ht key)      (remove! ht key)))
    (set! hashtable-clear!    (lambda (ht)          (clear! ht)))
    (set! hashtable-size      (lambda (ht)          (size ht)))
    (set! hashtable-for-each  (lambda (ht proc)     (ht-for-each ht proc)))
    (set! hashtable-map       (lambda (ht proc)     (ht-map ht proc)))
    (set! hashtable-copy      (lambda (ht)          (ht-copy ht)))
    #f))
; Hash trees: a functional data structure analogous to hash tables.
;
; (make-hashtree <hash-function> <bucket-searcher>)
;
;     Returns a newly allocated mutable hash table
;     using <hash-function> as the hash function
;     and <bucket-searcher>, e.g. ASSQ, ASSV, ASSOC, to search a bucket.
;     The <hash-function> must accept a key and return a non-negative exact
;     integer.
;
; (make-hashtree <hash-function>)
;
;     Equivalent to (make-hashtree <hash-function> assv).
;
; (make-hashtree)
;
;     Equivalent to (make-hashtree object-hash assv).
;
; (hashtree-contains? <hashtree> <key>)
;
;     Returns true iff the <hashtree> contains an entry for <key>.
;
; (hashtree-fetch <hashtree> <key> <flag>)
;
;     Returns the value associated with <key> in the <hashtree> if the
;     <hashtree> contains <key>; otherwise returns <flag>.
;
; (hashtree-get <hashtree> <key>)
;
;     Equivalent to (hashtree-fetch <hashtree> <key> #f)
;
; (hashtree-put <hashtree> <key> <value>)
;
;     Returns a new hashtree that is like <hashtree> except that
;     <key> is associated with <value>.
;
; (hashtree-remove <hashtree> <key>)
;
;     Returns a new hashtree that is like <hashtree> except that
;     <key> is not associated with any value.
;
; (hashtree-size <hashtree>)
;
;     Returns the number of keys contained within the <hashtree>.
;
; (hashtree-for-each <procedure> <hashtree>)
;
;     The <procedure> must accept two arguments, a key and the value
;     associated with that key.  Calls the <procedure> once for each
;     key-value association.  The order of these calls is indeterminate.
;
; (hashtree-map <procedure> <hashtree>)
;
;     The <procedure> must accept two arguments, a key and the value
;     associated with that key.  Calls the <procedure> once for each
;     key-value association, and returns a list of the results.  The
;     order of the calls is indeterminate.

; These global variables are assigned new values later.

(define make-hashtree      (lambda args '*))
(define hashtree-contains? (lambda (ht key) #f))
(define hashtree-fetch     (lambda (ht key flag) flag))
(define hashtree-get       (lambda (ht key) (hashtree-fetch ht key #f)))
(define hashtree-put       (lambda (ht key val) '*))
(define hashtree-remove    (lambda (ht key) '*))
(define hashtree-size      (lambda (ht) 0))
(define hashtree-for-each  (lambda (ht proc) '*))
(define hashtree-map       (lambda (ht proc) '()))

; Implementation.
; A hashtree is represented as a vector of the form
;
;     #(("hashtree") <count> <hasher> <searcher> <buckets>)
;
; where <count> is the number of associations within the hashtree,
; <hasher> is the hash function, <searcher> is the bucket searcher,
; and <buckets> is generated by the following grammar:
;
; <buckets>       ::=  ()
;                   |  (<fixnum> <associations> <buckets> <buckets>)
; <alist>         ::=  (<associations>)
; <associations>  ::=  
;                   |  <association> <associations>
; <association>   ::=  (<key> . <value>)
;
; If <buckets> is of the form (n alist buckets1 buckets2),
; then n is the hash code of all keys in alist, all keys in buckets1
; have a hash code less than n, and all keys in buckets2 have a hash
; code greater than n.

(let ((doc      (list "hashtree"))
      (count    (lambda (ht)   (vector-ref ht 1)))
      (hasher   (lambda (ht)   (vector-ref ht 2)))
      (searcher (lambda (ht)   (vector-ref ht 3)))
      (buckets  (lambda (ht)   (vector-ref ht 4)))
      
      (make-empty-buckets (lambda () '()))
      
      (make-buckets
       (lambda (h alist buckets1 buckets2)
         (list h alist buckets1 buckets2)))
      
      (buckets-empty? (lambda (buckets) (null? buckets)))
      
      (buckets-n      (lambda (buckets) (car buckets)))
      (buckets-alist  (lambda (buckets) (cadr buckets)))
      (buckets-left   (lambda (buckets) (caddr buckets)))
      (buckets-right  (lambda (buckets) (cadddr buckets))))
  
  (let ((hashtree? (lambda (ht)
                      (and (vector? ht)
                           (= 5 (vector-length ht))
                           (eq? doc (vector-ref ht 0)))))
        (hashtree-error (lambda (x)
                           (display "ERROR: Bad hash tree: ")
                           (newline)
                           (write x)
                           (newline))))
    
    ; Internal operations.
    
    (define (make-ht count hashfun searcher buckets)
      (vector doc count hashfun searcher buckets))
    
    ; Substitute x for the first occurrence of y within the list z.
    ; y is known to occur within z.
    
    (define (substitute1 x y z)
      (cond ((eq? y (car z))
             (cons x (cdr z)))
            (else
             (cons (car z)
                   (substitute1 x y (cdr z))))))
    
    ; Remove the first occurrence of x from y.
    ; x is known to occur within y.
    
    (define (remq1 x y)
      (cond ((eq? x (car y))
             (cdr y))
            (else
             (cons (car y)
                   (remq1 x (cdr y))))))
    
    ; Returns the contents of the hashtree as a list of pairs.
    
    (define (contents ht)
      (let* ((t (buckets ht)))
        
        (define (contents t alist)
          (if (buckets-empty? t)
              alist
              (contents (buckets-left t)
                        (contents (buckets-right t)
                                  (append-reverse (buckets-alist t)
                                                  alist)))))
        
        (define (append-reverse x y)
          (if (null? x)
              y
              (append-reverse (cdr x)
                              (cons (car x) y))))
        
        ; Creating a new hashtree from a list that is almost sorted
        ; in hash code order would create an extremely unbalanced
        ; hashtree, so this routine randomizes the order a bit.
        
        (define (randomize1 alist alist1 alist2 alist3)
          (if (null? alist)
              (randomize-combine alist1 alist2 alist3)
              (randomize2 (cdr alist)
                          (cons (car alist) alist1)
                          alist2
                          alist3)))
        
        (define (randomize2 alist alist1 alist2 alist3)
          (if (null? alist)
              (randomize-combine alist1 alist2 alist3)
              (randomize3 (cdr alist)
                          alist1
                          (cons (car alist) alist2)
                          alist3)))
        
        (define (randomize3 alist alist1 alist2 alist3)
          (if (null? alist)
              (randomize-combine alist1 alist2 alist3)
              (randomize1 (cdr alist)
                          alist1
                          alist2
                          (cons (car alist) alist3))))
        
        (define (randomize-combine alist1 alist2 alist3)
          (cond ((null? alist2)
                 alist1)
                ((null? alist3)
                 (append-reverse alist2 alist1))
                (else
                 (append-reverse
                  (randomize1 alist3 '() '() '())
                  (append-reverse
                   (randomize1 alist1 '() '() '())
                   (randomize1 alist2 '() '() '()))))))
        
        (randomize1 (contents t '()) '() '() '())))
    
    (define (contains? ht key)
      (if (hashtree? ht)
          (let* ((t (buckets ht))
                 (h ((hasher ht) key)))
            (if ((searcher ht) key (find-bucket t h))
                #t
                #f))
          (hashtree-error ht)))
    
    (define (fetch ht key flag)
      (if (hashtree? ht)
          (let* ((t (buckets ht))
                 (h ((hasher ht) key))
                 (probe ((searcher ht) key (find-bucket t h))))
            (if probe
                (cdr probe)
                flag))
          (hashtree-error ht)))
    
    ; Given a <buckets> t and a hash code h, returns the alist for h.
    
    (define (find-bucket t h)
      (if (buckets-empty? t)
          '()
          (let ((n (buckets-n t)))
            (cond ((< h n)
                   (find-bucket (buckets-left t) h))
                  ((< n h)
                   (find-bucket (buckets-right t) h))
                  (else
                   (buckets-alist t))))))
    
    (define (put ht key val)
      (if (hashtree? ht)
          (let ((t (buckets ht))
                (h ((hasher ht) key))
                (association (cons key val))
                (c (count ht)))
            (define (put t h)
              (if (buckets-empty? t)
                  (begin (set! c (+ c 1))
                         (make-buckets h (list association) t t))
                  (let ((n     (buckets-n t))
                        (alist (buckets-alist t))
                        (left  (buckets-left t))
                        (right (buckets-right t)))
                    (cond ((< h n)
                           (make-buckets n
                                         alist
                                         (put (buckets-left t) h)
                                         right))
                          ((< n h)
                           (make-buckets n
                                         alist
                                         left
                                         (put (buckets-right t) h)))
                          (else
                           (let ((probe ((searcher ht) key alist)))
                             (if probe
                                 (make-buckets n
                                               (substitute1 association
                                                            probe
                                                            alist)
                                               left
                                               right)
                                 (begin
                                  (set! c (+ c 1))
                                  (make-buckets n
                                                (cons association alist)
                                                left
                                                right)))))))))
            (let ((buckets (put t h)))
              (make-ht c (hasher ht) (searcher ht) buckets)))
          (hashtree-error ht)))
    
    (define (remove ht key)
      (if (hashtree? ht)
          (let ((t (buckets ht))
                (h ((hasher ht) key))
                (c (count ht)))
            (define (remove t h)
              (if (buckets-empty? t)
                  t
                  (let ((n     (buckets-n t))
                        (alist (buckets-alist t))
                        (left  (buckets-left t))
                        (right (buckets-right t)))
                    (cond ((< h n)
                           (make-buckets n
                                         alist
                                         (remove left h)
                                         right))
                          ((< n h)
                           (make-buckets n
                                         alist
                                         left
                                         (remove right h)))
                          (else
                           (let ((probe ((searcher ht) key alist)))
                             (if probe
                                 (begin (set! c (- c 1))
                                        (make-buckets n
                                                      (remq1 probe alist)
                                                      left
                                                      right))
                                 t)))))))
            (let ((buckets (remove t h)))
              (make-ht c (hasher ht) (searcher ht) buckets)))
          (hashtree-error ht)))
    
    (define (size ht)
      (if (hashtree? ht)
          (count ht)
          (hashtree-error ht)))
    
    (define (ht-for-each f ht)
      (if (hashtree? ht)
          (for-each (lambda (association)
                      (f (car association)
                         (cdr association)))
                    (contents ht))
          (hashtree-error ht)))
    
    (define (ht-map f ht)
      (if (hashtree? ht)
          (map (lambda (association)
                 (f (car association)
                    (cdr association)))
               (contents ht))
          (hashtree-error ht)))
    
    ; External entry points.
    
    (set! make-hashtree
          (lambda args
            (let* ((hashfun (if (null? args) object-hash (car args)))
                   (searcher (if (or (null? args) (null? (cdr args)))
                                 assv
                                 (cadr args))))
              (make-ht 0 hashfun searcher (make-empty-buckets)))))
    
    (set! hashtree-contains? (lambda (ht key)      (contains? ht key)))
    (set! hashtree-fetch     (lambda (ht key flag) (fetch ht key flag)))
    (set! hashtree-get       (lambda (ht key)      (fetch ht key #f)))
    (set! hashtree-put       (lambda (ht key val)  (put ht key val)))
    (set! hashtree-remove    (lambda (ht key)      (remove ht key)))
    (set! hashtree-size      (lambda (ht)          (size ht)))
    (set! hashtree-for-each  (lambda (ht proc)     (ht-for-each ht proc)))
    (set! hashtree-map       (lambda (ht proc)     (ht-map ht proc)))
    #f))
; Copyright 1994 William Clinger
;
; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
;
; 24 April 1999
;
; Compiler switches needed by Twobit.

(define make-twobit-flag)
(define display-twobit-flag)

(define make-twobit-flag
  (lambda (name)

    (define (twobit-warning)
      (display "Error: incorrect arguments to ")
      (write name)
      (newline)
      (reset))

    (define (display-flag state)
      (display (if state "  + " "  - "))
      (display name)
      (display " is ")
      (display (if state "on" "off"))
      (newline))

    (let ((state #t))
      (lambda args
        (cond ((null? args) state)
              ((and (null? (cdr args))
                    (boolean? (car args)))
               (set! state (car args))
               state)
              ((and (null? (cdr args))
                    (eq? (car args) 'display))
               (display-flag state))
              (else (twobit-warning)))))))

(define (display-twobit-flag flag)
  (flag 'display))
  
; Debugging and convenience.

(define issue-warnings
  (make-twobit-flag 'issue-warnings))

(define include-source-code
  (make-twobit-flag 'include-source-code))

(define include-variable-names
  (make-twobit-flag 'include-variable-names))

(define include-procedure-names
  (make-twobit-flag 'include-procedure-names))

; Space efficiency.
; This switch isn't fully implemented yet.  If it is true, then
; Twobit will generate flat closures and will go to some trouble
; to zero stale registers and stack slots.
; Don't turn this switch off unless space is more important than speed.

(define avoid-space-leaks
  (make-twobit-flag 'avoid-space-leaks))

; Major optimizations.

(define integrate-usual-procedures
  (make-twobit-flag 'integrate-usual-procedures))

(define control-optimization
  (make-twobit-flag 'control-optimization))

(define parallel-assignment-optimization
  (make-twobit-flag 'parallel-assignment-optimization))

(define lambda-optimization
  (make-twobit-flag 'lambda-optimization))

(define benchmark-mode
  (make-twobit-flag 'benchmark-mode))

(define benchmark-block-mode
  (make-twobit-flag 'benchmark-block-mode))

(define global-optimization
  (make-twobit-flag 'global-optimization))

(define interprocedural-inlining
  (make-twobit-flag 'interprocedural-inlining))

(define interprocedural-constant-propagation
  (make-twobit-flag 'interprocedural-constant-propagation))

(define common-subexpression-elimination
  (make-twobit-flag 'common-subexpression-elimination))

(define representation-inference
  (make-twobit-flag 'representation-inference))

(define local-optimization
  (make-twobit-flag 'local-optimization))

; For backwards compatibility, until I can change the code.

(define (ignore-space-leaks . args)
  (if (null? args)
      (not (avoid-space-leaks))
      (avoid-space-leaks (not (car args)))))

(define lambda-optimizations lambda-optimization)
(define local-optimizations local-optimization)

(define (set-compiler-flags! how)
  (case how
    ((no-optimization)
     (set-compiler-flags! 'standard)
     (avoid-space-leaks #t)
     (integrate-usual-procedures #f)
     (control-optimization #f)
     (parallel-assignment-optimization #f)
     (lambda-optimization #f)
     (benchmark-mode #f)
     (benchmark-block-mode #f)
     (global-optimization #f)
     (interprocedural-inlining #f)
     (interprocedural-constant-propagation #f)
     (common-subexpression-elimination #f)
     (representation-inference #f)
     (local-optimization #f))
    ((standard) 
     (issue-warnings #t)
     (include-source-code #f)
     (include-procedure-names #t)
     (include-variable-names #t)
     (avoid-space-leaks #f)
     (runtime-safety-checking #t)
     (integrate-usual-procedures #f)
     (control-optimization #t)
     (parallel-assignment-optimization #t)
     (lambda-optimization #t)
     (benchmark-mode #f)
     (benchmark-block-mode #f)
     (global-optimization #t)
     (interprocedural-inlining #t)
     (interprocedural-constant-propagation #t)
     (common-subexpression-elimination #t)
     (representation-inference #t)
     (local-optimization #t))
    ((fast-safe)
     (let ((bbmode (benchmark-block-mode)))
       (set-compiler-flags! 'standard)
       (integrate-usual-procedures #t)
       (benchmark-mode #t)
       (benchmark-block-mode bbmode)))
    ((fast-unsafe) 
     (set-compiler-flags! 'fast-safe)
     (runtime-safety-checking #f))
    (else 
     (error "set-compiler-flags!: unknown mode " how))))

(define (display-twobit-flags which)
  (case which
    ((debugging)
     (display-twobit-flag issue-warnings)
     (display-twobit-flag include-procedure-names)
     (display-twobit-flag include-variable-names)
     (display-twobit-flag include-source-code))
    ((safety)
     (display-twobit-flag avoid-space-leaks))
    ((optimization)
     (display-twobit-flag integrate-usual-procedures)
     (display-twobit-flag control-optimization)
     (display-twobit-flag parallel-assignment-optimization)
     (display-twobit-flag lambda-optimization)
     (display-twobit-flag benchmark-mode)
     (display-twobit-flag benchmark-block-mode)
     (display-twobit-flag global-optimization)
     (if (global-optimization)
         (begin (display "  ")
                (display-twobit-flag interprocedural-inlining)
                (display "  ")
                (display-twobit-flag interprocedural-constant-propagation)
                (display "  ")
                (display-twobit-flag common-subexpression-elimination)
                (display "  ")
                (display-twobit-flag representation-inference)))
     (display-twobit-flag local-optimization))
    (else
     ; The switch might mean something to the assembler, but not to Twobit
     #t)))

; eof
; Copyright 1991 William Clinger
;
; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
;
; 14 April 1999 / wdc

($$trace "pass1.aux")

;***************************************************************
;
; Each definition in this section should be overridden by an assignment
; in a target-specific file.
;
; If a lambda expression has more than @maxargs-with-rest-arg@ required
; arguments followed by a rest argument, then the macro expander will
; rewrite the lambda expression as a lambda expression with only one
; argument (a rest argument) whose body is a LET that binds the arguments
; of the original lambda expression.

(define @maxargs-with-rest-arg@
  1000000)                              ; infinity

(define (prim-entry name) #f)           ; no integrable procedures
(define (prim-arity name) 0)            ; all of which take 0 arguments
(define (prim-opcodename name) name)    ; and go by their source names

; End of definitions to be overridden by target-specific assignments.
;
;***************************************************************

; Miscellaneous routines.

(define (m-warn msg . more)
  (if (issue-warnings)
      (begin
       (display "WARNING from macro expander:")
       (newline)
       (display msg)
       (newline)
       (for-each (lambda (x) (write x) (newline))
                 more))))

(define (m-error msg . more)
  (display "ERROR detected during macro expansion:")
  (newline)
  (display msg)
  (newline)
  (for-each (lambda (x) (write x) (newline))
            more)
  (m-quit (make-constant #f)))

(define (m-bug msg . more)
  (display "BUG in macro expander: ")
  (newline)
  (display msg)
  (newline)
  (for-each (lambda (x) (write x) (newline))
            more)
  (m-quit (make-constant #f)))

; Given a <formals>, returns a list of bound variables.

'
(define (make-null-terminated x)
  (cond ((null? x) '())
        ((pair? x)
         (cons (car x) (make-null-terminated (cdr x))))
        (else (list x))))

; Returns the length of the given list, or -1 if the argument
; is not a list.  Does not check for circular lists.

(define (safe-length x)
  (define (loop x n)
    (cond ((null? x) n)
          ((pair? x) (loop (cdr x) (+ n 1)))
          (else -1)))
  (loop x 0))

; Given a unary predicate and a list, returns a list of those
; elements for which the predicate is true.

(define (filter1 p x)
  (cond ((null? x) '())
        ((p (car x)) (cons (car x) (filter1 p (cdr x))))
        (else (filter1 p (cdr x)))))

; Given a unary predicate and a list, returns #t if the
; predicate is true of every element of the list.

(define (every1? p x)
  (cond ((null? x) #t)
        ((p (car x)) (every1? p (cdr x)))
        (else #f)))

; Binary union of two sets represented as lists, using equal?.

(define (union2 x y)
  (cond ((null? x) y)
        ((member (car x) y)
         (union2 (cdr x) y))
        (else (union2 (cdr x) (cons (car x) y)))))

; Given an association list, copies the association pairs.

(define (copy-alist alist)
  (map (lambda (x) (cons (car x) (cdr x)))
       alist))

; Removes a value from a list.  May destroy the list.

'
(define remq!
  (letrec ((loop (lambda (x y prev)
                   (cond ((null? y) #t)
                         ((eq? x (car y))
                          (set-cdr! prev (cdr y))
                          (loop x (cdr prev) prev))
                         (else
                          (loop x (cdr y) y))))))
    (lambda (x y)
      (cond ((null? y) '())
            ((eq? x (car y))
             (remq! x (cdr y)))
            (else
             (loop x (cdr y) y)
             y)))))

; Procedure-specific source code transformations.
; The transformer is passed a source code expression and a predicate
; and returns one of:
;
;    the original source code expression
;    a new source code expression to use in place of the original
;    #f to indicate that the procedure is being called
;      with an incorrect number of arguments or
;      with an incorrect operand
;
; The original source code expression is guaranteed to be a list whose
; car is the name associated with the transformer.
; The predicate takes an identifier (a symbol) and returns true iff
; that identifier is bound to something other than its global binding.
;
; Since the procedures and their transformations are target-specific,
; they are defined in another file, in the Target subdirectory.

; FIXME:
; I think this is now used in only one place, in simplify-if.

(define (integrable? name)
  (and (integrate-usual-procedures)
       (prim-entry name)))

; MAKE-READABLE strips the referencing information
; and replaces (begin I) by I.
; If the optional argument is true, then it also reconstructs LET.

(define (make-readable exp . rest)
  (let ((fancy? (and (not (null? rest))
                     (car rest))))
    (define (make-readable exp)
      (case (car exp)
        ((quote)    (make-readable-quote exp))
        ((lambda)   `(lambda ,(lambda.args exp)
                             ,@(map (lambda (def)
                                      `(define ,(def.lhs def)
                                               ,(make-readable (def.rhs def))))
                                    (lambda.defs exp))
                               ,(make-readable (lambda.body exp))))
        ((set!)     `(set! ,(assignment.lhs exp)
                           ,(make-readable (assignment.rhs exp))))
        ((if)       `(if ,(make-readable (if.test exp))
                         ,(make-readable (if.then exp))
                         ,(make-readable (if.else exp))))
        ((begin)    (if (variable? exp)
                        (variable.name exp)
                        `(begin ,@(map make-readable (begin.exprs exp)))))
        (else       (make-readable-call exp))))
    (define (make-readable-quote exp)
      (let ((x (constant.value exp)))
        (if (and fancy?
                 (or (boolean? x)
                     (number? x)
                     (char? x)
                     (string? x)))
            x
            exp)))
    (define (make-readable-call exp)
      (let ((proc (call.proc exp)))
        (if (and fancy?
                 (lambda? proc)
                 (list? (lambda.args proc)))
            ;(make-readable-let* exp '() '() '())
            (make-readable-let exp)
            `(,(make-readable (call.proc exp))
              ,@(map make-readable (call.args exp))))))
    (define (make-readable-let exp)
      (let* ((L (call.proc exp))
             (formals (lambda.args L))
             (args (map make-readable (call.args exp)))
             (body (make-readable (lambda.body L))))
        (if (and (null? (lambda.defs L))
                 (= (length args) 1)
                 (pair? body)
                 (or (and (eq? (car body) 'let)
                          (= (length (cadr body)) 1))
                     (eq? (car body) 'let*)))
            `(let* ((,(car formals) ,(car args))
                    ,@(cadr body))
                   ,@(cddr body))
            `(let ,(map list
                        (lambda.args L)
                        args)
                  ,@(map (lambda (def)
                           `(define ,(def.lhs def)
                                    ,(make-readable (def.rhs def))))
                         (lambda.defs L))
                    ,body))))
    (define (make-readable-let* exp vars inits defs)
      (if (and (null? defs)
               (call? exp)
               (lambda? (call.proc exp))
               (= 1 (length (lambda.args (call.proc exp)))))
          (let ((proc (call.proc exp))
                (arg (car (call.args exp))))
            (if (and (call? arg)
                     (lambda? (call.proc arg))
                     (= 1 (length (lambda.args (call.proc arg))))
                     (null? (lambda.defs (call.proc arg))))
                (make-readable-let*
                 (make-call proc (list (lambda.body (call.proc arg))))
                 (cons (car (lambda.args (call.proc arg))) vars)
                 (cons (make-readable (car (call.args arg))) inits)
                 '())
                (make-readable-let* (lambda.body proc)
                                    (cons (car (lambda.args proc)) vars)
                                    (cons (make-readable (car (call.args exp)))
                                          inits)
                                    (map (lambda (def)
                                           `(define ,(def.lhs def)
                                                    ,(make-readable (def.rhs def))))
                                         (reverse (lambda.defs proc))))))
          (cond ((or (not (null? vars))
                     (not (null? defs)))
                 `(let* ,(map list
                              (reverse vars)
                              (reverse inits))
                        ,@defs
                         ,(make-readable exp)))
                ((and (call? exp)
                      (lambda? (call.proc exp)))
                 (let ((proc (call.proc exp)))
                   `(let ,(map list
                               (lambda.args proc)
                               (map make-readable (call.args exp)))
                         ,@(map (lambda (def)
                                  `(define ,(def.lhs def)
                                           ,(make-readable (def.rhs def))))
                                (lambda.defs proc))
                          ,(make-readable (lambda.body proc)))))
                (else
                 (make-readable exp)))))
    (make-readable exp)))

; For testing.

; MAKE-UNREADABLE does the reverse.
; It assumes there are no internal definitions.

(define (make-unreadable exp)
  (cond ((symbol? exp) (list 'begin exp))
        ((pair? exp)
         (case (car exp)
           ((quote) exp)
           ((lambda) (list 'lambda
                           (cadr exp)
                           '(begin)
                           (list '() '() '() '())
                           (make-unreadable (cons 'begin (cddr exp)))))
           ((set!) (list 'set! (cadr exp) (make-unreadable (caddr exp))))
           ((if) (list 'if
                       (make-unreadable (cadr exp))
                       (make-unreadable (caddr exp))
                       (if (= (length exp) 3)
                           '(unspecified)
                           (make-unreadable (cadddr exp)))))
           ((begin) (if (= (length exp) 2)
                        (make-unreadable (cadr exp))
                        (cons 'begin (map make-unreadable (cdr exp)))))
           (else (map make-unreadable exp))))
        (else (list 'quote exp))))
; Copyright 1991 William D Clinger.
;
; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
;
; 12 April 1999.
;
; Procedures for fetching and clobbering parts of expressions.

($$trace "pass2.aux")

(define (constant? exp) (eq? (car exp) 'quote))
(define (variable? exp)
  (and (eq? (car exp) 'begin)
       (null? (cddr exp))))
(define (lambda? exp) (eq? (car exp) 'lambda))
(define (call? exp) (pair? (car exp)))
(define (assignment? exp) (eq? (car exp) 'set!))
(define (conditional? exp) (eq? (car exp) 'if))
(define (begin? exp)
  (and (eq? (car exp) 'begin)
       (not (null? (cddr exp)))))

(define (make-constant value) (list 'quote value))
(define (make-variable name) (list 'begin name))
(define (make-lambda formals defs R F G decls doc body)
  (list 'lambda
        formals
        (cons 'begin defs)
        (list 'quote (list R F G decls doc))
        body))
(define (make-call proc args) (cons proc (append args '())))
(define (make-assignment lhs rhs) (list 'set! lhs rhs))
(define (make-conditional e0 e1 e2) (list 'if e0 e1 e2))
(define (make-begin exprs)
  (if (null? (cdr exprs))
      (car exprs)
      (cons 'begin (append exprs '()))))
(define (make-definition lhs rhs) (list 'define lhs rhs))

(define (constant.value exp) (cadr exp))
(define (variable.name exp) (cadr exp))
(define (lambda.args exp) (cadr exp))
(define (lambda.defs exp) (cdr (caddr exp)))
(define (lambda.R exp) (car (cadr (cadddr exp))))
(define (lambda.F exp) (cadr (cadr (cadddr exp))))
(define (lambda.G exp) (caddr (cadr (cadddr exp))))
(define (lambda.decls exp) (cadddr (cadr (cadddr exp))))
(define (lambda.doc exp) (car (cddddr (cadr (cadddr exp)))))
(define (lambda.body exp) (car (cddddr exp)))
(define (call.proc exp) (car exp))
(define (call.args exp) (cdr exp))
(define (assignment.lhs exp) (cadr exp))
(define (assignment.rhs exp) (caddr exp))
(define (if.test exp) (cadr exp))
(define (if.then exp) (caddr exp))
(define (if.else exp) (cadddr exp))
(define (begin.exprs exp) (cdr exp))
(define (def.lhs exp) (cadr exp))
(define (def.rhs exp) (caddr exp))

(define (variable-set! exp newexp)
  (set-car! exp (car newexp))
  (set-cdr! exp (append (cdr newexp) '())))
(define (lambda.args-set! exp args) (set-car! (cdr exp) args))
(define (lambda.defs-set! exp defs) (set-cdr! (caddr exp) defs))
(define (lambda.R-set! exp R) (set-car! (cadr (cadddr exp)) R))
(define (lambda.F-set! exp F) (set-car! (cdr (cadr (cadddr exp))) F))
(define (lambda.G-set! exp G) (set-car! (cddr (cadr (cadddr exp))) G))
(define (lambda.decls-set! exp decls) (set-car! (cdddr (cadr (cadddr exp))) decls))
(define (lambda.doc-set! exp doc) (set-car! (cddddr (cadr (cadddr exp))) doc))
(define (lambda.body-set! exp exp0) (set-car! (cddddr exp) exp0))
(define (call.proc-set! exp exp0) (set-car! exp exp0))
(define (call.args-set! exp exprs) (set-cdr! exp exprs))
(define (assignment.rhs-set! exp exp0) (set-car! (cddr exp) exp0))
(define (if.test-set! exp exp0) (set-car! (cdr exp) exp0))
(define (if.then-set! exp exp0) (set-car! (cddr exp) exp0))
(define (if.else-set! exp exp0) (set-car! (cdddr exp) exp0))
(define (begin.exprs-set! exp exprs) (set-cdr! exp exprs))

(define expression-set! variable-set!)  ; used only by pass 3

; FIXME:  This duplicates information in Lib/procinfo.sch.

(define (make-doc name arity formals source-code filename filepos)
  (vector name source-code arity filename filepos formals))
(define (doc.name d)    (vector-ref d 0))
(define (doc.code d)    (vector-ref d 1))
(define (doc.arity d)   (vector-ref d 2))
(define (doc.file d)    (vector-ref d 3))
(define (doc.filepos d) (vector-ref d 4))
(define (doc.formals d) (vector-ref d 5))
(define (doc.name-set! d x)    (if d (vector-set! d 0 x)))
(define (doc.code-set! d x)    (if d (vector-set! d 1 x)))
(define (doc.arity-set! d x)   (if d (vector-set! d 2 x)))
(define (doc.file-set! d x)    (if d (vector-set! d 3 x)))
(define (doc.filepos-set! d x) (if d (vector-set! d 4 x)))
(define (doc.formals-set! d x) (if d (vector-set! d 5 x)))
(define (doc-copy d) (list->vector (vector->list d)))

(define (ignored? name) (eq? name name:IGNORED))

; Fairly harmless bug: rest arguments aren't getting flagged.

(define (flag-as-ignored name L)
  (define (loop name formals)
    (cond ((null? formals)
           ;(pass2-error p2error:violation-of-invariant name formals)
           #t)
          ((symbol? formals) #t)
          ((eq? name (car formals))
           (set-car! formals name:IGNORED)
           (if (not (local? (lambda.R L) name:IGNORED))
               (lambda.R-set! L
                 (cons (make-R-entry name:IGNORED '() '() '())
                       (lambda.R L)))))
          (else (loop name (cdr formals)))))
  (loop name (lambda.args L)))

(define (make-null-terminated formals)
  (cond ((null? formals) '())
        ((symbol? formals) (list formals))
        (else (cons (car formals)
                    (make-null-terminated (cdr formals))))))

(define (list-head x n)
  (cond ((zero? n) '())
        (else (cons (car x) (list-head (cdr x) (- n 1))))))

(define (remq x y)
  (cond ((null? y) '())
        ((eq? x (car y)) (remq x (cdr y)))
        (else (cons (car y) (remq x (cdr y))))))

(define (make-call-to-LIST args)
  (cond ((null? args) (make-constant '()))
        ((null? (cdr args))
         (make-call (make-variable name:CONS)
                    (list (car args) (make-constant '()))))
        (else (make-call (make-variable name:LIST) args))))

(define (pass2-error i . etc)
  (apply cerror (cons (vector-ref pass2-error-messages i) etc)))

(define pass2-error-messages
  '#("System error: violation of an invariant in pass 2"
     "Wrong number of arguments to known procedure"))

(define p2error:violation-of-invariant 0)
(define p2error:wna 1)

; Procedures for fetching referencing information from R-tables.

(define (make-R-entry name refs assigns calls)
  (list name refs assigns calls))

(define (R-entry.name x) (car x))
(define (R-entry.references x) (cadr x))
(define (R-entry.assignments x) (caddr x))
(define (R-entry.calls x) (cadddr x))

(define (R-entry.references-set! x refs) (set-car! (cdr x) refs))
(define (R-entry.assignments-set! x assignments) (set-car! (cddr x) assignments))
(define (R-entry.calls-set! x calls) (set-car! (cdddr x) calls))

(define (local? R I)
  (assq I R))

(define (R-entry R I)
  (assq I R))

(define (R-lookup R I)
  (or (assq I R)
      (pass2-error p2error:violation-of-invariant R I)))

(define (references R I)
  (cadr (R-lookup R I)))

(define (assignments R I)
  (caddr (R-lookup R I)))

(define (calls R I)
  (cadddr (R-lookup R I)))

(define (references-set! R I X)
  (set-car! (cdr (R-lookup R I)) X))

(define (assignments-set! R I X)
  (set-car! (cddr (R-lookup R I)) X))

(define (calls-set! R I X)
  (set-car! (cdddr (R-lookup R I)) X))

; A notepad is a vector of the form #(L0 (L1 ...) (L2 ...) (I ...)),
; where the components are:
;    element 0: a parent lambda expression (or #f if there is no enclosing
;               parent, or we want to pretend that there isn't).
;    element 1: a list of lambda expressions that the parent lambda
;               expression encloses immediately.
;    element 2: a subset of that list that does not escape.
;    element 3: a list of free variables.

(define (make-notepad L)
  (vector L '() '() '()))

(define (notepad.parent np)      (vector-ref np 0))
(define (notepad.lambdas np)     (vector-ref np 1))
(define (notepad.nonescaping np) (vector-ref np 2))
(define (notepad.vars np)        (vector-ref np 3))

(define (notepad.lambdas-set! np x)     (vector-set! np 1 x))
(define (notepad.nonescaping-set! np x) (vector-set! np 2 x))
(define (notepad.vars-set! np x)        (vector-set! np 3 x))

(define (notepad-lambda-add! np L)
  (notepad.lambdas-set! np (cons L (notepad.lambdas np))))

(define (notepad-nonescaping-add! np L)
  (notepad.nonescaping-set! np (cons L (notepad.nonescaping np))))

(define (notepad-var-add! np I)
  (let ((vars (notepad.vars np)))
    (if (not (memq I vars))
        (notepad.vars-set! np (cons I vars)))))

; Given a notepad, returns the list of variables that are closed
; over by some nested lambda expression that escapes.

(define (notepad-captured-variables np)
  (let ((nonescaping (notepad.nonescaping np)))
    (apply-union
     (map (lambda (L)
            (if (memq L nonescaping)
                (lambda.G L)
                (lambda.F L)))
          (notepad.lambdas np)))))

; Given a notepad, returns a list of free variables computed
; as the union of the immediate free variables with the free
; variables of nested lambda expressions.

(define (notepad-free-variables np)
  (do ((lambdas (notepad.lambdas np) (cdr lambdas))
       (fv (notepad.vars np)
           (let ((L (car lambdas)))
             (union (difference (lambda.F L)
                                (make-null-terminated (lambda.args L)))
                    fv))))
      ((null? lambdas) fv)))
; Copyright 1992 William Clinger
;
; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
;
; 13 December 1998
; Implementation-dependent parameters and preferences that determine
; how identifiers are represented in the output of the macro expander.
;
; The basic problem is that there are no reserved words, so the
; syntactic keywords of core Scheme that are used to express the
; output need to be represented by data that cannot appear in the
; input.  This file defines those data.

($$trace "prefs")

; FIXME: The following definitions are currently ignored.

; The following definitions assume that identifiers of mixed case
; cannot appear in the input.

(define begin1  (string->symbol "Begin"))
(define define1 (string->symbol "Define"))
(define quote1  (string->symbol "Quote"))
(define lambda1 (string->symbol "Lambda"))
(define if1     (string->symbol "If"))
(define set!1   (string->symbol "Set!"))

; The following defines an implementation-dependent expression
; that evaluates to an undefined (not unspecified!) value, for
; use in expanding the (define x) syntax.

(define undefined1 (list (string->symbol "Undefined")))

; End of FIXME.

; A variable is renamed by suffixing a vertical bar followed by a unique
; integer.  In IEEE and R4RS Scheme, a vertical bar cannot appear as part
; of an identifier, but presumably this is enforced by the reader and not
; by the compiler.  Any other character that cannot appear as part of an
; identifier may be used instead of the vertical bar.

(define renaming-prefix-character #\.)
(define renaming-suffix-character #\|)

(define renaming-prefix (string renaming-prefix-character))
(define renaming-suffix (string renaming-suffix-character))

; Patches for Twobit.  Here temporarily.

(define (make-toplevel-definition id exp)
  (if (lambda? exp)
      (doc.name-set! (lambda.doc exp) id))
  (make-begin
   (list (make-assignment id exp)
         (make-constant id))))
        
(define (make-undefined)
  (make-call (make-variable 'undefined) '()))

(define (make-unspecified)
  (make-call (make-variable 'unspecified) '()))
; Copyright 1992 William Clinger
;
; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
;
; 9 December 1998
; Syntactic environments.
;
; A syntactic environment maps identifiers to denotations,
; where a denotation is one of
;
;    (special <special>)
;    (macro <rules> <env>)
;    (inline <rules> <env>)
;    (identifier <id> <references> <assignments> <calls>)
;
; and where <special> is one of
;
;    quote
;    lambda
;    if
;    set!
;    begin
;    define
;    define-syntax
;    let-syntax
;    letrec-syntax
;    syntax-rules
;
; and where <rules> is a compiled <transformer spec> (see R4RS),
; <env> is a syntactic environment, and <id> is an identifier.
;
; An inline denotation is like a macro denotation, except that it
; is not an error when none of the rules match the use.  Inline
; denotations are created by DEFINE-INLINE.
; The standard syntactic environment should not include any
; identifier denotations; space leaks will result if it does.

($$trace "syntaxenv")

(define standard-syntactic-environment
  `((quote         . (special quote))
    (lambda        . (special lambda))
    (if            . (special if))
    (set!          . (special set!))
    (begin         . (special begin))
    (define        . (special define))
    (define-inline . (special define-inline))
    (define-syntax . (special define-syntax))
    (let-syntax    . (special let-syntax))
    (letrec-syntax . (special letrec-syntax))
    (syntax-rules  . (special syntax-rules))
    ))

; Unforgeable synonyms for lambda and set!, used to expand definitions.

(define lambda0 (string->symbol " lambda "))
(define set!0 (string->symbol " set! "))

(define (syntactic-copy env)
  (copy-alist env))

(define (make-basic-syntactic-environment)
  (cons (cons lambda0
              (cdr (assq 'lambda standard-syntactic-environment)))
        (cons (cons set!0
                    (cdr (assq 'set! standard-syntactic-environment)))
              (syntactic-copy standard-syntactic-environment))))

; The global-syntactic-environment will always be a nonempty
; association list since there is no way to remove the entry
; for lambda0.  That entry is used as a header by destructive
; operations.

(define global-syntactic-environment
  (make-basic-syntactic-environment))

(define (global-syntactic-environment-set! env)
  (set-cdr! global-syntactic-environment env)
  #t)

(define (syntactic-bind-globally! id denotation)
  (if (and (identifier-denotation? denotation)
           (eq? id (identifier-name denotation)))
      (letrec ((remove-bindings-for-id
                (lambda (bindings)
                  (cond ((null? bindings) '())
                        ((eq? (caar bindings) id)
                         (remove-bindings-for-id (cdr bindings)))
                        (else (cons (car bindings)
                                    (remove-bindings-for-id (cdr bindings))))))))
        (global-syntactic-environment-set!
         (remove-bindings-for-id (cdr global-syntactic-environment))))
      (let ((x (assq id global-syntactic-environment)))
        (if x
            (begin (set-cdr! x denotation) #t)
            (global-syntactic-environment-set!
             (cons (cons id denotation)
                   (cdr global-syntactic-environment)))))))

(define (syntactic-divert env1 env2)
  (append env2 env1))

(define (syntactic-extend env ids denotations)
  (syntactic-divert env (map cons ids denotations)))

(define (syntactic-lookup env id)
  (let ((entry (assq id env)))
    (if entry
        (cdr entry)
        (make-identifier-denotation id))))

(define (syntactic-assign! env id denotation)
  (let ((entry (assq id env)))
    (if entry
        (set-cdr! entry denotation)
        (m-bug "Bug detected in syntactic-assign!" env id denotation))))

; Denotations.

(define denotation-class car)

(define (special-denotation? denotation)
  (eq? (denotation-class denotation) 'special))

(define (macro-denotation? denotation)
  (eq? (denotation-class denotation) 'macro))

(define (inline-denotation? denotation)
  (eq? (denotation-class denotation) 'inline))

(define (identifier-denotation? denotation)
  (eq? (denotation-class denotation) 'identifier))

(define (make-macro-denotation rules env)
  (list 'macro rules env))

(define (make-inline-denotation id rules env)
  (list 'inline rules env id))

(define (make-identifier-denotation id)
  (list 'identifier id '() '() '()))

(define macro-rules        cadr)
(define macro-env          caddr)

(define inline-rules       macro-rules)
(define inline-env         macro-env)
(define inline-name        cadddr)

(define identifier-name    cadr)
(define identifier-R-entry cdr)

(define (same-denotation? d1 d2)
  (or (eq? d1 d2)
      (and (identifier-denotation? d1)
           (identifier-denotation? d2)
           (eq? (identifier-name d1)
                (identifier-name d2)))))

(define denotation-of-quote
  (syntactic-lookup standard-syntactic-environment 'quote))

(define denotation-of-lambda
  (syntactic-lookup standard-syntactic-environment 'lambda))

(define denotation-of-if
  (syntactic-lookup standard-syntactic-environment 'if))

(define denotation-of-set!
  (syntactic-lookup standard-syntactic-environment 'set!))

(define denotation-of-begin
  (syntactic-lookup standard-syntactic-environment 'begin))

(define denotation-of-define
  (syntactic-lookup standard-syntactic-environment 'define))

(define denotation-of-define-inline
  (syntactic-lookup standard-syntactic-environment 'define-inline))

(define denotation-of-define-syntax
  (syntactic-lookup standard-syntactic-environment 'define-syntax))

(define denotation-of-let-syntax
  (syntactic-lookup standard-syntactic-environment 'let-syntax))

(define denotation-of-letrec-syntax
  (syntactic-lookup standard-syntactic-environment 'letrec-syntax))

(define denotation-of-syntax-rules
  (syntactic-lookup standard-syntactic-environment 'syntax-rules))

(define denotation-of-...
  (syntactic-lookup standard-syntactic-environment '...))

(define denotation-of-transformer
  (syntactic-lookup standard-syntactic-environment 'transformer))

; Given a syntactic environment env to be extended, an alist returned
; by rename-vars, and a syntactic environment env2, extends env by
; binding the fresh identifiers to the denotations of the original
; identifiers in env2.

(define (syntactic-alias env alist env2)
  (syntactic-divert
   env
   (map (lambda (name-pair)
          (let ((old-name (car name-pair))
                (new-name (cdr name-pair)))
            (cons new-name
                  (syntactic-lookup env2 old-name))))
        alist)))

; Given a syntactic environment and an alist returned by rename-vars,
; extends the environment by binding the old identifiers to the fresh
; identifiers.
; For Twobit, it also binds the fresh identifiers to their denotations.
; This is ok so long as the fresh identifiers are not legal Scheme
; identifiers.

(define (syntactic-rename env alist)
  (if (null? alist)
      env
      (let* ((old (caar alist))
             (new (cdar alist))
             (denotation (make-identifier-denotation new)))
        (syntactic-rename
         (cons (cons old denotation)
               (cons (cons new denotation)
                     env))
         (cdr alist)))))

; Renaming of variables.

(define renaming-counter 0)

(define (make-rename-procedure)
  (set! renaming-counter (+ renaming-counter 1))
  (let ((suffix (string-append renaming-suffix (number->string renaming-counter))))
    (lambda (sym)
      (if (symbol? sym)
          (let ((s (symbol->string sym)))
            (if (and (positive? (string-length s))
                     (char=? (string-ref s 0) renaming-prefix-character))
                (string->symbol (string-append s suffix))
                (string->symbol (string-append renaming-prefix s suffix))))
          (m-warn "Illegal use of rename procedure" 'ok:FIXME sym)))))

; Given a datum, strips the suffixes from any symbols that appear within
; the datum, trying not to copy any more of the datum than necessary.

(define (m-strip x)
  (define (original-symbol x)
    (define (loop sym s i n)
      (cond ((= i n) sym)
            ((char=? (string-ref s i)
                     renaming-suffix-character)
             (string->symbol (substring s 1 i)))
            (else
             (loop sym s (+ i 1) n))))
    (let ((s (symbol->string x)))
      (if (and (positive? (string-length s))
               (char=? (string-ref s 0) renaming-prefix-character))
          (loop x s 0 (string-length s))
          x)))
  (cond ((symbol? x)
         (original-symbol x))
        ((pair? x)
         (let ((a (m-strip (car x)))
               (b (m-strip (cdr x))))
           (if (and (eq? a (car x))
                    (eq? b (cdr x)))
               x
               (cons a b))))
        ((vector? x)
         (let* ((v (vector->list x))
                (v2 (map m-strip v)))
           (if (equal? v v2)
               x
               (list->vector v2))))
        (else x)))

; Given a list of identifiers, or a formal parameter "list",
; returns an alist that associates each identifier with a fresh identifier.

(define (rename-vars original-vars)
  (let ((rename (make-rename-procedure)))
    (define (loop vars newvars)
      (cond ((null? vars) (reverse newvars))
            ((pair? vars)
             (let ((var (car vars)))
               (if (symbol? var)
                   (loop (cdr vars)
                         (cons (cons var (rename var))
                               newvars))
                   (m-error "Illegal variable" var))))
            ((symbol? vars)
             (loop (list vars) newvars))
            (else (m-error "Malformed parameter list" original-vars))))
    (loop original-vars '())))

; Given a <formals> and an alist returned by rename-vars that contains
; a new name for each formal identifier in <formals>, renames the
; formal identifiers.

(define (rename-formals formals alist)
  (cond ((null? formals) '())
        ((pair? formals)
         (cons (cdr (assq (car formals) alist))
               (rename-formals (cdr formals) alist)))
        (else (cdr (assq formals alist)))))
; Copyright 1992 William Clinger
;
; Permission to copy this software, in whole or in part, to use this
; software for any lawful purpose, and to redistribute this software
; is granted subject to the restriction that all copies made of this
; software must include this copyright notice in full.
;
; I also request that you send me a copy of any improvements that you
; make to this software so that they may be incorporated within it to
; the benefit of the Scheme community.
;
; 23 November 1998
; Compiler for a <transformer spec>.
;
; References:
;
;    The Revised^4 Report on the Algorithmic Language Scheme.
;    Clinger and Rees [editors].  To appear in Lisp Pointers.
;    Also available as a technical report from U of Oregon,
;    MIT AI Lab, and Cornell.
;
;    Macros That Work.  Clinger and Rees.  POPL '91.
;
; The input is a <transformer spec> and a syntactic environment.
; Syntactic environments are described in another file.
;
; The supported syntax differs from the R4RS in that vectors are
; allowed as patterns and as templates and are not allowed as
; pattern or template data.
;
;    <transformer spec>  -->  (syntax-rules <literals> <rules>)
;    <rules>  -->  ()  |  (<rule> . <rules>)
;    <rule> --> (<pattern> <template>)
;    <pattern> --> <pattern_var>      ; a <symbol> not in <literals>
;                | <symbol>           ; a <symbol> in <literals>
;                | ()
;                | (<pattern> . <pattern>)
;                | (<ellipsis_pattern>)
;                | #(<pattern>*)                     ; extends R4RS
;                | #(<pattern>* <ellipsis_pattern>)  ; extends R4RS
;                | <pattern_datum>
;    <template> --> <pattern_var>
;                |  <symbol>
;                |  ()
;                |  (<template2> . <template2>)
;                |  #(<template>*)                   ; extends R4RS
;                |  <pattern_datum>
;    <template2> --> <template>  |  <ellipsis_template>
;    <pattern_datum> --> <string>                    ; no <vector>
;                     |  <character>
;                     |  <boolean>
;                     |  <number>
;    <ellipsis_pattern>  --> <pattern> ...
;    <ellipsis_template> --> <template> ...
;    <pattern_var>       --> <symbol> ; not in <literals>
;    <literals>  -->  ()  |  (<symbol> . <literals>)
;
; Definitions.
;
; scope of an ellipsis
;
;    Within a pattern or template, the scope of an ellipsis
;    (...) is the pattern or template that appears to its left.
;
; rank of a pattern variable
;
;    The rank of a pattern variable is the number of ellipses
;    within whose scope it appears in the pattern.
;
; rank of a subtemplate
;
;    The rank of a subtemplate is the number of ellipses within
;    whose scope it appears in the template.
;
; template rank of an occurrence of a pattern variable
;
;    The template rank of an occurrence of a pattern variable
;    within a template is the rank of that occurrence, viewed
;    as a subtemplate.
;
; variables bound by a pattern
;
;    The variables bound by a pattern are the pattern variables
;    that appear within it.
;
; referenced variables of a subtemplate
;
;    The referenced variables of a subtemplate are the pattern
;    variables that appear within it.
;
; variables opened by an ellipsis template
;
;    The variables opened by an ellipsis template are the
;    referenced pattern variables whose rank is greater than
;    the rank of the ellipsis template.
;    
;
; Restrictions.
;
;    No pattern variable appears more than once within a pattern.
;
;    For every occurrence of a pattern variable within a template,
;    the template rank of the occurrence must be greater than or
;    equal to the pattern variable's rank.
;
;    Every ellipsis template must open at least one variable.
;    
;    For every ellipsis template, the variables opened by an
;    ellipsis template must all be bound to sequences of the
;    same length.
;
;
; The compiled form of a <rule> is
;
;    <rule> --> (<pattern> <template> <inserted>)
;    <pattern> --> <pattern_var>
;                | <symbol>
;                | ()
;                | (<pattern> . <pattern>)
;                | <ellipsis_pattern>
;                | #(<pattern>)
;                | <pattern_datum>
;    <template> --> <pattern_var>
;                |  <symbol>
;                |  ()
;                |  (<template2> . <template2>)
;                |  #(<pattern>)
;                |  <pattern_datum>
;    <template2> --> <template>  |  <ellipsis_template>
;    <pattern_datum> --> <string>
;                     |  <character>
;                     |  <boolean>
;                     |  <number>
;    <pattern_var>       --> #(<V> <symbol> <rank>)
;    <ellipsis_pattern>  --> #(<E> <pattern> <pattern_vars>)
;    <ellipsis_template> --> #(<E> <template> <pattern_vars>)
;    <inserted> -->     ()  |  (<symbol> . <inserted>)
;    <pattern_vars> --> ()  |  (<pattern_var> . <pattern_vars>)
;    <rank>  -->  <exact non-negative integer>
;
; where <V> and <E> are unforgeable values.
; The pattern variables associated with an ellipsis pattern
; are the variables bound by the pattern, and the pattern
; variables associated with an ellipsis template are the
; variables opened by the ellipsis template.
;
;
; What's wrong with the above?
; If the template contains a big chunk that contains no pattern variables
; or inserted identifiers, then the big chunk will be copied unnecessarily.
; That shouldn't matter very often.

($$trace "syntaxrules")

(define pattern-variable-flag (list 'v))
(define ellipsis-pattern-flag (list 'e))
(define ellipsis-template-flag ellipsis-pattern-flag)

(define (make-patternvar v rank)
  (vector pattern-variable-flag v rank))
(define (make-ellipsis-pattern P vars)
  (vector ellipsis-pattern-flag P vars))
(define (make-ellipsis-template T vars)
  (vector ellipsis-template-flag T vars))

(define (patternvar? x)
  (and (vector? x)
       (= (vector-length x) 3)
       (eq? (vector-ref x 0) pattern-variable-flag)))

(define (ellipsis-pattern? x)
  (and (vector? x)
       (= (vector-length x) 3)
       (eq? (vector-ref x 0) ellipsis-pattern-flag)))

(define (ellipsis-template? x)
  (and (vector? x)
       (= (vector-length x) 3)
       (eq? (vector-ref x 0) ellipsis-template-flag)))

(define (patternvar-name V) (vector-ref V 1))
(define (patternvar-rank V) (vector-ref V 2))
(define (ellipsis-pattern P) (vector-ref P 1))
(define (ellipsis-pattern-vars P) (vector-ref P 2))
(define (ellipsis-template T) (vector-ref T 1))
(define (ellipsis-template-vars T) (vector-ref T 2))

(define (pattern-variable v vars)
  (cond ((null? vars) #f)
        ((eq? v (patternvar-name (car vars)))
         (car vars))
        (else (pattern-variable v (cdr vars)))))

; Given a <transformer spec> and a syntactic environment,
; returns a macro denotation.
;
; A macro denotation is of the form
;
;    (macro (<rule> ...) env)
;
; where each <rule> has been compiled as described above.

(define (m-compile-transformer-spec spec env)
  (if (and (> (safe-length spec) 1)
           (eq? (syntactic-lookup env (car spec))
                denotation-of-syntax-rules))
      (let ((literals (cadr spec))
            (rules (cddr spec)))
        (if (or (not (list? literals))
                (not (every1? (lambda (rule)
                                (and (= (safe-length rule) 2)
                                     (pair? (car rule))))
                              rules)))
            (m-error "Malformed syntax-rules" spec))
        (list 'macro
              (map (lambda (rule)
                     (m-compile-rule rule literals env))
                   rules)
              env))
      (m-error "Malformed syntax-rules" spec)))

(define (m-compile-rule rule literals env)
  (m-compile-pattern (cdr (car rule))
                     literals
                     env
                     (lambda (compiled-rule patternvars)
                       ; FIXME
                       ; should check uniqueness of pattern variables here
                       (cons compiled-rule
                             (m-compile-template
                              (cadr rule)
                              patternvars
                              env)))))

(define (m-compile-pattern P literals env k)
  (define (loop P vars rank k)
    (cond ((symbol? P)
           (if (memq P literals)
               (k P vars)
               (let ((var (make-patternvar P rank)))
                 (k var (cons var vars)))))
          ((null? P) (k '() vars))
          ((pair? P)
           (if (and (pair? (cdr P))
                    (symbol? (cadr P))
                    (same-denotation? (syntactic-lookup env (cadr P))
                                      denotation-of-...))
               (if (null? (cddr P))
                   (loop (car P)
                         '()
                         (+ rank 1)
                         (lambda (P vars1)
                           (k (make-ellipsis-pattern P vars1)
                              (union2 vars1 vars))))
                   (m-error "Malformed pattern" P))
               (loop (car P)
                     vars
                     rank
                     (lambda (P1 vars)
                       (loop (cdr P)
                             vars
                             rank
                             (lambda (P2 vars)
                               (k (cons P1 P2) vars)))))))
          ((vector? P)
           (loop (vector->list P)
                 vars
                 rank
                 (lambda (P vars)
                   (k (vector P) vars))))
          (else (k P vars))))
  (loop P '() 0 k))

(define (m-compile-template T vars env)
  
  (define (loop T inserted referenced rank escaped? k)
    (cond ((symbol? T)
           (let ((x (pattern-variable T vars)))
             (if x
                 (if (>= rank (patternvar-rank x))
                     (k x inserted (cons x referenced))
                     (m-error
                      "Too few ellipses follow pattern variable in template"
                      (patternvar-name x)))
                 (k T (cons T inserted) referenced))))
          ((null? T) (k '() inserted referenced))
          ((pair? T)
           (cond ((and (not escaped?)
                       (symbol? (car T))
                       (same-denotation? (syntactic-lookup env (car T))
                                         denotation-of-...)
                       (pair? (cdr T))
                       (null? (cddr T)))
                  (loop (cadr T) inserted referenced rank #t k))
                 ((and (not escaped?)
                       (pair? (cdr T))
                       (symbol? (cadr T))
                       (same-denotation? (syntactic-lookup env (cadr T))
                                         denotation-of-...))
                  (loop1 T inserted referenced rank escaped? k))
                 (else
                  (loop (car T)
                        inserted
                        referenced
                        rank
                        escaped?
                        (lambda (T1 inserted referenced)
                          (loop (cdr T)
                                inserted
                                referenced
                                rank
                                escaped?
                                (lambda (T2 inserted referenced)
                                  (k (cons T1 T2) inserted referenced))))))))
          ((vector? T)
           (loop (vector->list T)
                 inserted
                 referenced
                 rank
                 escaped?
                 (lambda (T inserted referenced)
                   (k (vector T) inserted referenced))))
          (else (k T inserted referenced))))
  
  (define (loop1 T inserted referenced rank escaped? k)
    (loop (car T)
          inserted
          '()
          (+ rank 1)
          escaped?
          (lambda (T1 inserted referenced1)
            (loop (cddr T)
                  inserted
                  (append referenced1 referenced)
                  rank
                  escaped?
                  (lambda (T2 inserted referenced)
                    (k (cons (make-ellipsis-template
                              T1
                              (filter1 (lambda (var)
                                         (> (patternvar-rank var)
                                            rank))
                                       referenced1))
                             T2)
                       inserted
                       referenced))))))
  
  (loop T
        '()
        '()
        0
        #f
        (lambda (T inserted referenced)
          (list T inserted))))

; The pattern matcher.
;
; Given an input, a pattern, and two syntactic environments,
; returns a pattern variable environment (represented as an alist)
; if the input matches the pattern, otherwise returns #f.

(define empty-pattern-variable-environment
  (list (make-patternvar (string->symbol "") 0)))

(define (m-match F P env-def env-use)
  
  (define (match F P answer rank)
    (cond ((null? P)
           (and (null? F) answer))
          ((pair? P)
           (and (pair? F)
                (let ((answer (match (car F) (car P) answer rank)))
                  (and answer (match (cdr F) (cdr P) answer rank)))))
          ((symbol? P)
           (and (symbol? F)
                (same-denotation? (syntactic-lookup env-def P)
                                  (syntactic-lookup env-use F))
                answer))
          ((patternvar? P)
           (cons (cons P F) answer))
          ((ellipsis-pattern? P)
           (match1 F P answer (+ rank 1)))
          ((vector? P)
           (and (vector? F)
                (match (vector->list F) (vector-ref P 0) answer rank)))
          (else (and (equal? F P) answer))))
  
  (define (match1 F P answer rank)
    (cond ((not (list? F)) #f)
          ((null? F)
           (append (map (lambda (var) (cons var '()))
                        (ellipsis-pattern-vars P))
                   answer))
          (else
           (let* ((P1 (ellipsis-pattern P))
                  (answers (map (lambda (F) (match F P1 answer rank))
                                F)))
             (if (every1? (lambda (answer) answer) answers)
                 (append (map (lambda (var)
                                (cons var
                                      (map (lambda (answer)
                                             (cdr (assq var answer)))
                                           answers)))
                              (ellipsis-pattern-vars P))
                         answer)
                 #f)))))
  
  (match F P empty-pattern-variable-environment 0))

(define (m-rewrite T alist)
  
  (define (rewrite T alist rank)
    (cond ((null? T) '())
          ((pair? T)
           ((if (ellipsis-pattern? (car T))
                append
                cons)
            (rewrite (car T) alist rank)
            (rewrite (cdr T) alist rank)))
          ((symbol? T) (cdr (assq T alist)))
          ((patternvar? T) (cdr (assq T alist)))
          ((ellipsis-template? T)
           (rewrite1 T alist (+ rank 1)))
          ((vector? T)
           (list->vector (rewrite (vector-ref T 0) alist rank)))
          (else T)))
  
  (define (rewrite1 T alist rank)
    (let* ((T1 (ellipsis-template T))
           (vars (ellipsis-template-vars T))
           (rows (map (lambda (var) (cdr (assq var alist)))
                      vars)))
      (map (lambda (alist) (rewrite T1 alist rank))
           (make-columns vars rows alist))))
  
  (define (make-columns vars rows alist)
    (define (loop rows)
      (if (null? (car rows))
          '()
          (cons (append (map (lambda (var row)
                               (cons var (car row)))
                             vars
                             rows)
                        alist)
                (loop (map cdr rows)))))
    (if (or (null? (cdr rows))
            (apply = (map length rows)))
        (loop rows)
        (m-error "Use of macro is not consistent with definition"
                 vars
                 rows)))
  
  (rewrite T alist 0))

; Given a use of a macro, the syntactic environment of the use,
; a continuation that expects a transcribed expression and
; a new environment in which to continue expansion, and a boolean
; that is true if this transcription is for an inline procedure,
; does the right thing.

(define (m-transcribe0 exp env-use k inline?)
  (let* ((m (syntactic-lookup env-use (car exp)))
         (rules (macro-rules m))
         (env-def (macro-env m))
         (F (cdr exp)))
    (define (loop rules)
      (if (null? rules)
          (if inline?
              (k exp env-use)
              (m-error "Use of macro does not match definition" exp))
          (let* ((rule (car rules))
                 (pattern (car rule))
                 (alist (m-match F pattern env-def env-use)))
            (if alist
                (let* ((template (cadr rule))
                       (inserted (caddr rule))
                       (alist2 (rename-vars inserted))
                       (newexp (m-rewrite template (append alist2 alist))))
                  (k newexp
                     (syntactic-alias env-use alist2 env-def)))
                (loop (cdr rules))))))
    (if (procedure? rules)
        (m-transcribe-low-level exp env-use k rules env-def)
        (loop rules))))

(define (m-transcribe exp env-use k)
  (m-transcribe0 exp env-use k #f))

(define (m-transcribe-inline exp env-use k)
  (m-transcribe0 exp env-use k #t))

; Copyright 1998 William Clinger
;
; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
;
; Low-level macro facility based on explicit renaming.  See
; William D Clinger. Hygienic macros through explicit renaming.
; In Lisp Pointers IV(4), 25-28, December 1991.

($$trace "lowlevel")

(define (m-transcribe-low-level exp env-use k transformer env-def)
  (let ((rename0 (make-rename-procedure))
        (renamed '())
        (ok #t))
    (define (lookup sym)
      (let loop ((alist renamed))
        (cond ((null? alist)
               (syntactic-lookup env-use sym))
              ((eq? sym (cdr (car alist)))
               (syntactic-lookup env-def (car (car alist))))
              (else
               (loop (cdr alist))))))
    (let ((rename
           (lambda (sym)
             (if ok
                 (let ((probe (assq sym renamed)))
                   (if probe
                       (cdr probe)
                       (let ((sym2 (rename0 sym)))
                         (set! renamed (cons (cons sym sym2) renamed))
                         sym2)))
                 (m-error "Illegal use of a rename procedure" sym))))
          (compare
           (lambda (sym1 sym2)
             (same-denotation? (lookup sym1) (lookup sym2)))))
      (let ((exp2 (transformer exp rename compare)))
        (set! ok #f)
        (k exp2
           (syntactic-alias env-use renamed env-def))))))

(define identifier? symbol?)

(define (identifier->symbol id)
  (m-strip id))
; Copyright 1992 William Clinger
;
; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
;
; 22 April 1999

($$trace "expand")

; This procedure sets the default scope of global macro definitions.

(define define-syntax-scope
  (let ((flag 'letrec))
    (lambda args
      (cond ((null? args) flag)
            ((not (null? (cdr args)))
             (apply m-warn
                    "Too many arguments passed to define-syntax-scope"
                    args))
            ((memq (car args) '(letrec letrec* let*))
             (set! flag (car args)))
            (else (m-warn "Unrecognized argument to define-syntax-scope"
                          (car args)))))))

; The main entry point.
; The outermost lambda allows known procedures to be lifted outside
; all local variables.

(define (macro-expand def-or-exp)
  (call-with-current-continuation
   (lambda (k)
     (set! m-quit k)
     (set! renaming-counter 0)
     (make-call
      (make-lambda '() ; formals
                   '() ; definitions
                   '() ; R
                   '() ; F
                   '() ; G
                   '() ; declarations
                   #f  ; documentation
                   (desugar-definitions def-or-exp
                                        global-syntactic-environment
                                        make-toplevel-definition))
      '()))))

(define (desugar-definitions exp env make-toplevel-definition)
  (letrec
    
    ((define-loop 
       (lambda (exp rest first env)
         (cond ((and (pair? exp)
                     (symbol? (car exp))
                     (eq? (syntactic-lookup env (car exp))
                          denotation-of-begin)
                     (pair? (cdr exp)))
                (define-loop (cadr exp) (append (cddr exp) rest) first env))
               ((and (pair? exp)
                     (symbol? (car exp))
                     (eq? (syntactic-lookup env (car exp))
                          denotation-of-define))
                (let ((exp (desugar-define exp env)))
                  (cond ((and (null? first) (null? rest))
                         exp)
                        ((null? rest)
                         (make-begin (reverse (cons exp first))))
                        (else (define-loop (car rest)
                                (cdr rest)
                                (cons exp first)
                                env)))))
               ((and (pair? exp)
                     (symbol? (car exp))
                     (or (eq? (syntactic-lookup env (car exp))
                              denotation-of-define-syntax)
                         (eq? (syntactic-lookup env (car exp))
                              denotation-of-define-inline))
                     (null? first))
                (define-syntax-loop exp rest env))
               ((and (pair? exp)
                     (symbol? (car exp))
                     (macro-denotation? (syntactic-lookup env (car exp))))
                (m-transcribe exp
                              env
                              (lambda (exp env)
                                (define-loop exp rest first env))))
               ((and (null? first) (null? rest))
                (m-expand exp env))
               ((null? rest)
                (make-begin (reverse (cons (m-expand exp env) first))))
               (else (make-begin
                      (append (reverse first)
                              (map (lambda (exp) (m-expand exp env))
                                   (cons exp rest))))))))
     
     (define-syntax-loop 
       (lambda (exp rest env)
         (cond ((and (pair? exp)
                     (symbol? (car exp))
                     (eq? (syntactic-lookup env (car exp))
                          denotation-of-begin)
                     (pair? (cdr exp)))
                (define-syntax-loop (cadr exp) (append (cddr exp) rest) env))
               ((and (pair? exp)
                     (symbol? (car exp))
                     (eq? (syntactic-lookup env (car exp))
                          denotation-of-define-syntax))
                (if (pair? (cdr exp))
                    (redefinition (cadr exp)))
                (if (null? rest)
                    (m-define-syntax exp env)
                    (begin (m-define-syntax exp env)
                           (define-syntax-loop (car rest) (cdr rest) env))))
               ((and (pair? exp)
                     (symbol? (car exp))
                     (eq? (syntactic-lookup env (car exp))
                          denotation-of-define-inline))
                (if (pair? (cdr exp))
                    (redefinition (cadr exp)))
                (if (null? rest)
                    (m-define-inline exp env)
                    (begin (m-define-inline exp env)
                           (define-syntax-loop (car rest) (cdr rest) env))))
               ((and (pair? exp)
                     (symbol? (car exp))
                     (macro-denotation? (syntactic-lookup env (car exp))))
                (m-transcribe exp
                              env
                              (lambda (exp env)
                                (define-syntax-loop exp rest env))))
               ((and (pair? exp)
                     (symbol? (car exp))
                     (eq? (syntactic-lookup env (car exp))
                          denotation-of-define))
                (define-loop exp rest '() env))
               ((null? rest)
                (m-expand exp env))
               (else (make-begin
                      (map (lambda (exp) (m-expand exp env))
                           (cons exp rest)))))))
     
     (desugar-define
      (lambda (exp env)
        (cond 
         ((null? (cdr exp)) (m-error "Malformed definition" exp))
         ; (define foo) syntax is transformed into (define foo (undefined)).
         ((null? (cddr exp))
          (let ((id (cadr exp)))
            (if (or (null? pass1-block-inlines)
                    (not (memq id pass1-block-inlines)))
                (begin
                 (redefinition id)
                 (syntactic-bind-globally! id (make-identifier-denotation id))))
            (make-toplevel-definition id (make-undefined))))
         ((pair? (cadr exp))              
          (desugar-define
           (let* ((def (car exp))
                  (pattern (cadr exp))
                  (f (car pattern))
                  (args (cdr pattern))
                  (body (cddr exp)))
             (if (and (symbol? (car (cadr exp)))
                      (benchmark-mode)
                      (list? (cadr exp)))
                 `(,def ,f
                        (,lambda0 ,args
                           ((,lambda0 (,f)
                               (,set!0 ,f (,lambda0 ,args ,@body))
                               ,pattern)
                            0)))
                 `(,def ,f (,lambda0 ,args ,@body))))
           env))
         ((> (length exp) 3) (m-error "Malformed definition" exp))
         (else (let ((id (cadr exp)))
                 (if (or (null? pass1-block-inlines)
                         (not (memq id pass1-block-inlines)))
                     (begin
                      (redefinition id)
                      (syntactic-bind-globally! id (make-identifier-denotation id))))
                 (make-toplevel-definition id (m-expand (caddr exp) env)))))))
     
     (redefinition
      (lambda (id)
        (if (symbol? id)
            (if (not (identifier-denotation?
                      (syntactic-lookup global-syntactic-environment id)))
                (if (issue-warnings)
                    (m-warn "Redefining " id)))
            (m-error "Malformed variable or keyword" id)))))
    
    ; body of letrec
    
    (define-loop exp '() '() env)))

; Given an expression and a syntactic environment,
; returns an expression in core Scheme.

(define (m-expand exp env)
  (cond ((not (pair? exp))
         (m-atom exp env))
        ((not (symbol? (car exp)))
         (m-application exp env))
        (else
         (let ((keyword (syntactic-lookup env (car exp))))
           (case (denotation-class keyword)
             ((special)
              (cond
               ((eq? keyword denotation-of-quote)         (m-quote exp))
               ((eq? keyword denotation-of-lambda)        (m-lambda exp env))
               ((eq? keyword denotation-of-if)            (m-if exp env))
               ((eq? keyword denotation-of-set!)          (m-set exp env))
               ((eq? keyword denotation-of-begin)         (m-begin exp env))
               ((eq? keyword denotation-of-let-syntax)
		(m-let-syntax exp env))
               ((eq? keyword denotation-of-letrec-syntax)
		(m-letrec-syntax exp env))
               ((or (eq? keyword denotation-of-define)
                    (eq? keyword denotation-of-define-syntax)
                    (eq? keyword denotation-of-define-inline))
                (m-error "Definition out of context" exp))
               (else (m-bug "Bug detected in m-expand" exp env))))
             ((macro) (m-macro exp env))
             ((inline) (m-inline exp env))
             ((identifier) (m-application exp env))
             (else (m-bug "Bug detected in m-expand" exp env)))))))

(define (m-atom exp env)
  (cond ((not (symbol? exp))
         ; Here exp ought to be a boolean, number, character, or string.
         ; I'll warn about other things but treat them as if quoted.
	 ;
	 ; I'm turning off some of the warnings because notably procedures
	 ; and #!unspecified can occur in loaded files and it's a major
	 ; pain if a warning is printed for each. --lars
         (if (and (not (boolean? exp))
                  (not (number? exp))
                  (not (char? exp))
                  (not (string? exp))
		  (not (procedure? exp))
		  (not (eq? exp (unspecified))))
             (m-warn "Malformed constant -- should be quoted" exp))
         (make-constant exp))
        (else (let ((denotation (syntactic-lookup env exp)))
                (case (denotation-class denotation)
                  ((special macro)
                   (m-warn "Syntactic keyword used as a variable" exp)
                   ; Syntactic keywords used as variables are treated as #t.
                   (make-constant #t))
                  ((inline)
                   (make-variable (inline-name denotation)))
                  ((identifier)
                   (let ((var (make-variable (identifier-name denotation)))
                         (R-entry (identifier-R-entry denotation)))
                     (R-entry.references-set!
                      R-entry
                      (cons var (R-entry.references R-entry)))
                     var))
                  (else (m-bug "Bug detected by m-atom" exp env)))))))

(define (m-quote exp)
  (if (and (pair? (cdr exp))
           (null? (cddr exp)))
      (make-constant (m-strip (cadr exp)))
      (m-error "Malformed quoted constant" exp)))

(define (m-lambda exp env)
  (if (> (safe-length exp) 2)
      
      (let* ((formals (cadr exp))
             (alist (rename-vars formals))
             (env (syntactic-rename env alist))
             (body (cddr exp)))
        
        (do ((alist alist (cdr alist)))
            ((null? alist))
            (if (assq (caar alist) (cdr alist))
                (m-error "Malformed parameter list" formals)))
        
        ; To simplify the run-time system, there's a limit on how many
        ; fixed arguments can be followed by a rest argument.
        ; That limit is removed here.
        ; Bug: documentation slot isn't right when this happens.
        ; Bug: this generates extremely inefficient code.
        
        (if (and (not (list? formals))
                 (> (length alist) @maxargs-with-rest-arg@))
            (let ((TEMP (car (rename-vars '(temp)))))
              (m-lambda
               `(,lambda0 ,TEMP
                           ((,lambda0 ,(map car alist)
                                      ,@(cddr exp))
                            ,@(do ((actuals '() (cons (list name:CAR path)
                                                      actuals))
                                   (path TEMP (list name:CDR path))
                                   (formals formals (cdr formals)))
                                  ((symbol? formals)
                                   (append (reverse actuals) (list path))))))
               env))
            (make-lambda (rename-formals formals alist)
                         '() ; no definitions yet
                         (map (lambda (entry)
                                (cdr (syntactic-lookup env (cdr entry))))
                              alist) ; R
                         '() ; F
                         '() ; G
                         '() ; decls
                         (make-doc #f
                                   (if (list? formals)
                                       (length alist)
                                       (exact->inexact (- (length alist) 1)))
                                   (if (include-variable-names)
                                       formals
                                       #f)
                                   (if (include-source-code)
                                       exp
                                       #f)
                                   source-file-name
                                   source-file-position)
                         (m-body body env))))
      
      (m-error "Malformed lambda expression" exp)))

(define (m-body body env)
  (define (loop body env defs)
    (if (null? body)
        (m-error "Empty body"))
    (let ((exp (car body)))
      (if (and (pair? exp)
               (symbol? (car exp)))
          (let ((denotation (syntactic-lookup env (car exp))))
            (case (denotation-class denotation)
              ((special)
               (cond ((eq? denotation denotation-of-begin)
                      (loop (append (cdr exp) (cdr body)) env defs))
                     ((eq? denotation denotation-of-define)
                      (loop (cdr body) env (cons exp defs)))
                     (else (finalize-body body env defs))))
              ((macro)
               (m-transcribe exp
                             env
                             (lambda (exp env)
                               (loop (cons exp (cdr body))
                                     env
                                     defs))))
              ((inline identifier)
               (finalize-body body env defs))
              (else (m-bug "Bug detected in m-body" body env))))
          (finalize-body body env defs))))
  (loop body env '()))

(define (finalize-body body env defs)
  (if (null? defs)
      (let ((body (map (lambda (exp) (m-expand exp env))
                       body)))
        (if (null? (cdr body))
            (car body)
            (make-begin body)))
      (let ()
        (define (sort-defs defs)
          (let* ((augmented
                  (map (lambda (def)
                         (let ((rhs (cadr def)))
                           (if (not (pair? rhs))
                               (cons 'trivial def)
                               (let ((denotation
                                      (syntactic-lookup env (car rhs))))
                                 (cond ((eq? denotation
                                             denotation-of-lambda)
                                        (cons 'procedure def))
                                       ((eq? denotation
                                             denotation-of-quote)
                                        (cons 'trivial def))
                                       (else
                                        (cons 'miscellaneous def)))))))
                       defs))
                 (sorted (twobit-sort (lambda (x y)
                                        (or (eq? (car x) 'procedure)
                                            (eq? (car y) 'miscellaneous)))
                                      augmented)))
            (map cdr sorted)))
        (define (desugar-definition def)
          (if (> (safe-length def) 2)
              (cond ((pair? (cadr def))
                     (desugar-definition
                      `(,(car def)
                        ,(car (cadr def))
                        (,lambda0
                          ,(cdr (cadr def))
                          ,@(cddr def)))))
                    ((and (= (length def) 3)
                          (symbol? (cadr def)))
                     (cdr def))
                    (else (m-error "Malformed definition" def)))
              (m-error "Malformed definition" def)))
        (define (expand-letrec bindings body)
          (make-call
           (m-expand
            `(,lambda0 ,(map car bindings)
                       ,@(map (lambda (binding)
                                `(,set!0 ,(car binding)
                                         ,(cadr binding)))
                              bindings)
                         ,@body)
            env)
           (map (lambda (binding) (make-unspecified)) bindings)))
        (expand-letrec (sort-defs (map desugar-definition
                                       (reverse defs)))
                       body))))

(define (m-if exp env)
  (let ((n (safe-length exp)))
    (if (or (= n 3) (= n 4))
        (make-conditional (m-expand (cadr exp) env)
                          (m-expand (caddr exp) env)
                          (if (= n 3)
                              (make-unspecified)
                              (m-expand (cadddr exp) env)))
        (m-error "Malformed if expression" exp))))

(define (m-set exp env)
  (if (= (safe-length exp) 3)
      (let ((lhs (m-expand (cadr exp) env))
            (rhs (m-expand (caddr exp) env)))
        (if (variable? lhs)
            (let* ((x (variable.name lhs))
                   (assignment (make-assignment x rhs))
                   (denotation (syntactic-lookup env x)))
              (if (identifier-denotation? denotation)
                  (let ((R-entry (identifier-R-entry denotation)))
                    (R-entry.references-set!
                     R-entry
                     (remq lhs (R-entry.references R-entry)))
                    (R-entry.assignments-set!
                     R-entry
                     (cons assignment (R-entry.assignments R-entry)))))
              (if (and (lambda? rhs)
                       (include-procedure-names))
                  (let ((doc (lambda.doc rhs)))
                    (doc.name-set! doc x)))
              (if pass1-block-compiling?
                  (set! pass1-block-assignments
                        (cons x pass1-block-assignments)))
              assignment)
            (m-error "Malformed assignment" exp)))
      (m-error "Malformed assignment" exp)))

(define (m-begin exp env)
  (cond ((> (safe-length exp) 1)
         (make-begin (map (lambda (exp) (m-expand exp env)) (cdr exp))))
        ((= (safe-length exp) 1)
         (m-warn "Non-standard begin expression" exp)
         (make-unspecified))
        (else
         (m-error "Malformed begin expression" exp))))

(define (m-application exp env)
  (if (> (safe-length exp) 0)
      (let* ((proc (m-expand (car exp) env))
             (args (map (lambda (exp) (m-expand exp env))
                        (cdr exp)))
             (call (make-call proc args)))
        (if (variable? proc)
            (let* ((procname (variable.name proc))
                   (entry
                    (and (not (null? args))
                         (constant? (car args))
                         (integrate-usual-procedures)
                         (every1? constant? args)
                         (let ((entry (constant-folding-entry procname)))
                           (and entry
                                (let ((predicates
                                       (constant-folding-predicates entry)))
                                  (and (= (length args)
                                          (length predicates))
                                       (let loop ((args args)
                                                  (predicates predicates))
                                         (cond ((null? args) entry)
                                               (((car predicates)
                                                 (constant.value (car args)))
                                                (loop (cdr args)
                                                      (cdr predicates)))
                                               (else #f))))))))))
              (if entry
                  (make-constant (apply (constant-folding-folder entry)
                                        (map constant.value args)))
                  (let ((denotation (syntactic-lookup env procname)))
                    (if (identifier-denotation? denotation)
                        (let ((R-entry (identifier-R-entry denotation)))
                          (R-entry.calls-set!
                           R-entry
                           (cons call (R-entry.calls R-entry)))))
                    call)))
            call))
      (m-error "Malformed application" exp)))

; The environment argument should always be global here.

(define (m-define-inline exp env)
  (cond ((and (= (safe-length exp) 3)
              (symbol? (cadr exp)))
         (let ((name (cadr exp)))
           (m-define-syntax1 name
                             (caddr exp)
                             env
                             (define-syntax-scope))
           (let ((denotation
                  (syntactic-lookup global-syntactic-environment name)))
             (syntactic-bind-globally!
              name
              (make-inline-denotation name
                                      (macro-rules denotation)
                                      (macro-env denotation))))
           (make-constant name)))
        (else
         (m-error "Malformed define-inline" exp))))

; The environment argument should always be global here.

(define (m-define-syntax exp env)
  (cond ((and (= (safe-length exp) 3)
              (symbol? (cadr exp)))
         (m-define-syntax1 (cadr exp)
                           (caddr exp)
                           env
                           (define-syntax-scope)))
        ((and (= (safe-length exp) 4)
              (symbol? (cadr exp))
              ; FIXME: should use denotations here
              (memq (caddr exp) '(letrec letrec* let*)))
         (m-define-syntax1 (cadr exp)
                           (cadddr exp)
                           env
                           (caddr exp)))
        (else (m-error "Malformed define-syntax" exp))))

(define (m-define-syntax1 keyword spec env scope)
  (if (and (pair? spec)
           (symbol? (car spec)))
      (let* ((transformer-keyword (car spec))
             (denotation (syntactic-lookup env transformer-keyword)))
        (cond ((eq? denotation denotation-of-syntax-rules)
               (case scope
                 ((letrec)  (m-define-syntax-letrec keyword spec env))
                 ((letrec*) (m-define-syntax-letrec* keyword spec env))
                 ((let*)    (m-define-syntax-let* keyword spec env))
                 (else      (m-bug "Weird scope" scope))))
              ((same-denotation? denotation denotation-of-transformer)
               ; FIXME: no error checking here
               (syntactic-bind-globally!
                keyword
                (make-macro-denotation (eval (cadr spec)) env)))
              (else
               (m-error "Malformed syntax transformer" spec))))
      (m-error "Malformed syntax transformer" spec))
  (make-constant keyword))

(define (m-define-syntax-letrec keyword spec env)
  (syntactic-bind-globally!
   keyword
   (m-compile-transformer-spec spec env)))

(define (m-define-syntax-letrec* keyword spec env)
  (let* ((env (syntactic-extend (syntactic-copy env)
                                (list keyword)
                                '((fake denotation))))
         (transformer (m-compile-transformer-spec spec env)))
    (syntactic-assign! env keyword transformer)
    (syntactic-bind-globally! keyword transformer)))

(define (m-define-syntax-let* keyword spec env)
  (syntactic-bind-globally!
   keyword
   (m-compile-transformer-spec spec (syntactic-copy env))))

(define (m-let-syntax exp env)
  (if (and (> (safe-length exp) 2)
           (every1? (lambda (binding)
                      (and (pair? binding)
                           (symbol? (car binding))
                           (pair? (cdr binding))
                           (null? (cddr binding))))
                    (cadr exp)))
      (m-body (cddr exp)
              (syntactic-extend env
                                (map car (cadr exp))
                                (map (lambda (spec)
                                       (m-compile-transformer-spec
                                        spec
                                        env))
                                     (map cadr (cadr exp)))))
      (m-error "Malformed let-syntax" exp)))

(define (m-letrec-syntax exp env)
  (if (and (> (safe-length exp) 2)
           (every1? (lambda (binding)
                      (and (pair? binding)
                           (symbol? (car binding))
                           (pair? (cdr binding))
                           (null? (cddr binding))))
                    (cadr exp)))
      (let ((env (syntactic-extend env
                                   (map car (cadr exp))
                                   (map (lambda (id)
                                          '(fake denotation))
                                        (cadr exp)))))
        (for-each (lambda (id spec)
                    (syntactic-assign!
                     env
                     id
                     (m-compile-transformer-spec spec env)))
                  (map car (cadr exp))
                  (map cadr (cadr exp)))
        (m-body (cddr exp) env))
      (m-error "Malformed let-syntax" exp)))

(define (m-macro exp env)
  (m-transcribe exp
                env
                (lambda (exp env)
                  (m-expand exp env))))

(define (m-inline exp env)
  (if (integrate-usual-procedures)
      (m-transcribe-inline exp
                           env
                           (lambda (newexp env)
                             (if (eq? exp newexp)
                                 (m-application exp env)
                                 (m-expand newexp env))))
      (m-application exp env)))

(define m-quit             ; assigned by macro-expand
  (lambda (v) v))

; To do:
; Clean up alist hacking et cetera.
; Declarations.
; Integrable procedures.
; New semantics for body of LET-SYNTAX and LETREC-SYNTAX.
; Copyright 1992 William Clinger
;
; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
;
; 5 April 1999.

($$trace "usual")

; The usual macros, adapted from Jonathan's Version 2 implementation.
; DEFINE is handled primitively, since top-level DEFINE has a side
; effect on the global syntactic environment, and internal definitions
; have to be handled specially anyway.
;
; Some extensions are noted, as are some optimizations.
;
; The LETREC* scope rule is used here to protect these macros against
; redefinition of LAMBDA etc.  The scope rule is changed to LETREC at
; the end of this file.

(define-syntax-scope 'letrec*)

(for-each (lambda (form)
            (macro-expand form))
          '(

; Named LET is defined later, after LETREC has been defined.

(define-syntax let
  (syntax-rules ()
    ((let ((?name ?val) ...) ?body ?body1 ...)
     ((lambda (?name ...) ?body ?body1 ...) ?val ...))))

(define-syntax let*
  (syntax-rules ()
    ((let* () ?body ?body1 ...)
     (let () ?body ?body1 ...))
    ((let* ((?name1 ?val1) (?name ?val) ...) ?body ?body1 ...)
     (let ((?name1 ?val1)) (let* ((?name ?val) ...) ?body ?body1 ...)))))

; Internal definitions have to be handled specially anyway,
; so we might as well rely on them here.

(define-syntax letrec
  (syntax-rules (lambda quote)
   ((letrec ((?name ?val) ...) ?body ?body2 ...)
    ((lambda ()
       (define ?name ?val) ...
       ?body ?body2 ...)))))

; This definition of named LET extends the prior definition of LET.
; The first rule is non-circular, thanks to the LET* scope that is
; specified for this use of DEFINE-SYNTAX.

(define-syntax let let*
  (syntax-rules ()
    ((let (?bindings ...) . ?body)
     (let (?bindings ...) . ?body))
    ((let ?tag ((?name ?val) ...) ?body ?body1 ...)
     (let ((?name ?val) ...)
       (letrec ((?tag (lambda (?name ...) ?body ?body1 ...)))
         (?tag ?name ...))))))

(define-syntax and
  (syntax-rules ()
    ((and) #t)
    ((and ?e) ?e)
    ((and ?e1 ?e2 ?e3 ...)
     (if ?e1 (and ?e2 ?e3 ...) #f))))

(define-syntax or
  (syntax-rules ()
    ((or) #f)
    ((or ?e) ?e)
    ((or ?e1 ?e2 ?e3 ...)
     (let ((temp ?e1))
       (if temp temp (or ?e2 ?e3 ...))))))

(define-syntax cond
  (syntax-rules (else =>)
    ((cond (else ?result ?result2 ...))
     (begin ?result ?result2 ...))
    
    ((cond (?test => ?result))
     (let ((temp ?test))
       (if temp (?result temp))))
    
    ((cond (?test)) ?test)
    
    ((cond (?test ?result ?result2 ...))
     (if ?test (begin ?result ?result2 ...)))
    
    ((cond (?test => ?result) ?clause ?clause2 ...)
     (let ((temp ?test))
       (if temp (?result temp) (cond ?clause ?clause2 ...))))
    
    ((cond (?test) ?clause ?clause2 ...)
     (or ?test (cond ?clause ?clause2 ...)))
    
    ((cond (?test ?result ?result2 ...)
           ?clause ?clause2 ...)
     (if ?test
         (begin ?result ?result2 ...)
         (cond ?clause ?clause2 ...)))))

; The R4RS says a <step> may be omitted.
; That's a good excuse for a macro-defining macro that uses LETREC-SYNTAX
; and the ... escape.

(define-syntax do
  (syntax-rules ()
    ((do (?bindings0 ...) (?test) ?body0 ...)
     (do (?bindings0 ...) (?test (if #f #f)) ?body0 ...))
    ((do (?bindings0 ...) ?clause0 ?body0 ...)
     (letrec-syntax
       ((do-aux
         (... (syntax-rules ()
                ((do-aux () ((?name ?init ?step) ...) ?clause ?body ...)
                 (letrec ((loop (lambda (?name ...)
                                  (cond ?clause
                                        (else
                                         (begin #t ?body ...)
                                         (loop ?step ...))))))
                   (loop ?init ...)))
                ((do-aux ((?name ?init ?step) ?todo ...)
                         (?bindings ...)
                         ?clause
                         ?body ...)
                 (do-aux (?todo ...)
                         (?bindings ... (?name ?init ?step))
                         ?clause
                         ?body ...))
                ((do-aux ((?name ?init) ?todo ...)
                         (?bindings ...)
                         ?clause
                         ?body ...)
                 (do-aux (?todo ...)
                         (?bindings ... (?name ?init ?name))
                         ?clause
                         ?body ...))))))
       (do-aux (?bindings0 ...) () ?clause0 ?body0 ...)))))

(define-syntax delay
  (syntax-rules ()
    ((delay ?e) (.make-promise (lambda () ?e)))))

; Another use of LETREC-SYNTAX and the escape extension.

(define-syntax case
  (syntax-rules (else)
    ((case ?e1 (else ?body ?body2 ...))
     (begin ?e1 ?body ?body2 ...))
    ((case ?e1 (?z ?body ?body2 ...))
     (if (memv ?e1 '?z) (begin ?body ?body2 ...)))
    ((case ?e1 ?clause1 ?clause2 ?clause3 ...)
     (letrec-syntax
       ((case-aux
          (... (syntax-rules (else)
                ((case-aux ?temp (else ?body ?body2 ...))
                 (begin ?body ?body2 ...))
                ((case-aux ?temp ((?z ...) ?body ?body2 ...))
                 (if (memv ?temp '(?z ...)) (begin ?body ?body2 ...)))
                ((case-aux ?temp ((?z ...) ?body ?body2 ...) ?c1 ?c2 ...)
                 (if (memv ?temp '(?z ...))
                     (begin ?body ?body2 ...)
                     (case-aux ?temp ?c1 ?c2 ...)))
                ; a popular extension
                ((case-aux ?temp (?z ?body ...) ?c1 ...)
                 (case-aux ?temp ((?z) ?body ...) ?c1 ...))))))
       (let ((temp ?e1))
         (case-aux temp ?clause1 ?clause2 ?clause3 ...))))))

; A complete implementation of quasiquote, obtained by translating
; Jonathan Rees's implementation that was posted to RRRS-AUTHORS
; on 22 December 1986.
; Unfortunately, the use of LETREC scope means that it is vulnerable
; to top-level redefinitions of QUOTE etc.  That could be fixed, but
; it has hair enough already.

(begin
 
 (define-syntax .finalize-quasiquote letrec
   (syntax-rules (quote unquote unquote-splicing)
    ((.finalize-quasiquote quote ?arg ?return)
     (.interpret-continuation ?return (quote ?arg)))
    ((.finalize-quasiquote unquote ?arg ?return)
     (.interpret-continuation ?return ?arg))
    ((.finalize-quasiquote unquote-splicing ?arg ?return)
     (syntax-error ",@ in illegal context" ?arg))
    ((.finalize-quasiquote ?mode ?arg ?return)
     (.interpret-continuation ?return (?mode . ?arg)))))
 
 ; The first two "arguments" to .descend-quasiquote and to
 ; .descend-quasiquote-pair are always identical.
 
 (define-syntax .descend-quasiquote letrec
   (syntax-rules (quasiquote unquote unquote-splicing)
    ((.descend-quasiquote `?y ?x ?level ?return)
     (.descend-quasiquote-pair ?x ?x (?level) ?return))
    ((.descend-quasiquote ,?y ?x () ?return)
     (.interpret-continuation ?return unquote ?y))
    ((.descend-quasiquote ,?y ?x (?level) ?return)
     (.descend-quasiquote-pair ?x ?x ?level ?return))
    ((.descend-quasiquote ,@?y ?x () ?return)
     (.interpret-continuation ?return unquote-splicing ?y))
    ((.descend-quasiquote ,@?y ?x (?level) ?return)
     (.descend-quasiquote-pair ?x ?x ?level ?return))
    ((.descend-quasiquote (?y . ?z) ?x ?level ?return)
     (.descend-quasiquote-pair ?x ?x ?level ?return))
    ((.descend-quasiquote #(?y ...) ?x ?level ?return)
     (.descend-quasiquote-vector ?x ?x ?level ?return))
    ((.descend-quasiquote ?y ?x ?level ?return)
     (.interpret-continuation ?return quote ?x))))
 
 (define-syntax .descend-quasiquote-pair letrec
   (syntax-rules (quote unquote unquote-splicing)
    ((.descend-quasiquote-pair (?carx . ?cdrx) ?x ?level ?return)
     (.descend-quasiquote ?carx ?carx ?level (1 ?cdrx ?x ?level ?return)))))
 
 (define-syntax .descend-quasiquote-vector letrec
   (syntax-rules (quote)
    ((.descend-quasiquote-vector #(?y ...) ?x ?level ?return)
     (.descend-quasiquote (?y ...) (?y ...) ?level (6 ?x ?return)))))
 
 ; Representations for continuations used here.
 ; Continuation types 0, 1, 2, and 6 take a mode and an expression.
 ; Continuation types -1, 3, 4, 5, and 7 take just an expression.
 ;
 ; (-1)
 ;     means no continuation
 ; (0)
 ;     means to call .finalize-quasiquote with no further continuation
 ; (1 ?cdrx ?x ?level ?return)
 ;     means a return from the call to .descend-quasiquote from
 ;     .descend-quasiquote-pair
 ; (2 ?car-mode ?car-arg ?x ?return)
 ;     means a return from the second call to .descend-quasiquote in
 ;     in Jonathan's code for .descend-quasiquote-pair
 ; (3 ?car-arg ?return)
 ;     means take the result and return an append of ?car-arg with it
 ; (4 ?cdr-mode ?cdr-arg ?return)
 ;     means take the result and call .finalize-quasiquote on ?cdr-mode
 ;     and ?cdr-arg with a continuation of type 5
 ; (5 ?car-result ?return)
 ;     means take the result and return a cons of ?car-result onto it
 ; (6 ?x ?return)
 ;     means a return from the call to .descend-quasiquote from
 ;     .descend-quasiquote-vector
 ; (7 ?return)
 ;     means take the result and return a call of list->vector on it
 
 (define-syntax .interpret-continuation letrec
   (syntax-rules (quote unquote unquote-splicing)
    ((.interpret-continuation (-1) ?e) ?e)
    ((.interpret-continuation (0) ?mode ?arg)
     (.finalize-quasiquote ?mode ?arg (-1)))    
    ((.interpret-continuation (1 ?cdrx ?x ?level ?return) ?car-mode ?car-arg)
     (.descend-quasiquote ?cdrx
                          ?cdrx
                          ?level
                          (2 ?car-mode ?car-arg ?x ?return)))    
    ((.interpret-continuation (2 quote ?car-arg ?x ?return) quote ?cdr-arg)
     (.interpret-continuation ?return quote ?x))    
    ((.interpret-continuation (2 unquote-splicing ?car-arg ?x ?return) quote ())
     (.interpret-continuation ?return unquote ?car-arg))
    ((.interpret-continuation (2 unquote-splicing ?car-arg ?x ?return)
                              ?cdr-mode ?cdr-arg)
     (.finalize-quasiquote ?cdr-mode ?cdr-arg (3 ?car-arg ?return)))  
    ((.interpret-continuation (2 ?car-mode ?car-arg ?x ?return)
                              ?cdr-mode ?cdr-arg)
     (.finalize-quasiquote ?car-mode ?car-arg (4 ?cdr-mode ?cdr-arg ?return)))
      
    ((.interpret-continuation (3 ?car-arg ?return) ?e)
     (.interpret-continuation ?return append (?car-arg ?e)))
    ((.interpret-continuation (4 ?cdr-mode ?cdr-arg ?return) ?e1)
     (.finalize-quasiquote ?cdr-mode ?cdr-arg (5 ?e1 ?return)))
    ((.interpret-continuation (5 ?e1 ?return) ?e2)
     (.interpret-continuation ?return .cons (?e1 ?e2)))
    ((.interpret-continuation (6 ?x ?return) quote ?arg)
     (.interpret-continuation ?return quote ?x))
    ((.interpret-continuation (6 ?x ?return) ?mode ?arg)
     (.finalize-quasiquote ?mode ?arg (7 ?return)))
    ((.interpret-continuation (7 ?return) ?e)
     (.interpret-continuation ?return .list->vector (?e)))))
 
 (define-syntax quasiquote letrec
   (syntax-rules ()
    ((quasiquote ?x)
     (.descend-quasiquote ?x ?x () (0)))))
 )

(define-syntax let*-syntax
  (syntax-rules ()
    ((let*-syntax () ?body)
     (let-syntax () ?body))
    ((let*-syntax ((?name1 ?val1) (?name ?val) ...) ?body)
     (let-syntax ((?name1 ?val1)) (let*-syntax ((?name ?val) ...) ?body)))))


            ))

(define-syntax-scope 'letrec)

(define standard-syntactic-environment
  (syntactic-copy global-syntactic-environment))

(define (make-standard-syntactic-environment)
  (syntactic-copy standard-syntactic-environment))
; Copyright 1998 William Clinger.
;
; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
;
; 25 April 1999
;
; Given an expression in the subset of Scheme used as an intermediate language
; by Twobit, returns a newly allocated copy of the expression in which the
; local variables have been renamed and the referencing information has been
; recomputed.

(define (copy-exp exp)
  
  (define special-names (cons name:IGNORED argument-registers))
  
  (define original-names (make-hashtable symbol-hash assq))
  
  (define renaming-counter 0)
  
  (define (rename-vars vars)
    (let ((rename (make-rename-procedure)))
      (map (lambda (var)
             (cond ((memq var special-names)
                    var)
                   ((hashtable-get original-names var)
                    (rename var))
                   (else
                    (hashtable-put! original-names var #t)
                    var)))
           vars)))
  
  (define (rename-formals formals newnames)
    (cond ((null? formals) '())
          ((symbol? formals) (car newnames))
          ((memq (car formals) special-names)
           (cons (car formals)
                 (rename-formals (cdr formals)
                                 (cdr newnames))))
          (else (cons (car newnames)
                      (rename-formals (cdr formals)
                                      (cdr newnames))))))
  
  ; Environments that map symbols to arbitrary information.
  ; This data type is mutable, and uses the shallow binding technique.
  
  (define (make-env) (make-hashtable symbol-hash assq))
  
  (define (env-bind! env sym info)
    (let ((stack (hashtable-get env sym)))
      (hashtable-put! env sym (cons info stack))))
  
  (define (env-unbind! env sym)
    (let ((stack (hashtable-get env sym)))
      (hashtable-put! env sym (cdr stack))))
  
  (define (env-lookup env sym default)
    (let ((stack (hashtable-get env sym)))
      (if stack
          (car stack)
          default)))
  
  (define (env-bind-multiple! env symbols infos)
    (for-each (lambda (sym info) (env-bind! env sym info))
              symbols
              infos))
  
  (define (env-unbind-multiple! env symbols)
    (for-each (lambda (sym) (env-unbind! env sym))
              symbols))
  
  ;
  
  (define (lexical-lookup R-table name)
    (assq name R-table))
  
  (define (copy exp env notepad R-table)
    (cond ((constant? exp) exp)
          ((lambda? exp)
           (let* ((bvl (make-null-terminated (lambda.args exp)))
                  (newnames (rename-vars bvl))
                  (procnames (map def.lhs (lambda.defs exp)))
                  (newprocnames (rename-vars procnames))
                  (refinfo (map (lambda (var)
                                  (make-R-entry var '() '() '()))
                                (append newnames newprocnames)))
                  (newexp
                   (make-lambda
                    (rename-formals (lambda.args exp) newnames)
                    '()
                    refinfo
                    '()
                    '()
                    (lambda.decls exp)
                    (lambda.doc exp)
                    (lambda.body exp))))
             (env-bind-multiple! env procnames newprocnames)
             (env-bind-multiple! env bvl newnames)
             (for-each (lambda (entry)
                         (env-bind! R-table (R-entry.name entry) entry))
                       refinfo)
             (notepad-lambda-add! notepad newexp)
             (let ((newnotepad (make-notepad notepad)))
               (for-each (lambda (name rhs)
                           (lambda.defs-set!
                             newexp
                             (cons (make-definition
                                    name
                                    (copy rhs env newnotepad R-table))
                                   (lambda.defs newexp))))
                         (reverse newprocnames)
                         (map def.rhs
                              (reverse (lambda.defs exp))))
               (lambda.body-set!
                 newexp
                 (copy (lambda.body exp) env newnotepad R-table))
               (lambda.F-set! newexp (notepad-free-variables newnotepad))
               (lambda.G-set! newexp (notepad-captured-variables newnotepad)))
             (env-unbind-multiple! env procnames)
             (env-unbind-multiple! env bvl)
             (for-each (lambda (entry)
                         (env-unbind! R-table (R-entry.name entry)))
                       refinfo)
             newexp))
          ((assignment? exp)
           (let* ((oldname (assignment.lhs exp))
                  (name (env-lookup env oldname oldname))
                  (varinfo (env-lookup R-table name #f))
                  (newexp
                   (make-assignment name
                                    (copy (assignment.rhs exp) env notepad R-table))))
             (notepad-var-add! notepad name)
             (if varinfo
                 (R-entry.assignments-set!
                  varinfo
                  (cons newexp (R-entry.assignments varinfo))))
             newexp))
          ((conditional? exp)
           (make-conditional (copy (if.test exp) env notepad R-table)
                             (copy (if.then exp) env notepad R-table)
                             (copy (if.else exp) env notepad R-table)))
          ((begin? exp)
           (make-begin (map (lambda (exp) (copy exp env notepad R-table))
                            (begin.exprs exp))))
          ((variable? exp)
           (let* ((oldname (variable.name exp))
                  (name (env-lookup env oldname oldname))
                  (varinfo (env-lookup R-table name #f))
                  (newexp (make-variable name)))
             (notepad-var-add! notepad name)
             (if varinfo
                 (R-entry.references-set!
                  varinfo
                  (cons newexp (R-entry.references varinfo))))
             newexp))
          ((call? exp)
           (let ((newexp (make-call (copy (call.proc exp) env notepad R-table)
                                    (map (lambda (exp)
                                           (copy exp env notepad R-table))
                                         (call.args exp)))))
             (if (variable? (call.proc newexp))
                 (let ((varinfo
                        (env-lookup R-table
                                    (variable.name
                                     (call.proc newexp))
                                    #f)))
                   (if varinfo
                       (R-entry.calls-set!
                        varinfo
                        (cons newexp (R-entry.calls varinfo))))))
             (if (lambda? (call.proc newexp))
                 (notepad-nonescaping-add! notepad (call.proc newexp)))
             newexp))
          (else ???)))
  
  (copy exp (make-env) (make-notepad #f) (make-env)))

; For debugging.
; Given an expression, traverses the expression to confirm
; that the referencing invariants are correct.

(define (check-referencing-invariants exp . flags)
  
  (let ((check-free-variables? (memq 'free flags))
        (check-referencing? (memq 'reference flags))
        (first-violation? #t))
    
    ; env is the list of enclosing lambda expressions,
    ; beginning with the innermost.
    
    (define (check exp env)
      (cond ((constant? exp) (return exp #t))
            ((lambda? exp)
             (let ((env (cons exp env)))
               (return exp
                       (and (every? (lambda (exp)
                                      (check exp env))
                                    (map def.rhs (lambda.defs exp)))
                            (check (lambda.body exp) env)
                            (if (and check-free-variables?
                                     (not (null? env)))
                                 (subset? (difference
                                           (lambda.F exp)
                                           (make-null-terminated
                                            (lambda.args exp)))
                                          (lambda.F (car env)))
                                #t)
                            (if check-referencing?
                                (let ((env (cons exp env))
                                      (R (lambda.R exp)))
                                  (every? (lambda (formal)
                                            (or (ignored? formal)
                                                (R-entry R formal)))
                                          (make-null-terminated
                                           (lambda.args exp))))
                                #t)))))
            ((variable? exp)
             (return exp
                     (and (if (and check-free-variables?
                                   (not (null? env)))
                              (memq (variable.name exp)
                                    (lambda.F (car env)))
                              #t)
                          (if check-referencing?
                              (let ((Rinfo (lookup env (variable.name exp))))
                                (if Rinfo
                                    (memq exp (R-entry.references Rinfo))
                                    #t))
                              #t))))
            ((assignment? exp)
             (return exp
                     (and (check (assignment.rhs exp) env)
                          (if (and check-free-variables?
                                   (not (null? env)))
                              (memq (assignment.lhs exp)
                                    (lambda.F (car env)))
                              #t)
                          (if check-referencing?
                              (let ((Rinfo (lookup env (assignment.lhs exp))))
                                (if Rinfo
                                    (memq exp (R-entry.assignments Rinfo))
                                    #t))
                              #t))))
            ((conditional? exp)
             (return exp
                     (and (check (if.test exp) env)
                          (check (if.then exp) env)
                          (check (if.else exp) env))))
            ((begin? exp)
             (return exp
                     (every? (lambda (exp) (check exp env))
                             (begin.exprs exp))))
            ((call? exp)
             (return exp
                     (and (check (call.proc exp) env)
                          (every? (lambda (exp) (check exp env))
                                  (call.args exp))
                          (if (and check-referencing?
                                   (variable? (call.proc exp)))
                              (let ((Rinfo (lookup env
                                                   (variable.name 
                                                    (call.proc exp)))))
                                (if Rinfo
                                    (memq exp (R-entry.calls Rinfo))
                                    #t))
                              #t))))
            (else ???)))
    
    (define (return exp flag)
      (cond (flag
             #t)
            (first-violation?
             (set! first-violation? #f)
             (display "Violation of referencing invariants")
             (newline)
             (pretty-print (make-readable exp))
             #f)
            (else (pretty-print (make-readable exp))
                  #f)))
    
    (define (lookup env I)
      (if (null? env)
          #f
          (let ((Rinfo (R-entry (lambda.R (car env)) I)))
            (or Rinfo
                (lookup (cdr env) I)))))
    
    (if (null? flags)
        (begin (set! check-free-variables? #t)
               (set! check-referencing? #t)))
    
    (check exp '())))


; Calculating the free variable information for an expression
; as output by pass 2.  This should be faster than computing both
; the free variables and the referencing information.

(define (compute-free-variables! exp)
  
  (define empty-set (make-set '()))
  
  (define (singleton x) (list x))
  
  (define (union2 x y) (union x y))
  (define (union3 x y z) (union x y z))
  
  (define (set->list set) set)
  
  (define (free exp)
    (cond ((constant? exp) empty-set)
          ((lambda? exp)
           (let* ((defs (lambda.defs exp))
                  (formals (make-set
                            (make-null-terminated (lambda.args exp))))
                  (defined (make-set (map def.lhs defs)))
                  (Fdefs
                   (apply-union
                    (map (lambda (def)
                           (free (def.rhs def)))
                         defs)))
                  (Fbody (free (lambda.body exp)))
                  (F (union2 Fdefs Fbody)))
             (lambda.F-set! exp (set->list F))
             (lambda.G-set! exp (set->list F))
             (difference F (union2 formals defined))))
          ((assignment? exp)
           (union2 (make-set (list (assignment.lhs exp)))
                   (free (assignment.rhs exp))))
          ((conditional? exp)
           (union3 (free (if.test exp))
                   (free (if.then exp))
                   (free (if.else exp))))
          ((begin? exp)
           (apply-union
            (map (lambda (exp) (free exp))
                 (begin.exprs exp))))
          ((variable? exp)
           (singleton (variable.name exp)))
          ((call? exp)
           (union2 (free (call.proc exp))
                   (apply-union
                    (map (lambda (exp) (free exp))
                         (call.args exp)))))
          (else ???)))
  
  (free exp))

; As above, but representing sets as hashtrees.
; This is commented out because it is much slower than the implementation
; above.  Because the set of free variables is represented as a list
; within a lambda expression, this implementation must convert the
; representation for every lambda expression, which is quite expensive
; for A-normal form.

(begin
'
(define (compute-free-variables! exp)
  
  (define empty-set (make-hashtree symbol-hash assq))
  
  (define (singleton x)
    (hashtree-put empty-set x #t))
  
  (define (make-set values)
    (if (null? values)
        empty-set
        (hashtree-put (make-set (cdr values))
                      (car values)
                      #t)))
  
  (define (union2 x y)
    (hashtree-for-each (lambda (key val)
                         (set! x (hashtree-put x key #t)))
                       y)
    x)
  
  (define (union3 x y z)
    (union2 (union2 x y) z))
  
  (define (apply-union sets)
    (cond ((null? sets)
           (make-set '()))
          ((null? (cdr sets))
           (car sets))
          (else
           (union2 (car sets)
                   (apply-union (cdr sets))))))
  
  (define (difference x y)
    (hashtree-for-each (lambda (key val)
                         (set! x (hashtree-remove x key)))
                       y)
    x)
  
  (define (set->list set)
    (hashtree-map (lambda (sym val) sym) set))
  
  (define (free exp)
    (cond ((constant? exp) empty-set)
          ((lambda? exp)
           (let* ((defs (lambda.defs exp))
                  (formals (make-set
                            (make-null-terminated (lambda.args exp))))
                  (defined (make-set (map def.lhs defs)))
                  (Fdefs
                   (apply-union
                    (map (lambda (def)
                           (free (def.rhs def)))
                         defs)))
                  (Fbody (free (lambda.body exp)))
                  (F (union2 Fdefs Fbody)))
             (lambda.F-set! exp (set->list F))
             (lambda.G-set! exp (set->list F))
             (difference F (union2 formals defined))))
          ((assignment? exp)
           (union2 (make-set (list (assignment.lhs exp)))
                   (free (assignment.rhs exp))))
          ((conditional? exp)
           (union3 (free (if.test exp))
                   (free (if.then exp))
                   (free (if.else exp))))
          ((begin? exp)
           (apply-union
            (map (lambda (exp) (free exp))
                 (begin.exprs exp))))
          ((variable? exp)
           (singleton (variable.name exp)))
          ((call? exp)
           (union2 (free (call.proc exp))
                   (apply-union
                    (map (lambda (exp) (free exp))
                         (call.args exp)))))
          (else ???)))
  
  (hashtree-map (lambda (sym val) sym)
                (free exp)))
#t); Copyright 1991 William Clinger
;
; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
;
; 24 April 1999
;
; First pass of the Twobit compiler:
;   macro expansion, syntax checking, alpha conversion,
;   preliminary annotation.
;
; The input to this pass is a Scheme definition or expression.
; The output is an expression in the subset of Scheme described
; by the following grammar, where the output satisfies certain
; additional invariants described below.
;
; "X ..." means zero or more occurrences of X.
;
; L  -->  (lambda (I_1 ...)
;           (begin D ...)
;           (quote (R F G <decls> <doc>)
;           E)
;      |  (lambda (I_1 ... . I_rest)
;           (begin D ...)
;           (quote (R F <decls> <doc>))
;           E)
; D  -->  (define I L)
; E  -->  (quote K)                        ; constants
;      |  (begin I)                        ; variable references
;      |  L                                ; lambda expressions
;      |  (E0 E1 ...)                      ; calls
;      |  (set! I E)                       ; assignments
;      |  (if E0 E1 E2)                    ; conditionals
;      |  (begin E0 E1 E2 ...)             ; sequential expressions
; I  -->  <identifier>
;
; R  -->  ((I <references> <assignments> <calls>) ...)
; F  -->  (I ...)
; G  -->  (I ...)
;
; Invariants that hold for the output:
;   *  There are no internal definitions.
;   *  No identifier containing an upper case letter is bound anywhere.
;      (Change the "name:..." variables if upper case is preferred.)
;   *  No identifier is bound in more than one place.
;   *  Each R contains one entry for every identifier bound in the
;      formal argument list and the internal definition list that
;      precede it.  Each entry contains a list of pointers to all
;      references to the identifier, a list of pointers to all
;      assignments to the identifier, and a list of pointers to all
;      calls to the identifier.
;   *  Except for constants, the expression does not share structure
;      with the original input or itself, except that the references
;      and assignments in R are guaranteed to share structure with
;      the expression.  Thus the expression may be side effected, and
;      side effects to references or assignments obtained through R
;      are guaranteed to change the references or assignments pointed
;      to by R.
;   *  F and G are garbage.

($$trace "pass1")

(define source-file-name #f)
(define source-file-position #f)

(define pass1-block-compiling? #f)
(define pass1-block-assignments '())
(define pass1-block-inlines '())

(define (pass1 def-or-exp . rest)
  (set! source-file-name #f)
  (set! source-file-position #f)
  (set! pass1-block-compiling? #f)
  (set! pass1-block-assignments '())
  (set! pass1-block-inlines '())
  (if (not (null? rest))
      (begin (set! source-file-name (car rest))
             (if (not (null? (cdr rest)))
                 (set! source-file-position (cadr rest)))))
  (set! renaming-counter 0)
  (macro-expand def-or-exp))

; Compiles a whole sequence of top-level forms on the assumption
; that no variable that is defined by a form in the sequence is
; ever defined or assigned outside of the sequence.
;
; This is a crock in three parts:
;
;    1.  Macro-expand each form and record assignments.
;    2.  Find the top-level variables that are defined but not
;        assigned, give them local names, generate a DEFINE-INLINE
;        for each of the top-level procedures, and macro-expand
;        each form again.
;    3.  Wrap the whole mess in an appropriate LET and recompute
;        the referencing information by copying it.
;
; Note that macros get expanded twice, and that all DEFINE-SYNTAX
; macros are considered local to the forms.

; FIXME: Need to turn off warning messages.

(define (pass1-block forms . rest)
  
  (define (part1)
    (set! pass1-block-compiling? #t)
    (set! pass1-block-assignments '())
    (set! pass1-block-inlines '())
    (set! renaming-counter 0)
    (let ((env0 (syntactic-copy global-syntactic-environment))
          (bmode (benchmark-mode))
          (wmode (issue-warnings))
          (defined '()))
      (define (make-toplevel-definition id exp)
        (cond ((memq id defined)
               (set! pass1-block-assignments
                     (cons id pass1-block-assignments)))
              ((or (constant? exp)
                   (and (lambda? exp)
                        (list? (lambda.args exp))))
               (set! defined (cons id defined))))
        (make-begin
         (list (make-assignment id exp)
               (make-constant id))))
      (benchmark-mode #f)
      (issue-warnings #f)
      (for-each (lambda (form)
                  (desugar-definitions form
                                       global-syntactic-environment
                                       make-toplevel-definition))
                forms)
      (set! global-syntactic-environment env0)
      (benchmark-mode bmode)
      (issue-warnings wmode)
      (part2 (filter (lambda (id)
                       (not (memq id pass1-block-assignments)))
                     (reverse defined)))))
  
  (define (part2 defined)
    (set! pass1-block-compiling? #f)
    (set! pass1-block-assignments '())
    (set! pass1-block-inlines '())
    (set! renaming-counter 0)
    (let* ((rename (make-rename-procedure))
           (alist (map (lambda (id)
                         (cons id (rename id)))
                       defined))
           (definitions0 '())    ; for constants
           (definitions1 '()))   ; for lambda expressions
      (define (make-toplevel-definition id exp)
        (if (lambda? exp)
            (doc.name-set! (lambda.doc exp) id))
        (let ((probe (assq id alist)))
          (if probe
              (let ((id1 (cdr probe)))
                (cond ((constant? exp)
                       (set! definitions0
                             (cons (make-assignment id exp)
                                   definitions0))
                       (make-constant id))
                      ((lambda? exp)
                       (set! definitions1
                             (cons (make-assignment id1 exp)
                                   definitions1))
                       (make-assignment
                        id
                        (make-lambda (lambda.args exp)
                                     '() ; no definitions
                                     '() ; R
                                     '() ; F
                                     '() ; G
                                     '() ; decls
                                     (lambda.doc exp)
                                     (make-call
                                      (make-variable id1)
                                      (map make-variable
                                           (lambda.args exp))))))
                      (else
                       (m-error "Inconsistent macro expansion"
                                (make-readable exp)))))
              (make-assignment id exp))))
      (let ((env0 (syntactic-copy global-syntactic-environment))
            (bmode (benchmark-mode))
            (wmode (issue-warnings)))
        (issue-warnings #f)
        (for-each (lambda (pair)
                    (let ((id0 (car pair))
                          (id1 (cdr pair)))
                      (syntactic-bind-globally!
                       id0
                       (make-inline-denotation
                        id0
                        (lambda (exp rename compare)
                          ; Deliberately non-hygienic!
                          (cons id1 (cdr exp)))
                        global-syntactic-environment))
                      (set! pass1-block-inlines
                            (cons id0 pass1-block-inlines))))
                  alist)
        (benchmark-mode #f)
        (issue-warnings wmode)
        (let ((forms
               (do ((forms forms (cdr forms))
                    (newforms '()
                              (cons (desugar-definitions
                                     (car forms)
                                     global-syntactic-environment
                                     make-toplevel-definition)
                                    newforms)))
                   ((null? forms)
                    (reverse newforms)))))
          (benchmark-mode bmode)
          (set! global-syntactic-environment env0)
          (part3 alist definitions0 definitions1 forms)))))
  
  (define (part3 alist definitions0 definitions1 forms)
    (set! pass1-block-compiling? #f)
    (set! pass1-block-assignments '())
    (set! pass1-block-inlines '())
    (let* ((constnames0 (map assignment.lhs definitions0))
           (constnames1 (map (lambda (id0)
                               (cdr (assq id0 alist)))
                             constnames0))
           (procnames1 (map assignment.lhs definitions1)))
      (copy-exp
       (make-call
        (make-lambda
         constnames1
         '() ; no definitions
         '() ; R
         '() ; F
         '() ; G
         '() ; decls
         #f  ; doc
         (make-begin
          (list
           (make-begin
            (cons (make-constant #f)
                  (reverse
                   (map (lambda (id)
                          (make-assignment id (make-variable (cdr (assq id alist)))))
                        constnames0))))
           (make-call
            (make-lambda
             constnames0
             '() ; no definitions
             '() ; R
             '() ; F
             '() ; G
             '() ; decls
             #f  ; doc
             (make-call
              (make-lambda
               (map assignment.lhs definitions1)
               '() ; no definitions
               '() ; R
               '() ; F
               '() ; G
               '() ; decls
               #f  ; doc
               (make-begin (cons (make-constant #f)
                                 (append definitions1 forms))))
              (map (lambda (ignored) (make-unspecified))
                   definitions1)))
            (map make-variable constnames1))
           )))
        (map assignment.rhs definitions0)))))
  
  (set! source-file-name #f)
  (set! source-file-position #f)
  (if (not (null? rest))
      (begin (set! source-file-name (car rest))
             (if (not (null? (cdr rest)))
                 (set! source-file-position (cadr rest)))))
  (part1))
; Copyright 1999 William D Clinger.
;
; Permission to copy this software, in whole or in part, to use this
; software for any lawful noncommercial purpose, and to redistribute
; this software is granted subject to the restriction that all copies
; made of this software must include this copyright notice in full.
;
; I also request that you send me a copy of any improvements that you
; make to this software so that they may be incorporated within it to
; the benefit of the Scheme community.
;
; 7 June 1999.
;
; Support for intraprocedural value numbering:
;     set of available expressions
;     miscellaneous
;
; The set of available expressions is represented as a
; mutable abstract data type Available with these operations:
;
; make-available-table:                                    -> Available
; copy-available-table: Available                          -> Available
; available-expression: Available x Expr                   -> (symbol + {#f})
; available-variable:   Available x symbol                 -> Expr
; available-extend!:    Available x symbol x Expr x Killer ->
; available-kill!:      Available x Killer                 ->
;
; where Expr is of the form
;
; Expr  -->  W
;         |  (W_0 W_1 ...)
;
; W  -->  (quote K)
;      |  (begin I)
;
; and Killer is a fixnum, as defined later in this file.
;
; (make-available-table)
;     returns an empty table of available expressions.
; (copy-available-table available)
;     copies the given table.
; (available-expression available E)
;     returns the name of E if it is available in the table, else #f.
; (available-variable available T)
;     returns a constant or variable to use in place of T, else #f.
; (available-extend! available T E K)
;     adds the binding (T E) to the table, with Killer K.
;     If E is a variable and this binding is never killed, then copy
;         propagation will replace uses of T by uses of E; otherwise
;         commoning will replace uses of E by uses of T, until the
;         binding is killed.
; (available-kill! available K)
;     removes all bindings whose Killer intersects K.
;
; (available-extend! available T E K) is very fast if the previous
; operation on the table was (available-expression available E).

; Implementation.
;
; Quick and dirty.
; The available expressions are represented as a vector of 2 association
; lists.  The first list is used for common subexpression elimination,
; and the second is used for copy and constant propagation.
;
; Each element of the first list is a binding of
; a symbol T to an expression E, with killer K,
; represented by the list (E T K).
;
; Each element of the second list is a binding of
; a symbol T to an expression E, with killer K,
; represented by the list (T E K).
; The expression E will be a constant or variable.

(define (make-available-table)
  (vector '() '()))

(define (copy-available-table available)
  (vector (vector-ref available 0)
          (vector-ref available 1)))

(define (available-expression available E)
  (let ((binding (assoc E (vector-ref available 0))))
    (if binding
        (cadr binding)
        #f)))

(define (available-variable available T)
  (let ((binding (assq T (vector-ref available 1))))
    (if binding
        (cadr binding)
        #f)))

(define (available-extend! available T E K)
  (cond ((constant? E)
         (vector-set! available
                      1
                      (cons (list T E K)
                            (vector-ref available 1))))
        ((and (variable? E)
              (eq? K available:killer:none))
         (vector-set! available
                      1
                      (cons (list T E K)
                            (vector-ref available 1))))
        (else
         (vector-set! available
                      0
                      (cons (list E T K)
                            (vector-ref available 0))))))

(define (available-kill! available K)
  (vector-set! available
               0
               (filter (lambda (binding)
                         (zero?
                          (logand K
                                  (caddr binding))))
                       (vector-ref available 0)))
  (vector-set! available
               1
               (filter (lambda (binding)
                         (zero?
                          (logand K
                                  (caddr binding))))
                       (vector-ref available 1))))

(define (available-intersect! available0 available1 available2)
  (vector-set! available0
               0
               (intersection (vector-ref available1 0)
                             (vector-ref available2 0)))
  (vector-set! available0
               1
               (intersection (vector-ref available1 1)
                             (vector-ref available2 1))))

; The Killer concrete data type, represented as a fixnum.
;
; The set of side effects that can kill an available expression
; are a subset of
;
; assignments to global variables
; uses of SET-CAR!
; uses of SET-CDR!
; uses of STRING-SET!
; uses of VECTOR-SET!
;
; This list is not complete.  If we were trying to perform common
; subexpression elimination on calls to PEEK-CHAR, for example,
; then those calls would be killed by reads.

(define available:killer:globals   2)
(define available:killer:car       4)
(define available:killer:cdr       8)
(define available:killer:string   16) ; also bytevectors etc
(define available:killer:vector   32) ; also structures etc
(define available:killer:cell     64)
(define available:killer:io      128)
(define available:killer:none      0) ; none of the above
(define available:killer:all    1022) ; all of the above

(define available:killer:immortal  0) ; never killed
(define available:killer:dead   1023) ; never available



(define (available:killer-combine k1 k2)
  (logior k1 k2))

; Miscellaneous.

; A simple lambda expression has no internal definitions at its head
; and no declarations aside from A-normal form.

(define (simple-lambda? L)
  (and (null? (lambda.defs L))
       (every? (lambda (decl)
                 (eq? decl A-normal-form-declaration))
               (lambda.decls L))))

; A real call is a call whose procedure expression is
; neither a lambda expression nor a primop.

(define (real-call? E)
  (and (call? E)
       (let ((proc (call.proc E)))
         (and (not (lambda? proc))
              (or (not (variable? proc))
                  (let ((f (variable.name proc)))
                    (or (not (integrate-usual-procedures))
                        (not (prim-entry f)))))))))

(define (prim-call E)
  (and (call? E)
       (let ((proc (call.proc E)))
         (and (variable? proc)
              (integrate-usual-procedures)
              (prim-entry (variable.name proc))))))

(define (no-side-effects? E)
  (or (constant? E)
      (variable? E)
      (lambda? E)
      (and (conditional? E)
           (no-side-effects? (if.test E))
           (no-side-effects? (if.then E))
           (no-side-effects? (if.else E)))
      (and (call? E)
           (let ((proc (call.proc E)))
             (and (variable? proc)
                  (integrate-usual-procedures)
                  (let ((entry (prim-entry (variable.name proc))))
                    (and entry
                         (not (eq? available:killer:dead
                                   (prim-lives-until entry))))))))))

; Given a local variable, the expression within its scope, and
; a list of local variables that are known to be used only once,
; returns #t if the variable is used only once.
;
; The purpose of this routine is to recognize temporaries that
; may once have had two or more uses because of CSE, but now have
; only one use because of further CSE followed by dead code elimination.

(define (temporary-used-once? T E used-once)
  (cond ((call? E)
         (let ((proc (call.proc E))
               (args (call.args E)))
           (or (and (lambda? proc)
                    (not (memq T (lambda.F proc)))
                    (and (pair? args)
                         (null? (cdr args))
                         (temporary-used-once? T (car args) used-once)))
               (do ((exprs (cons proc (call.args E))
                           (cdr exprs))
                    (n     0
                           (let ((exp (car exprs)))
                             (cond ((constant? exp)
                                    n)
                                   ((variable? exp)
                                    (if (eq? T (variable.name exp))
                                        (+ n 1)
                                        n))
                                   (else
                                    ; Terminate the loop and return #f.
                                    2)))))
                   ((or (null? exprs)
                        (> n 1))
                    (= n 1))))))
        (else
         (memq T used-once))))

; Register bindings.

(define (make-regbinding lhs rhs use)
  (list lhs rhs use))

(define (regbinding.lhs x) (car x))
(define (regbinding.rhs x) (cadr x))
(define (regbinding.use x) (caddr x))

; Given a list of register bindings, an expression E and its free variables F,
; returns two values:
;     E with the register bindings wrapped around it
;     the free variables of the wrapped expression

(define (wrap-with-register-bindings regbindings E F)
  (if (null? regbindings)
      (values E F)
      (let* ((regbinding (car regbindings))
             (R (regbinding.lhs regbinding))
             (x (regbinding.rhs regbinding)))
        (wrap-with-register-bindings
         (cdr regbindings)
         (make-call (make-lambda (list R)
                                 '()
                                 '()
                                 F
                                 F
                                 (list A-normal-form-declaration)
                                 #f
                                 E)
                    (list (make-variable x)))
         (union (list x)
                (difference F (list R)))))))

; Returns two values:
;   the subset of regbindings that have x as their right hand side
;   the rest of regbindings

(define (register-bindings regbindings x)
  (define (loop regbindings to-x others)
    (cond ((null? regbindings)
           (values to-x others))
          ((eq? x (regbinding.rhs (car regbindings)))
           (loop (cdr regbindings)
                 (cons (car regbindings) to-x)
                 others))
          (else
           (loop (cdr regbindings)
                 to-x
                 (cons (car regbindings) others)))))
  (loop regbindings '() '()))

; This procedure is called when the compiler can tell that an assertion
; is never true.

(define (declaration-error E)
  (if (issue-warnings)
      (begin (display "WARNING: Assertion is false: ")
             (write (make-readable E #t))
             (newline))))
; Representations, which form a subtype hierarchy.
;
; <rep>  ::=  <fixnum>  |  (<fixnum> <datum> ...)
;
; (<rep> <datum> ...) is a subtype of <rep>, but the non-fixnum
; representations are otherwise interpreted by arbitrary code.

(define *nreps* 0)
(define *rep-encodings* '())
(define *rep-decodings* '())
(define *rep-subtypes* '())
(define *rep-joins* (make-bytevector 0))
(define *rep-meets* (make-bytevector 0))
(define *rep-joins-special* '#())
(define *rep-meets-special* '#())

(define (representation-error msg . stuff)
  (apply error
         (if (string? msg)
             (string-append "Bug in flow analysis: " msg)
             msg)
         stuff))

(define (symbol->rep sym)
  (let ((probe (assq sym *rep-encodings*)))
    (if probe
        (cdr probe)
        (let ((rep *nreps*))
          (set! *nreps* (+ *nreps* 1))
          (if (> *nreps* 255)
              (representation-error "Too many representation types"))
          (set! *rep-encodings*
                (cons (cons sym rep)
                      *rep-encodings*))
          (set! *rep-decodings*
                (cons (cons rep sym)
                      *rep-decodings*))
          rep))))

(define (rep->symbol rep)
  (if (pair? rep)
      (cons (rep->symbol (car rep)) (cdr rep))
      (let ((probe (assv rep *rep-decodings*)))
        (if probe
            (cdr probe)
            'unknown))))

(define (representation-table table)
  (map (lambda (row)
         (map (lambda (x)
                (if (list? x)
                    (map symbol->rep x)
                    x))
              row))
       table))

; DEFINE-SUBTYPE is how representation types are defined.

(define (define-subtype sym1 sym2)
  (let* ((rep2 (symbol->rep sym2))
         (rep1 (symbol->rep sym1)))
    (set! *rep-subtypes*
          (cons (cons rep1 rep2)
                *rep-subtypes*))
    sym1))

; COMPUTE-TYPE-STRUCTURE! must be called before DEFINE-INTERSECTION.

(define (define-intersection sym1 sym2 sym3)
  (let ((rep1 (symbol->rep sym1))
        (rep2 (symbol->rep sym2))
        (rep3 (symbol->rep sym3)))
    (representation-aset! *rep-meets* rep1 rep2 rep3)
    (representation-aset! *rep-meets* rep2 rep1 rep3)))

;

(define (representation-aref bv i j)
  (bytevector-ref bv (+ (* *nreps* i) j)))

(define (representation-aset! bv i j x)
  (bytevector-set! bv (+ (* *nreps* i) j) x))

(define (compute-unions!)
  
  ; Always define a bottom element.
  
  (for-each (lambda (sym)
              (define-subtype 'bottom sym))
            (map car *rep-encodings*))
  
  (let* ((debugging? #f)
         (n *nreps*)
         (n^2 (* n n))
         (matrix (make-bytevector n^2)))
    
    ; This code assumes there will always be a top element.
    
    (define (lub rep1 rep2 subtype?)
      (do ((i 0 (+ i 1))
           (bounds '()
                   (if (and (subtype? rep1 i)
                            (subtype? rep2 i))
                       (cons i bounds)
                       bounds)))
          ((= i n)
           (car (twobit-sort subtype? bounds)))))
    
    (define (join i j)
      (lub i j (lambda (rep1 rep2)
                 (= 1 (representation-aref matrix rep1 rep2)))))
    
    (define (compute-transitive-closure!)
      (let ((changed? #f))
        (define (loop)
          (do ((i 0 (+ i 1)))
              ((= i n))
              (do ((k 0 (+ k 1)))
                  ((= k n))
                  (do ((j 0 (+ j 1))
                       (sum 0
                            (logior sum
                                    (logand
                                     (representation-aref matrix i j)
                                     (representation-aref matrix j k)))))
                      ((= j n)
                       (if (> sum 0)
                           (let ((x (representation-aref matrix i k)))
                             (if (zero? x)
                                 (begin
                                  (set! changed? #t)
                                  (representation-aset! matrix i k 1)))))))))
          (if changed?
              (begin (set! changed? #f)
                     (loop))))
        (loop)))
    
    (define (compute-joins!)
      (let ((default (lambda (x y)
                       (error "Compiler bug: special meet or join" x y))))
        (set! *rep-joins-special* (make-vector n default))
        (set! *rep-meets-special* (make-vector n default)))
      (set! *rep-joins* (make-bytevector n^2))
      (set! *rep-meets* (make-bytevector n^2))
      (do ((i 0 (+ i 1)))
          ((= i n))
          (do ((j 0 (+ j 1)))
              ((= j n))
              (representation-aset! *rep-joins*
                                    i
                                    j
                                    (join i j)))))
    
    (do ((i 0 (+ i 1)))
        ((= i n))
        (do ((j 0 (+ j 1)))
            ((= j n))
            (representation-aset! matrix i j 0))
        (representation-aset! matrix i i 1))
    (for-each (lambda (subtype)
                (let ((rep1 (car subtype))
                      (rep2 (cdr subtype)))
                  (representation-aset! matrix rep1 rep2 1)))
              *rep-subtypes*)
    (compute-transitive-closure!)
    (if debugging?
        (do ((i 0 (+ i 1)))
            ((= i n))
            (do ((j 0 (+ j 1)))
                ((= j n))
                (write-char #\space)
                (write (representation-aref matrix i j)))
            (newline)))
    (compute-joins!)
    (set! *rep-subtypes* '())))

; Intersections are not dual to unions because a conservative analysis
; must always err on the side of the larger subtype.
; COMPUTE-UNIONS! must be called before COMPUTE-INTERSECTIONS!.

(define (compute-intersections!)
  (let ((n *nreps*))
    
    (define (meet i j)
      (let ((k (representation-union i j)))
        (if (= i k)
            j
            i)))
    
    (do ((i 0 (+ i 1)))
        ((= i n))
        (do ((j 0 (+ j 1)))
            ((= j n))
            (representation-aset! *rep-meets*
                                  i
                                  j
                                  (meet i j))))))

(define (compute-type-structure!)
  (compute-unions!)
  (compute-intersections!))

(define (representation-subtype? rep1 rep2)
  (equal? rep2 (representation-union rep1 rep2)))

(define (representation-union rep1 rep2)
  (if (fixnum? rep1)
      (if (fixnum? rep2)
          (representation-aref *rep-joins* rep1 rep2)
          (representation-union rep1 (car rep2)))
      (if (fixnum? rep2)
          (representation-union (car rep1) rep2)
          (let ((r1 (car rep1))
                (r2 (car rep2)))
            (if (= r1 r2)
                ((vector-ref *rep-joins-special* r1) rep1 rep2)
                (representation-union r1 r2))))))

(define (representation-intersection rep1 rep2)
  (if (fixnum? rep1)
      (if (fixnum? rep2)
          (representation-aref *rep-meets* rep1 rep2)
          (representation-intersection rep1 (car rep2)))
      (if (fixnum? rep2)
          (representation-intersection (car rep1) rep2)
          (let ((r1 (car rep1))
                (r2 (car rep2)))
            (if (= r1 r2)
                ((vector-ref *rep-meets-special* r1) rep1 rep2)
                (representation-intersection r1 r2))))))

; For debugging.

(define (display-unions-and-intersections)
  (let* ((column-width 10)
         (columns/row (quotient 80 column-width)))
    
    (define (display-symbol sym)
      (let* ((s (symbol->string sym))
             (n (string-length s)))
        (if (< n column-width)
            (begin (display s)
                   (display (make-string (- column-width n) #\space)))
            (begin (display (substring s 0 (- column-width 1)))
                   (write-char #\space)))))
    
    ; Display columns i to n.
    
    (define (display-matrix f i n)
      (display (make-string column-width #\space))
      (do ((i i (+ i 1)))
          ((= i n))
          (display-symbol (rep->symbol i)))
      (newline)
      (newline)
      (do ((k 0 (+ k 1)))
          ((= k *nreps*))
          (display-symbol (rep->symbol k))
          (do ((i i (+ i 1)))
              ((= i n))
              (display-symbol (rep->symbol (f k i))))
          (newline))
      (newline)
      (newline))
    
    (display "Unions:")
    (newline)
    (newline)
    
    (do ((i 0 (+ i columns/row)))
        ((>= i *nreps*))
        (display-matrix representation-union
                        i
                        (min *nreps* (+ i columns/row))))
    
    (display "Intersections:")
    (newline)
    (newline)
    
    (do ((i 0 (+ i columns/row)))
        ((>= i *nreps*))
        (display-matrix representation-intersection
                        i
                        (min *nreps* (+ i columns/row))))))

; Operations that can be specialized.
;
; Format: (<name> (<arg-rep> ...) <specific-name>)

(define (rep-specific? f rs)
  (rep-match f rs rep-specific caddr))

; Operations whose result has some specific representation.
;
; Format: (<name> (<arg-rep> ...) (<result-rep>))

(define (rep-result? f rs)
  (rep-match f rs rep-result caaddr))

; Unary predicates that give information about representation.
;
; Format: (<name> <rep-if-true> <rep-if-false>)

(define (rep-if-true f rs)
  (rep-match f rs rep-informing caddr))

(define (rep-if-false f rs)
  (rep-match f rs rep-informing cadddr))

; Given the name of an integrable primitive,
; the representations of its arguments,
; a representation table, and a selector function
; finds the most type-specific row of the table that matches both
; the name of the primitive and the representations of its arguments,
; and returns the result of applying the selector to that row.
; If no row matches, then REP-MATCH returns #f.
;
; FIXME:  This should be more efficient, and should prefer the most
; specific matches.

(define (rep-match f rs table selector)
  (let ((n (length rs)))
    (let loop ((entries table))
      (cond ((null? entries)
             #f)
            ((eq? f (car (car entries)))
             (let ((rs0 (cadr (car entries))))
               (if (and (= n (length rs0))
                        (every? (lambda (r1+r2)
                                  (let ((r1 (car r1+r2))
                                        (r2 (cdr r1+r2)))
                                    (representation-subtype? r1 r2)))
                                (map cons rs rs0)))
                   (selector (car entries))
                   (loop (cdr entries)))))
            (else
             (loop (cdr entries)))))))

; Abstract interpretation with respect to types and constraints.
; Returns a representation type.

(define (aeval E types constraints)
  (cond ((call? E)
         (let ((proc (call.proc E)))
           (if (variable? proc)
               (let* ((op (variable.name proc))
                      (argtypes (map (lambda (E)
                                       (aeval E types constraints))
                                     (call.args E)))
                      (type (rep-result? op argtypes)))
                 (if type
                     type
                     rep:object))
               rep:object)))
        ((variable? E)
         (representation-typeof (variable.name E) types constraints))
        ((constant? E)
         (representation-of-value (constant.value E)))
        (else
         rep:object)))

; If x has representation type t0 in the hash table,
; and some further constraints
;
;     x = (op y1 ... yn)
;     x : t1
;      ...
;     x : tk
;
; then
;
;     typeof (x) = op (typeof (y1), ..., typeof (yn))
;                  &  t0  &  t1  &  ...  &  tk
;
; where & means intersection and op is the abstraction of op.
;
; Also if T : true and T = E then E may give information about
; the types of other variables.  Similarly for T : false.

(define (representation-typeof name types constraints)
  (let ((t0 (hashtable-fetch types name rep:object))
        (cs (hashtable-fetch (constraints.table constraints) name '())))
    (define (loop type cs)
      (if (null? cs)
          type
          (let* ((c (car cs))
                 (cs (cdr cs))
                 (E (constraint.rhs c)))
            (cond ((constant? E)
                   (loop (representation-intersection type
                                                      (constant.value E))
                         cs))
                  ((call? E)
                   (loop (representation-intersection
                          type (aeval E types constraints))
                         cs))
                  (else
                   (loop type cs))))))
    (loop t0 cs)))

; Constraints.
;
; The constraints used by this analysis consist of type constraints
; together with the available expressions used for commoning.
;
; (T E      K)   T = E     until killed by an effect in K
; (T '<rep> K)   T : <rep> until killed by an effect in K

(define (make-constraint T E K)
  (list T E K))

(define (constraint.lhs c)
  (car c))

(define (constraint.rhs c)
  (cadr c))

(define (constraint.killer c)
  (caddr c))

(define (make-type-constraint T type K)
  (make-constraint T
                   (make-constant type)
                   K))

; If the new constraint is of the form T = E until killed by K,
; then there shouldn't be any prior constraints.
;
; Otherwise the new constraint is of the form T : t until killed by K.
; Suppose the prior constraints are
;     T = E  until killed by K
;     T : t1 until killed by K1
;      ...
;     T : tn until killed by Kn
;
; If there exists i such that ti is a subtype of t and Ki a subset of K,
; then the new constraint adds no new information and should be ignored.
; Otherwise compute t' = t1 & ... & tn and K' = K1 | ... | Kn, where
; & indicates intersection and | indicates union.
; If K = K' then add the new constraint T : t' until killed by K;
; otherwise add two new constraints:
;     T : t' until killed by K'
;     T : t  until killed by K

(define (constraints-add! types constraints new)
  (let* ((debugging? #f)
         (T (constraint.lhs new))
         (E (constraint.rhs new))
         (K (constraint.killer new))
         (cs (constraints-for-variable constraints T)))
    
    (define (loop type K cs newcs)
      (if (null? cs)
          (cons (make-type-constraint T type K) newcs)
          (let* ((c2 (car cs))
                 (cs (cdr cs))
                 (E2 (constraint.rhs c2))
                 (K2 (constraint.killer c2)))
            (if (constant? E2)
                (let* ((type2 (constant.value E2))
                       (type3 (representation-intersection type type2)))
                  (cond ((eq? type2 type3)
                         (if (= K2 (logand K K2))
                             (append newcs cs)
                             (loop (representation-intersection type type2)
                                   (available:killer-combine K K2)
                                   cs
                                   (cons c2 newcs))))
                        ((representation-subtype? type type3)
                         (if (= K (logand K K2))
                             (loop type K cs newcs)
                             (loop type K cs (cons c2 newcs))))
                        (else
                         (loop type3
                               (available:killer-combine K K2)
                               cs
                               (cons c2 newcs)))))
                (let* ((op (variable.name (call.proc E2)))
                       (args (call.args E2))
                       (argtypes (map (lambda (exp)
                                        (aeval exp types constraints))
                                      args)))
                  (cond ((representation-subtype? type rep:true)
                         (let ((reps (rep-if-true op argtypes)))
                           (if reps
                               (record-new-reps! args argtypes reps K2))))
                        ((representation-subtype? type rep:false)
                         (let ((reps (rep-if-false op argtypes)))
                           (if reps
                               (record-new-reps! args argtypes reps K2)))))
                  (loop type K cs (cons c2 newcs)))))))
    
    (define (record-new-reps! args argtypes reps K2)
      (if debugging?
          (begin (write (list (map make-readable args)
                              (map rep->symbol argtypes)
                              (map rep->symbol reps)))
                 (newline)))
      (for-each (lambda (arg type0 type1)
                  (if (not (representation-subtype? type0 type1))
                      (if (variable? arg)
                          (let ((name (variable.name arg)))
                            ; FIXME:  In this context, a variable
                            ; should always be local so the hashtable
                            ; operation isn't necessary.
                            (if (hashtable-get types name)
                                (constraints-add!
                                 types
                                 constraints
                                 (make-type-constraint
                                  name
                                  type1 
                                  (available:killer-combine K K2)))
                                (cerror
                                 "Compiler bug: unexpected global: "
                                 name))))))
                args argtypes reps))
    
    (if (not (zero? K))
        (constraints-add-killedby! constraints T K))
    
    (let* ((table (constraints.table constraints))
           (cs (hashtable-fetch table T '())))
      (cond ((constant? E)
             ; It's a type constraint.
             (let ((type (constant.value E)))
               (if debugging?
                   (begin (display T)
                          (display " : ")
                          (display (rep->symbol type))
                          (newline)))
               (let ((cs (loop type K cs '())))
                 (hashtable-put! table T cs)
                 constraints)))
            (else
             (if debugging?
                 (begin (display T)
                        (display " = ")
                        (display (make-readable E #t))
                        (newline)))
             (if (not (null? cs))
                 (begin
                  (display "Compiler bug: ")
                  (write T)
                  (display " has unexpectedly nonempty constraints")
                  (newline)))
             (hashtable-put! table T (list (list T E K)))
             constraints)))))

; Sets of constraints.
;
; The set of constraints is represented as (<hashtable> <killedby>),
; where <hashtable> is a hashtable mapping variables to lists of
; constraints as above, and <killedby> is a vector mapping basic killers
; to lists of variables that need to be examined for constraints that
; are killed by that basic killer.

(define number-of-basic-killers
  (do ((i 0 (+ i 1))
       (k 1 (+ k k)))
      ((> k available:killer:dead)
       i)))

(define (constraints.table  constraints) (car constraints))
(define (constraints.killed constraints) (cadr constraints))

(define (make-constraints-table)
  (list (make-hashtable symbol-hash assq)
        (make-vector number-of-basic-killers '())))

(define (copy-constraints-table constraints)
  (list (hashtable-copy (constraints.table constraints))
        (list->vector (vector->list (constraints.killed constraints)))))

(define (constraints-for-variable constraints T)
  (hashtable-fetch (constraints.table constraints) T '()))

(define (constraints-add-killedby! constraints T K0)
  (if (not (zero? K0))
      (let ((v (constraints.killed constraints)))
        (do ((i 0 (+ i 1))
             (k 1 (+ k k)))
            ((= i number-of-basic-killers))
            (if (not (zero? (logand k K0)))
                (vector-set! v i (cons T (vector-ref v i))))))))

(define (constraints-kill! constraints K)
  (if (not (zero? K))
      (let ((table (constraints.table constraints))
            (killed (constraints.killed constraints)))
        (define (examine! T)
          (let ((cs (filter (lambda (c)
                              (zero? (logand (constraint.killer c) K)))
                            (hashtable-fetch table T '()))))
            (if (null? cs)
                (hashtable-remove! table T)
                (hashtable-put! table T cs))))
        (do ((i 0 (+ i 1))
             (j 1 (+ j j)))
            ((= i number-of-basic-killers))
            (if (not (zero? (logand j K)))
                (begin (for-each examine! (vector-ref killed i))
                       (vector-set! killed i '())))))))

(define (constraints-intersect! constraints0 constraints1 constraints2)
  (let ((table0 (constraints.table constraints0))
        (table1 (constraints.table constraints1))
        (table2 (constraints.table constraints2)))
    (if (eq? table0 table1)
        ; FIXME:  Which is more efficient: to update the killed vector,
        ; or not to update it?  Both are safe.
        (hashtable-for-each (lambda (T cs)
                              (if (not (null? cs))
                                  (hashtable-put!
                                   table0
                                   T
                                   (cs-intersect
                                    (hashtable-fetch table2 T '())
                                    cs))))
                            table1)
        ; This case shouldn't ever happen, so it can be slow.
        (begin
         (constraints-intersect! constraints0 constraints0 constraints1)
         (constraints-intersect! constraints0 constraints0 constraints2)))))

(define (cs-intersect cs1 cs2)
  (define (loop cs init rep Krep)
    (if (null? cs)
        (values init rep Krep)
        (let* ((c (car cs))
               (cs (cdr cs))
               (E2 (constraint.rhs c))
               (K2 (constraint.killer c)))
          (cond ((constant? E2)
                 (loop cs
                       init
                       (representation-intersection rep (constant.value E2))
                       (available:killer-combine Krep K2)))
                ((call? E2)
                 (if init
                     (begin (display "Compiler bug in cs-intersect")
                            (break))
                     (loop cs c rep Krep)))
                (else
                 (error "Compiler bug in cs-intersect"))))))
  (call-with-values
   (lambda ()
     (loop cs1 #f rep:object available:killer:none))
   (lambda (c1 rep1 Krep1)
     (call-with-values
      (lambda ()
        (loop cs2 #f rep:object available:killer:none))
      (lambda (c2 rep2 Krep2)
        (let ((c (if (equal? c1 c2) c1 #f))
              (rep (representation-union rep1 rep2))
              (Krep (available:killer-combine Krep1 Krep2)))
          (if (eq? rep rep:object)
              (if c (list c) '())
              (let ((T (constraint.lhs (car cs1))))
                (if c
                    (list c (make-type-constraint T rep Krep))
                    (list (make-type-constraint T rep Krep)))))))))))
; DO NOT EDIT THIS FILE. Edit the config file and rerun "config".

(define $gc.ephemeral 0)
(define $gc.tenuring 1)
(define $gc.full 2)
(define $mstat.wallocated-hi 0)
(define $mstat.wallocated-lo 1)
(define $mstat.wcollected-hi 2)
(define $mstat.wcollected-lo 3)
(define $mstat.wcopied-hi 4)
(define $mstat.wcopied-lo 5)
(define $mstat.gctime 6)
(define $mstat.wlive 7)
(define $mstat.gc-last-gen 8)
(define $mstat.gc-last-type 9)
(define $mstat.generations 10)
(define $mstat.g-gc-count 0)
(define $mstat.g-prom-count 1)
(define $mstat.g-gctime 2)
(define $mstat.g-wlive 3)
(define $mstat.g-np-youngp 4)
(define $mstat.g-np-oldp 5)
(define $mstat.g-np-j 6)
(define $mstat.g-np-k 7)
(define $mstat.g-alloc 8)
(define $mstat.g-target 9)
(define $mstat.g-promtime 10)
(define $mstat.remsets 11)
(define $mstat.r-apool 0)
(define $mstat.r-upool 1)
(define $mstat.r-ahash 2)
(define $mstat.r-uhash 3)
(define $mstat.r-hrec-hi 4)
(define $mstat.r-hrec-lo 5)
(define $mstat.r-hrem-hi 6)
(define $mstat.r-hrem-lo 7)
(define $mstat.r-hscan-hi 8)
(define $mstat.r-hscan-lo 9)
(define $mstat.r-wscan-hi 10)
(define $mstat.r-wscan-lo 11)
(define $mstat.r-ssbrec-hi 12)
(define $mstat.r-ssbrec-lo 13)
(define $mstat.r-np-p 14)
(define $mstat.fflushed-hi 12)
(define $mstat.fflushed-lo 13)
(define $mstat.wflushed-hi 14)
(define $mstat.wflushed-lo 15)
(define $mstat.stk-created 16)
(define $mstat.frestored-hi 17)
(define $mstat.frestored-lo 18)
(define $mstat.words-heap 19)
(define $mstat.words-remset 20)
(define $mstat.words-rts 21)
(define $mstat.swb-assign 22)
(define $mstat.swb-lhs-ok 23)
(define $mstat.swb-rhs-const 24)
(define $mstat.swb-not-xgen 25)
(define $mstat.swb-trans 26)
(define $mstat.rtime 27)
(define $mstat.stime 28)
(define $mstat.utime 29)
(define $mstat.minfaults 30)
(define $mstat.majfaults 31)
(define $mstat.np-remsetp 32)
(define $mstat.max-heap 33)
(define $mstat.promtime 34)
(define $mstat.wmoved-hi 35)
(define $mstat.wmoved-lo 36)
(define $mstat.vsize 37)
(define $g.reg0 12)
(define $r.reg8 44)
(define $r.reg9 48)
(define $r.reg10 52)
(define $r.reg11 56)
(define $r.reg12 60)
(define $r.reg13 64)
(define $r.reg14 68)
(define $r.reg15 72)
(define $r.reg16 76)
(define $r.reg17 80)
(define $r.reg18 84)
(define $r.reg19 88)
(define $r.reg20 92)
(define $r.reg21 96)
(define $r.reg22 100)
(define $r.reg23 104)
(define $r.reg24 108)
(define $r.reg25 112)
(define $r.reg26 116)
(define $r.reg27 120)
(define $r.reg28 124)
(define $r.reg29 128)
(define $r.reg30 132)
(define $r.reg31 136)
(define $g.stkbot 180)
(define $g.gccnt 420)
(define $m.alloc 1024)
(define $m.alloci 1032)
(define $m.gc 1040)
(define $m.addtrans 1048)
(define $m.stkoflow 1056)
(define $m.stkuflow 1072)
(define $m.creg 1080)
(define $m.creg-set! 1088)
(define $m.add 1096)
(define $m.subtract 1104)
(define $m.multiply 1112)
(define $m.quotient 1120)
(define $m.remainder 1128)
(define $m.divide 1136)
(define $m.modulo 1144)
(define $m.negate 1152)
(define $m.numeq 1160)
(define $m.numlt 1168)
(define $m.numle 1176)
(define $m.numgt 1184)
(define $m.numge 1192)
(define $m.zerop 1200)
(define $m.complexp 1208)
(define $m.realp 1216)
(define $m.rationalp 1224)
(define $m.integerp 1232)
(define $m.exactp 1240)
(define $m.inexactp 1248)
(define $m.exact->inexact 1256)
(define $m.inexact->exact 1264)
(define $m.make-rectangular 1272)
(define $m.real-part 1280)
(define $m.imag-part 1288)
(define $m.sqrt 1296)
(define $m.round 1304)
(define $m.truncate 1312)
(define $m.apply 1320)
(define $m.varargs 1328)
(define $m.typetag 1336)
(define $m.typetag-set 1344)
(define $m.break 1352)
(define $m.eqv 1360)
(define $m.partial-list->vector 1368)
(define $m.timer-exception 1376)
(define $m.exception 1384)
(define $m.singlestep 1392)
(define $m.syscall 1400)
(define $m.bvlcmp 1408)
(define $m.enable-interrupts 1416)
(define $m.disable-interrupts 1424)
(define $m.alloc-bv 1432)
(define $m.global-ex 1440)
(define $m.invoke-ex 1448)
(define $m.global-invoke-ex 1456)
(define $m.argc-ex 1464)
; DO NOT EDIT THIS FILE. Edit the config file and rerun "config".

(define $r.g0 0)
(define $r.g1 1)
(define $r.g2 2)
(define $r.g3 3)
(define $r.g4 4)
(define $r.g5 5)
(define $r.g6 6)
(define $r.g7 7)
(define $r.o0 8)
(define $r.o1 9)
(define $r.o2 10)
(define $r.o3 11)
(define $r.o4 12)
(define $r.o5 13)
(define $r.o6 14)
(define $r.o7 15)
(define $r.l0 16)
(define $r.l1 17)
(define $r.l2 18)
(define $r.l3 19)
(define $r.l4 20)
(define $r.l5 21)
(define $r.l6 22)
(define $r.l7 23)
(define $r.i0 24)
(define $r.i1 25)
(define $r.i2 26)
(define $r.i3 27)
(define $r.i4 28)
(define $r.i5 29)
(define $r.i6 30)
(define $r.i7 31)
(define $r.result $r.o0)
(define $r.argreg2 $r.o1)
(define $r.argreg3 $r.o2)
(define $r.stkp $r.o3)
(define $r.stklim $r.i0)
(define $r.tmp1 $r.o4)
(define $r.tmp2 $r.o5)
(define $r.tmp0 $r.g1)
(define $r.e-top $r.i0)
(define $r.e-limit $r.o3)
(define $r.timer $r.i4)
(define $r.millicode $r.i7)
(define $r.globals $r.i7)
(define $r.reg0 $r.l0)
(define $r.reg1 $r.l1)
(define $r.reg2 $r.l2)
(define $r.reg3 $r.l3)
(define $r.reg4 $r.l4)
(define $r.reg5 $r.l5)
(define $r.reg6 $r.l6)
(define $r.reg7 $r.l7)
; DO NOT EDIT THIS FILE. Edit the config file and rerun "config".

(define $ex.car 0)
(define $ex.cdr 1)
(define $ex.setcar 2)
(define $ex.setcdr 3)
(define $ex.add 10)
(define $ex.sub 11)
(define $ex.mul 12)
(define $ex.div 13)
(define $ex.lessp 14)
(define $ex.lesseqp 15)
(define $ex.equalp 16)
(define $ex.greatereqp 17)
(define $ex.greaterp 18)
(define $ex.quotient 19)
(define $ex.remainder 20)
(define $ex.modulo 21)
(define $ex.logior 22)
(define $ex.logand 23)
(define $ex.logxor 24)
(define $ex.lognot 25)
(define $ex.lsh 26)
(define $ex.rsha 27)
(define $ex.rshl 28)
(define $ex.e2i 29)
(define $ex.i2e 30)
(define $ex.exactp 31)
(define $ex.inexactp 32)
(define $ex.round 33)
(define $ex.trunc 34)
(define $ex.zerop 35)
(define $ex.neg 36)
(define $ex.abs 37)
(define $ex.realpart 38)
(define $ex.imagpart 39)
(define $ex.vref 40)
(define $ex.vset 41)
(define $ex.vlen 42)
(define $ex.pref 50)
(define $ex.pset 51)
(define $ex.plen 52)
(define $ex.sref 60)
(define $ex.sset 61)
(define $ex.slen 62)
(define $ex.bvref 70)
(define $ex.bvset 71)
(define $ex.bvlen 72)
(define $ex.bvlref 80)
(define $ex.bvlset 81)
(define $ex.bvllen 82)
(define $ex.vlref 90)
(define $ex.vlset 91)
(define $ex.vllen 92)
(define $ex.typetag 100)
(define $ex.typetagset 101)
(define $ex.apply 102)
(define $ex.argc 103)
(define $ex.vargc 104)
(define $ex.nonproc 105)
(define $ex.undef-global 106)
(define $ex.dump 107)
(define $ex.dumpfail 108)
(define $ex.timer 109)
(define $ex.unsupported 110)
(define $ex.int2char 111)
(define $ex.char2int 112)
(define $ex.mkbvl 113)
(define $ex.mkvl 114)
(define $ex.char<? 115)
(define $ex.char<=? 116)
(define $ex.char=? 117)
(define $ex.char>? 118)
(define $ex.char>=? 119)
(define $ex.bvfill 120)
(define $ex.enable-interrupts 121)
(define $ex.keyboard-interrupt 122)
(define $ex.arithmetic-exception 123)
(define $ex.global-invoke 124)
(define $ex.fx+ 140)
(define $ex.fx- 141)
(define $ex.fx-- 142)
(define $ex.fx= 143)
(define $ex.fx< 144)
(define $ex.fx<= 145)
(define $ex.fx> 146)
(define $ex.fx>= 147)
(define $ex.fxpositive? 148)
(define $ex.fxnegative? 149)
(define $ex.fxzero? 150)
(define $ex.fx* 151)
; DO NOT EDIT THIS FILE. Edit the config file and rerun "config".

(define $tag.tagmask 7)
(define $tag.pair-tag 1)
(define $tag.vector-tag 3)
(define $tag.bytevector-tag 5)
(define $tag.procedure-tag 7)
(define $imm.vector-header 162)
(define $imm.bytevector-header 194)
(define $imm.procedure-header 254)
(define $imm.true 6)
(define $imm.false 2)
(define $imm.null 10)
(define $imm.unspecified 278)
(define $imm.eof 534)
(define $imm.undefined 790)
(define $imm.character 38)
(define $tag.vector-typetag 0)
(define $tag.rectnum-typetag 4)
(define $tag.ratnum-typetag 8)
(define $tag.symbol-typetag 12)
(define $tag.port-typetag 16)
(define $tag.structure-typetag 20)
(define $tag.bytevector-typetag 0)
(define $tag.string-typetag 4)
(define $tag.flonum-typetag 8)
(define $tag.compnum-typetag 12)
(define $tag.bignum-typetag 16)
(define $hdr.port 178)
(define $hdr.struct 182)
(define $p.codevector -3)
(define $p.constvector 1)
(define $p.linkoffset 5)
(define $p.reg0 5)
(define $p.codeoffset -1)
; Copyright 1991 William Clinger
;
; Relatively target-independent information for Twobit's backend.
;
; 24 April 1999 / wdc
;
; Most of the definitions in this file can be extended or overridden by
; target-specific definitions.

(define twobit-sort
  (lambda (less? list) (compat:sort list less?)))

(define renaming-prefix ".")

; The prefix used for cells introduced by the compiler.

(define cell-prefix (string-append renaming-prefix "CELL:"))

; Names of global procedures that cannot be redefined or assigned
; by ordinary code.
; The expansion of quasiquote uses .cons and .list directly, so these
; should not be changed willy-nilly.
; Others may be used directly by a DEFINE-INLINE.

(define name:CHECK!  '.check!)
(define name:CONS '.cons)
(define name:LIST '.list)
(define name:MAKE-CELL '.make-cell)
(define name:CELL-REF '.cell-ref)
(define name:CELL-SET! '.cell-set!)
(define name:IGNORED (string->symbol "IGNORED"))
(define name:CAR '.car)
(define name:CDR '.cdr)

;(begin (eval `(define ,name:CONS cons))
;       (eval `(define ,name:LIST list))
;       (eval `(define ,name:MAKE-CELL list))
;       (eval `(define ,name:CELL-REF car))
;       (eval `(define ,name:CELL-SET! set-car!)))

; If (INTEGRATE-USUAL-PROCEDURES) is true, then control optimization
; recognizes calls to these procedures.

(define name:NOT 'not)
(define name:MEMQ 'memq)
(define name:MEMV 'memv)

; If (INTEGRATE-USUAL-PROCEDURES) is true, then control optimization
; recognizes calls to these procedures and also creates calls to them.

(define name:EQ? 'eq?)
(define name:EQV? 'eqv?)

; Control optimization creates calls to these procedures,
; which do not need to check their arguments.

(define name:FIXNUM?       'fixnum?)
(define name:CHAR?         'char?)
(define name:SYMBOL?       'symbol?)
(define name:FX<           '<:fix:fix)
(define name:FX-           'fx-)                   ; non-checking version
(define name:CHAR->INTEGER 'char->integer)         ; non-checking version
(define name:VECTOR-REF    'vector-ref:trusted)


; Constant folding.
; Prototype, will probably change in the future.

(define (constant-folding-entry name)
  (assq name $usual-constant-folding-procedures$))

(define constant-folding-predicates cadr)
(define constant-folding-folder caddr)

(define $usual-constant-folding-procedures$
  (let ((always? (lambda (x) #t))
        (charcode? (lambda (n)
                     (and (number? n)
                          (exact? n)
                          (<= 0 n)
                          (< n 128))))
        (ratnum? (lambda (n)
                   (and (number? n)
                        (exact? n)
                        (rational? n))))
        ; smallint? is defined later.
        (smallint? (lambda (n) (smallint? n))))
    `(
      ; This makes some assumptions about the host system.
      
      (integer->char (,charcode?) ,integer->char)
      (char->integer (,char?) ,char->integer)
      (zero? (,ratnum?) ,zero?)
      (< (,ratnum? ,ratnum?) ,<)
      (<= (,ratnum? ,ratnum?) ,<=)
      (= (,ratnum? ,ratnum?) ,=)
      (>= (,ratnum? ,ratnum?) ,>=)
      (> (,ratnum? ,ratnum?) ,>)
      (+ (,ratnum? ,ratnum?) ,+)
      (- (,ratnum? ,ratnum?) ,-)
      (* (,ratnum? ,ratnum?) ,*)
      (-- (,ratnum?) ,(lambda (x) (- 0 x)))
      (eq? (,always? ,always?) ,eq?)
      (eqv? (,always? ,always?) ,eqv?)
      (equal? (,always? ,always?) ,equal?)
      (memq (,always? ,list?) ,memq)
      (memv (,always? ,list?) ,memv)
      (member (,always? ,list?) ,member)
      (assq (,always? ,list?) ,assq)
      (assv (,always? ,list?) ,assv)
      (assoc (,always? ,list?) ,assoc)
      (length (,list?) ,length)
      (fixnum? (,smallint?) ,smallint?)
      (=:fix:fix  (,smallint? ,smallint?) ,=)
      (<:fix:fix  (,smallint? ,smallint?) ,<)
      (<=:fix:fix (,smallint? ,smallint?) ,<=)
      (>:fix:fix  (,smallint? ,smallint?) ,>)
      (>=:fix:fix (,smallint? ,smallint?) ,>=)
      )))

(begin '
       (define (.check! flag exn . args)
         (if (not flag)
             (apply error "Runtime check exception: " exn args)))
       #t)

; Order matters.  If f and g are both inlined, and the definition of g
; uses f, then f should be defined before g.

(for-each pass1
          `(

(define-inline car
  (syntax-rules ()
   ((car x0)
    (let ((x x0))
      (.check! (pair? x) ,$ex.car x)
      (car:pair x)))))
   
(define-inline cdr
  (syntax-rules ()
   ((car x0)
    (let ((x x0))
      (.check! (pair? x) ,$ex.cdr x)
      (cdr:pair x)))))

(define-inline vector-length
  (syntax-rules ()
   ((vector-length v0)
    (let ((v v0))
      (.check! (vector? v) ,$ex.vlen v)
      (vector-length:vec v)))))
   
(define-inline vector-ref
  (syntax-rules ()
   ((vector-ref v0 i0)
    (let ((v v0)
          (i i0))
      (.check! (fixnum? i) ,$ex.vref v i)
      (.check! (vector? v) ,$ex.vref v i)
      (.check! (<:fix:fix i (vector-length:vec v)) ,$ex.vref v i)
      (.check! (>=:fix:fix i 0) ,$ex.vref  v i)
      (vector-ref:trusted v i)))))
   
(define-inline vector-set!
  (syntax-rules ()
   ((vector-set! v0 i0 x0)
    (let ((v v0)
          (i i0)
          (x x0))
      (.check! (fixnum? i) ,$ex.vset v i x)
      (.check! (vector? v) ,$ex.vset v i x)
      (.check! (<:fix:fix i (vector-length:vec v)) ,$ex.vset v i x)
      (.check! (>=:fix:fix i 0) ,$ex.vset v i x)
      (vector-set!:trusted v i x)))))
   
; This transformation must make sure the entire list is freshly
; allocated when an argument to LIST returns more than once.

(define-inline list
  (syntax-rules ()
   ((list)
    '())
   ((list ?e)
    (cons ?e '()))
   ((list ?e1 ?e2 ...)
    (let* ((t1 ?e1)
           (t2 (list ?e2 ...)))
      (cons t1 t2)))))

; This transformation must make sure the entire list is freshly
; allocated when an argument to VECTOR returns more than once.

(define-inline vector
  (syntax-rules ()
   ((vector)
    '#())
   ((vector ?e)
    (make-vector 1 ?e))
   ((vector ?e1 ?e2 ...)
    (letrec-syntax
      ((vector-aux1
        (... (syntax-rules ()
              ((vector-aux1 () ?n ?exps ?indexes ?temps)
               (vector-aux2 ?n ?exps ?indexes ?temps))
              ((vector-aux1 (?exp1 ?exp2 ...) ?n ?exps ?indexes ?temps)
               (vector-aux1 (?exp2 ...)
                            (+ ?n 1)
                            (?exp1 . ?exps)
                            (?n . ?indexes)
                            (t . ?temps))))))
       (vector-aux2
        (... (syntax-rules ()
              ((vector-aux2 ?n (?exp1 ?exp2 ...) (?n1 ?n2 ...) (?t1 ?t2 ...))
               (let* ((?t1 ?exp1)
                      (?t2 ?exp2)
                      ...
                      (v (make-vector ?n ?t1)))
                 (vector-set! v ?n2 ?t2)
                 ...
                 v))))))
      (vector-aux1 (?e1 ?e2 ...) 0 () () ())))))

(define-inline cadddr
  (syntax-rules ()
   ((cadddr ?e)
    (car (cdr (cdr (cdr ?e)))))))

(define-inline cddddr
  (syntax-rules ()
   ((cddddr ?e)
    (cdr (cdr (cdr (cdr ?e)))))))

(define-inline cdddr
  (syntax-rules ()
   ((cdddr ?e)
    (cdr (cdr (cdr ?e))))))

(define-inline caddr
  (syntax-rules ()
   ((caddr ?e)
    (car (cdr (cdr ?e))))))

(define-inline cddr
  (syntax-rules ()
   ((cddr ?e)
    (cdr (cdr ?e)))))

(define-inline cdar
  (syntax-rules ()
   ((cdar ?e)
    (cdr (car ?e)))))

(define-inline cadr
  (syntax-rules ()
   ((cadr ?e)
    (car (cdr ?e)))))

(define-inline caar
  (syntax-rules ()
   ((caar ?e)
    (car (car ?e)))))

(define-inline make-vector
  (syntax-rules ()
   ((make-vector ?n)
    (make-vector ?n '()))))

(define-inline make-string
  (syntax-rules ()
   ((make-string ?n)
    (make-string ?n #\space))))

(define-inline =
  (syntax-rules ()
   ((= ?e1 ?e2 ?e3 ?e4 ...)
    (let ((t ?e2))
      (and (= ?e1 t)
           (= t ?e3 ?e4 ...))))))

(define-inline <
  (syntax-rules ()
   ((< ?e1 ?e2 ?e3 ?e4 ...)
    (let ((t ?e2))
      (and (< ?e1 t)
           (< t ?e3 ?e4 ...))))))

(define-inline >
  (syntax-rules ()
   ((> ?e1 ?e2 ?e3 ?e4 ...)
    (let ((t ?e2))
      (and (> ?e1 t)
           (> t ?e3 ?e4 ...))))))

(define-inline <=
  (syntax-rules ()
   ((<= ?e1 ?e2 ?e3 ?e4 ...)
    (let ((t ?e2))
      (and (<= ?e1 t)
           (<= t ?e3 ?e4 ...))))))

(define-inline >=
  (syntax-rules ()
   ((>= ?e1 ?e2 ?e3 ?e4 ...)
    (let ((t ?e2))
      (and (>= ?e1 t)
           (>= t ?e3 ?e4 ...))))))

(define-inline +
  (syntax-rules ()
   ((+)
    0)
   ((+ ?e)
    ?e)
   ((+ ?e1 ?e2 ?e3 ?e4 ...)
    (+ (+ ?e1 ?e2) ?e3 ?e4 ...))))

(define-inline *
  (syntax-rules ()
   ((*)
    1)
   ((* ?e)
    ?e)
   ((* ?e1 ?e2 ?e3 ?e4 ...)
    (* (* ?e1 ?e2) ?e3 ?e4 ...))))

(define-inline -
  (syntax-rules ()
   ((- ?e)
    (- 0 ?e))
   ((- ?e1 ?e2 ?e3 ?e4 ...)
    (- (- ?e1 ?e2) ?e3 ?e4 ...))))

(define-inline /
  (syntax-rules ()
   ((/ ?e)
    (/ 1 ?e))
   ((/ ?e1 ?e2 ?e3 ?e4 ...)
    (/ (/ ?e1 ?e2) ?e3 ?e4 ...))))

(define-inline abs
  (syntax-rules ()
   ((abs ?z)
    (let ((temp ?z))
      (if (< temp 0)
          (-- temp)
          temp)))))

(define-inline negative?
  (syntax-rules ()
   ((negative? ?x)
    (< ?x 0))))

(define-inline positive?
  (syntax-rules ()
   ((positive? ?x)
    (> ?x 0))))

(define-inline eqv?
  (transformer
   (lambda (exp rename compare)
     (let ((arg1 (cadr exp))
           (arg2 (caddr exp)))
       (define (constant? exp)
         (or (boolean? exp)
             (char? exp)
             (and (pair? exp)
                  (= (length exp) 2)
                  (identifier? (car exp))
                  (compare (car exp) (rename 'quote))
                  (symbol? (cadr exp)))))
       (if (or (constant? arg1)
               (constant? arg2))
           (cons (rename 'eq?) (cdr exp))
           exp)))))

(define-inline memq
  (syntax-rules (quote)
   ((memq ?expr '(?datum ...))
    (letrec-syntax
      ((memq0
        (... (syntax-rules (quote)
              ((memq0 '?xx '(?d ...))
               (let ((t1 '(?d ...)))
                 (memq1 '?xx t1 (?d ...))))
              ((memq0 ?e '(?d ...))
               (let ((t0 ?e)
                     (t1 '(?d ...)))
                 (memq1 t0 t1 (?d ...)))))))
       (memq1
        (... (syntax-rules ()
              ((memq1 ?t0 ?t1 ())
               #f)
              ((memq1 ?t0 ?t1 (?d1 ?d2 ...))
               (if (eq? ?t0 '?d1)
                   ?t1
                   (let ((?t1 (cdr ?t1)))
                     (memq1 ?t0 ?t1 (?d2 ...)))))))))
      (memq0 ?expr '(?datum ...))))))

(define-inline memv
  (transformer
   (lambda (exp rename compare)
     (let ((arg1 (cadr exp))
           (arg2 (caddr exp)))
       (if (or (boolean? arg1)
               (fixnum? arg1)
               (char? arg1)
               (and (pair? arg1)
                    (= (length arg1) 2)
                    (identifier? (car arg1))
                    (compare (car arg1) (rename 'quote))
                    (symbol? (cadr arg1)))
               (and (pair? arg2)
                    (= (length arg2) 2)
                    (identifier? (car arg2))
                    (compare (car arg2) (rename 'quote))
                    (every1? (lambda (x)
                               (or (boolean? x)
                                   (fixnum? x)
                                   (char? x)
                                   (symbol? x)))
                             (cadr arg2))))
           (cons (rename 'memq) (cdr exp))
           exp)))))

(define-inline assv
  (transformer
   (lambda (exp rename compare)
     (let ((arg1 (cadr exp))
           (arg2 (caddr exp)))
       (if (or (boolean? arg1)
               (char? arg1)
               (and (pair? arg1)
                    (= (length arg1) 2)
                    (identifier? (car arg1))
                    (compare (car arg1) (rename 'quote))
                    (symbol? (cadr arg1)))
               (and (pair? arg2)
                    (= (length arg2) 2)
                    (identifier? (car arg2))
                    (compare (car arg2) (rename 'quote))
                    (every1? (lambda (y)
                               (and (pair? y)
                                    (let ((x (car y)))
                                      (or (boolean? x)
                                          (char? x)
                                          (symbol? x)))))
                             (cadr arg2))))
           (cons (rename 'assq) (cdr exp))
           exp)))))

(define-inline map
  (syntax-rules (lambda)
   ((map ?proc ?exp1 ?exp2 ...)
    (letrec-syntax
      ((loop
        (... (syntax-rules (lambda)
              ((loop 1 () (?y1 ?y2 ...) ?f ?exprs)
               (loop 2 (?y1 ?y2 ...) ?f ?exprs))
              ((loop 1 (?a1 ?a2 ...) (?y2 ...) ?f ?exprs)
               (loop 1 (?a2 ...) (y1 ?y2 ...) ?f ?exprs))
              
              ((loop 2 ?ys (lambda ?formals ?body) ?exprs)
               (loop 3 ?ys (lambda ?formals ?body) ?exprs))
              ((loop 2 ?ys (?f1 . ?f2) ?exprs)
               (let ((f (?f1 . ?f2)))
                 (loop 3 ?ys f ?exprs)))
              ; ?f must be a constant or variable.
              ((loop 2 ?ys ?f ?exprs)
               (loop 3 ?ys ?f ?exprs))
              
              ((loop 3 (?y1 ?y2 ...) ?f (?e1 ?e2 ...))
               (do ((?y1 ?e1 (cdr ?y1))
                    (?y2 ?e2 (cdr ?y2))
                    ...
                    (results '() (cons (?f (car ?y1) (car ?y2) ...)
                                       results)))
                   ((or (null? ?y1) (null? ?y2) ...)
                    (reverse results))))))))
      
      (loop 1 (?exp1 ?exp2 ...) () ?proc (?exp1 ?exp2 ...))))))

(define-inline for-each
  (syntax-rules (lambda)
   ((for-each ?proc ?exp1 ?exp2 ...)
    (letrec-syntax
      ((loop
        (... (syntax-rules (lambda)
              ((loop 1 () (?y1 ?y2 ...) ?f ?exprs)
               (loop 2 (?y1 ?y2 ...) ?f ?exprs))
              ((loop 1 (?a1 ?a2 ...) (?y2 ...) ?f ?exprs)
               (loop 1 (?a2 ...) (y1 ?y2 ...) ?f ?exprs))
              
              ((loop 2 ?ys (lambda ?formals ?body) ?exprs)
               (loop 3 ?ys (lambda ?formals ?body) ?exprs))
              ((loop 2 ?ys (?f1 . ?f2) ?exprs)
               (let ((f (?f1 . ?f2)))
                 (loop 3 ?ys f ?exprs)))
              ; ?f must be a constant or variable.
              ((loop 2 ?ys ?f ?exprs)
               (loop 3 ?ys ?f ?exprs))
              
              ((loop 3 (?y1 ?y2 ...) ?f (?e1 ?e2 ...))
               (do ((?y1 ?e1 (cdr ?y1))
                    (?y2 ?e2 (cdr ?y2))
                    ...)
                   ((or (null? ?y1) (null? ?y2) ...)
                    (if #f #f))
                   (?f (car ?y1) (car ?y2) ...)))))))
      
      (loop 1 (?exp1 ?exp2 ...) () ?proc (?exp1 ?exp2 ...))))))

))

(define extended-syntactic-environment
  (syntactic-copy global-syntactic-environment))

(define (make-extended-syntactic-environment)
  (syntactic-copy extended-syntactic-environment))

; MacScheme machine assembly instructions.

(define instruction.op car)
(define instruction.arg1 cadr)
(define instruction.arg2 caddr)
(define instruction.arg3 cadddr)

; Opcode table.

(define *mnemonic-names* '())           ; For readify-lap
(begin
 '
 (define *last-reserved-mnemonic* 32767)	; For consistency check
 '
 (define make-mnemonic
   (let ((count 0))
     (lambda (name)
       (set! count (+ count 1))
       (if (= count *last-reserved-mnemonic*)
           (error "Error in make-mnemonic: conflict: " name))
       (set! *mnemonic-names* (cons (cons count name) *mnemonic-names*))
       count)))
 '
 (define (reserved-mnemonic name value)
   (if (and (> value 0) (< value *last-reserved-mnemonic*))
       (set! *last-reserved-mnemonic* value))
   (set! *mnemonic-names* (cons (cons value name) *mnemonic-names*))
   value)
 #t)

(define make-mnemonic
   (let ((count 0))
     (lambda (name)
       (set! count (+ count 1))
       (set! *mnemonic-names* (cons (cons count name) *mnemonic-names*))
       count)))

(define (reserved-mnemonic name ignored)
  (make-mnemonic name))

(define $.linearize (reserved-mnemonic '.linearize -1))  ; unused?
(define $.label (reserved-mnemonic '.label 63))
(define $.proc (reserved-mnemonic '.proc 62))    ; proc entry point
(define $.cont (reserved-mnemonic '.cont 61))    ; return point
(define $.align (reserved-mnemonic '.align 60))  ; align code stream
(define $.asm (reserved-mnemonic '.asm 59))      ; in-line native code
(define $.proc-doc                               ; internal def proc info
  (reserved-mnemonic '.proc-doc 58))
(define $.end                                    ; end of code vector
  (reserved-mnemonic '.end 57))                  ; (asm internal)
(define $.singlestep                             ; insert singlestep point
  (reserved-mnemonic '.singlestep 56))           ; (asm internal)
(define $.entry (reserved-mnemonic '.entry 55))  ; procedure entry point 
                                                 ; (asm internal)

(define $op1 (make-mnemonic 'op1))               ; op      prim
(define $op2 (make-mnemonic 'op2))               ; op2     prim,k
(define $op3 (make-mnemonic 'op3))               ; op3     prim,k1,k2
(define $op2imm (make-mnemonic 'op2imm))         ; op2imm  prim,x
(define $const (make-mnemonic 'const))           ; const   x
(define $global (make-mnemonic 'global))         ; global  x
(define $setglbl (make-mnemonic 'setglbl))       ; setglbl x
(define $lexical (make-mnemonic 'lexical))       ; lexical m,n
(define $setlex (make-mnemonic 'setlex))         ; setlex  m,n
(define $stack (make-mnemonic 'stack))           ; stack   n
(define $setstk (make-mnemonic 'setstk))         ; setstk  n
(define $load (make-mnemonic 'load))             ; load    k,n
(define $store (make-mnemonic 'store))           ; store   k,n
(define $reg (make-mnemonic 'reg))               ; reg     k
(define $setreg (make-mnemonic 'setreg))         ; setreg  k
(define $movereg (make-mnemonic 'movereg))       ; movereg k1,k2
(define $lambda (make-mnemonic 'lambda))         ; lambda  x,n,doc
(define $lexes (make-mnemonic 'lexes))           ; lexes   n,doc
(define $args= (make-mnemonic 'args=))           ; args=   k
(define $args>= (make-mnemonic 'args>=))         ; args>=  k
(define $invoke (make-mnemonic 'invoke))         ; invoke  k
(define $save (make-mnemonic 'save))             ; save    L,k
(define $setrtn (make-mnemonic 'setrtn))         ; setrtn  L
(define $restore (make-mnemonic 'restore))       ; restore n    ; deprecated
(define $pop (make-mnemonic 'pop))               ; pop     k
(define $popstk (make-mnemonic 'popstk))         ; popstk       ; for students
(define $return (make-mnemonic 'return))         ; return
(define $mvrtn (make-mnemonic 'mvrtn))           ; mvrtn        ; NYI
(define $apply (make-mnemonic 'apply))           ; apply
(define $nop (make-mnemonic 'nop))               ; nop
(define $jump (make-mnemonic 'jump))             ; jump    m,o
(define $skip (make-mnemonic 'skip))             ; skip    L    ; forward
(define $branch (make-mnemonic 'branch))         ; branch  L
(define $branchf (make-mnemonic 'branchf))       ; branchf L
(define $check (make-mnemonic 'check))           ; check   k1,k2,k3,L
(define $trap (make-mnemonic 'trap))             ; trap    k1,k2,k3,exn

; A peephole optimizer may define more instructions in some
; target-specific file.

; eof
; Copyright 1991 William Clinger
;
; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
;
; Larceny -- target-specific information for Twobit's SPARC backend.
;
; 11 June 1999 / wdc

; The maximum number of fixed arguments that may be followed by a rest
; argument.  This limitation is removed by the macro expander.

(define @maxargs-with-rest-arg@ 30)

; The number of MacScheme machine registers.
; (They do not necessarily correspond to hardware registers.)

(define *nregs* 32)
(define *lastreg* (- *nregs* 1))
(define *fullregs* (quotient *nregs* 2))

; The number of argument registers that are represented by hardware
; registers.

(define *nhwregs* 8)

; Variable names that indicate register targets.

(define *regnames*
  (do ((alist '() (cons (cons (string->symbol
                               (string-append ".REG" (number->string r)))
                              r)
                        alist))
       (r (- *nhwregs* 1) (- r 1)))
      ((<= r 0)
       alist)))

; A non-inclusive upper bound for the instruction encodings.

(define *number-of-mnemonics* 72)

; Integrable procedures and procedure-specific source code transformations.
; Every integrable procedure that takes a varying number of arguments must
; supply a transformation procedure to map calls into the fixed arity
; required by the MacScheme machine instructions.

; The table of integrable procedures.
; Each entry is a list of the following items:
;
;    procedure name
;    arity (or -1 for special primops like .check!)
;    procedure name to be used by the disassembler
;    predicate for immediate operands (or #f)
;    primop code in the MacScheme machine (not used by Larceny)
;    the effects that kill this primop's result
;    the effects of this primop that kill available expressions

(define (prim-entry name)
  (assq name $usual-integrable-procedures$))

(define prim-arity cadr)
(define prim-opcodename caddr)
(define prim-immediate? cadddr)
(define (prim-primcode entry)
  (car (cddddr entry)))

; This predicate returns #t iff its argument will be represented
; as a fixnum on the target machine.

(define smallint?
  (let* ((least (- (expt 2 29)))
         (greatest (- (- least) 1)))
    (lambda (x)
      (and (number? x)
           (exact? x)
           (integer? x)
           (<= least x greatest)))))

(define (sparc-imm? x)
  (and (fixnum? x)
       (<= -1024 x 1023)))

(define (sparc-eq-imm? x)
  (or (sparc-imm? x)
      (eq? x #t)
      (eq? x #f)
      (eq? x '())))

(define (valid-typetag? x)
  (and (fixnum? x)
       (<= 0 x 7)))

(define (fixnum-primitives) #t)
(define (flonum-primitives) #t)

; The table of primitives has been extended with
; kill information used for commoning.

(define (prim-lives-until entry)
  (list-ref entry 5))

(define (prim-kills entry)
  (list-ref entry 6))

(define $usual-integrable-procedures$
  (let ((:globals  available:killer:globals)
        (:car      available:killer:car)
        (:cdr      available:killer:cdr)
        (:string   available:killer:string)
        (:vector   available:killer:vector)
        (:cell     available:killer:cell)
        (:io       available:killer:io)
        (:none     available:killer:none)     ; none of the above
        (:all      available:killer:all)      ; all of the above
        (:immortal available:killer:immortal) ; never killed
        (:dead     available:killer:dead)     ; never available
        )

;    external     arity  internal    immediate    ignored  killed     kills
;    name                name        predicate             by what
;                                                          kind of
;                                                          effect

  `((break            0 break            #f             3 ,:dead     ,:all)
    (creg             0 creg             #f             7 ,:dead     ,:all)
    (unspecified      0 unspecified      #f            -1 ,:dead     ,:none)
    (undefined        0 undefined        #f             8 ,:dead     ,:none)
    (eof-object       0 eof-object       #f            -1 ,:dead     ,:none)
    (enable-interrupts 1 enable-interrupts #f          -1 ,:dead     ,:all)
    (disable-interrupts 0 disable-interrupts #f        -1 ,:dead     ,:all)

    (typetag          1 typetag          #f          #x11 ,:dead     ,:none)
    (not              1 not              #f          #x18 ,:immortal ,:none)
    (null?            1 null?            #f          #x19 ,:immortal ,:none)
    (pair?            1 pair?            #f          #x1a ,:immortal ,:none)
    (eof-object?      1 eof-object?      #f            -1 ,:immortal ,:none)
    (port?            1 port?            #f            -1 ,:dead     ,:none)
    (structure?       1 structure?       #f            -1 ,:dead     ,:none)
    (car              1 car              #f          #x1b ,:car      ,:none)
    (,name:CAR        1 car              #f          #x1b ,:car      ,:none)
    (cdr              1 cdr              #f          #x1c ,:cdr      ,:none)
    (,name:CDR        1 cdr              #f          #x1c ,:cdr      ,:none)
    (symbol?          1 symbol?          #f          #x1f ,:immortal ,:none)
    (number?          1 complex?         #f          #x20 ,:immortal ,:none)
    (complex?         1 complex?         #f          #x20 ,:immortal ,:none)
    (real?            1 rational?        #f          #x21 ,:immortal ,:none)
    (rational?        1 rational?        #f          #x21 ,:immortal ,:none)
    (integer?         1 integer?         #f          #x22 ,:immortal ,:none)
    (fixnum?          1 fixnum?          #f          #x23 ,:immortal ,:none)
    (flonum?          1 flonum?          #f            -1 ,:immortal ,:none)
    (compnum?         1 compnum?         #f            -1 ,:immortal ,:none)
    (exact?           1 exact?           #f          #x24 ,:immortal ,:none)
    (inexact?         1 inexact?         #f          #x25 ,:immortal ,:none)
    (exact->inexact   1 exact->inexact   #f          #x26 ,:immortal ,:none)
    (inexact->exact   1 inexact->exact   #f          #x27 ,:immortal ,:none)
    (round            1 round            #f          #x28 ,:immortal ,:none)
    (truncate         1 truncate         #f          #x29 ,:immortal ,:none)
    (zero?            1 zero?            #f          #x2c ,:immortal ,:none)
    (--               1 --               #f          #x2d ,:immortal ,:none)
    (lognot           1 lognot           #f          #x2f ,:immortal ,:none)
    (real-part        1 real-part        #f          #x3e ,:immortal ,:none)
    (imag-part        1 imag-part        #f          #x3f ,:immortal ,:none)
    (char?            1 char?            #f          #x40 ,:immortal ,:none)
    (char->integer    1 char->integer    #f          #x41 ,:immortal ,:none)
    (integer->char    1 integer->char    #f          #x42 ,:immortal ,:none)
    (string?          1 string?          #f          #x50 ,:immortal ,:none)
    (string-length    1 string-length    #f          #x51 ,:immortal ,:none)
    (vector?          1 vector?          #f          #x52 ,:immortal ,:none)
    (vector-length    1 vector-length    #f          #x53 ,:immortal ,:none)
    (bytevector?      1 bytevector?      #f          #x54 ,:immortal ,:none)
    (bytevector-length 1 bytevector-length #f        #x55 ,:immortal ,:none)
    (bytevector-fill! 2 bytevector-fill! #f            -1 ,:dead     ,:string)
    (make-bytevector  1 make-bytevector  #f          #x56 ,:dead     ,:none)
    (procedure?       1 procedure?       #f          #x58 ,:immortal ,:none)
    (procedure-length 1 procedure-length #f          #x59 ,:dead     ,:none)
    (make-procedure   1 make-procedure   #f          #x5a ,:dead     ,:none)
    (creg-set!        1 creg-set!        #f          #x71 ,:dead     ,:none)
    (,name:MAKE-CELL  1 make-cell        #f          #x7e ,:dead     ,:none)
    (,name:CELL-REF   1 cell-ref         #f          #x7f ,:cell     ,:none)
    (,name:CELL-SET!  2 cell-set!        #f          #xdf ,:dead     ,:cell)
    (typetag-set!     2 typetag-set! ,valid-typetag? #xa0 ,:dead     ,:all)
    (eq?              2 eq?           ,sparc-eq-imm? #xa1 ,:immortal ,:none)
    (eqv?             2 eqv?             #f          #xa2 ,:immortal ,:none)
    (cons             2 cons             #f          #xa8 ,:dead     ,:none)
    (,name:CONS       2 cons             #f          #xa8 ,:dead     ,:none)
    (set-car!         2 set-car!         #f          #xa9 ,:dead     ,:car)
    (set-cdr!         2 set-cdr!         #f          #xaa ,:dead     ,:cdr)
    (+                2 +                ,sparc-imm? #xb0 ,:immortal ,:none)
    (-                2 -                ,sparc-imm? #xb1 ,:immortal ,:none)
    (*                2 *                ,sparc-imm? #xb2 ,:immortal ,:none)
    (/                2 /                #f          #xb3 ,:immortal ,:none)
    (quotient         2 quotient         #f          #xb4 ,:immortal ,:none)
    (<                2 <                ,sparc-imm? #xb5 ,:immortal ,:none)
    (<=               2 <=               ,sparc-imm? #xb6 ,:immortal ,:none)
    (=                2 =                ,sparc-imm? #xb7 ,:immortal ,:none)
    (>                2 >                ,sparc-imm? #xb8 ,:immortal ,:none)
    (>=               2 >=               ,sparc-imm? #xb9 ,:immortal ,:none)
    (logand           2 logand           #f          #xc0 ,:immortal ,:none)
    (logior           2 logior           #f          #xc1 ,:immortal ,:none)
    (logxor           2 logxor           #f          #xc2 ,:immortal ,:none)
    (lsh              2 lsh              #f          #xc3 ,:immortal ,:none)
    (rsha             2 rsha             #f            -1 ,:immortal ,:none)
    (rshl             2 rshl             #f            -1 ,:immortal ,:none)
    (rot              2 rot              #f          #xc4 ,:immortal ,:none)
    (make-string      2 make-string      #f            -1 ,:dead     ,:none)
    (string-ref       2 string-ref       ,sparc-imm? #xd1 ,:string   ,:none)
    (string-set!      3 string-set!      ,sparc-imm?   -1 ,:dead     ,:string)
    (make-vector      2 make-vector      #f          #xd2 ,:dead     ,:none)
    (vector-ref       2 vector-ref       ,sparc-imm? #xd3 ,:vector   ,:none)
    (bytevector-ref   2 bytevector-ref   ,sparc-imm? #xd5 ,:string   ,:none)
    (procedure-ref    2 procedure-ref    #f          #xd7 ,:dead     ,:none)
    (char<?           2 char<?           ,char?      #xe0 ,:immortal ,:none)
    (char<=?          2 char<=?          ,char?      #xe1 ,:immortal ,:none)
    (char=?           2 char=?           ,char?      #xe2 ,:immortal ,:none)
    (char>?           2 char>?           ,char?      #xe3 ,:immortal ,:none)
    (char>=?          2 char>=?          ,char?      #xe4 ,:immortal ,:none)
    
    (sys$partial-list->vector 2 sys$partial-list->vector #f -1 ,:dead ,:all)
    (vector-set!      3 vector-set!      #f          #xf1 ,:dead     ,:vector)
    (bytevector-set!  3 bytevector-set!  #f          #xf2 ,:dead     ,:string)
    (procedure-set!   3 procedure-set!   #f          #xf3 ,:dead     ,:all)
    (bytevector-like? 1 bytevector-like? #f            -1 ,:immortal ,:none)
    (vector-like?     1 vector-like?     #f            -1 ,:immortal ,:none)
    (bytevector-like-ref 2 bytevector-like-ref #f      -1 ,:string   ,:none)
    (bytevector-like-set! 3 bytevector-like-set! #f    -1 ,:dead     ,:string)
    (sys$bvlcmp       2 sys$bvlcmp       #f            -1 ,:dead     ,:all)
    (vector-like-ref  2 vector-like-ref  #f            -1 ,:vector   ,:none)
    (vector-like-set! 3 vector-like-set! #f            -1 ,:dead     ,:vector)
    (vector-like-length 1 vector-like-length #f        -1 ,:immortal ,:none)
    (bytevector-like-length 1 bytevector-like-length #f -1 ,:immortal ,:none)
    (remainder        2 remainder        #f            -1 ,:immortal ,:none)
    (sys$read-char    1 sys$read-char    #f            -1 ,:dead     ,:io)
    (gc-counter       0 gc-counter       #f            -1 ,:dead     ,:none)
    ,@(if (fixnum-primitives)
	  `((most-positive-fixnum
                          0 most-positive-fixnum
                                         #f            -1 ,:immortal ,:none)
	    (most-negative-fixnum
                          0 most-negative-fixnum
                                         #f            -1 ,:immortal ,:none)
	    (fx+          2 fx+          ,sparc-imm?   -1 ,:immortal ,:none)
	    (fx-          2 fx-          ,sparc-imm?   -1 ,:immortal ,:none)
	    (fx--         1 fx--         #f            -1 ,:immortal ,:none)
	    (fx*          2 fx*          #f            -1 ,:immortal ,:none)
	    (fx=          2 fx=          ,sparc-imm?   -1 ,:immortal ,:none)
	    (fx<          2 fx<          ,sparc-imm?   -1 ,:immortal ,:none)
	    (fx<=         2 fx<=         ,sparc-imm?   -1 ,:immortal ,:none)
	    (fx>          2 fx>          ,sparc-imm?   -1 ,:immortal ,:none)
	    (fx>=         2 fx>=         ,sparc-imm?   -1 ,:immortal ,:none)
	    (fxzero?      1 fxzero?      #f            -1 ,:immortal ,:none)
	    (fxpositive?  1 fxpositive?  #f            -1 ,:immortal ,:none)
	    (fxnegative?  1 fxnegative?  #f            -1 ,:immortal ,:none))
	  '())
    ,@(if (flonum-primitives)
          `((fl+          2 +            #f            -1 ,:immortal ,:none)
	    (fl-          2 -            #f            -1 ,:immortal ,:none)
	    (fl--         1 --           #f            -1 ,:immortal ,:none)
	    (fl*          2 *            #f            -1 ,:immortal ,:none)
	    (fl=          2 =            #f            -1 ,:immortal ,:none)
	    (fl<          2 <            #f            -1 ,:immortal ,:none)
	    (fl<=         2 <=           #f            -1 ,:immortal ,:none)
	    (fl>          2 >            #f            -1 ,:immortal ,:none)
	    (fl>=         2 >=           #f            -1 ,:immortal ,:none))
          '())

    ; Added for CSE, representation analysis.

    (,name:CHECK!    -1 check!           #f            -1 ,:dead     ,:none)
    (vector-length:vec 1 vector-length:vec #f          -1 ,:immortal ,:none)
    (vector-ref:trusted 2 vector-ref:trusted ,sparc-imm? -1 ,:vector   ,:none)
    (vector-set!:trusted 3 vector-set!:trusted #f      -1 ,:dead     ,:vector)
    (car:pair         1 car:pair         #f            -1 ,:car      ,:none)
    (cdr:pair         1 cdr:pair         #f            -1 ,:cdr      ,:none)
    (=:fix:fix        2 =:fix:fix        ,sparc-imm?   -1 ,:immortal ,:none)
    (<:fix:fix        2 <:fix:fix        ,sparc-imm?   -1 ,:immortal ,:none)
    (<=:fix:fix       2 <=:fix:fix       ,sparc-imm?   -1 ,:immortal ,:none)
    (>=:fix:fix       2 >=:fix:fix       ,sparc-imm?   -1 ,:immortal ,:none)
    (>:fix:fix        2 >:fix:fix        ,sparc-imm?   -1 ,:immortal ,:none)
    
    ; Not yet implemented.

    (+:idx:idx        2 +:idx:idx        #f            -1 ,:immortal ,:none)
    (+:fix:fix        2 +:idx:idx        #f            -1 ,:immortal ,:none)
    (+:exi:exi        2 +:idx:idx        #f            -1 ,:immortal ,:none)
    (+:flo:flo        2 +:idx:idx        #f            -1 ,:immortal ,:none)
    (=:flo:flo        2 =:flo:flo        #f            -1 ,:immortal ,:none)
    (=:obj:flo        2 =:obj:flo        #f            -1 ,:immortal ,:none)
    (=:flo:obj        2 =:flo:obj        #f            -1 ,:immortal ,:none)
    )))

; Not used by the Sparc assembler; for information only.

(define $immediate-primops$
  '((typetag-set! #x80)
    (eq? #x81)
    (+ #x82)
    (- #x83)
    (< #x84)
    (<= #x85)
    (= #x86)
    (> #x87)
    (>= #x88)
    (char<? #x89)
    (char<=? #x8a)
    (char=? #x8b)
    (char>? #x8c)
    (char>=? #x8d)
    (string-ref #x90)
    (vector-ref #x91)
    (bytevector-ref #x92)
    (bytevector-like-ref -1)
    (vector-like-ref -1)
    (fx+ -1)
    (fx- -1)
    (fx-- -1)
    (fx= -1)
    (fx< -1)
    (fx<= -1)
    (fx> -1)
    (fx>= -1)))

; Operations introduced by peephole optimizer.

(define $reg/op1/branchf                  ; reg/op1/branchf    prim,k1,L
  (make-mnemonic 'reg/op1/branchf))
(define $reg/op2/branchf                  ; reg/op2/branchf    prim,k1,k2,L
  (make-mnemonic 'reg/op2/branchf))
(define $reg/op2imm/branchf               ; reg/op2imm/branchf prim,k1,x,L
  (make-mnemonic 'reg/op2imm/branchf))
(define $reg/op1/check             ; reg/op1/check      prim,k1,k2,k3,k4,exn
  (make-mnemonic 'reg/op1/check))
(define $reg/op2/check             ; reg/op2/check      prim,k1,k2,k3,k4,k5,exn
  (make-mnemonic 'reg/op2/check))
(define $reg/op2imm/check          ; reg/op2imm/check   prim,k1,x,k2,k3,k4,exn
  (make-mnemonic 'reg/op2imm/check))
(define $reg/op1/setreg                   ; reg/op1/setreg     prim,k1,kr
  (make-mnemonic 'reg/op1/setreg))
(define $reg/op2/setreg                   ; reg/op2/setreg     prim,k1,k2,kr
  (make-mnemonic 'reg/op2/setreg))
(define $reg/op2imm/setreg                ; reg/op2imm/setreg  prim,k1,x,kr
  (make-mnemonic 'reg/op2imm/setreg))
(define $reg/branchf                      ; reg/branchf        k, L
  (make-mnemonic 'reg/branchf))
(define $reg/return                       ; reg/return         k
  (make-mnemonic 'reg/return))
(define $reg/setglbl                      ; reg/setglbl        k,x
  (make-mnemonic 'reg/setglbl))
(define $reg/op3                          ; reg/op3            prim,k1,k2,k3
  (make-mnemonic 'reg/op3))
(define $const/setreg                     ; const/setreg       const,k
  (make-mnemonic 'const/setreg))
(define $const/return                     ; const/return       const
  (make-mnemonic 'const/return))
(define $global/setreg                    ; global/setreg      x,k
  (make-mnemonic 'global/setreg))
(define $setrtn/branch                    ; setrtn/branch      L,doc
  (make-mnemonic 'setrtn/branch))
(define $setrtn/invoke                    ; setrtn/invoke      L
  (make-mnemonic 'setrtn/invoke))
(define $global/invoke                    ; global/invoke      global,n
  (make-mnemonic 'global/invoke))

; misc

(define $cons     'cons)
(define $car:pair 'car)
(define $cdr:pair 'cdr)

; eof
; Target-specific representations.
;
; A few of these representation types must be specified for every target:
;     rep:object
;     rep:procedure
;     rep:true
;     rep:false
;     rep:bottom

(define-subtype 'true       'object)      ; values that count as true
(define-subtype 'eqtype     'object)      ; can use EQ? instead of EQV?
(define-subtype 'nonpointer 'eqtype)      ; can omit write barrier
(define-subtype 'eqtype1    'eqtype)      ; eqtypes excluding #f
(define-subtype 'boolean    'nonpointer)
(define-subtype 'truth      'eqtype1)     ; { #t }
(define-subtype 'truth      'boolean)
(define-subtype 'false      'boolean)     ; { #f }
(define-subtype 'eqtype1    'true)  
(define-subtype 'procedure  'true)
(define-subtype 'vector     'true)
(define-subtype 'bytevector 'true)
(define-subtype 'string     'true)
(define-subtype 'pair       'true)
(define-subtype 'emptylist  'eqtype1)
(define-subtype 'emptylist  'nonpointer)
(define-subtype 'symbol     'eqtype1)
(define-subtype 'char       'eqtype1)
(define-subtype 'char       'nonpointer)
(define-subtype 'number     'true)
(define-subtype 'inexact    'number)
(define-subtype 'flonum     'inexact)
(define-subtype 'integer    'number)
(define-subtype 'exact      'number)
(define-subtype 'exactint   'integer)
(define-subtype 'exactint   'exact)
(define-subtype 'fixnum     'exactint)
(define-subtype '!fixnum    'fixnum)      ; 0 <= n
(define-subtype 'fixnum!    'fixnum)      ; n <= largest index
(define-subtype 'index      '!fixnum)
(define-subtype 'index      'fixnum!)
(define-subtype 'zero       'index)
(define-subtype 'fixnum     'eqtype1)
(define-subtype 'fixnum     'nonpointer)

(compute-type-structure!)

; If the intersection of rep1 and rep2 is known precisely,
; but neither is a subtype of the other, then their intersection
; should be declared explicitly.
; Otherwise a conservative approximation will be used.

(define-intersection 'true 'eqtype 'eqtype1)
(define-intersection 'true 'boolean 'truth)
(define-intersection 'exact 'integer 'exactint)
(define-intersection '!fixnum 'fixnum! 'index)

;(display-unions-and-intersections)

; Parameters.

(define rep:min_fixnum (- (expt 2 29)))
(define rep:max_fixnum (- (expt 2 29) 1))
(define rep:max_index  (- (expt 2 24) 1))

; The representations we'll recognize for now.

(define rep:object       (symbol->rep 'object))
(define rep:true         (symbol->rep 'true))
(define rep:truth        (symbol->rep 'truth))
(define rep:false        (symbol->rep 'false))
(define rep:boolean      (symbol->rep 'boolean))
(define rep:pair         (symbol->rep 'pair))
(define rep:symbol       (symbol->rep 'symbol))
(define rep:number       (symbol->rep 'number))
(define rep:zero         (symbol->rep 'zero))
(define rep:index        (symbol->rep 'index))
(define rep:fixnum       (symbol->rep 'fixnum))
(define rep:exactint     (symbol->rep 'exactint))
(define rep:flonum       (symbol->rep 'flonum))
(define rep:exact        (symbol->rep 'exact))
(define rep:inexact      (symbol->rep 'inexact))
(define rep:integer      (symbol->rep 'integer))
;(define rep:real         (symbol->rep 'real))
(define rep:char         (symbol->rep 'char))
(define rep:string       (symbol->rep 'string))
(define rep:vector       (symbol->rep 'vector))
(define rep:procedure    (symbol->rep 'procedure))
(define rep:bottom       (symbol->rep 'bottom))

; Given the value of a quoted constant, return its representation.

(define (representation-of-value x)
  (cond ((boolean? x)
         (if x
             rep:truth
             rep:false))
        ((pair? x)
         rep:pair)
        ((symbol? x)
         rep:symbol)
        ((number? x)
         (cond ((and (exact? x)
                     (integer? x))
                (cond ((zero? x)
                       rep:zero)
                      ((<= 0 x rep:max_index)
                       rep:index)
                      ((<= rep:min_fixnum
                           x
                           rep:max_fixnum)
                       rep:fixnum)
                      (else
                       rep:exactint)))
               ((and (inexact? x)
                     (real? x))
                rep:flonum)
               (else
                ; We're not tracking other numbers yet.
                rep:number)))
        ((char? x)
         rep:char)
        ((string? x)
         rep:string)
        ((vector? x)
         rep:vector)
        ; Everything counts as true except for #f.
        (else
         rep:true)))

; Tables that express the representation-specific operations,
; and the information about representations that are implied
; by certain operations.
; FIXME:  Currently way incomplete, but good enough for testing.

(define rep-specific
  
  (representation-table
   
   ; When the procedure in the first column is called with
   ; arguments described in the middle column, then the procedure
   ; in the last column can be called instead.
   
   '(
    ;(+                  (index index)               +:idx:idx)
    ;(+                  (fixnum fixnum)             +:fix:fix)
    ;(-                  (index index)               -:idx:idx)
    ;(-                  (fixnum fixnum)             -:fix:fix)
     
     (=                  (fixnum fixnum)             =:fix:fix)
     (<                  (fixnum fixnum)             <:fix:fix)
     (<=                 (fixnum fixnum)             <=:fix:fix)
     (>                  (fixnum fixnum)             >:fix:fix)
     (>=                 (fixnum fixnum)             >=:fix:fix)
     
    ;(+                  (flonum flonum)             +:flo:flo)
    ;(-                  (flonum flonum)             -:flo:flo)
    ;(=                  (flonum flonum)             =:flo:flo)
    ;(<                  (flonum flonum)             <:flo:flo)
    ;(<=                 (flonum flonum)             <=:flo:flo)
    ;(>                  (flonum flonum)             >:flo:flo)
    ;(>=                 (flonum flonum)             >=:flo:flo)
     
    ;(vector-set!:trusted (vector fixnum nonpointer) vector-set!:trusted:imm)
     )))

(define rep-result
  
  (representation-table
   
   ; When the procedure in the first column is called with
   ; arguments described in the middle column, then the result
   ; is described by the last column.
   
   '((fixnum?           (fixnum)                    (truth))
     (vector?           (vector)                    (truth))
     (<=                (zero !fixnum)              (truth))
     (>=                (!fixnum zero)              (truth))
     (<=:fix:fix        (zero !fixnum)              (truth))
     (>=:fix:fix        (!fixnum zero)              (truth))
     
     (+                 (index index)               (!fixnum))
     (+                 (fixnum fixnum)             (exactint))
     (-                 (index index)               (fixnum!))
     (-                 (fixnum fixnum)             (exactint))
     
     (+                 (flonum flonum)             (flonum))
     (-                 (flonum flonum)             (flonum))
     
    ;(+:idx:idx         (index index)               (!fixnum))
    ;(-:idx:idx         (index index)               (fixnum!))
    ;(+:fix:fix         (index index)               (exactint))
    ;(+:fix:fix         (fixnum fixnum)             (exactint))
    ;(-:idx:idx         (index index)               (fixnum))
    ;(-:fix:fix         (fixnum fixnum)             (exactint))
     
     (make-vector       (object object)             (vector))
     (vector-length:vec (vector)                    (index))
     (cons              (object object)             (pair))
     
     ; Is it really all that useful to know that the result
     ; of these comparisons is a boolean?
     
     (=                 (number number)             (boolean))
     (<                 (number number)             (boolean))
     (<=                (number number)             (boolean))
     (>                 (number number)             (boolean))
     (>=                (number number)             (boolean))
     
     (=:fix:fix         (fixnum fixnum)             (boolean))
     (<:fix:fix         (fixnum fixnum)             (boolean))
     (<=:fix:fix        (fixnum fixnum)             (boolean))
     (>:fix:fix         (fixnum fixnum)             (boolean))
     (>=:fix:fix        (fixnum fixnum)             (boolean))
     )))

(define rep-informing
  
  (representation-table
   
   ; When the predicate in the first column is called in the test position
   ; of a conditional expression, on arguments described by the second
   ; column, then the arguments are described by the third column if the
   ; predicate returns true, and by the fourth column if the predicate
   ; returns false.
   
   '(
     (fixnum?     (object)           (fixnum)          (object))
     (flonum?     (object)           (flonum)          (object))
     (vector?     (object)           (vector)          (object))
     (pair?       (object)           (pair)            (object))
     
     (=           (exactint index)   (index index)     (exactint index))
     (=           (index exactint)   (index index)     (index exactint))
     (=           (exactint !fixnum) (!fixnum !fixnum) (exactint !fixnum))
     (=           (!fixnum exactint) (!fixnum !fixnum) (!fixnum exactint))
     (=           (exactint fixnum!) (fixnum! fixnum!) (exactint fixnum!))
     (=           (fixnum! exactint) (fixnum! fixnum!) (fixnum! exactint))
     
     (<           (!fixnum fixnum!)  (index index)     (!fixnum fixnum!))
     (<           (fixnum fixnum!)   (fixnum! fixnum!) (fixnum fixnum!))
     (<           (!fixnum fixnum)   (!fixnum !fixnum) (!fixnum fixnum))
     (<           (fixnum! !fixnum)  (fixnum! !fixnum) (index index))
     
     (<=          (!fixnum fixnum!)  (index index)     (!fixnum fixnum!))
     (<=          (fixnum! !fixnum)  (fixnum! !fixnum) (index index))
     (<=          (fixnum fixnum!)   (fixnum! fixnum!) (fixnum fixnum!))
     (<=          (!fixnum fixnum)   (!fixnum !fixnum) (!fixnum fixnum))
     
     (>           (!fixnum fixnum!)  (!fixnum fixnum!) (index index))
     (>           (fixnum! !fixnum)  (index index)     (fixnum! !fixnum))
     (>           (fixnum fixnum!)   (fixnum fixnum!)  (fixnum! fixnum!))
     (>           (!fixnum fixnum)   (!fixnum fixnum)  (!fixnum !fixnum))
     
     (>=          (!fixnum fixnum!)  (!fixnum fixnum!) (index index))
     (>=          (fixnum! !fixnum)  (index index)     (fixnum! !fixnum))
     (>=          (fixnum fixnum!)   (fixnum fixnum!)  (fixnum! fixnum!))
     (>=          (!fixnum fixnum)   (!fixnum fixnum)  (!fixnum !fixnum))
     
     (=:fix:fix   (exactint index)   (index index)     (exactint index))
     (=:fix:fix   (index exactint)   (index index)     (index exactint))
     (=:fix:fix   (exactint !fixnum) (!fixnum !fixnum) (exactint !fixnum))
     (=:fix:fix   (!fixnum exactint) (!fixnum !fixnum) (!fixnum exactint))
     (=:fix:fix   (exactint fixnum!) (fixnum! fixnum!) (exactint fixnum!))
     (=:fix:fix   (fixnum! exactint) (fixnum! fixnum!) (fixnum! exactint))
     
     (<:fix:fix   (!fixnum fixnum!)  (index index)     (!fixnum fixnum!))
     (<:fix:fix   (fixnum! !fixnum)  (fixnum! !fixnum) (index index))
     (<:fix:fix   (fixnum fixnum!)   (fixnum! fixnum!) (fixnum fixnum!))
     (<:fix:fix   (!fixnum fixnum)   (!fixnum !fixnum) (!fixnum fixnum))
     
     (<=:fix:fix  (!fixnum fixnum!)  (index index)     (!fixnum fixnum!))
     (<=:fix:fix  (fixnum! !fixnum)  (fixnum! !fixnum) (index index))
     (<=:fix:fix  (fixnum fixnum!)   (fixnum! fixnum!) (fixnum fixnum!))
     (<=:fix:fix  (!fixnum fixnum)   (!fixnum !fixnum) (!fixnum fixnum))
     
     (>:fix:fix   (!fixnum fixnum!)  (!fixnum fixnum!) (index index))
     (>:fix:fix   (fixnum! !fixnum)  (index index)     (fixnum! !fixnum))
     (>:fix:fix   (fixnum fixnum!)   (fixnum fixnum!)  (fixnum! fixnum!))
     (>:fix:fix   (!fixnum fixnum)   (!fixnum fixnum)  (!fixnum !fixnum))
     
     (>=:fix:fix  (!fixnum fixnum!)  (!fixnum fixnum!) (index index))
     (>=:fix:fix  (fixnum! !fixnum)  (index index)     (fixnum! !fixnum))
     (>=:fix:fix  (fixnum fixnum!)   (fixnum fixnum!)  (fixnum! fixnum!))
     (>=:fix:fix  (!fixnum fixnum)   (!fixnum fixnum)  (!fixnum !fixnum))
     )))
; Copyright 1991 William D Clinger.
;
; Permission to copy this software, in whole or in part, to use this
; software for any lawful noncommercial purpose, and to redistribute
; this software is granted subject to the restriction that all copies
; made of this software must include this copyright notice in full.
; 
; I also request that you send me a copy of any improvements that you
; make to this software so that they may be incorporated within it to
; the benefit of the Scheme community.
;
; 25 April 1999.
;
; Second pass of the Twobit compiler:
;   single assignment analysis, local source transformations,
;   assignment elimination, and lambda lifting.
; The code for assignment elimination and lambda lifting
; are in a separate file.
;
; This pass operates as a source-to-source transformation on
; expressions written in the subset of Scheme described by the
; following grammar, where the input and output expressions
; satisfy certain additional invariants described below.
;
; "X ..." means zero or more occurrences of X.
;
; L  -->  (lambda (I_1 ...)
;           (begin D ...)
;           (quote (R F G <decls> <doc>)
;           E)
;      |  (lambda (I_1 ... . I_rest)
;           (begin D ...)
;           (quote (R F G <decls> <doc>))
;           E)
; D  -->  (define I L)
; E  -->  (quote K)                        ; constants
;      |  (begin I)                        ; variable references
;      |  L                                ; lambda expressions
;      |  (E0 E1 ...)                      ; calls
;      |  (set! I E)                       ; assignments
;      |  (if E0 E1 E2)                    ; conditionals
;      |  (begin E0 E1 E2 ...)             ; sequential expressions
; I  -->  <identifier>
;
; R  -->  ((I <references> <assignments> <calls>) ...)
; F  -->  (I ...)
; G  -->  (I ...)
;
; Invariants that hold for the input only:
;   *  There are no internal definitions.
;   *  No identifier containing an upper case letter is bound anywhere.
;      (Change the "name:..." variables if upper case is preferred.)
;   *  No identifier is bound in more than one place.
;   *  Each R contains one entry for every identifier bound in the
;      formal argument list and the internal definition list that
;      precede it.  Each entry contains a list of pointers to all
;      references to the identifier, a list of pointers to all
;      assignments to the identifier, and a list of pointers to all
;      calls to the identifier.
;   *  Except for constants, the expression does not share structure
;      with the original input or itself, except that the references
;      and assignments in R are guaranteed to share structure with
;      the expression.  Thus the expression may be side effected, and
;      side effects to references or assignments obtained through R
;      are guaranteed to change the references or assignments pointed
;      to by R.
;
; Invariants that hold for the output only:
;   *  There are no assignments except to global variables.
;   *  If I is declared by an internal definition, then the right hand
;      side of the internal definition is a lambda expression and I
;      is referenced only in the procedure position of a call.
;   *  Each R contains one entry for every identifier bound in the
;      formal argument list and the internal definition list that
;      precede it.  Each entry contains a list of pointers to all
;      references to the identifier, a list of pointers to all
;      assignments to the identifier, and a list of pointers to all
;      calls to the identifier.
;   *  For each lambda expression, the associated F is a list of all
;      the identifiers that occur free in the body of that lambda
;      expression, and possibly a few extra identifiers that were
;      once free but have been removed by optimization.
;   *  For each lambda expression, the associated G is a subset of F
;      that contains every identifier that occurs free within some
;      inner lambda expression that escapes, and possibly a few that
;      don't.  (Assignment-elimination does not calculate G exactly.)
;   *  Variables named IGNORED are neither referenced nor assigned.
;   *  Except for constants, the expression does not share structure
;      with the original input or itself, except that the references
;      and assignments in R are guaranteed to share structure with
;      the expression.  Thus the expression may be side effected, and
;      side effects to references or assignments obtained through R
;      are guaranteed to change the references or assignments pointed
;      to by R.

(define (pass2 exp)
  (simplify exp (make-notepad #f)))

; Given an expression and a "notepad" data structure that conveys
; inherited attributes, performs the appropriate optimizations and
; destructively modifies the notepad to record various attributes
; that it synthesizes while traversing the expression.  In particular,
; any nested lambda expressions and any variable references will be
; noted in the notepad.

(define (simplify exp notepad)
  (case (car exp)
    ((quote)    exp)
    ((lambda)   (simplify-lambda exp notepad))
    ((set!)     (simplify-assignment exp notepad))
    ((if)       (simplify-conditional exp notepad))
    ((begin)    (if (variable? exp)
                    (begin (notepad-var-add! notepad (variable.name exp))
                           exp)
                    (simplify-sequential exp notepad)))
    (else       (simplify-call exp notepad))))

; Most optimization occurs here.
; The  right hand sides of internal definitions are simplified,
; as is the body.
; Internal definitions of enclosed lambda expressions may
; then be lifted to this one.
; Single assignment analysis creates internal definitions.
; Single assignment elimination converts single assignments
; to bindings where possible, and renames arguments whose value
; is ignored.
; Assignment elimination then replaces all remaining assigned
; variables by heap-allocated cells.

(define (simplify-lambda exp notepad)
  (notepad-lambda-add! notepad exp)
  (let ((defs (lambda.defs exp))
        (body (lambda.body exp))
        (newnotepad (make-notepad exp)))
    (for-each (lambda (def)
                (simplify-lambda (def.rhs def) newnotepad))
              defs)
    (lambda.body-set! exp (simplify body newnotepad))
    (lambda.F-set! exp (notepad-free-variables newnotepad))
    (lambda.G-set! exp (notepad-captured-variables newnotepad))
    (single-assignment-analysis exp newnotepad)
    (let ((known-lambdas (notepad.nonescaping newnotepad)))
      (for-each (lambda (L)
                  (if (memq L known-lambdas)
                      (lambda-lifting L exp)
                      (lambda-lifting L L)))
                (notepad.lambdas newnotepad))))
  (single-assignment-elimination exp notepad)
  (assignment-elimination exp)
  (if (not (notepad.parent notepad))
      ; This is an outermost lambda expression.
      (lambda-lifting exp exp))
  exp)

; SIMPLIFY-ASSIGNMENT performs this transformation:
;
;    (set! I (begin ... E))
; -> (begin ... (set! I E))

(define (simplify-assignment exp notepad)
  (notepad-var-add! notepad (assignment.lhs exp))
  (let ((rhs (simplify (assignment.rhs exp) notepad)))
    (cond ((begin? rhs)
           (let ((exprs (reverse (begin.exprs rhs))))
             (assignment.rhs-set! exp (car exprs))
             (post-simplify-begin
              (make-begin (reverse (cons exp (cdr exprs))))
              notepad)))
          (else (assignment.rhs-set! exp rhs) exp))))

(define (simplify-sequential exp notepad)
  (let ((exprs (map (lambda (exp) (simplify exp notepad))
                    (begin.exprs exp))))
    (begin.exprs-set! exp exprs)
    (post-simplify-begin exp notepad)))

; Given (BEGIN E0 E1 E2 ...) where the E_i are simplified expressions,
; flattens any nested BEGINs and removes trivial expressions that
; don't appear in the last position.  The second argument is used only
; if a lambda expression is removed.
; This procedure is careful to return E instead of (BEGIN E).
; Fairly harmless bug: a variable reference removed by this procedure
; may remain on the notepad when it shouldn't.

(define (post-simplify-begin exp notepad)
  (let ((unspecified-expression (make-unspecified)))
    ; (flatten exprs '()) returns the flattened exprs in reverse order.
    (define (flatten exprs flattened)
      (cond ((null? exprs) flattened)
            ((begin? (car exprs))
             (flatten (cdr exprs)
                      (flatten (begin.exprs (car exprs)) flattened)))
            (else (flatten (cdr exprs) (cons (car exprs) flattened)))))
    (define (filter exprs filtered)
      (if (null? exprs)
          filtered
          (let ((exp (car exprs)))
            (cond ((constant? exp) (filter (cdr exprs) filtered))
                  ((variable? exp) (filter (cdr exprs) filtered))
                  ((lambda? exp)
                   (notepad.lambdas-set!
                    notepad
                    (remq exp (notepad.lambdas notepad)))
                   (filter (cdr exprs) filtered))
                  ((equal? exp unspecified-expression)
                   (filter (cdr exprs) filtered))
                  (else (filter (cdr exprs) (cons exp filtered)))))))
    (let ((exprs (flatten (begin.exprs exp) '())))
      (begin.exprs-set! exp (filter (cdr exprs) (list (car exprs))))
      (if (null? (cdr (begin.exprs exp)))
          (car (begin.exprs exp))
          exp))))

; SIMPLIFY-CALL performs this transformation:
;
;    (... (begin ... E) ...)
; -> (begin ... (... E ...))
;
; It also takes care of LET transformations.

(define (simplify-call exp notepad)
  (define (loop args newargs exprs)
    (cond ((null? args)
           (finish newargs exprs))
          ((begin? (car args))
           (let ((newexprs (reverse (begin.exprs (car args)))))
             (loop (cdr args)
                   (cons (car newexprs) newargs)
                   (append (cdr newexprs) exprs))))
          (else (loop (cdr args) (cons (car args) newargs) exprs))))
  (define (finish newargs exprs)
    (call.args-set! exp (reverse newargs))
    (let* ((newexp
            (if (lambda? (call.proc exp))
                (simplify-let exp notepad)
                (begin
                 (call.proc-set! exp
                                 (simplify (call.proc exp) notepad))
                 exp)))
           (newexp
            (if (and (call? newexp)
                     (variable? (call.proc newexp)))
                (let* ((procname (variable.name (call.proc newexp)))
                       (args (call.args newexp))
                       (entry
                        (and (not (null? args))
                             (constant? (car args))
                             (integrate-usual-procedures)
                             (every? constant? args)
                             (let ((entry (constant-folding-entry procname)))
                               (and entry
                                    (let ((predicates
                                           (constant-folding-predicates entry)))
                                      (and (= (length args)
                                              (length predicates))
                                           (let loop ((args args)
                                                      (predicates predicates))
                                             (cond ((null? args) entry)
                                                   (((car predicates)
                                                     (constant.value
                                                      (car args)))
                                                    (loop (cdr args)
                                                          (cdr predicates)))
                                                   (else #f))))))))))
                  (if entry
                      (make-constant (apply (constant-folding-folder entry)
                                            (map constant.value args)))
                      newexp))
                newexp)))
      (cond ((and (call? newexp)
                  (begin? (call.proc newexp)))
             (let ((exprs0 (reverse (begin.exprs (call.proc newexp)))))
               (call.proc-set! newexp (car exprs0))
               (post-simplify-begin
                (make-begin (reverse
                             (cons newexp
                                   (append (cdr exprs0) exprs))))
                notepad)))
            ((null? exprs)
             newexp)
            (else
             (post-simplify-begin
              (make-begin (reverse (cons newexp exprs)))
              notepad)))))
  (call.args-set! exp (map (lambda (arg) (simplify arg notepad))
                           (call.args exp)))
  (loop (call.args exp) '() '()))

; SIMPLIFY-LET performs these transformations:
;
;    ((lambda (I_1 ... I_k . I_rest) ---) E1 ... Ek Ek+1 ...)
; -> ((lambda (I_1 ... I_k I_rest) ---) E1 ... Ek (LIST Ek+1 ...))
;
;    ((lambda (I1 I2 ...) (begin D ...) (quote ...) E) L ...)
; -> ((lambda (I2 ...) (begin (define I1 L) D ...) (quote ...) E) ...)
;
; provided I1 is not assigned and each reference to I1 is in call position.
;
;    ((lambda (I1)
;       (begin)
;       (quote ((I1 ((begin I1)) () ())))
;       (begin I1))
;     E1)
;
; -> E1
;
;    ((lambda (I1)
;       (begin)
;       (quote ((I1 ((begin I1)) () ())))
;       (if (begin I1) E2 E3))
;     E1)
;
; -> (if E1 E2 E3)
;
; (Together with SIMPLIFY-CONDITIONAL, this cleans up the output of the OR
; macro and enables certain control optimizations.)
;
;    ((lambda (I1 I2 ...)
;       (begin D ...)
;       (quote (... (I <references> () <calls>) ...) ...)
;       E)
;     K ...)
; -> ((lambda (I2 ...)
;       (begin D' ...)
;       (quote (... ...) ...)
;       E')
;     ...)
;
; where D' ... and E' ... are obtained from D ... and E ...
; by replacing all references to I1 by K.  This transformation
; applies if K is a constant that can be duplicated without changing
; its EQV? behavior.
;
;    ((lambda () (begin) (quote ...) E)) -> E
;
;    ((lambda (IGNORED I2 ...) ---) E1 E2 ...)
; -> (begin E1 ((lambda (I2 ...) ---) E2 ...))
;
; (Single assignment analysis, performed by the simplifier for lambda
; expressions, detects unused arguments and replaces them in the argument
; list by the special identifier IGNORED.)

(define (simplify-let exp notepad)
  (define proc (call.proc exp))
  
  ; Loop1 operates before simplification of the lambda body.
  
  (define (loop1 formals actuals processed-formals processed-actuals)
    (cond ((null? formals)
           (if (not (null? actuals))
               (pass2-error p2error:wna exp))
           (return1 processed-formals processed-actuals))
          ((symbol? formals)
           (return1 (cons formals processed-formals)
                    (cons (make-call-to-LIST actuals) processed-actuals)))
          ((null? actuals)
           (pass2-error p2error:wna exp)
           (return1 processed-formals
                    processed-actuals))
          ((and (lambda? (car actuals))
                (let ((Rinfo (R-lookup (lambda.R proc) (car formals))))
                  (and (null? (R-entry.assignments Rinfo))
                       (= (length (R-entry.references Rinfo))
                          (length (R-entry.calls Rinfo))))))
           (let ((I (car formals))
                 (L (car actuals)))
             (notepad-nonescaping-add! notepad L)
             (lambda.defs-set! proc
               (cons (make-definition I L)
                     (lambda.defs proc)))
             (standardize-known-calls L
                                      (R-entry.calls
                                       (R-lookup (lambda.R proc) I)))
             (lambda.F-set! proc (union (lambda.F proc)
                                        (free-variables L)))
             (lambda.G-set! proc (union (lambda.G proc) (lambda.G L))))
           (loop1 (cdr formals)
                  (cdr actuals)
                  processed-formals
                  processed-actuals))
          ((and (constant? (car actuals))
                (let ((x (constant.value (car actuals))))
                  (or (boolean? x)
                      (number? x)
                      (symbol? x)
                      (char? x))))
           (let* ((I (car formals))
                  (Rinfo (R-lookup (lambda.R proc) I)))
             (if (null? (R-entry.assignments Rinfo))
                 (begin
                  (for-each (lambda (ref)
                              (variable-set! ref (car actuals)))
                            (R-entry.references Rinfo))
                  (lambda.R-set! proc (remq Rinfo (lambda.R proc)))
                  (lambda.F-set! proc (remq I (lambda.F proc)))
                  (lambda.G-set! proc (remq I (lambda.G proc)))
                  (loop1 (cdr formals)
                         (cdr actuals)
                         processed-formals
                         processed-actuals))
                 (loop1 (cdr formals)
                        (cdr actuals)
                        (cons (car formals) processed-formals)
                        (cons (car actuals) processed-actuals)))))
          (else (if (null? actuals)
                    (pass2-error p2error:wna exp))
                (loop1 (cdr formals)
                       (cdr actuals)
                       (cons (car formals) processed-formals)
                       (cons (car actuals) processed-actuals)))))
  
  (define (return1 rev-formals rev-actuals)
    (let ((formals (reverse rev-formals))
          (actuals (reverse rev-actuals)))
      (lambda.args-set! proc formals)
      (if (and (not (null? formals))
               (null? (cdr formals))
               (let* ((x (car formals))
                      (R (lambda.R proc))
                      (refs (references R x)))
                 (and (= 1 (length refs))
                      (null? (assignments R x)))))
          (let ((x (car formals))
                (body (lambda.body proc)))
            (cond ((and (variable? body)
                        (eq? x (variable.name body)))
                   (simplify (car actuals) notepad))
                  ((and (conditional? body)
                        (let ((B0 (if.test body)))
                          (variable? B0)
                          (eq? x (variable.name B0))))
                   (if.test-set! body (car actuals))
                   (simplify body notepad))
                  (else
                   (return1-finish formals actuals))))
          (return1-finish formals actuals))))
  
  (define (return1-finish formals actuals)
    (simplify-lambda proc notepad)
    (loop2 formals actuals '() '() '()))
  
  ; Loop2 operates after simplification of the lambda body.
  
  (define (loop2 formals actuals processed-formals processed-actuals for-effect)
    (cond ((null? formals)
           (return2 processed-formals processed-actuals for-effect))
          ((ignored? (car formals))
           (loop2 (cdr formals)
                  (cdr actuals)
                  processed-formals
                  processed-actuals
                  (cons (car actuals) for-effect)))
          (else (loop2 (cdr formals)
                       (cdr actuals)
                       (cons (car formals) processed-formals)
                       (cons (car actuals) processed-actuals)
                       for-effect))))
  
  (define (return2 rev-formals rev-actuals rev-for-effect)
    (let ((formals (reverse rev-formals))
          (actuals (reverse rev-actuals))
          (for-effect (reverse rev-for-effect)))
      (lambda.args-set! proc formals)
      (call.args-set! exp actuals)
      (let ((exp (if (and (null? actuals)
                          (or (null? (lambda.defs proc))
                              (and (notepad.parent notepad)
                                   (POLICY:LIFT? proc
                                                 (notepad.parent notepad)
                                                 (map (lambda (def) '())
                                                      (lambda.defs proc))))))
                     (begin (for-each (lambda (I)
                                        (notepad-var-add! notepad I))
                                      (lambda.F proc))
                            (if (not (null? (lambda.defs proc)))
                                (let ((parent (notepad.parent notepad))
                                      (defs (lambda.defs proc))
                                      (R (lambda.R proc)))
                                  (lambda.defs-set!
                                    parent
                                    (append defs (lambda.defs parent)))
                                  (lambda.defs-set! proc '())
                                  (lambda.R-set!
                                    parent
                                    (append (map (lambda (def)
                                                   (R-lookup R (def.lhs def)))
                                                 defs)
                                            (lambda.R parent)))))
                            (lambda.body proc))
                     exp)))
        (if (null? for-effect)
            exp
            (post-simplify-begin (make-begin (append for-effect (list exp)))
                                 notepad)))))
  
  (notepad-nonescaping-add! notepad proc)
  (loop1 (lambda.args proc) (call.args exp) '() '()))

; Single assignment analysis performs the transformation
;
;    (lambda (... I ...)
;      (begin D ...)
;      (quote (... (I <references> ((set! I L)) <calls>) ...) ...)
;      (begin (set! I L) E1 ...))
; -> (lambda (... IGNORED ...)
;      (begin (define I L) D ...)
;      (quote (... (I <references> () <calls>) ...) ...)
;      (begin E1 ...))
;
; For best results, pass 1 should sort internal definitions and LETRECs so
; that procedure definitions/bindings come first.
;
; This procedure operates by side effect.

(define (single-assignment-analysis L notepad)
  (let ((formals (lambda.args L))
        (defs (lambda.defs L))
        (R (lambda.R L))
        (body (lambda.body L)))
    (define (finish! exprs escapees)
      (begin.exprs-set! body
                        (append (reverse escapees)
                                exprs))
      (lambda.body-set! L (post-simplify-begin body '())))
    (if (begin? body)
        (let loop ((exprs (begin.exprs body))
                   (escapees '()))
          (let ((first (car exprs)))
            (if (and (assignment? first)
                     (not (null? (cdr exprs))))
                (let ((I (assignment.lhs first))
                      (rhs (assignment.rhs first)))
                  (if (and (lambda? rhs)
                           (local? R I)
                           (= 1 (length (assignments R I))))
                      (if (= (length (calls R I))
                             (length (references R I)))
                          (begin (notepad-nonescaping-add! notepad rhs)
                                 (flag-as-ignored I L)
                                 (lambda.defs-set! L
                                   (cons (make-definition I rhs)
                                         (lambda.defs L)))
                                 (assignments-set! R I '())
                                 (standardize-known-calls
                                  rhs
                                  (R-entry.calls (R-lookup R I)))
                                 (loop (cdr exprs) escapees))
                          (loop (cdr exprs)
                                (cons (car exprs) escapees)))
                      (finish! exprs escapees)))
                (finish! exprs escapees)))))))

(define (standardize-known-calls L calls)
  (let ((formals (lambda.args L)))
    (cond ((not (list? formals))
           (let* ((newformals (make-null-terminated formals))
                  (n (- (length newformals) 1)))
             (lambda.args-set! L newformals)
             (for-each (lambda (call)
                         (if (>= (length (call.args call)) n)
                             (call.args-set!
                              call
                              (append (list-head (call.args call) n)
                                      (list
                                       (make-call-to-LIST
                                        (list-tail (call.args call) n)))))
                             (pass2-error p2error:wna call)))
                       calls)))
          (else (let ((n (length formals)))
                  (for-each (lambda (call)
                              (if (not (= (length (call.args call)) n))
                                  (pass2-error p2error:wna call)))
                            calls))))))
; Copyright 1991 William D Clinger.
;
; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
;
; 13 November 1998
;
; Second pass of the Twobit compiler, part 2:
;   single assignment elimination, assignment elimination,
;   and lambda lifting.
;
; See part 1 for further documentation.

; Single assignment elimination performs the transformation
;
;    (lambda (... I1 ... In ...)
;      (begin D ...)
;      (begin (set! I1 E1)
;             ...
;             (set! In En)
;             E ...))
; -> (lambda (... IGNORED ... IGNORED ...)
;      (let* ((I1 E1) ... (In En))
;        (begin D ...)
;        (begin E ...)))
;
; provided for each k:
;
;    1.  Ik does not occur in E1, ..., Ek.
;    2.  Either E1 through Ek contain no procedure calls
;        or Ik is not referenced by an escaping lambda expression.
;    3.  Ik is assigned only once.
;
; I doubt whether the third condition is really necessary, but
; dropping it would involve a more complex calculation of the
; revised referencing information.
;
; A more precise description of the transformation:
;
;    (lambda (... I1 ... In ...)
;      (begin (define F1 L1) ...)
;      (quote (... (I1 <references> ((set! I1 E1)) <calls>) ...
;                  (In <references> ((set! In En)) <calls>)
;                  (F1 <references> () <calls>) ...) ...)
;      (begin (set! I1 E1) ... (set! In En) E ...))
; -> (lambda (... IGNORED ... IGNORED ...)
;      (begin)
;      (quote (...) ...)
;      ((lambda (I1)
;         (begin)
;         (quote ((I1 <references> () <calls>)) ...)
;         ...
;           ((lambda (In)
;              (begin (define F1 L1) ...)
;              (quote (... (In <references> () <calls>)
;                          (F1 <references> () <calls>) ...) ...)
;              (begin E ...))
;            En)
;         ...)
;       E1))
;
; For best results, pass 1 should sort internal definitions and LETRECs
; so that procedure definitions/bindings come first, followed by
; definitions/bindings whose right hand side contains no calls,
; followed by definitions/bindings of variables that do not escape,
; followed by all other definitions/bindings.
;
; Pass 1 can't tell which variables escape, however.  Pass 2 can't tell
; which variables escape either until all enclosed lambda expressions
; have been simplified and the first transformation above has been
; performed.  That is why single assignment analysis precedes single
; assignment elimination.  As implemented here, an assignment that does
; not satisfy the conditions above will prevent the transformation from
; being applied to any subsequent assignments.
;
; This procedure operates by side effect.

(define (single-assignment-elimination L notepad)
  
  (if (begin? (lambda.body L))
      
      (let* ((formals (make-null-terminated (lambda.args L)))
             (defined (map def.lhs (lambda.defs L)))
             (escaping (intersection formals
                                     (notepad-captured-variables notepad)))
             (R (lambda.R L)))
        
        ; Given:
        ;    exprs that remain in the body;
        ;    assigns that will be replaced by let* variables;
        ;    call-has-occurred?, a boolean;
        ;    free variables of the assigns;
        ; Performs the transformation described above.
        
        (define (loop exprs assigns call-has-occurred? free)
          (cond ((null? (cdr exprs))
                 (return exprs assigns))
                ((assignment? (car exprs))
                 (let ((I1 (assignment.lhs (car exprs)))
                       (E1 (assignment.rhs (car exprs))))
                   (if (and (memq I1 formals)
                            (= (length (assignments R I1)) 1)
                            (not (and call-has-occurred?
                                      (memq I1 escaping))))
                       (let* ((free-in-E1 (free-variables E1))
                              (newfree (union free-in-E1 free)))
                         (if (or (memq I1 newfree)
                                 (not
                                  (empty-set?
                                   (intersection free-in-E1 defined))))
                             (return exprs assigns)
                             (loop (cdr exprs)
                                   (cons (car exprs) assigns)
                                   (or call-has-occurred?
                                       (might-return-twice? E1))
                                   newfree)))
                       (return exprs assigns))))
                (else (return exprs assigns))))
        
        (define (return exprs assigns)
          (if (not (null? assigns))
              (let ((I (assignment.lhs (car assigns)))
                    (E (assignment.rhs (car assigns)))
                    (defs (lambda.defs L))
                    (F (lambda.F L))
                    (G (lambda.G L)))
                (flag-as-ignored I L)
                (assignments-set! R I '())
                (let ((L2 (make-lambda (list I)
                                       defs
                                       (cons (R-entry R I)
                                             (map (lambda (def)
                                                    (R-entry R (def.lhs def)))
                                                  defs))
                                       F
                                       G
                                       (lambda.decls L)
                                       (lambda.doc L)
                                       (make-begin exprs))))
                  (lambda.defs-set! L '())
                  (for-each (lambda (entry)
                              (lambda.R-set! L (remq entry R)))
                            (lambda.R L2))
                  (return-loop (cdr assigns) (make-call L2 (list E)))))))
        
        (define (return-loop assigns body)
          (if (null? assigns)
              (let ((L3 (call.proc body)))
                (lambda.body-set! L body)
                (lambda-lifting L3 L))
              (let* ((I (assignment.lhs (car assigns)))
                     (E (assignment.rhs (car assigns)))
                     (L3 (call.proc body))
                     (F (remq I (lambda.F L3)))
                     (G (remq I (lambda.G L3))))
                (flag-as-ignored I L)
                (assignments-set! R I '())
                (let ((L2 (make-lambda (list I)
                                       '()
                                       (list (R-entry R I))
                                       F
                                       G
                                       (lambda.decls L)
                                       (lambda.doc L)
                                       body)))
                  (lambda.R-set! L (remq (R-entry R I) R))
                  (lambda-lifting L3 L2)
                  (return-loop (cdr assigns) (make-call L2 (list E)))))))
        
        (loop (begin.exprs (lambda.body L)) '() #f '())))
  
  L)

; Temporary definitions.

(define (free-variables exp)
  (case (car exp)
    ((quote)    '())
    ((lambda)   (difference (lambda.F exp)
                            (make-null-terminated (lambda.args exp))))
    ((set!)     (union (list (assignment.lhs exp))
                       (free-variables (assignment.rhs exp))))
    ((if)       (union (free-variables (if.test exp))
                       (free-variables (if.then exp))
                       (free-variables (if.else exp))))
    ((begin)    (if (variable? exp)
                    (list (variable.name exp))
                    (apply union (map free-variables (begin.exprs exp)))))
    (else       (apply union (map free-variables exp)))))

(define (might-return-twice? exp)
  (case (car exp)
    ((quote)    #f)
    ((lambda)   #f)
    ((set!)     (might-return-twice? (assignment.rhs exp)))
    ((if)       (or (might-return-twice? (if.test exp))
                    (might-return-twice? (if.then exp))
                    (might-return-twice? (if.else exp))))
    ((begin)    (if (variable? exp)
                    #f
                    (some? might-return-twice? (begin.exprs exp))))
    (else       #t)))


; Assignment elimination replaces variables that appear on the left
; hand side of an assignment by data structures.  This is necessary
; to avoid some nasty complications with lambda lifting.
;
; This procedure operates by side effect.

(define (assignment-elimination L)
  (let ((R (lambda.R L)))
    
    ; Given a list of entries, return those for assigned variables.
    
    (define (loop entries assigned)
      (cond ((null? entries)
             (if (not (null? assigned))
                 (eliminate assigned)))
            ((not (null? (R-entry.assignments (car entries))))
             (loop (cdr entries) (cons (car entries) assigned)))
            ((null? (R-entry.references (car entries)))
             (flag-as-ignored (R-entry.name (car entries)) L)
             (loop (cdr entries) assigned))
            (else (loop (cdr entries) assigned))))
    
    ; Given a list of entries for assigned variables I1 ...,
    ; remove the assignments by replacing the body by a LET of the form
    ; ((LAMBDA (V1 ...) ...) (MAKE-CELL I1) ...), by replacing references
    ; by calls to CELL-REF, and by replacing assignments by calls to
    ; CELL-SET!.
    
    (define (eliminate assigned)
      (let* ((oldnames (map R-entry.name assigned))
             (newnames (map generate-new-name oldnames)))
        (let ((augmented-entries (map list newnames assigned))
              (renaming-alist (map cons oldnames newnames))
              (defs (lambda.defs L)))
          (for-each cellify! augmented-entries)
          (for-each (lambda (def)
                      (do ((free (lambda.F (def.rhs def)) (cdr free)))
                          ((null? free))
                          (let ((z (assq (car free) renaming-alist)))
                            (if z
                                (set-car! free (cdr z))))))
                    defs)
          (let ((newbody
                 (make-call
                  (make-lambda (map car augmented-entries)
                               defs
                               (union (map (lambda (def)
                                             (R-entry R (def.lhs def)))
                                           defs)
                                      (map new-reference-info augmented-entries))
                               (union (list name:CELL-REF name:CELL-SET!)
                                      newnames
                                      (difference (lambda.F L) oldnames))
                               (union (list name:CELL-REF name:CELL-SET!)
                                      newnames
                                      (difference (lambda.G L) oldnames))
                               (lambda.decls L)
                               (lambda.doc L)
                               (lambda.body L))
                  (map (lambda (name)
                         (make-call (make-variable name:MAKE-CELL)
                                    (list (make-variable name))))
                       (map R-entry.name assigned)))))
            (lambda.F-set! L (union (list name:MAKE-CELL name:CELL-REF name:CELL-SET!)
                                    (difference (lambda.F L)
                                                (map def.lhs (lambda.defs L)))))
            (lambda.defs-set! L '())
            (for-each update-old-reference-info!
                      (map (lambda (arg)
                             (car (call.args arg)))
                           (call.args newbody)))
            (lambda.body-set! L newbody)
            (lambda-lifting (call.proc newbody) L)))))
    
    (define (generate-new-name name)
      (string->symbol (string-append cell-prefix (symbol->string name))))
    
    ; In addition to replacing references and assignments involving the
    ; old variable by calls to CELL-REF and CELL-SET! on the new, CELLIFY!
    ; uses the old entry to collect the referencing information for the
    ; new variable.
    
    (define (cellify! augmented-entry)
      (let ((newname (car augmented-entry))
            (entry (cadr augmented-entry)))
        (do ((refs (R-entry.references entry)
                   (cdr refs)))
            ((null? refs))
            (let* ((reference (car refs))
                   (newref (make-variable newname)))
              (set-car! reference (make-variable name:CELL-REF))
              (set-car! (cdr reference) newref)
              (set-car! refs newref)))
        (do ((assigns (R-entry.assignments entry)
                      (cdr assigns)))
            ((null? assigns))
            (let* ((assignment (car assigns))
                   (newref (make-variable newname)))
              (set-car! assignment (make-variable name:CELL-SET!))
              (set-car! (cdr assignment) newref)
              (R-entry.references-set! entry
                                       (cons newref
                                             (R-entry.references entry)))))
        (R-entry.assignments-set! entry '())))
    
    ; This procedure creates a brand new entry for a new variable, extracting
    ; the references stored in the old entry by CELLIFY!.
    
    (define (new-reference-info augmented-entry)
      (make-R-entry (car augmented-entry)
                    (R-entry.references (cadr augmented-entry))
                    '()
                    '()))
    
    ; This procedure updates the old entry to reflect the fact that it is
    ; now referenced once and never assigned.
    
    (define (update-old-reference-info! ref)
      (references-set! R (variable.name ref) (list ref))
      (assignments-set! R (variable.name ref) '())
      (calls-set! R (variable.name ref) '()))
    
    (loop R '())))

; Lambda lifting raises internal definitions to outer scopes to avoid
; having to choose between creating a closure or losing tail recursion.
; If L is not #f, then L2 is a lambda expression nested within L.
; Any internal definitions that occur within L2 may be lifted to L
; by adding extra arguments to the defined procedure and to all calls to it.
; Lambda lifting is not a clear win, because the extra arguments could
; easily become more expensive than creating a closure and referring
; to the non-local arguments through the closure.  The heuristics used
; to decide whether to lift a group of internal definitions are isolated
; within the POLICY:LIFT? procedure.

; L2 can be the same as L, so the order of side effects is critical.

(define (lambda-lifting L2 L)
  
  ; The call to sort is optional.  It gets the added arguments into
  ; the same order they appear in the formals list, which is an
  ; advantage for register targeting.
  
  (define (lift L2 L args-to-add)
    (let ((formals (make-null-terminated (lambda.args L2))))
      (do ((defs (lambda.defs L2) (cdr defs))
           (args-to-add args-to-add (cdr args-to-add)))
          ((null? defs))
          (let* ((def (car defs))
                 (entry (R-lookup (lambda.R L2) (def.lhs def)))
                 (calls (R-entry.calls entry))
                 (added (twobit-sort (lambda (x y)
                                       (let ((xx (memq x formals))
                                             (yy (memq y formals)))
                                         (if (and xx yy)
                                             (> (length xx) (length yy))
                                             #t)))
                                     (car args-to-add)))
                 (L3 (def.rhs def)))
            ; The flow equation guarantees that these added arguments
            ; will occur free by the time this round of lifting is done.
            (lambda.F-set! L3 (union added (lambda.F L3)))
            (lambda.args-set! L3 (append added (lambda.args L3)))
            (for-each (lambda (call)
                        (let ((newargs (map make-variable added)))
                          ; The referencing information is made obsolete here!
                          (call.args-set! call
                                          (append newargs (call.args call)))))
                      calls)
            (lambda.R-set! L2 (remq entry (lambda.R L2)))
            (lambda.R-set! L (cons entry (lambda.R L)))
            ))
      (if (not (eq? L2 L))
          (begin
           (lambda.defs-set! L (append (lambda.defs L2) (lambda.defs L)))
           (lambda.defs-set! L2 '())))))
  
  (if L
      (if (not (null? (lambda.defs L2)))
          (let ((args-to-add (compute-added-arguments
                              (lambda.defs L2)
                              (make-null-terminated (lambda.args L2)))))
            (if (POLICY:LIFT? L2 L args-to-add)
                (lift L2 L args-to-add))))))

; Given a list of definitions ((define f1 ...) ...) and a set of formals
; N over which the definitions may be lifted, returns a list of the
; subsets of N that need to be added to each procedure definition
; as new arguments.
;
; Algorithm: Let F_i be the variables that occur free in the body of
; the lambda expression associated with f_i.  Construct the call graph.
; Solve the flow equations
;
;     A_i = (F_i /\ N) \/ (\/ {A_j | A_i calls A_j})
;
; where /\ is intersection and \/ is union.

(define (compute-added-arguments defs formals)
  (let ((procs (map def.lhs defs))
        (freevars (map lambda.F (map def.rhs defs))))
    (let ((callgraph (map (lambda (names)
                            (map (lambda (name)
                                   (position name procs))
                                 (intersection names procs)))
                          freevars))
          (added_0 (map (lambda (names)
                          (intersection names formals))
                        freevars)))
      (vector->list
       (compute-fixedpoint
        (make-vector (length procs) '())
        (list->vector (map (lambda (term0 indexes)
                             (lambda (approximations)
                               (union term0
                                      (apply union
                                             (map (lambda (i)
                                                    (vector-ref approximations i))
                                                  indexes)))))
                           added_0
                           callgraph))
        set-equal?)))))

(define (position x l)
  (cond ((eq? x (car l)) 0)
        (else (+ 1 (position x (cdr l))))))

; Given a vector of starting approximations,
; a vector of functions that compute a next approximation
; as a function of the vector of approximations,
; and an equality predicate,
; returns a vector of fixed points.

(define (compute-fixedpoint v functions equiv?)
  (define (loop i flag)
    (if (negative? i)
        (if flag
            (loop (- (vector-length v) 1) #f)
            v)
        (let ((next_i ((vector-ref functions i) v)))
          (if (equiv? next_i (vector-ref v i))
              (loop (- i 1) flag)
              (begin (vector-set! v i next_i)
                     (loop (- i 1) #t))))))
  (loop (- (vector-length v) 1) #f))


; Given a lambda expression L2, its parent lambda expression
; L (which may be the same as L2, or #f), and a list of the
; lists of arguments that would need to be added to known
; local procedures, returns #t iff lambda lifting should be done.
;
; Here are some heuristics:
;
;   Don't lift if it means adding too many arguments.
;   Don't lift large groups of definitions.
;   In questionable cases it is better to lift to an outer
;     lambda expression that already contains internal
;     definitions than to one that doesn't.
;   It is better not to lift if the body contains a lambda
;     expression that has to be closed anyway.

(define (POLICY:LIFT? L2 L args-to-add)
  (and (lambda-optimizations)
       (not (lambda? (lambda.body L2)))
       (every? (lambda (addlist)
                 (< (length addlist) 6))
               args-to-add)))
; Copyright 1991 William D Clinger (for SIMPLIFY-CONDITIONAL)
; Copyright 1999 William D Clinger (for everything else)
;
; Permission to copy this software, in whole or in part, to use this
; software for any lawful noncommercial purpose, and to redistribute
; this software is granted subject to the restriction that all copies
; made of this software must include this copyright notice in full.
; 
; I also request that you send me a copy of any improvements that you
; make to this software so that they may be incorporated within it to
; the benefit of the Scheme community.
;
; 11 April 1999.
;
; Some source transformations on IF expressions:
;
; (if '#f E1 E2)                      E2
; (if 'K  E1 E2)                      E1                    K != #f
; (if (if B0 '#f '#f) E1 E2)          (begin B0 E2)
; (if (if B0 '#f 'K ) E1 E2)          (if B0 E2 E1)         K != #f
; (if (if B0 'K  '#f) E1 E2)          (if B0 E1 E2)         K != #f
; (if (if B0 'K1 'K2) E1 E2)          (begin B0 E1)         K1, K2 != #f
; (if (if B0 (if B1 #t #f) B2) E1 E2) (if (if B0 B1 B2) E1 E2)
; (if (if B0 B1 (if B2 #t #f)) E1 E2) (if (if B0 B1 B2) E1 E2)
; (if (if X  X   B0 ) E1 E2)          (if (if X #t B0) E1 E2)   X a variable
; (if (if X  B0  X  ) E1 E2)          (if (if X B0 #f) E1 E2)   X a variable
; (if ((lambda (X)                    (if ((lambda (X)
;        (if X X B2)) B0)                    (if X #t (if B2 #t #f))) B0)
;     E1 E2)                              E1 E2)
; (if (begin ... B0) E1 E2)           (begin ... (if B0 E1 E2))
; (if (not E0) E1 E2)                 (if E0 E2 E1)         not is integrable
;
; FIXME:  Three of the transformations above are intended to clean up
; the output of the OR macro.  It isn't yet clear how well this works.

(define (simplify-conditional exp notepad)
  (define (coercion-to-boolean? exp)
    (and (conditional? exp)
         (let ((E1 (if.then exp))
               (E2 (if.else exp)))
           (and (constant? E1)
                (eq? #t (constant.value E1))
                (constant? E2)
                (eq? #f (constant.value E2))))))
  (if (not (control-optimization))
      (begin (if.test-set! exp (simplify (if.test exp) notepad))
             (if.then-set! exp (simplify (if.then exp) notepad))
             (if.else-set! exp (simplify (if.else exp) notepad))
             exp)
      (let* ((test (if.test exp)))
        (if (and (call? test)
                 (lambda? (call.proc test))
                 (let* ((L (call.proc test))
                        (body (lambda.body L)))
                   (and (conditional? body)
                        (let ((R (lambda.R L))
                              (B0 (if.test body))
                              (B1 (if.then body)))
                          (and (variable? B0)
                               (variable? B1)
                               (let ((x (variable.name B0)))
                                 (and (eq? x (variable.name B1))
                                      (local? R x)
                                      (= 1 (length R))
                                      (= 1 (length (call.args test))))))))))
            (let* ((L (call.proc test))
                   (R (lambda.R L))
                   (body (lambda.body L))
                   (ref (if.then body))
                   (x (variable.name ref))
                   (entry (R-entry R x)))
              (if.then-set! body (make-constant #t))
              (if.else-set! body
                            (make-conditional (if.else body)
                                              (make-constant #t)
                                              (make-constant #f)))
              (R-entry.references-set! entry
                                       (remq ref
                                             (R-entry.references entry)))
              (simplify-conditional exp notepad))
            (let loop ((test (simplify (if.test exp) notepad)))
              (if.test-set! exp test)
              (cond ((constant? test)
                     (simplify (if (constant.value test)
                                   (if.then exp)
                                   (if.else exp))
                               notepad))
                    ((and (conditional? test)
                          (constant? (if.then test))
                          (constant? (if.else test)))
                     (cond ((and (constant.value (if.then test))
                                 (constant.value (if.else test)))
                            (post-simplify-begin
                             (make-begin (list (if.test test)
                                               (simplify (if.then exp)
                                                         notepad)))
                             notepad))
                           ((and (not (constant.value (if.then test)))
                                 (not (constant.value (if.else test))))
                            (post-simplify-begin
                             (make-begin (list (if.test test)
                                               (simplify (if.else exp)
                                                         notepad)))
                             notepad))
                           (else (if (not (constant.value (if.then test)))
                                     (let ((temp (if.then exp)))
                                       (if.then-set! exp (if.else exp))
                                       (if.else-set! exp temp)))
                                 (if.test-set! exp (if.test test))
                                 (loop (if.test exp)))))
                    ((and (conditional? test)
                          (or (coercion-to-boolean? (if.then test))
                              (coercion-to-boolean? (if.else test))))
                     (if (coercion-to-boolean? (if.then test))
                         (if.then-set! test (if.test (if.then test)))
                         (if.else-set! test (if.test (if.else test))))
                     (loop test))
                    ((and (conditional? test)
                          (variable? (if.test test))
                          (let ((x (variable.name (if.test test))))
                            (or (and (variable? (if.then test))
                                     (eq? x (variable.name (if.then test)))
                                     1)
                                (and (variable? (if.else test))
                                     (eq? x (variable.name (if.else test)))
                                     2))))
                     =>
                     (lambda (n)
                       (case n
                         ((1) (if.then-set! test (make-constant #t)))
                         ((2) (if.else-set! test (make-constant #f))))
                       (loop test)))
                    ((begin? test)
                     (let ((exprs (reverse (begin.exprs test))))
                       (if.test-set! exp (car exprs))
                       (post-simplify-begin
                        (make-begin (reverse (cons (loop (car exprs))
                                                   (cdr exprs))))
                        notepad)))
                    ((and (call? test)
                          (variable? (call.proc test))
                          (eq? (variable.name (call.proc test)) name:NOT)
                          (integrable? name:NOT)
                          (integrate-usual-procedures)
                          (= (length (call.args test)) 1))
                     (let ((temp (if.then exp)))
                       (if.then-set! exp (if.else exp))
                       (if.else-set! exp temp))
                     (loop (car (call.args test))))
                    (else
                     (simplify-case exp notepad))))))))

; Given a conditional expression whose test has been simplified,
; simplifies the then and else parts while applying optimizations
; for CASE expressions.
; Precondition: (control-optimization) is true.

(define (simplify-case exp notepad)
  (let ((E0 (if.test exp)))
    (if (and (call? E0)
             (variable? (call.proc E0))
             (let ((name (variable.name (call.proc E0))))
               ; FIXME: Should ensure that the name is integrable,
               ; but MEMQ and MEMV probably aren't according to the
               ; INTEGRABLE? predicate.
               (or (eq? name name:EQ?)
                   (eq? name name:EQV?)
                   (eq? name name:MEMQ)
                   (eq? name name:MEMV)))
             (integrate-usual-procedures)
             (= (length (call.args E0)) 2)
             (variable? (car (call.args E0)))
             (constant? (cadr (call.args E0))))
        (simplify-case-clauses (variable.name (car (call.args E0)))
                               exp
                               notepad)
        (begin (if.then-set! exp (simplify (if.then exp) notepad))
               (if.else-set! exp (simplify (if.else exp) notepad))
               exp))))

; Code generation for case expressions.
;
; A case expression turns into a conditional expression
; of the form
;
; CASE{I}  ::=  E  |  (if (PRED I K) E CASE{I})
; PRED  ::=  memv  |  memq  |  eqv?  |  eq?
;
; The memq and eq? predicates are used when the constant
; is a (list of) boolean, fixnum, char, empty list, or symbol.
; The constants will almost always be of these types.
;
; The first step is to remove duplicated constants and to
; collect all the case clauses, sorting them into the following
; categories based on their simplified list of constants:
;     constants are fixnums
;     constants are characters
;     constants are symbols
;     constants are of mixed or other type
; After duplicated constants have been removed, the predicates
; for these clauses can be tested in any order.

; Given the name of an arbitrary variable, an expression that
; has not yet been simplified or can safely be simplified again,
; and a notepad, returns the expression after simplification.
; If the expression is equivalent to a case expression that dispatches
; on the given variable, then case-optimization will be applied.

(define (simplify-case-clauses var0 E notepad)
  
  (define notepad2 (make-notepad (notepad.parent notepad)))
  
  (define (collect-clauses E fix chr sym other constants)
    (if (not (conditional? E))
        (analyze (simplify E notepad2)
                 fix chr sym other constants)
        (let ((test (simplify (if.test E) notepad2))
              (code (simplify (if.then E) notepad2)))
          (if.test-set! E test)
          (if.then-set! E code)
          (if (not (call? test))
              (finish E fix chr sym other constants)
              (let ((proc (call.proc test))
                    (args (call.args test)))
                (if (not (and (variable? proc)
                              (let ((name (variable.name proc)))
                                ; FIXME: See note above.
                                (or (eq? name name:EQ?)
                                    (eq? name name:EQV?)
                                    (eq? name name:MEMQ)
                                    (eq? name name:MEMV)))
                              (= (length args) 2)
                              (variable? (car args))
                              (eq? (variable.name (car args)) var0)
                              (constant? (cadr args))))
                    (finish E fix chr sym other constants)
                    (let ((pred (variable.name proc))
                          (datum (constant.value (cadr args))))
                      ; FIXME
                      (if (or (and (or (eq? pred name:MEMV)
                                       (eq? pred name:MEMQ))
                                   (not (list? datum)))
                              (and (eq? pred name:EQ?)
                                   (not (eqv-is-ok? datum)))
                              (and (eq? pred name:MEMQ)
                                   (not (every? (lambda (datum)
                                                  (eqv-is-ok? datum))
                                                datum))))
                          (finish E fix chr sym other constants)
                          (call-with-values
                           (lambda ()
                             (remove-duplicates (if (or (eq? pred name:EQV?)
                                                        (eq? pred name:EQ?))
                                                    (list datum)
                                                    datum)
                                                constants))
                           (lambda (data constants)
                             (let ((clause (list data code))
                                   (E2 (if.else E)))
                               (cond ((every? smallint? data)
                                      (collect-clauses E2
                                                       (cons clause fix)
                                                       chr
                                                       sym
                                                       other
                                                       constants))
                                     ((every? char? data)
                                      (collect-clauses E2
                                                       fix
                                                       (cons clause chr)
                                                       sym
                                                       other
                                                       constants))
                                     ((every? symbol? data)
                                      (collect-clauses E2
                                                       fix
                                                       chr
                                                       (cons clause sym)
                                                       other
                                                       constants))
                                     (else
                                      (collect-clauses E2
                                                       fix
                                                       chr
                                                       sym
                                                       (cons clause other)
                                                       constants))))))))))))))
  
  (define (remove-duplicates data set)
    (let loop ((originals data)
               (data '())
               (set set))
      (if (null? originals)
          (values data set)
          (let ((x (car originals))
                (originals (cdr originals)))
            (if (memv x set)
                (loop originals data set)
                (loop originals (cons x data) (cons x set)))))))
  
  (define (finish E fix chr sym other constants)
    (if.else-set! E (simplify (if.else E) notepad2))
    (analyze E fix chr sym other constants))
  
  (define (analyze default fix chr sym other constants)
    (notepad-var-add! notepad2 var0)
    (for-each (lambda (L)
                (notepad-lambda-add! notepad L))
              (notepad.lambdas notepad2))
    (for-each (lambda (L)
                (notepad-nonescaping-add! notepad L))
              (notepad.nonescaping notepad2))
    (for-each (lambda (var)
                (notepad-var-add! notepad var))
              (append (list name:FIXNUM?
                            name:CHAR?
                            name:SYMBOL?
                            name:FX<
                            name:FX-
                            name:CHAR->INTEGER
                            name:VECTOR-REF)
                      (notepad.vars notepad2)))
    (analyze-clauses (notepad.vars notepad2)
                     var0
                     default
                     (reverse fix)
                     (reverse chr)
                     (reverse sym)
                     (reverse other)
                     constants))
  
  (collect-clauses E '() '() '() '() '()))

; Returns true if EQ? and EQV? behave the same on x.

(define (eqv-is-ok? x)
  (or (smallint? x)
      (char? x)
      (symbol? x)
      (boolean? x)))

; Returns true if EQ? and EQV? behave the same on x.

(define (eq-is-ok? x)
  (eqv-is-ok? x))

; Any case expression that dispatches on a variable var0 and whose
; constants are disjoint can be compiled as
;
; (let ((n (cond ((eq? var0 'K1) ...)   ; miscellaneous constants
;                ...
;                ((fixnum? var0)
;                 <dispatch-on-fixnum>)
;                ((char? var0)
;                 <dispatch-on-char>)
;                ((symbol? var0)
;                 <dispatch-on-symbols>)
;                (else 0))))
;   <dispatch-on-case-number>)
;
; where the <dispatch-on-case-number> uses binary search within
; the interval [0, p+1), where p is the number of non-default cases.
;
; On the SPARC, sequential search is faster if there are fewer than
; 8 constants, and sequential search uses less than half the space
; if there are fewer than 10 constants.  Most target machines should
; similar, so I'm hard-wiring this constant.
; FIXME:  The hardwired constant is annoying.

(define (analyze-clauses F var0 default fix chr sym other constants)
  (cond ((or (and (null? fix)
                  (null? chr))
             (< (length constants) 12))
         (implement-clauses-by-sequential-search var0
                                                 default
                                                 (append fix chr sym other)))
        (else
         (implement-clauses F var0 default fix chr sym other constants))))

; Implements the general technique described above.

(define (implement-clauses F var0 default fix chr sym other constants)
  (let* ((name:n ((make-rename-procedure) 'n))
         ; Referencing information is destroyed by pass 2.
         (entry (make-R-entry name:n '() '() '()))
         (F (union (make-set (list name:n)) F))
         (L (make-lambda
             (list name:n)
             '()
             '()  ; entry
             F
             '()
             '()
             #f
             (implement-case-dispatch
              name:n
              (cons default
                    (map cadr
                         ; The order here must match the order
                         ; used by IMPLEMENT-DISPATCH.
                         (append other fix chr sym)))))))
    (make-call L
               (list (implement-dispatch 0
                                         var0
                                         (map car other)
                                         (map car fix)
                                         (map car chr)
                                         (map car sym))))))

(define (implement-case-dispatch var0 exprs)
  (implement-intervals var0
                       (map (lambda (n code)
                              (list n (+ n 1) code))
                            (iota (length exprs))
                            exprs)))

; Given the number of prior clauses,
; the variable on which to dispatch,
; a list of constant lists for mixed or miscellaneous clauses,
; a list of constant lists for the fixnum clauses,
; a list of constant lists for the character clauses, and
; a list of constant lists for the symbol clauses,
; returns code that computes the index of the selected clause.
; The mixed/miscellaneous clauses must be tested first because
; Twobit's SMALLINT? predicate might not be true of all fixnums
; on the target machine, which means that Twobit might classify
; some fixnums as miscellaneous.

(define (implement-dispatch prior var0 other fix chr sym)
  (cond ((not (null? other))
         (implement-dispatch-other
          (implement-dispatch (+ prior (length other))
                              var0 fix chr sym '())
          prior var other))
        ((not (null? fix))
         (make-conditional (make-call (make-variable name:FIXNUM?)
                                      (list (make-variable var0)))
                           (implement-dispatch-fixnum prior var0 fix)
                           (implement-dispatch (+ prior (length fix))
                                               var0 '() chr sym other)))
        ((not (null? chr))
         (make-conditional (make-call (make-variable name:CHAR?)
                                      (list (make-variable var0)))
                           (implement-dispatch-char prior var0 chr)
                           (implement-dispatch (+ prior (length chr))
                                               var0 fix '() sym other)))
        ((not (null? sym))
         (make-conditional (make-call (make-variable name:SYMBOL?)
                                      (list (make-variable var0)))
                           (implement-dispatch-symbol prior var0 sym)
                           (implement-dispatch (+ prior (length sym))
                                               var0 fix chr '() other)))
        (else
         (make-constant 0))))

; The value of var0 will be known to be a fixnum.
; Can use table lookup, binary search, or sequential search.
; FIXME: Never uses sequential search, which is best when
; there are only a few constants, with gaps between them.

(define (implement-dispatch-fixnum prior var0 lists)
  
  (define (calculate-intervals n lists)
    (define (loop n lists intervals)
      (if (null? lists)
          (twobit-sort (lambda (interval1 interval2)
                         (< (car interval1) (car interval2)))
                       intervals)
          (let ((constants (twobit-sort < (car lists))))
            (loop (+ n 1)
                  (cdr lists)
                  (append (extract-intervals n constants)
                          intervals)))))
    (loop n lists '()))
  
  (define (extract-intervals n constants)
    (if (null? constants)
        '()
        (let ((k0 (car constants)))
          (do ((constants (cdr constants) (cdr constants))
               (k1 (+ k0 1) (+ k1 1)))
              ((or (null? constants)
                   (not (= k1 (car constants))))
               (cons (list k0 k1 (make-constant n))
                     (extract-intervals n constants)))))))
  
  (define (complete-intervals intervals)
    (cond ((null? intervals)
           intervals)
          ((null? (cdr intervals))
           intervals)
          (else
           (let* ((i1 (car intervals))
                  (i2 (cadr intervals))
                  (end1 (cadr i1))
                  (start2 (car i2))
                  (intervals (complete-intervals (cdr intervals))))
             (if (= end1 start2)
                 (cons i1 intervals)
                 (cons i1
                       (cons (list end1 start2 (make-constant 0))
                             intervals)))))))
  
  (let* ((intervals (complete-intervals
                     (calculate-intervals (+ prior 1) lists)))
         (lo (car (car intervals)))
         (hi (car (car (reverse intervals))))
         (p (length intervals)))
    (make-conditional
     (make-call (make-variable name:FX<)
                (list (make-variable var0)
                      (make-constant lo)))
     (make-constant 0)
     (make-conditional
      (make-call (make-variable name:FX<)
                 (list (make-variable var0)
                       (make-constant (+ hi 1))))
      ; The static cost of table lookup is about hi - lo words.
      ; The static cost of binary search is about 5 SPARC instructions
      ; per interval.
      (if (< (- hi lo) (* 5 p))
          (implement-table-lookup var0 (+ prior 1) lists lo hi)
          (implement-intervals var0 intervals))
      (make-constant 0)))))

(define (implement-dispatch-char prior var0 lists)
  (let* ((lists (map (lambda (constants)
                       (map compat:char->integer constants))
                     lists))
         (name:n ((make-rename-procedure) 'n))
         ; Referencing information is destroyed by pass 2.
         ;(entry (make-R-entry name:n '() '() '()))
         (F (list name:n name:EQ? name:FX< name:FX- name:VECTOR-REF))
         (L (make-lambda
             (list name:n)
             '()
             '()  ; entry
             F
             '()
             '()
             #f
             (implement-dispatch-fixnum prior name:n lists))))
    (make-call L
               (make-call (make-variable name:CHAR->INTEGER)
                          (list (make-variable var0))))))

(define (implement-dispatch-symbol prior var0 lists)
  (implement-dispatch-other (make-constant 0) prior var0 lists))

(define (implement-dispatch-other default prior var0 lists)
  (if (null? lists)
      default
      (let* ((constants (car lists))
             (lists (cdr lists))
             (n (+ prior 1)))
      (make-conditional (make-call-to-memv var0 constants)
                        (make-constant n)
                        (implement-dispatch-other default n var0 lists)))))

(define (make-call-to-memv var0 constants)
  (cond ((null? constants)
         (make-constant #f))
        ((null? (cdr constants))
         (make-call-to-eqv var0 (car constants)))
        (else
         (make-conditional (make-call-to-eqv var0 (car constants))
                           (make-constant #t)
                           (make-call-to-memv var0 (cdr constants))))))

(define (make-call-to-eqv var0 constant)
  (make-call (make-variable
              (if (eq-is-ok? constant)
                  name:EQ?
                  name:EQV?))
             (list (make-variable var0)
                   (make-constant constant))))

; Given a variable whose value is known to be a fixnum,
; the clause index for the first fixnum clause,
; an ordered list of lists of constants for fixnum-only clauses,
; and the least and greatest constants in those lists,
; returns code for a table lookup.

(define (implement-table-lookup var0 index lists lo hi)
  (let ((v (make-vector (+ 1 (- hi lo)) 0)))
    (do ((index index (+ index 1))
         (lists lists (cdr lists)))
        ((null? lists))
        (for-each (lambda (k)
                    (vector-set! v (- k lo) index))
                  (car lists)))
    (make-call (make-variable name:VECTOR-REF)
               (list (make-constant v)
                     (make-call (make-variable name:FX-)
                                (list (make-variable var0)
                                      (make-constant lo)))))))

; Given a variable whose value is known to lie within the
; half-open interval [m0, mk), and an ordered complete
; list of intervals of the form
;
;     ((m0 m1 code0)
;      (m1 m2 code1)
;      ...
;      (m{k-1} mk code{k-1})
;     )
;
; returns an expression that finds the unique i such that
; var0 lies within [mi, m{i+1}), and then executes code{i}.

(define (implement-intervals var0 intervals)
  (if (null? (cdr intervals))
      (caddr (car intervals))
      (let ((n (quotient (length intervals) 2)))
        (do ((n n (- n 1))
             (intervals1 '() (cons (car intervals2) intervals1))
             (intervals2 intervals (cdr intervals2)))
            ((zero? n)
             (let ((intervals1 (reverse intervals1))
                   (m (car (car intervals2))))
               (make-conditional (make-call (make-variable name:FX<)
                                            (list
                                             (make-variable var0)
                                             (make-constant m)))
                                 (implement-intervals var0 intervals1)
                                 (implement-intervals var0 intervals2))))))))

; The brute force approach.
; Given the variable on which the dispatch is being performed, and
; actual (simplified) code for the default clause and
; for all other clauses,
; returns code to perform the dispatch by sequential search.

(define *memq-threshold* 20)
(define *memv-threshold* 4)

(define (implement-clauses-by-sequential-search var0 default clauses)
  (if (null? clauses)
      default
      (let* ((case1 (car clauses))
             (clauses (cdr clauses))
             (constants1 (car case1))
             (code1 (cadr case1)))
        (make-conditional (make-call-to-memv var0 constants1)
                          code1
                          (implement-clauses-by-sequential-search
                           var0 default clauses)))))
; Copyright 1999 William D Clinger.
;
; Permission to copy this software, in whole or in part, to use this
; software for any lawful noncommercial purpose, and to redistribute
; this software is granted subject to the restriction that all copies
; made of this software must include this copyright notice in full.
;
; I also request that you send me a copy of any improvements that you
; make to this software so that they may be incorporated within it to
; the benefit of the Scheme community.
;
; 13 April 1999.
;
; The tail and non-tail call graphs of known and unknown procedures.
;
; Given an expression E returned by pass 2 of Twobit,
; returns a list of the following form:
;
; ((#t     L ()     <tailcalls> <nontailcalls> <size> #f)
;  (<name> L <vars> <tailcalls> <nontailcalls> <size> #f)
;  ...)
;
; where
;
; Each L is a lambda expression that occurs within E
; as either an escaping lambda expression or as a known
; procedure.  If L is a known procedure, then <name> is
; its name; otherwise <name> is #f.
;
; <vars> is a list of the non-global variables within whose
; scope L occurs.
;
; <tailcalls> is a complete list of names of known local procedures
; that L calls tail-recursively, disregarding calls from other known
; procedures or escaping lambda expressions that occur within L.
;
; <nontailcalls> is a complete list of names of known local procedures
; that L calls non-tail-recursively, disregarding calls from other
; known procedures or escaping lambda expressions that occur within L.
;
; <size> is a measure of the size of L, including known procedures
; and escaping lambda expressions that occur within L.

(define (callgraphnode.name x) (car x))
(define (callgraphnode.code x) (cadr x))
(define (callgraphnode.vars x) (caddr x))
(define (callgraphnode.tailcalls x) (cadddr x))
(define (callgraphnode.nontailcalls x) (car (cddddr x)))
(define (callgraphnode.size x) (cadr (cddddr x)))
(define (callgraphnode.info x) (caddr (cddddr x)))

(define (callgraphnode.size! x v) (set-car! (cdr (cddddr x)) v) #f)
(define (callgraphnode.info! x v) (set-car! (cddr (cddddr x)) v) #f)

(define (callgraph exp)
  
  ; Returns (union (list x) z).
  
  (define (adjoin x z)
    (if (memq x z)
        z
        (cons x z)))
  
  (let ((result '()))
    
    ; Given a <name> as described above, a lambda expression, a list
    ; of variables that are in scope, and a list of names of known
    ; local procedure that are in scope, computes an entry for L and
    ; entries for any nested known procedures or escaping lambda
    ; expressions, and adds them to the result.
    
    (define (add-vertex! name L vars known)
      
      (let ((tailcalls '())
            (nontailcalls '())
            (size 0))
        
        ; Given an expression, a list of variables that are in scope,
        ; a list of names of known local procedures that are in scope,
        ; and a boolean indicating whether the expression occurs in a
        ; tail context, adds any tail or non-tail calls to known
        ; procedures that occur within the expression to the list
        ; variables declared above.
        
        (define (graph! exp vars known tail?)
          (set! size (+ size 1))
          (case (car exp)
            
            ((quote)    #f)
            
            ((lambda)   (add-vertex! #f exp vars known)
                        (set! size
                              (+ size
                                 (callgraphnode.size (car result)))))
            
            ((set!)     (graph! (assignment.rhs exp) vars known #f))
            
            ((if)       (graph! (if.test exp) vars known #f)
                        (graph! (if.then exp) vars known tail?)
                        (graph! (if.else exp) vars known tail?))
            
            ((begin)    (if (not (variable? exp))
                            (do ((exprs (begin.exprs exp) (cdr exprs)))
                                ((null? (cdr exprs))
                                 (graph! (car exprs) vars known tail?))
                                (graph! (car exprs) vars known #f))))
            
            (else       (let ((proc (call.proc exp)))
                          (cond ((variable? proc)
                                 (let ((name (variable.name proc)))
                                   (if (memq name known)
                                       (if tail?
                                           (set! tailcalls
                                                 (adjoin name tailcalls))
                                           (set! nontailcalls
                                                 (adjoin name nontailcalls))))))
                                 ((lambda? proc)
                                  (graph-lambda! proc vars known tail?))
                                 (else
                                  (graph! proc vars known #f)))
                          (for-each (lambda (exp)
                                      (graph! exp vars known #f))
                                    (call.args exp))))))
        
        (define (graph-lambda! L vars known tail?)
          (let* ((defs (lambda.defs L))
                 (newknown (map def.lhs defs))
                 (vars (append newknown
                               (make-null-terminated
                                (lambda.args L))
                               vars))
                 (known (append newknown known)))
            (for-each (lambda (def)
                        (add-vertex! (def.lhs def)
                                     (def.rhs def)
                                     vars
                                     known)
                        (set! size
                              (+ size
                                 (callgraphnode.size (car result)))))
                      defs)
            (graph! (lambda.body L) vars known tail?)))
        
        (graph-lambda! L vars known #t)
        
        (set! result
              (cons (list name L vars tailcalls nontailcalls size #f)
                    result))))
    
    (add-vertex! #t
                 (make-lambda '() '() '() '() '() '() '() exp)
                 '()
                 '())
    result))

; Displays the callgraph, for debugging.

(define (view-callgraph g)
  (for-each (lambda (entry)
              (let ((name (callgraphnode.name entry))
                    (exp  (callgraphnode.code entry))
                    (vars (callgraphnode.vars entry))
                    (tail (callgraphnode.tailcalls entry))
                    (nt   (callgraphnode.nontailcalls entry))
                    (size (callgraphnode.size entry)))
                (cond ((symbol? name)
                       (write name))
                      (name
                       (display "TOP LEVEL EXPRESSION"))
                      (else
                       (display "ESCAPING LAMBDA EXPRESSION")))
                (display ":")
                (newline)
                (display "Size: ")
                (write size)
                (newline)
                ;(newline)
                ;(display "Variables in scope: ")
                ;(write vars)
                ;(newline)
                (display "Tail calls:     ")
                (write tail)
                (newline)
                (display "Non-tail calls: ")
                (write nt)
                (newline)
                ;(newline)
                ;(pretty-print (make-readable exp))
                ;(newline)
                ;(newline)
                (newline)))
            g))
; Copyright 1999 William D Clinger.
;
; Permission to copy this software, in whole or in part, to use this
; software for any lawful noncommercial purpose, and to redistribute
; this software is granted subject to the restriction that all copies
; made of this software must include this copyright notice in full.
;
; I also request that you send me a copy of any improvements that you
; make to this software so that they may be incorporated within it to
; the benefit of the Scheme community.
;
; 14 April 1999.
;
; Inlining of known local procedures.
;
; First find the known and escaping procedures and compute the call graph.
;
; If a known local procedure is not called at all, then delete its code.
;
; If a known local procedure is called exactly once,
; then inline its code at the call site and delete the
; known local procedure.  Change the size of the code
; at the call site by adding the size of the inlined code.
;
; Divide the remaining known and escaping procedures into categories:
;     1.  makes no calls to known local procedures
;     2.  known procedures that call known procedures;
;         within this category, try to sort so that procedures do not
;         call procedures that come later in the sequence; or sort by
;         number of calls and/or size
;     3.  escaping procedures that call known procedures
;
; Approve each procedure in category 1 for inlining if its code size
; is less than some threshold.
;
; For each procedure in categories 2 and 3, traverse its code, inlining
; where it seems like a good idea.  The compiler should be more aggressive
; about inlining non-tail calls than tail calls because:
;
;     Inlining a non-tail call can eliminate a stack frame
;     or expose the inlined code to loop optimizations.
;
;     The main reason for inlining a tail call is to enable
;     intraprocedural optimizations or to unroll a loop.
;
; After inlining has been performed on a known local procedure,
; then approve it for inlining if its size is less than some threshold.
;
; FIXME:
; This strategy avoids infinite unrolling, but it also avoids finite
; unrolling of loops.

; Parameters to control inlining.
; These can be tuned later.

(define *tail-threshold* 10)
(define *nontail-threshold* 20)
(define *multiplier* 300)

; Given a callgraph, performs inlining of known local procedures
; by side effect.  The original expression must then be copied to
; reinstate Twobit's invariants.

; FIXME:  This code doesn't yet do the right thing with known local
; procedures that aren't called or are called in exactly one place.

(define (inline-using-callgraph! g)
  (let ((known (make-hashtable))
        (category2 '())
        (category3 '()))
    (for-each (lambda (node)
                (let ((name (callgraphnode.name node))
                      (tcalls (callgraphnode.tailcalls node))
                      (ncalls (callgraphnode.nontailcalls node)))
                  (if (symbol? name)
                      (hashtable-put! known name node))
                  (if (and (null? tcalls)
                           (null? ncalls))
                      (if (< (callgraphnode.size node)
                             *nontail-threshold*)
                          (callgraphnode.info! node #t))
                      (if (symbol? name)
                          (set! category2 (cons node category2))
                          (set! category3 (cons node category3))))))
              g)
    (set! category2 (twobit-sort (lambda (x y)
                                   (< (callgraphnode.size x)
                                      (callgraphnode.size y)))
                                 category2))
    (for-each (lambda (node)
                (inline-node! node known))
              category2)
    (for-each (lambda (node)
                (inline-node! node known))
              category3)
    ; FIXME:
    ; Inlining destroys the callgraph, so maybe this cleanup is useless.
    (hashtable-for-each (lambda (name node) (callgraphnode.info! node #f))
                        known)))

; Given a node of the callgraph and a hash table of nodes for
; known local procedures, performs inlining by side effect.

(define (inline-node! node known)
  (let* ((debugging? #f)
         (name (callgraphnode.name node))
         (exp (callgraphnode.code node))
         (size0 (callgraphnode.size node))
         (budget (quotient (* (- *multiplier* 100) size0) 100))
         (tail-threshold *tail-threshold*)
         (nontail-threshold *nontail-threshold*))
    
    ; Given an expression,
    ; a boolean indicating whether the expression is in a tail context,
    ; a list of procedures that should not be inlined,
    ; and a size budget,
    ; performs inlining by side effect and returns the unused budget.
    
    (define (inline exp tail? budget)
        (if (positive? budget)
            
            (case (car exp)
              
              ((quote lambda)
               budget)
              
              ((set!)
               (inline (assignment.rhs exp) #f budget))
              
              ((if)
               (let* ((budget (inline (if.test exp) #f budget))
                      (budget (inline (if.then exp) tail? budget))
                      (budget (inline (if.else exp) tail? budget)))
                 budget))
              
              ((begin)
               (if (variable? exp)
                   budget
                   (do ((exprs (begin.exprs exp) (cdr exprs))
                        (budget budget
                                (inline (car exprs) #f budget)))
                       ((null? (cdr exprs))
                        (inline (car exprs) tail? budget)))))
              
              (else
               (let ((budget (do ((exprs (call.args exp) (cdr exprs))
                                  (budget budget
                                          (inline (car exprs) #f budget)))
                                 ((null? exprs)
                                  budget))))
                 (let ((proc (call.proc exp)))
                   (cond ((variable? proc)
                          (let* ((procname (variable.name proc))
                                 (procnode (hashtable-get known procname)))
                            (if procnode
                                (let ((size (callgraphnode.size procnode))
                                      (info (callgraphnode.info procnode)))
                                  (if (and info
                                           (<= size budget)
                                           (<= size
                                               (if tail?
                                                   tail-threshold
                                                   nontail-threshold)))
                                      (begin
                                       (if debugging?
                                           (begin
                                            (display "    Inlining ")
                                            (write (variable.name proc))
                                            (newline)))
                                       (call.proc-set!
                                        exp
                                        (copy-exp
                                         (callgraphnode.code procnode)))
                                       (callgraphnode.size!
                                        node
                                        (+ (callgraphnode.size node) size))
                                       (- budget size))
                                      (begin
                                       (if (and #f debugging?)
                                           (begin
                                            (display "    Declining to inline ")
                                            (write (variable.name proc))
                                            (newline)))
                                       budget)))
                                budget)))
                         ((lambda? proc)
                          (inline (lambda.body proc) tail? budget))
                         (else
                          (inline proc #f budget)))))))
            -1))
    
    (if (and #f debugging?)
        (begin
         (display "Processing ")
         (write name)
         (newline)))
    
    (let ((budget (inline (if (lambda? exp)
                              (lambda.body exp)
                              exp)
                          #t
                          budget)))
      (if (and (negative? budget)
               debugging?)
          ; This shouldn't happen very often.
          (begin (display "Ran out of inlining budget for ")
                 (write (callgraphnode.name node))
                 (newline)))
      (if (<= (callgraphnode.size node) nontail-threshold)
          (callgraphnode.info! node #t))
      #f)))

; For testing.

(define (test-inlining test0)
  (begin (define exp0 (begin (display "Compiling...")
                             (newline)
                             (pass2 (pass1 test0))))
         (define g0 (begin (display "Computing call graph...")
                           (newline)
                           (callgraph exp0))))
  (display "Inlining...")
  (newline)
  (inline-using-callgraph! g0)
  (pretty-print (make-readable (copy-exp exp0))))
; Copyright 1999 William D Clinger.
;
; Permission to copy this software, in whole or in part, to use this
; software for any lawful noncommercial purpose, and to redistribute
; this software is granted subject to the restriction that all copies
; made of this software must include this copyright notice in full.
;
; I also request that you send me a copy of any improvements that you
; make to this software so that they may be incorporated within it to
; the benefit of the Scheme community.
;
; 14 April 1999.
;
; Interprocedural constant propagation and folding.
;
; Constant propagation must converge before constant folding can be
; performed.  Constant folding creates more constants that can be
; propagated, so these two optimizations must be iterated, but it
; is safe to stop at any time.
;
; Abstract interpretation for constant folding.
;
; The abstract values are
;     bottom    (represented here by #f)
;     constants (represented by quoted literals)
;     top       (represented here by #t)
;
; Let [[ E ]] be the abstract interpretation of E over that domain
; of abstract values, with respect to some arbitrary set of abstract
; values for local variables.
;
; If a is a global variable or a formal parameter of an escaping
; lambda expression, then [[ a ]] = #t.
;
; If x is the ith formal parameter of a known local procedure f,
; then [[ x ]] = \join_{(f E1 ... En)} [[ Ei ]].
;
; [[ K ]] = K
; [[ L ]] = #t
; [[ (begin E1 ... En) ]] = [[ En ]]
; [[ (set! I E) ]] = #f
;
; If [[ E0 ]] = #t, then [[ (if E0 E1 E2) ]] = [[ E1 ]] \join [[ E2 ]]
; else if [[ E0 ]] = K, then [[ (if E0 E1 E2) ]] = [[ E1 ]]
;                         or [[ (if E0 E1 E2) ]] = [[ E2 ]]
;                       depending upon K
; else [[ (if E0 E1 E2) ]] = #f
;
; If f is a known local procedure with body E,
;     then [[ (f E1 ... En) ]] = [[ E ]]
;
; If g is a foldable integrable procedure, then:
; if there is some i for which [[ Ei ]] = #t,
;     then [[ (g E1 ... En) ]] = #t
; else if [[ E1 ]] = K1, ..., [[ En ]] = Kn,
;     then [[ (g E1 ... En) ]] = (g K1 ... Kn)
; else [[ (g E1 ... En) ]] = #f
;
; Symbolic representations of abstract values.
; (Can be thought of as mappings from abstract environments to
; abstract values.)
;
; <symbolic>     ::=  #t  |  ( <expressions> )
; <expressions>  ::=  <empty>  |  <expression> <expressions>

; Parameter to limit constant propagation and folding.
; This parameter can be tuned later.

(define *constant-propagation-limit* 5)

; Given an expression as output by pass 2, performs constant
; propagation and folding.

(define (constant-propagation exp)
  (define (constant-propagation exp i)
    (if (< i *constant-propagation-limit*)
        (begin
         ;(display "Performing constant propagation and folding...")
         ;(newline)
         (let* ((g (callgraph exp))
                (L (callgraphnode.code (car g)))
                (variables (constant-propagation-using-callgraph g))
                (changed? (constant-folding! L variables)))
           (if changed?
               (constant-propagation (lambda.body L) (+ i 1))
               (lambda.body L))))))
  (constant-propagation exp 0))

; Given a callgraph, returns a hashtable of abstract values for
; all local variables.

(define (constant-propagation-using-callgraph g)
  (let ((debugging? #f)
        (folding? (integrate-usual-procedures))
        (known (make-hashtable))
        (variables (make-hashtable))
        (counter 0))
    
    ; Computes joins of abstract values.
    
    (define (join x y)
      (cond ((boolean? x)
             (if x #t y))
            ((boolean? y)
             (join y x))
            ((equal? x y)
             x)
            (else #t)))
    
    ; Given a <symbolic> and a vector of abstract values,
    ; evaluates the <symbolic> and returns its abstract value.
    
    (define (aeval rep env)
      (cond ((eq? rep #t)
             #t)
            ((null? rep)
             #f)
            ((null? (cdr rep))
             (aeval1 (car rep) env))
            (else
             (join (aeval1 (car rep) env)
                   (aeval (cdr rep) env)))))
    
    (define (aeval1 exp env)
      
      (case (car exp)
        
        ((quote)
         exp)
        
        ((lambda)
         #t)
        
        ((set!)
         #f)
        
        ((begin)
         (if (variable? exp)
             (let* ((name (variable.name exp))
                    (i (hashtable-get variables name)))
               (if i
                   (vector-ref env i)
                   #t))
             (aeval1-error)))
        
        ((if)
         (let* ((val0 (aeval1 (if.test exp) env))
                (val1 (aeval1 (if.then exp) env))
                (val2 (aeval1 (if.else exp) env)))
           (cond ((eq? val0 #t)
                  (join val1 val2))
                 ((pair? val0)
                  (if (constant.value val0)
                      val1
                      val2))
                 (else
                  #f))))
        
        (else
         (do ((exprs (reverse (call.args exp)) (cdr exprs))
              (vals '() (cons (aeval1 (car exprs) env) vals)))
             ((null? exprs)
              (let ((proc (call.proc exp)))
                (cond ((variable? proc)
                       (let* ((procname (variable.name proc))
                              (procnode (hashtable-get known procname))
                              (entry (if folding?
                                         (constant-folding-entry procname)
                                         #f)))
                         (cond (procnode
                                (vector-ref env
                                            (hashtable-get variables
                                                           procname)))
                               (entry
                                ; FIXME: No constant folding
                                #t)
                               (else (aeval1-error)))))
                      (else
                       (aeval1-error)))))))))
    
    (define (aeval1-error)
      (error "Compiler bug: constant propagation (aeval1)"))
    
    ; Combines two <symbolic>s.
    
    (define (combine-symbolic rep1 rep2)
      (cond ((eq? rep1 #t) #t)
            ((eq? rep2 #t) #t)
            (else
             (append rep1 rep2))))
    
    ; Given an expression, returns a <symbolic> that represents
    ; a list of expressions whose abstract values can be joined
    ; to obtain the abstract value of the given expression.
    ; As a side effect, enters local variables into variables.
    
    (define (collect! exp)
      
      (case (car exp)
        
        ((quote)
         (list exp))
        
        ((lambda)
         #t)
        
        ((set!)
         (collect! (assignment.rhs exp))
         '())
        
        ((begin)
         (if (variable? exp)
             (list exp)
             (do ((exprs (begin.exprs exp) (cdr exprs)))
                 ((null? (cdr exprs))
                  (collect! (car exprs)))
                 (collect! (car exprs)))))
        
        ((if)
         (collect! (if.test exp))
         (collect! (if.then exp))
         (collect! (if.else exp))
         #t)
        
        (else
         (do ((exprs (reverse (call.args exp)) (cdr exprs))
              (reps '() (cons (collect! (car exprs)) reps)))
             ((null? exprs)
              (let ((proc (call.proc exp)))
                (define (put-args! args reps)
                  (cond ((pair? args)
                         (let ((v (car args))
                               (rep (car reps)))
                           (hashtable-put! variables v rep)
                           (put-args! (cdr args) (cdr reps))))
                        ((symbol? args)
                         (hashtable-put! variables args #t))
                        (else #f)))
                (cond ((variable? proc)
                       (let* ((procname (variable.name proc))
                              (procnode (hashtable-get known procname))
                              (entry (if folding?
                                         (constant-folding-entry procname)
                                         #f)))
                         (cond (procnode
                                (for-each (lambda (v rep)
                                            (hashtable-put!
                                             variables
                                             v
                                             (combine-symbolic
                                              rep (hashtable-get variables v))))
                                          (lambda.args
                                            (callgraphnode.code procnode))
                                          reps)
                                (list (make-variable procname)))
                               (entry
                                ; FIXME: No constant folding
                                #t)
                               (else #t))))
                      ((lambda? proc)
                       (put-args! (lambda.args proc) reps)
                       (collect! (lambda.body proc)))
                      (else
                       (collect! proc)
                       #t))))))))
    
    (for-each (lambda (node)
                (let* ((name (callgraphnode.name node))
                       (code (callgraphnode.code node))
                       (known? (symbol? name))
                       (rep (if known? '() #t)))
                  (if known?
                      (hashtable-put! known name node))
                  (if (lambda? code)
                      (for-each (lambda (var)
                                  (hashtable-put! variables var rep))
                                (make-null-terminated (lambda.args code))))))
              g)
    
    (for-each (lambda (node)
                (let ((name (callgraphnode.name node))
                      (code (callgraphnode.code node)))
                  (cond ((symbol? name)
                         (hashtable-put! variables
                                         name
                                         (collect! (lambda.body code))))
                        (else
                         (collect! (lambda.body code))))))
              g)
    
    (if (and #f debugging?)
        (begin
         (hashtable-for-each (lambda (v rep)
                               (write v)
                               (display ": ")
                               (write rep)
                               (newline))
                             variables)
         
         (display "----------------------------------------")
         (newline)))
    
    ;(trace aeval aeval1)
    
    (let* ((n (hashtable-size variables))
           (vars (hashtable-map (lambda (v rep) v) variables))
           (reps (map (lambda (v) (hashtable-get variables v)) vars))
           (init (make-vector n #f))
           (next (make-vector n)))
      (do ((i 0 (+ i 1))
           (vars vars (cdr vars))
           (reps reps (cdr reps)))
          ((= i n))
          (hashtable-put! variables (car vars) i)
          (vector-set! next
                       i
                       (let ((rep (car reps)))
                         (lambda (env)
                           (aeval rep env)))))
      (compute-fixedpoint init next equal?)
      (for-each (lambda (v)
                  (let* ((i (hashtable-get variables v))
                         (aval (vector-ref init i)))
                    (hashtable-put! variables v aval)
                    (if (and debugging?
                             (not (eq? aval #t)))
                        (begin (write v)
                               (display ": ")
                               (write aval)
                               (newline)))))
                vars)
      variables)))

; Given a lambda expression, performs constant propagation, folding,
; and simplifications by side effect, using the abstract values in the
; hash table of variables.
; Returns #t if any new constants were created by constant folding,
; otherwise returns #f.

(define (constant-folding! L variables)
  (let ((debugging? #f)
        (msg1 "    Propagating constant value for ")
        (msg2 "    Folding: ")
        (msg3 " ==> ")
        (folding? (integrate-usual-procedures))
        (changed? #f))
    
    ; Given a known lambda expression L, its original formal parameters,
    ; and a list of all calls to L, deletes arguments that are now
    ; ignored because of constant propagation.
    
    (define (delete-ignored-args! L formals0 calls)
      (let ((formals1 (lambda.args L)))
        (for-each (lambda (call)
                    (do ((formals0 formals0 (cdr formals0))
                         (formals1 formals1 (cdr formals1))
                         (args (call.args call)
                               (cdr args))
                         (newargs '()
                                  (if (and (eq? (car formals1) name:IGNORED)
                                           (pair?
                                            (hashtable-get variables
                                                           (car formals0))))
                                      newargs
                                      (cons (car args) newargs))))
                        ((null? formals0)
                         (call.args-set! call (reverse newargs)))))
                  calls)
        (do ((formals0 formals0 (cdr formals0))
             (formals1 formals1 (cdr formals1))
             (formals2 '()
                       (if (and (not (eq? (car formals0)
                                          (car formals1)))
                                (eq? (car formals1) name:IGNORED)
                                (pair?
                                 (hashtable-get variables
                                                (car formals0))))
                           formals2
                           (cons (car formals1) formals2))))
            ((null? formals0)
             (lambda.args-set! L (reverse formals2))))))
    
    (define (fold! exp)
      
      (case (car exp)
        
        ((quote) exp)
        
        ((lambda)
         (let ((Rinfo (lambda.R exp))
               (known (map def.lhs (lambda.defs exp))))
           (for-each (lambda (entry)
                       (let* ((v (R-entry.name entry))
                              (aval (hashtable-fetch variables v #t)))
                         (if (and (pair? aval)
                                  (not (memq v known)))
                             (let ((x (constant.value aval)))
                               (if (or (boolean? x)
                                       (null? x)
                                       (symbol? x)
                                       (number? x)
                                       (char? x)
                                       (and (vector? x)
                                            (zero? (vector-length x))))
                                   (let ((refs (R-entry.references entry)))
                                     (for-each (lambda (ref)
                                                 (variable-set! ref aval))
                                               refs)
                                     ; Do not try to use Rinfo in place of
                                     ; (lambda.R exp) below!
                                     (lambda.R-set!
                                       exp
                                       (remq entry (lambda.R exp)))
                                     (flag-as-ignored v exp)
                                     (if debugging?
                                         (begin (display msg1)
                                                (write v)
                                                (display ": ")
                                                (write aval)
                                                (newline)))))))))
                     Rinfo)
           (for-each (lambda (def)
                       (let* ((name (def.lhs def))
                              (rhs (def.rhs def))
                              (entry (R-lookup Rinfo name))
                              (calls (R-entry.calls entry)))
                         (if (null? calls)
                             (begin (lambda.defs-set!
                                      exp
                                      (remq def (lambda.defs exp)))
                                    ; Do not try to use Rinfo in place of
                                    ; (lambda.R exp) below!
                                    (lambda.R-set!
                                      exp
                                      (remq entry (lambda.R exp))))
                             (let* ((formals0 (append (lambda.args rhs) '()))
                                    (L (fold! rhs))
                                    (formals1 (lambda.args L)))
                               (if (not (equal? formals0 formals1))
                                   (delete-ignored-args! L formals0 calls))))))
                     (lambda.defs exp))
           (lambda.body-set!
             exp
             (fold! (lambda.body exp)))
           exp))
        
        ((set!)
         (assignment.rhs-set! exp (fold! (assignment.rhs exp)))
         exp)
        
        ((begin)
         (if (variable? exp)
             exp
             (post-simplify-begin (make-begin (map fold! (begin.exprs exp)))
                                  (make-notepad #f))))
        
        ((if)
         (let ((exp0 (fold! (if.test exp)))
               (exp1 (fold! (if.then exp)))
               (exp2 (fold! (if.else exp))))
           (if (constant? exp0)
               (let ((newexp (if (constant.value exp0)
                                 exp1
                                 exp2)))
                 (if debugging?
                     (begin (display msg2)
                            (write (make-readable exp))
                            (display msg3)
                            (write (make-readable newexp))
                            (newline)))
                 (set! changed? #t)
                 newexp)
               (make-conditional exp0 exp1 exp2))))
        
        (else
         (let ((args (map fold! (call.args exp)))
               (proc (fold! (call.proc exp))))
           (cond ((and folding?
                       (variable? proc)
                       (every? constant? args)
                       (let ((entry
                              (constant-folding-entry (variable.name proc))))
                         (and entry
                              (let ((preds
                                     (constant-folding-predicates entry)))
                                (and (= (length args) (length preds))
                                     (every?
                                      (lambda (x) x)
                                      (map (lambda (f v) (f v))
                                           (constant-folding-predicates entry)
                                           (map constant.value args))))))))
                  (set! changed? #t)
                  (let ((result
                         (make-constant
                          (apply (constant-folding-folder
                                  (constant-folding-entry
                                   (variable.name proc)))
                                 (map constant.value args)))))
                    (if debugging?
                        (begin (display msg2)
                               (write (make-readable (make-call proc args)))
                               (display msg3)
                               (write result)
                               (newline)))
                    result))
                 ((and (lambda? proc)
                       (list? (lambda.args proc)))
                  ; FIXME: Folding should be done even if there is
                  ; a rest argument.
                  (let loop ((formals (reverse (lambda.args proc)))
                             (actuals (reverse args))
                             (processed-formals '())
                             (processed-actuals '())
                             (for-effect '()))
                    (cond ((null? formals)
                           (lambda.args-set! proc processed-formals)
                           (call.args-set! exp processed-actuals)
                           (let ((call (if (and (null? processed-formals)
                                                (null? (lambda.defs proc)))
                                           (lambda.body proc)
                                           exp)))
                             (if (null? for-effect)
                                 call
                                 (post-simplify-begin
                                  (make-begin
                                   (reverse (cons call for-effect)))
                                  (make-notepad #f)))))
                          ((ignored? (car formals))
                           (loop (cdr formals)
                                 (cdr actuals)
                                 processed-formals
                                 processed-actuals
                                 (cons (car actuals) for-effect)))
                          (else
                           (loop (cdr formals)
                                 (cdr actuals)
                                 (cons (car formals) processed-formals)
                                 (cons (car actuals) processed-actuals)
                                 for-effect)))))
                 (else
                  (call.proc-set! exp proc)
                  (call.args-set! exp args)
                  exp))))))
    
    (fold! L)
    changed?))
; Copyright 1998 William D Clinger.
;
; Permission to copy this software, in whole or in part, to use this
; software for any lawful noncommercial purpose, and to redistribute
; this software is granted subject to the restriction that all copies
; made of this software must include this copyright notice in full.
; 
; I also request that you send me a copy of any improvements that you
; make to this software so that they may be incorporated within it to
; the benefit of the Scheme community.
;
; 7 June 1999.
;
; Conversion to A-normal form, with heuristics for
; choosing a good order of evaluation.
;
; This pass operates as a source-to-source transformation on
; expressions written in the subset of Scheme described by the
; following grammar, where the input and output expressions
; satisfy certain additional invariants described below.
;
; "X ..." means zero or more occurrences of X.
;
; L  -->  (lambda (I_1 ...)
;           (begin D ...)
;           (quote (R F G <decls> <doc>)
;           E)
;      |  (lambda (I_1 ... . I_rest)
;           (begin D ...)
;           (quote (R F G <decls> <doc>))
;           E)
; D  -->  (define I L)
; E  -->  (quote K)                        ; constants
;      |  (begin I)                        ; variable references
;      |  L                                ; lambda expressions
;      |  (E0 E1 ...)                      ; calls
;      |  (set! I E)                       ; assignments
;      |  (if E0 E1 E2)                    ; conditionals
;      |  (begin E0 E1 E2 ...)             ; sequential expressions
; I  -->  <identifier>
;
; R  -->  ((I <references> <assignments> <calls>) ...)
; F  -->  (I ...)
; G  -->  (I ...)
;
; Invariants that hold for the input only:
;   *  There are no assignments except to global variables.
;   *  If I is declared by an internal definition, then the right hand
;      side of the internal definition is a lambda expression and I
;      is referenced only in the procedure position of a call.
;   *  For each lambda expression, the associated F is a list of all
;      the identifiers that occur free in the body of that lambda
;      expression, and possibly a few extra identifiers that were
;      once free but have been removed by optimization.
;   *  For each lambda expression, the associated G is a subset of F
;      that contains every identifier that occurs free within some
;      inner lambda expression that escapes, and possibly a few that
;      don't.  (Assignment-elimination does not calculate G exactly.)
;   *  Variables named IGNORED are neither referenced nor assigned.
;
; Invariants that hold for the output only:
;   *  There are no assignments except to global variables.
;   *  If I is declared by an internal definition, then the right hand
;      side of the internal definition is a lambda expression and I
;      is referenced only in the procedure position of a call.
;   *  R, F, and G are garbage.
;   *  There are no sequential expressions.
;   *  The output is an expression E with syntax
;
; E  -->  A
;      |  (L)
;      |  (L A)
;
; A  -->  W
;      |  L
;      |  (W_0 W_1 ...)
;      |  (set! I W)
;      |  (if W E1 E2)
;
; W  -->  (quote K)
;      |  (begin I)
;
; In other words:
; An expression is a LET* such that the rhs of every binding is
;     a conditional with the test already evaluated, or
;     an expression that can be evaluated in one step
;         (treating function calls as a single step)
;
; A-normal form corresponds to the control flow graph for a lambda
; expression.

; Algorithm: repeated use of these rules:
;
; (E0 E1 ...)                              ((lambda (T0 T1 ...) (T0 T1 ...))
;                                           E0 E1 ...)
; (set! I E)                               ((lambda (T) (set! I T)) E)
; (if E0 E1 E2)                            ((lambda (T) (if T E1 E2)) E0)
; (begin E0 E1 E2 ...)                     ((lambda (T) (begin E1 E2 ...)) E0)
;
; ((lambda (I1 I2 I3 ...) E)               ((lambda (I1)
;  E1 E2 E3)                                  ((lambda (I2 I3 ...) E)
;                                              E2 E3))
;                                           E1)
;
; ((lambda (I2) E)                         ((lambda (I1)
;  ((lambda (I1) E2)                          ((lambda (I2) E)
;   E1))                                       E2)
;                                           E1)
;
; In other words:
; Introduce a temporary name for every expression except:
;     tail expressions
;     the alternatives of a non-tail conditional
; Convert every LET into a LET*.
; Get rid of LET* on the right hand side of a binding.

; Given an expression E in the representation output by pass 2,
; returns an A-normal form for E in that representation.
; Except for quoted values, the A-normal form does not share
; mutable structure with the original expression E.
;
; KNOWN BUG:
;
; If you call A-normal on a form that has already been converted
; to A-normal form, then the same temporaries will be generated
; twice.  An optional argument lets you specify a different prefix
; for temporaries the second time around.  Example:
;
; (A-normal-form (A-normal-form E ".T")
;                ".U")

; This is the declaration that is used to indicate A-normal form.

(define A-normal-form-declaration (list 'anf))

(define (A-normal-form E . rest)
  
  (define (A-normal-form E)
    (anf-make-let* (anf E '() '())))
  
  ; New temporaries.
  
  (define temp-counter 0)
  
  (define temp-prefix
    (if (or (null? rest)
            (not (string? (car rest))))
        (string-append renaming-prefix "T")
        (car rest)))
  
  (define (newtemp)
    (set! temp-counter (+ temp-counter 1))
    (string->symbol
     (string-append temp-prefix
                    (number->string temp-counter))))
  
  ; Given an expression E as output by pass 2,
  ; a list of surrounding LET* bindings,
  ; and an ordered list of likely register variables,
  ; return a non-empty list of LET* bindings
  ; whose first binding associates a dummy variable
  ; with an A-expression giving the value for E.
  
  (define (anf E bindings regvars)
    (case (car E)
      ((quote)    (anf-bind-dummy E bindings))
      ((begin)    (if (variable? E)
                      (anf-bind-dummy E bindings)
                      (anf-sequential E bindings regvars)))
      ((lambda)   (anf-lambda E bindings regvars))
      ((set!)     (anf-assignment E bindings regvars))
      ((if)       (anf-conditional E bindings regvars))
      (else       (anf-call E bindings regvars))))
  
  (define anf:dummy (string->symbol "RESULT"))
  
  (define (anf-bind-dummy E bindings)
    (cons (list anf:dummy E)
          bindings))
  
  ; Unlike anf-bind-dummy, anf-bind-name and anf-bind convert
  ; their expression argument to A-normal form.
  ; Don't change anf-bind to call anf-bind-name, because that
  ; would name the temporaries in an aesthetically bad order.
  
  (define (anf-bind-name name E bindings regvars)
    (let ((bindings (anf E bindings regvars)))
      (cons (list name (cadr (car bindings)))
            (cdr bindings))))
  
  (define (anf-bind E bindings regvars)
    (let ((bindings (anf E bindings regvars)))
      (cons (list (newtemp) (cadr (car bindings)))
            (cdr bindings))))
  
  (define (anf-result bindings)
    (make-variable (car (car bindings))))
  
  (define (anf-make-let* bindings)
    (define (loop bindings body)
      (if (null? bindings)
          body
          (let ((T1 (car (car bindings)))
                (E1 (cadr (car bindings))))
            (loop (cdr bindings)
                  (make-call (make-lambda (list T1)
                                          '()
                                          '()
                                          '()
                                          '()
                                          (list A-normal-form-declaration)
                                          '()
                                          body)
                             (list E1))))))
    (loop (cdr bindings)
          (cadr (car bindings))))                                  
  
  (define (anf-sequential E bindings regvars)
    (do ((bindings bindings
                   (anf-bind (car exprs) bindings regvars))
         (exprs (begin.exprs E)
                (cdr exprs)))
        ((null? (cdr exprs))
         (anf (car exprs) bindings regvars))))
  
  ; Heuristic: the formal parameters of an escaping lambda or
  ; known local procedure are kept in REG1, REG2, et cetera.
  
  (define (anf-lambda L bindings regvars)
    (anf-bind-dummy
     (make-lambda (lambda.args L)
                  (map (lambda (def)
                         (make-definition
                          (def.lhs def)
                          (A-normal-form (def.rhs def))))
                       (lambda.defs L))
                  '()
                  '()
                  '()
                  (cons A-normal-form-declaration
                        (lambda.decls L))
                  (lambda.doc L)
                  (anf-make-let*
                   (anf (lambda.body L)
                        '()
                        (make-null-terminated (lambda.args L)))))
     bindings))
  
  (define (anf-assignment E bindings regvars)
    (let ((I (assignment.lhs E))
          (E1 (assignment.rhs E)))
      (if (variable? E1)
          (anf-bind-dummy E bindings)
          (let* ((bindings (anf-bind E1 bindings regvars))
                 (T1 (anf-result bindings)))
            (anf-bind-dummy (make-assignment I T1) bindings)))))
  
  (define (anf-conditional E bindings regvars)
    (let ((E0 (if.test E))
          (E1 (if.then E))
          (E2 (if.else E)))
      (if (variable? E0)
          (let ((E1 (anf-make-let* (anf E1 '() regvars)))
                (E2 (anf-make-let* (anf E2 '() regvars))))
            (anf-bind-dummy
             (make-conditional E0 E1 E2)
             bindings))
          (let* ((bindings (anf-bind E0 bindings regvars))
                 (E1 (anf-make-let* (anf E1 '() regvars)))
                 (E2 (anf-make-let* (anf E2 '() regvars))))
            (anf-bind-dummy
             (make-conditional (anf-result bindings) E1 E2)
             bindings)))))
  
  (define (anf-call E bindings regvars)
    (let* ((proc (call.proc E))
           (args (call.args E)))
      
      ; Evaluates the exprs and returns both a list of bindings and
      ; a list of the temporaries that name the results of the exprs.
      ; If rename-always? is true, then temporaries are generated even
      ; for constants and temporaries.
      
      (define (loop exprs bindings names rename-always?)
        (if (null? exprs)
            (values bindings (reverse names))
            (let ((E (car exprs)))
              (if (or rename-always?
                      (not (or (constant? E)
                               (variable? E))))
                  (let* ((bindings
                          (anf-bind (car exprs) bindings regvars)))
                    (loop (cdr exprs)
                          bindings
                          (cons (anf-result bindings) names)
                          rename-always?))
                  (loop (cdr exprs)
                        bindings
                        (cons E names)
                        rename-always?)))))
      
      ; Evaluates the exprs, binding them to the vars, and returns
      ; a list of bindings.
      ;
      ; Although LET variables are likely to be kept in registers,
      ; trying to guess which register will be allocated is likely
      ; to do more harm than good.
      
      (define (let-loop exprs bindings regvars vars)
        (if (null? exprs)
            (if (null? (lambda.defs proc))
                (anf (lambda.body proc)
                     bindings
                     regvars)
                (let ((bindings
                       (anf-bind
                        (make-lambda '()
                                     (lambda.defs proc)
                                     '()
                                     '()
                                     '()
                                     (cons A-normal-form-declaration
                                           (lambda.decls proc))
                                     (lambda.doc proc)
                                     (lambda.body proc))
                        bindings
                        '())))
                  (anf-bind-dummy
                   (make-call (anf-result bindings) '())
                   bindings)))
            (let-loop (cdr exprs)
              (anf-bind-name (car vars)
                             (car exprs)
                             bindings
                             regvars)
              regvars
              (cdr vars))))
      
      (cond ((lambda? proc)
             (let ((formals (lambda.args proc)))
               (if (list? formals)
                   (let* ((pi (anf-order-of-evaluation args regvars #f))
                          (exprs (permute args pi))
                          (names (permute (lambda.args proc) pi)))
                     (let-loop (reverse exprs) bindings regvars (reverse names)))
                   (anf-call (normalize-let E) bindings regvars))))
            
            ((not (variable? proc))
             (let ((pi (anf-order-of-evaluation args regvars #f)))
               (call-with-values
                (lambda () (loop (permute args pi) bindings '() #t))
                (lambda (bindings names)
                  (let ((bindings (anf-bind proc bindings regvars)))
                    (anf-bind-dummy
                     (make-call (anf-result bindings)
                                (unpermute names pi))
                     bindings))))))
            
            ((and (integrate-usual-procedures)
                  (prim-entry (variable.name proc)))
             (let ((pi (anf-order-of-evaluation args regvars #t)))
               (call-with-values
                (lambda () (loop (permute args pi) bindings '() #t))
                (lambda (bindings names)
                  (anf-bind-dummy
                   (make-call proc (unpermute names pi))
                   bindings)))))
            
            ((memq (variable.name proc) regvars)
             (let* ((exprs (cons proc args))
                    (pi (anf-order-of-evaluation
                         exprs
                         (cons name:IGNORED regvars)
                         #f)))
               (call-with-values
                (lambda () (loop (permute exprs pi) bindings '() #t))
                (lambda (bindings names)
                  (let ((names (unpermute names pi)))
                    (anf-bind-dummy
                     (make-call (car names) (cdr names))
                     bindings))))))
            
            (else
             (let ((pi (anf-order-of-evaluation args regvars #f)))
               (call-with-values
                (lambda () (loop (permute args pi) bindings '() #t))
                (lambda (bindings names)
                  (anf-bind-dummy
                   (make-call proc (unpermute names pi))
                   bindings))))))))
  
  ; Given a list of expressions, a list of likely register contents,
  ; and a switch telling whether these are arguments for a primop
  ; or something else (such as the arguments for a real call),
  ; try to choose a good order in which to evaluate the expressions.
  ;
  ; Heuristic:  If none of the expressions is a call to a non-primop,
  ; then parallel assignment optimization gives a good order if the
  ; regvars are right, and should do no worse than a random order if
  ; the regvars are wrong.
  ;
  ; Heuristic:  If the expressions are arguments to a primop, and
  ; none are a call to a non-primop, then the register contents
  ; are irrelevant, and the first argument should be evaluated last.
  ;
  ; Heuristic:  If one or more of the expressions is a call to a
  ; non-primop, then the following should be a good order:
  ;
  ;     expressions that are neither a constant, variable, or a call
  ;     calls to non-primops
  ;     constants and variables
  
  (define (anf-order-of-evaluation exprs regvars for-primop?)
    (define (ordering targets exprs alist)
      (let ((para
             (parallel-assignment targets alist exprs)))
        (or para
            ; Evaluate left to right until a parallel assignment is found.
            (cons (car targets)
                  (ordering (cdr targets)
                            (cdr exprs)
                            alist)))))
    (if (parallel-assignment-optimization)
        (cond ((null? exprs) '())
              ((null? (cdr exprs)) '(0))
              (else
               (let* ((contains-call? #f)
                      (vexprs (list->vector exprs))
                      (vindexes (list->vector
                                 (iota (vector-length vexprs))))
                      (contains-call? #f)
                      (categories
                       (list->vector
                        (map (lambda (E)
                               (cond ((constant? E)
                                      2)
                                     ((variable? E)
                                      2)
                                     ((complicated? E)
                                      (set! contains-call? #t)
                                      1)
                                     (else
                                      0)))
                             exprs))))
                 (cond (contains-call?
                        (twobit-sort (lambda (i j)
                                       (< (vector-ref categories i)
                                          (vector-ref categories j)))
                                     (iota (length exprs))))
                       (for-primop?
                        (reverse (iota (length exprs))))
                       (else
                        (let ((targets (iota (length exprs))))
                          (define (pairup regvars targets)
                            (if (or (null? targets)
                                    (null? regvars))
                                '()
                                (cons (cons (car regvars)
                                            (car targets))
                                      (pairup (cdr regvars)
                                              (cdr targets)))))
                          (ordering targets
                                    exprs
                                    (pairup regvars targets))))))))
        (iota (length exprs))))
  
  (define (permute things pi)
    (let ((v (list->vector things)))
      (map (lambda (i) (vector-ref v i))
           pi)))
  
  (define (unpermute things pi)
    (let* ((v0 (list->vector things))
           (v1 (make-vector (vector-length v0))))
      (do ((pi pi (cdr pi))
           (k 0 (+ k 1)))
          ((null? pi)
           (vector->list v1))
          (vector-set! v1 (car pi) (vector-ref v0 k)))))
  
  ; Given a call whose procedure is a lambda expression that has
  ; a rest argument, return a genuine let expression.
  
  (define (normalize-let-error exp)
    (if (issue-warnings)
        (begin (display "WARNING from compiler: ")
               (display "Wrong number of arguments ")
               (display "to lambda expression")
               (newline)
               (pretty-print (make-readable exp) #t)
               (newline))))
  
  (define (normalize-let exp)
    (let* ((L (call.proc exp)))
      (let loop ((formals (lambda.args L))
                 (args (call.args exp))
                 (newformals '())
                 (newargs '()))
        (cond ((null? formals)
               (if (null? args)
                   (begin (lambda.args-set! L (reverse newformals))
                          (call.args-set! exp (reverse newargs)))
                   (begin (normalize-let-error exp)
                          (loop (list (newtemp))
                                args
                                newformals
                                newargs))))
              ((pair? formals)
               (if (pair? args)
                   (loop (cdr formals)
                         (cdr args)
                         (cons (car formals) newformals)
                         (cons (car args) newargs))
                   (begin (normalize-let-error exp)
                          (loop formals
                                (cons (make-constant 0)
                                      args)
                                newformals
                                newargs))))
              (else
               (loop (list formals)
                     (list (make-call-to-list args))
                     newformals
                     newargs))))))
  
  ; For heuristic use only.
  ; An expression is complicated unless it can probably be evaluated
  ; without saving and restoring any registers, even if it occurs in
  ; a non-tail position.
  
  (define (complicated? exp)
    ; Let's not spend all day on this.
    (let ((budget 10))
      (define (complicated? exp)
        (set! budget (- budget 1))
        (if (zero? budget)
            #t
            (case (car exp)
              ((quote)    #f)
              ((lambda)   #f)
              ((set!)     (complicated? (assignment.rhs exp)))
              ((if)       (or (complicated? (if.test exp))
                              (complicated? (if.then exp))
                              (complicated? (if.else exp))))
              ((begin)    (if (variable? exp)
                              #f
                              (some? complicated?
                                     (begin.exprs exp))))
              (else       (let ((proc (call.proc exp)))
                            (if (and (variable? proc)
                                     (integrate-usual-procedures)
                                     (prim-entry (variable.name proc)))
                                (some? complicated?
                                       (call.args exp))
                                #t))))))
      (complicated? exp)))
  
  (A-normal-form E))
(define (post-simplify-anf L0 T1 E0 E1 free regbindings L2)
  
  (define (return-normally)
    (values (make-call L0 (list E1))
            free
            regbindings))
  
  (return-normally))
; Copyright 1999 William D Clinger.
;
; Permission to copy this software, in whole or in part, to use this
; software for any lawful noncommercial purpose, and to redistribute
; this software is granted subject to the restriction that all copies
; made of this software must include this copyright notice in full.
;
; I also request that you send me a copy of any improvements that you
; make to this software so that they may be incorporated within it to
; the benefit of the Scheme community.
;
; 7 June 1999.
;
; Intraprocedural common subexpression elimination, constant propagation,
; copy propagation, dead code elimination, and register targeting.
;
; (intraprocedural-commoning E 'commoning)
;
;     Given an A-normal form E (alpha-converted, with correct free
;     variables and referencing information), returns an optimized
;     A-normal form with correct free variables but incorrect referencing
;     information.
;
; (intraprocedural-commoning E 'target-registers)
;
;     Given an A-normal form E (alpha-converted, with correct free
;     variables and referencing information), returns an A-normal form
;     with correct free variables but incorrect referencing information,
;     and in which MacScheme machine register names are used as temporary
;     variables.  The result is alpha-converted except for register names.
;
; (intraprocedural-commoning E 'commoning 'target-registers)
; (intraprocedural-commoning E)
;
;     Given an A-normal form as described above, returns an optimized
;     form in which register names are used as temporary variables.

; Semantics of .check!:
;
; (.check! b exn x ...) faults with code exn and arguments x ...
; if b is #f.

; The list of argument registers.
; This can't go in pass3commoning.aux.sch because that file must be
; loaded before the target-specific file that defines *nregs*.

(define argument-registers
  (do ((n (- *nregs* 2) (- n 1))
       (regs '()
             (cons (string->symbol
                    (string-append ".REG" (number->string n)))
                   regs)))
      ((zero? n)
       regs)))

(define (intraprocedural-commoning E . flags)
  
  (define target-registers? (or (null? flags) (memq 'target-registers flags)))
  (define commoning? (or (null? flags) (memq 'commoning flags)))
  
  (define debugging? #f)
  
  (call-with-current-continuation
   (lambda (return)
     
     (define (error . stuff)
       (display "Bug detected during intraprocedural optimization")
       (newline)
       (for-each (lambda (s)
                   (display s) (newline))
                 stuff)
       (return (make-constant #f)))
     
     ; Given an expression, an environment, the available expressions,
     ; and an ordered list of likely register variables (used heuristically),
     ; returns the transformed expression and its set of free variables.
     
     (define (scan-body E env available regvars)
       
       ; The local variables are those that are bound by a LET within
       ; this procedure.  The formals of a lambda expression and the
       ; known local procedures are counted as non-global, not local,
       ; because there is no let-binding for a formal that can be
       ; renamed during register targeting.
       ; For each local variable, we keep track of how many times it
       ; is referenced.  This information is not accurate until we
       ; are backing out of the recursion, and does not have to be.
       
       (define local-variables (make-hashtable symbol-hash assq))
       
       (define (local-variable? sym)
         (hashtable-get local-variables sym))
       
       (define (local-variable-not-used? sym)
         (= 0 (hashtable-fetch local-variables sym -1)))
       
       (define (local-variable-used-once? sym)
         (= 1 (hashtable-fetch local-variables sym 0)))
       
       (define (record-local-variable! sym)
         (hashtable-put! local-variables sym 0))
       
       (define (used-local-variable! sym)
         (adjust-local-variable! sym 1))
       
       (define (adjust-local-variable! sym n)
         (let ((m (hashtable-get local-variables sym)))
           (if debugging?
               (if (and m (> m 0))
                   (begin (write (list sym (+ m n)))
                          (newline))))
           (if m
               (hashtable-put! local-variables
                               sym
                               (+ m n)))))
       
       (define (closed-over-local-variable! sym)
         ; Set its reference count to infinity so it won't be optimized away.
         ; FIXME:  One million isn't infinity.
         (hashtable-put! local-variables sym 1000000))
       
       (define (used-variable! sym)
         (used-local-variable! sym))
       
       (define (abandon-expression! E)
         (cond ((variable? E)
                (adjust-local-variable! (variable.name E) -1))
               ((conditional? E)
                (abandon-expression! (if.test E))
                (abandon-expression! (if.then E))
                (abandon-expression! (if.else E)))
               ((call? E)
                (for-each (lambda (exp)
                            (if (variable? exp)
                                (let ((name (variable.name exp)))
                                  (if (local-variable? name)
                                      (adjust-local-variable! name -1)))))
                          (cons (call.proc E)
                                (call.args E))))))
       
       ; Environments are represented as hashtrees.
       
       (define (make-empty-environment)
         (make-hashtree symbol-hash assq))
       
       (define (environment-extend env sym)
         (hashtree-put env sym #t))
       
       (define (environment-extend* env symbols)
         (if (null? symbols)
             env
             (environment-extend* (hashtree-put env (car symbols) #t)
                                  (cdr symbols))))
       
       (define (environment-lookup env sym)
         (hashtree-get env sym))
       
       (define (global? x)
         (cond ((local-variable? x)
                #f)
               ((environment-lookup env x)
                #f)
               (else
                #t)))
       
       ;
       
       (define (available-add! available T E)
         (cond ((constant? E)
                (available-extend! available T E available:killer:immortal))
               ((variable? E)
                (available-extend! available
                                   T
                                   E
                                   (if (global? (variable.name E))
                                       available:killer:globals
                                       available:killer:immortal)))
               (else
                (let ((entry (prim-call E)))
                  (if entry
                      (let ((killer (prim-lives-until entry)))
                        (if (not (eq? killer available:killer:dead))
                            (do ((args (call.args E) (cdr args))
                                 (k killer
                                    (let ((arg (car args)))
                                      (if (and (variable? arg)
                                               (global? (variable.name arg)))
                                          available:killer:globals
                                          k))))
                                ((null? args)
                                 (available-extend!
                                  available
                                  T
                                  E
                                  (logior killer k)))))))))))
       
       ; Given an expression E,
       ; an environment containing all variables that are in scope,
       ; and a table of available expressions,
       ; returns multiple values:
       ;   the transformed E
       ;   the free variables of E
       ;   the register bindings to be inserted; each binding has the form
       ;     (R x (begin R)), where (begin R) is a reference to R.
       ; 
       ; Side effects E.
       
       (define (scan E env available)
         (if (not (call? E))
             (scan-rhs E env available)
             (let ((proc (call.proc E)))
               (if (not (lambda? proc))
                   (scan-rhs E env available)
                   (let ((vars (lambda.args proc)))
                     (cond ((null? vars)
                            (scan-let0 E env available))
                           ((null? (cdr vars))
                            (scan-binding E env available))
                           (else
                            (error (make-readable E)))))))))
       
       ; E has the form of (let ((T1 E1)) E0).
       
       (define (scan-binding E env available)
         (let* ((L (call.proc E))
                (T1 (car (lambda.args L)))
                (E1 (car (call.args E)))
                (E0 (lambda.body L)))
           (record-local-variable! T1)
           (call-with-values
            (lambda () (scan-rhs E1 env available))
            (lambda (E1 F1 regbindings1)
              (available-add! available T1 E1)
              (let* ((env (let ((formals
                                 (make-null-terminated (lambda.args L))))
                            (environment-extend*
                             (environment-extend* env formals)
                             (map def.lhs (lambda.defs L)))))
                     (Fdefs (scan-defs L env available)))
                (call-with-values
                 (lambda () (scan E0 env available))
                 (lambda (E0 F0 regbindings0)
                   (lambda.body-set! L E0)
                   (if target-registers?
                       (scan-binding-phase2
                        L T1 E0 E1 F0 F1 Fdefs regbindings0 regbindings1)
                       (scan-binding-phase3
                        L E0 E1 (union F0 Fdefs)
                                F1 regbindings0 regbindings1)))))))))
       
       ; Given the lambda expression for a let expression that binds
       ; a single variable T1, the transformed body E0 and right hand side E1,
       ; their sets of free variables F0 and F1, the set of free variables
       ; for the internal definitions of L, and the sets of register
       ; bindings that need to be wrapped around E0 and E1, returns the
       ; transformed let expression, its free variables, and register
       ; bindings.
       ;
       ; This phase is concerned exclusively with register bindings,
       ; and is bypassed unless the target-registers flag is specified.
       
       (define (scan-binding-phase2
                L T1 E0 E1 F0 F1 Fdefs regbindings0 regbindings1)
         
         ; T1 can't be a register because we haven't
         ; yet inserted register bindings that high up.
         
         ; Classify the register bindings that need to wrapped around E0:
         ;     1.  those that have T1 as their rhs
         ;     2.  those whose lhs is a register that is likely to hold
         ;         a variable that occurs free in E1
         ;     3.  all others
         
         (define (phase2a)
           (do ((rvars regvars (cdr rvars))
                (regs argument-registers (cdr regs))
                (regs1 '() (if (memq (car rvars) F1)
                               (cons (car regs) regs1)
                               regs1)))
               ((or (null? rvars)
                    (null? regs))
                ; regs1 is the set of registers that are live for E1
                
                (let loop ((regbindings regbindings0)
                           (rb1 '())
                           (rb2 '())
                           (rb3 '()))
                  (if (null? regbindings)
                      (phase2b rb1 rb2 rb3)
                      (let* ((binding (car regbindings))
                             (regbindings (cdr regbindings))
                             (lhs (regbinding.lhs binding))
                             (rhs (regbinding.rhs binding)))
                        (cond ((eq? rhs T1)
                               (loop regbindings
                                     (cons binding rb1)
                                     rb2
                                     rb3))
                              ((memq lhs regs1)
                               (loop regbindings
                                     rb1
                                     (cons binding rb2)
                                     rb3))
                              (else
                               (loop regbindings
                                     rb1
                                     rb2
                                     (cons binding rb3))))))))))
         
         ; Determine which categories of register bindings should be
         ; wrapped around E0.
         ; Always wrap the register bindings in category 2.
         ; If E1 is a conditional or a real call, then wrap category 3.
         ; If T1 might be used more than once, then wrap category 1.
         
         (define (phase2b rb1 rb2 rb3)
           (if (or (conditional? E1)
                   (real-call? E1))
               (phase2c (append rb2 rb3) rb1 '())
               (phase2c rb2 rb1 rb3)))
         
         (define (phase2c towrap rb1 regbindings0)
           (cond ((and (not (null? rb1))
                       (local-variable-used-once? T1))
                  (phase2d towrap rb1 regbindings0))
                 (else
                  (phase2e (append rb1 towrap) regbindings0))))
         
         ; T1 is used only once, and there is a register binding (R T1).
         ; Change T1 to R.
         
         (define (phase2d towrap regbindings-T1 regbindings0)
           (if (not (null? (cdr regbindings-T1)))
               (error "incorrect number of uses" T1))
           (let* ((regbinding (car regbindings-T1))
                  (R (regbinding.lhs regbinding)))
             (lambda.args-set! L (list R))
             (phase2e towrap regbindings0)))
         
         ; Wrap the selected register bindings around E0.
         
         (define (phase2e towrap regbindings0)
           (call-with-values
            (lambda ()
              (wrap-with-register-bindings towrap E0 F0))
            (lambda (E0 F0)
              (let ((F (union Fdefs F0)))
                (scan-binding-phase3
                 L E0 E1 F F1 regbindings0 regbindings1)))))
         
         (phase2a))
       
       ; This phase, with arguments as above, constructs the result.
       
       (define (scan-binding-phase3 L E0 E1 F F1 regbindings0 regbindings1)
         (let* ((args (lambda.args L))
                (T1 (car args))
                (free (union F1 (difference F args)))
                (simple-let? (simple-lambda? L))
                (regbindings 
                 
                 ; At least one of regbindings0 and regbindings1
                 ; is the empty list.
                 
                 (cond ((null? regbindings0)
                        regbindings1)
                       ((null? regbindings1)
                        regbindings0)
                       (else
                        (error 'scan-binding 'regbindings)))))
           (lambda.body-set! L E0)
           (lambda.F-set! L F)
           (lambda.G-set! L F)
           (cond ((and simple-let?
                       (not (memq T1 F))
                       (no-side-effects? E1))
                  (abandon-expression! E1)
                  (values E0 F regbindings0))
                 ((and target-registers?
                       simple-let?
                       (local-variable-used-once? T1))
                  (post-simplify-anf L T1 E0 E1 free regbindings #f))
                 (else
                  (values (make-call L (list E1))
                          free
                          regbindings)))))
       
       (define (scan-let0 E env available)
         (let ((L (call.proc E)))
           (if (simple-lambda? L)
               (scan (lambda.body L) env available)
               (let ((T1 (make-variable name:IGNORED)))
                 (lambda.args-set! L (list T1))
                 (call-with-values
                  (lambda () (scan (make-call L (list (make-constant 0)))
                                   env
                                   available))
                  (lambda (E F regbindings)
                    (lambda.args-set! L '())
                    (values (make-call L '())
                            F
                            regbindings)))))))
       
       ; Optimizes the internal definitions of L and returns their
       ; free variables.
       
       (define (scan-defs L env available)
         (let loop ((defs (lambda.defs L))
                    (newdefs '())
                    (Fdefs '()))
           (if (null? defs)
               (begin (lambda.defs-set! L (reverse newdefs))
                      Fdefs)
               (let ((def (car defs)))
                 (call-with-values
                  (lambda ()
                    (let* ((Ldef (def.rhs def))
                           (Lformals (make-null-terminated (lambda.args Ldef)))
                           (Lenv (environment-extend*
                                  (environment-extend* env Lformals)
                                  (map def.lhs (lambda.defs Ldef)))))
                      (scan Ldef Lenv available)))
                  (lambda (rhs Frhs empty)
                    (if (not (null? empty))
                        (error 'scan-binding 'def))
                    (loop (cdr defs)
                          (cons (make-definition (def.lhs def) rhs)
                                newdefs)
                          (union Frhs Fdefs))))))))
       
       ; Given the right-hand side of a let-binding, an environment,
       ; and a table of available expressions, returns the transformed
       ; expression, its free variables, and the register bindings that
       ; need to be wrapped around it.
       
       (define (scan-rhs E env available)
         
         (cond
          ((constant? E)
           (values E (empty-set) '()))
          
          ((variable? E)
           (let* ((name (variable.name E))
                  (Enew (and commoning?
                             (if (global? name)
                                 (let ((T (available-expression
                                           available E)))
                                   (if T
                                       (make-variable T)
                                       #f))
                                 (available-variable available name)))))
             (if Enew
                 (scan-rhs Enew env available)
                 (begin (used-variable! name)
                        (values E (list name) '())))))
          
          ((lambda? E)
           (let* ((formals (make-null-terminated (lambda.args E)))
                  (env (environment-extend*
                        (environment-extend* env formals)
                        (map def.lhs (lambda.defs E))))
                  (Fdefs (scan-defs E env available)))
             (call-with-values
              (lambda ()
                (let ((available (copy-available-table available)))
                  (available-kill! available available:killer:all)
                  (scan-body (lambda.body E)
                             env
                             available
                             formals)))
              (lambda (E0 F0 regbindings0)
                (call-with-values
                 (lambda ()
                   (wrap-with-register-bindings regbindings0 E0 F0))
                 (lambda (E0 F0)
                   (lambda.body-set! E E0)
                   (let ((F (union Fdefs F0)))
                     (for-each (lambda (x)
                                 (closed-over-local-variable! x))
                               F)
                     (lambda.F-set! E F)
                     (lambda.G-set! E F)
                     (values E
                             (difference F
                                         (make-null-terminated
                                          (lambda.args E)))
                             '()))))))))
          
          ((conditional? E)
           (let ((E0 (if.test E))
                 (E1 (if.then E))
                 (E2 (if.else E)))
             (if (constant? E0)
                 ; FIXME: E1 and E2 might not be a legal rhs,
                 ; so we can't just return the simplified E1 or E2.
                 (let ((E1 (if (constant.value E0) E1 E2)))
                   (call-with-values
                    (lambda () (scan E1 env available))
                    (lambda (E1 F1 regbindings1)
                      (cond ((or (not (call? E1))
                                 (not (lambda? (call.proc E1))))
                             (values E1 F1 regbindings1))
                            (else
                             ; FIXME: Must return a valid rhs.
                             (values (make-conditional
                                      (make-constant #t)
                                      E1
                                      (make-constant 0))
                                     F1
                                     regbindings1))))))
                 (call-with-values
                  (lambda () (scan E0 env available))
                  (lambda (E0 F0 regbindings0)
                    (if (not (null? regbindings0))
                        (error 'scan-rhs 'if))
                    (if (not (eq? E0 (if.test E)))
                        (scan-rhs (make-conditional E0 E1 E2)
                                  env available)
                        (let ((available1
                               (copy-available-table available))
                              (available2
                               (copy-available-table available)))
                          (if (variable? E0)
                              (let ((T0 (variable.name E0)))
                                (available-add!
                                 available2 T0 (make-constant #f)))
                              (error (make-readable E #t)))
                          (call-with-values
                           (lambda () (scan E1 env available1))
                           (lambda (E1 F1 regbindings1)
                             (call-with-values
                              (lambda ()
                                (wrap-with-register-bindings
                                 regbindings1 E1 F1))
                              (lambda (E1 F1)
                                (call-with-values
                                 (lambda () (scan E2 env available2))
                                 (lambda (E2 F2 regbindings2)
                                   (call-with-values
                                    (lambda ()
                                      (wrap-with-register-bindings
                                       regbindings2 E2 F2))
                                    (lambda (E2 F2)
                                      (let ((E (make-conditional
                                                E0 E1 E2))
                                            (F (union F0 F1 F2)))
                                        (available-intersect!
                                         available
                                         available1
                                         available2)
                                        (values E F '())))))))))))))))))
          
          
          ((assignment? E)
           (call-with-values
            (lambda () (scan-rhs (assignment.rhs E) env available))
            (lambda (E1 F1 regbindings1)
              (if (not (null? regbindings1))
                  (error 'scan-rhs 'set!))
              (available-kill! available available:killer:globals)
              (values (make-assignment (assignment.lhs E) E1)
                      (union (list (assignment.lhs E)) F1)
                      '()))))
          
          ((begin? E)
           ; Shouldn't occur in A-normal form.
           (error 'scan-rhs 'begin))
          
          ((real-call? E)
           (let* ((E0 (call.proc E))
                  (args (call.args E))
                  (regcontents (append regvars
                                       (map (lambda (x) #f) args))))
             (let loop ((args args)
                        (regs argument-registers)
                        (regcontents regcontents)
                        (newargs '())
                        (regbindings '())
                        (F (if (variable? E0)
                               (let ((f (variable.name E0)))
                                 (used-variable! f)
                                 (list f))
                               (empty-set))))
               (cond ((null? args)
                      (available-kill! available available:killer:all)
                      (values (make-call E0 (reverse newargs))
                              F
                              regbindings))
                     ((null? regs)
                      (let ((arg (car args)))
                        (loop (cdr args)
                              '()
                              (cdr regcontents)
                              (cons arg newargs)
                              regbindings
                              (if (variable? arg)
                                  (let ((name (variable.name arg)))
                                    (used-variable! name)
                                    (union (list name) F))
                                  F))))
                     ((and commoning?
                           (variable? (car args))
                           (available-variable
                            available
                            (variable.name (car args))))
                      (let* ((name (variable.name (car args)))
                             (Enew (available-variable available name)))
                        (loop (cons Enew (cdr args))
                              regs regcontents newargs regbindings F)))
                     ((and target-registers?
                           (variable? (car args))
                           (let ((x (variable.name (car args))))
                             ; We haven't yet recorded this use.
                             (or (local-variable-not-used? x)
                                 (and (memq x regvars)
                                      (not (eq? x (car regcontents)))))))
                      (let* ((x (variable.name (car args)))
                             (R (car regs))
                             (newarg (make-variable R)))
                        (used-variable! x)
                        (loop (cdr args)
                              (cdr regs)
                              (cdr regcontents)
                              (cons newarg newargs)
                              (cons (make-regbinding R x newarg)
                                    regbindings)
                              (union (list R) F))))
                     (else
                      (let ((E1 (car args)))
                        (loop (cdr args)
                              (cdr regs)
                              (cdr regcontents)
                              (cons E1 newargs)
                              regbindings
                              (if (variable? E1)
                                  (let ((name (variable.name E1)))
                                    (used-variable! name)
                                    (union (list name) F))
                                  F))))))))
          
          ((call? E)
           ; Must be a call to a primop.
           (let* ((E0 (call.proc E))
                  (f0 (variable.name E0)))
             (let loop ((args (call.args E))
                        (newargs '())
                        (F (list f0)))
               (cond ((null? args)
                      (let* ((E (make-call E0 (reverse newargs)))
                             (T (and commoning?
                                     (available-expression
                                      available E))))
                        (if T
                            (begin (abandon-expression! E)
                                   (scan-rhs (make-variable T) env available))
                            (begin
                             (available-kill!
                              available
                              (prim-kills (prim-entry f0)))
                             (cond ((eq? f0 name:check!)
                                    (let ((x (car (call.args E))))
                                      (cond ((not (runtime-safety-checking))
                                             (abandon-expression! E)
                                             ;(values x '() '())
                                             (scan-rhs x env available))
                                            ((variable? x)
                                             (available-add!
                                              available
                                              (variable.name x)
                                              (make-constant #t))
                                             (values E F '()))
                                            ((constant.value x)
                                             (abandon-expression! E)
                                             (values x '() '()))
                                            (else
                                             (declaration-error E)
                                             (values E F '())))))
                                   (else
                                    (values E F '())))))))
                     ((variable? (car args))
                      (let* ((E1 (car args))
                             (x (variable.name E1))
                             (Enew
                              (and commoning?
                                   (available-variable available x))))
                        (if Enew
                            ; All of the arguments are constants or
                            ; variables, so if the variable is replaced
                            ; here it will be replaced throughout the call.
                            (loop (cons Enew (cdr args))
                                  newargs
                                  (remq x F))
                            (begin
                             (used-variable! x)
                             (loop (cdr args)
                                   (cons (car args) newargs)
                                   (union (list x) F))))))
                     (else
                      (loop (cdr args)
                            (cons (car args) newargs)
                            F))))))
          
          (else
           (error 'scan-rhs (make-readable E)))))
       
       (call-with-values
        (lambda () (scan E env available))
        (lambda (E F regbindings)
          (call-with-values
           (lambda () (wrap-with-register-bindings regbindings E F))
           (lambda (E F)
             (values E F '()))))))
     
     (call-with-values
      (lambda ()
        (scan-body E
                   (make-hashtree symbol-hash assq)
                   (make-available-table)
                   '()))
      (lambda (E F regbindings)
        (if (not (null? regbindings))
            (error 'scan-body))
        E)))))
; Copyright 1999 William D Clinger.
;
; Permission to copy this software, in whole or in part, to use this
; software for any lawful noncommercial purpose, and to redistribute
; this software is granted subject to the restriction that all copies
; made of this software must include this copyright notice in full.
;
; I also request that you send me a copy of any improvements that you
; make to this software so that they may be incorporated within it to
; the benefit of the Scheme community.
;
; 16 June 1999.
;
; Intraprocedural representation inference.

(define (representation-analysis exp)
  (let* ((debugging? #f)
         (integrate-usual? (integrate-usual-procedures))
         (known (make-hashtable symbol-hash assq))
         (types (make-hashtable symbol-hash assq))
         (g (callgraph exp))
         (schedule (list (callgraphnode.code (car g))))
         (changed? #f)
         (mutate? #f))
    
    ; known is a hashtable that maps the name of a known local procedure
    ; to a list of the form (tv1 ... tvN), where tv1, ..., tvN
    ; are type variables that stand for the representation types of its
    ; arguments.  The type variable that stands for the representation
    ; type of the result of the procedure has the same name as the
    ; procedure itself.
    
    ; types is a hashtable that maps local variables and the names
    ; of known local procedures to an approximation of their
    ; representation type.
    ; For a known local procedure, the representation type is for the
    ; result of the procedure, not the procedure itself.
    
    ; schedule is a stack of work that needs to be done.
    ; Each entry in the stack is either an escaping lambda expression
    ; or the name of a known local procedure.
    
    (define (schedule! job)
      (if (not (memq job schedule))
          (begin (set! schedule (cons job schedule))
                 (if (not (symbol? job))
                     (callgraphnode.info! (lookup-node job) #t)))))
    
    ; Schedules a known local procedure.
    
    (define (schedule-known-procedure! name)
      ; Mark every known procedure that can actually be called.
      (callgraphnode.info! (assq name g) #t)
      (schedule! name))
    
    ; Schedule all code that calls the given known local procedure.
    
    (define (schedule-callers! name)
      (for-each (lambda (node)
                  (if (and (callgraphnode.info node)
                           (or (memq name (callgraphnode.tailcalls node))
                               (memq name (callgraphnode.nontailcalls node))))
                      (let ((caller (callgraphnode.name node)))
                        (if caller
                            (schedule! caller)
                            (schedule! (callgraphnode.code node))))))
                g))
    
    ; Schedules local procedures of a lambda expression.
    
    (define (schedule-local-procedures! L)
      (for-each (lambda (def)
                  (let ((name (def.lhs def)))
                    (if (known-procedure-is-callable? name)
                        (schedule! name))))
                (lambda.defs L)))
    
    ; Returns true iff the given known procedure is known to be callable.
    
    (define (known-procedure-is-callable? name)
      (callgraphnode.info (assq name g)))
    
    ; Sets CHANGED? to #t and returns #t if the type variable's
    ; approximation has changed; otherwise returns #f.
    
    (define (update-typevar! tv type)
      (let* ((type0 (hashtable-get types tv))
             (type0 (or type0
                        (begin (hashtable-put! types tv rep:bottom)
                               rep:bottom)))
             (type1 (representation-union type0 type)))
        (if (eq? type0 type1)
            #f
            (begin (hashtable-put! types tv type1)
                   (set! changed? #t)
                   (if (and debugging? mutate?)
                       (begin (display "******** Changing type of ")
                              (display tv)
                              (display " from ")
                              (display (rep->symbol type0))
                              (display " to ")
                              (display (rep->symbol type1))
                              (newline)))
                   #t))))
    
    ; GIven the name of a known local procedure, returns its code.
    
    (define (lookup-code name)
      (callgraphnode.code (assq name g)))
    
    ; Given a lambda expression, either escaping or the code for
    ; a known local procedure, returns its node in the call graph.
    
    (define (lookup-node L)
      (let loop ((g g))
        (cond ((null? g)
               (error "Unknown lambda expression" (make-readable L #t)))
              ((eq? L (callgraphnode.code (car g)))
               (car g))
              (else
               (loop (cdr g))))))
    
    ; Given: a type variable, expression, and a set of constraints.
    ; Side effects:
    ;     Update the representation types of all variables that are
    ;         bound within the expression.
    ;     Update the representation types of all arguments to known
    ;         local procedures that are called within the expression.
    ;     If the representation type of an argument to a known local
    ;         procedure changes, then schedule that procedure's code
    ;         for analysis.
    ;     Update the constraint set to reflect the constraints that
    ;         hold following execution of the expression.
    ;     If mutate? is true, then transform the expression to rely
    ;         on the representation types that have been inferred.
    ; Return: type of the expression under the current assumptions
    ;     and constraints.
    
    (define (analyze exp constraints)
      
      (if (and #f debugging?)
          (begin (display "Analyzing: ")
                 (newline)
                 (pretty-print (make-readable exp #t))
                 (newline)))
      
      (case (car exp)
        
        ((quote)
         (representation-of-value (constant.value exp)))
        
        ((begin)
         (let* ((name (variable.name exp)))
           (representation-typeof name types constraints)))
        
        ((lambda)
         (schedule! exp)
         rep:procedure)
        
        ((set!)
         (analyze (assignment.rhs exp) constraints)
         (constraints-kill! constraints available:killer:globals)
         rep:object)
        
        ((if)
         (let* ((E0 (if.test exp))
                (E1 (if.then exp))
                (E2 (if.else exp))
                (type0 (analyze E0 constraints)))
           (if mutate?
               (cond ((representation-subtype? type0 rep:true)
                      (if.test-set! exp (make-constant #t)))
                     ((representation-subtype? type0 rep:false)
                      (if.test-set! exp (make-constant #f)))))
           (cond ((representation-subtype? type0 rep:true)
                  (analyze E1 constraints))
                 ((representation-subtype? type0 rep:false)
                  (analyze E2 constraints))
                 ((variable? E0)
                  (let* ((T0 (variable.name E0))
                         (ignored (analyze E0 constraints))
                         (constraints1 (copy-constraints-table constraints))
                         (constraints2 (copy-constraints-table constraints)))
                    (constraints-add! types
                                      constraints1
                                      (make-type-constraint
                                       T0 rep:true available:killer:immortal))
                    (constraints-add! types
                                      constraints2
                                      (make-type-constraint
                                       T0 rep:false available:killer:immortal))
                    (let* ((type1 (analyze E1 constraints1))
                           (type2 (analyze E2 constraints2))
                           (type (representation-union type1 type2)))
                      (constraints-intersect! constraints
                                              constraints1
                                              constraints2)
                      type)))
                 (else
                  (representation-error "Bad ANF" (make-readable exp #t))))))
        
        (else
         (let ((proc (call.proc exp))
               (args (call.args exp)))
           (cond ((lambda? proc)
                  (cond ((null? args)
                         (analyze-let0 exp constraints))
                        ((null? (cdr args))
                         (analyze-let1 exp constraints))
                        (else
                         (error "Compiler bug: pass3rep"))))
                 ((variable? proc)
                  (let* ((procname (variable.name proc)))
                    (cond ((hashtable-get known procname)
                           =>
                           (lambda (vars)
                             (analyze-known-call exp constraints vars)))
                          (integrate-usual?
                           (let ((entry (prim-entry procname)))
                             (if entry
                                 (analyze-primop-call exp constraints entry)
                                 (analyze-unknown-call exp constraints))))
                          (else
                           (analyze-unknown-call exp constraints)))))
                 (else
                  (analyze-unknown-call exp constraints)))))))
    
    (define (analyze-let0 exp constraints)
      (let ((proc (call.proc exp)))
        (schedule-local-procedures! proc)
        (if (null? (lambda.args proc))
            (analyze (lambda.body exp) constraints)
            (analyze-unknown-call exp constraints))))
    
    (define (analyze-let1 exp constraints)
      (let* ((proc (call.proc exp))
             (vars (lambda.args proc)))
        (schedule-local-procedures! proc)
        (if (and (pair? vars)
                 (null? (cdr vars)))
            (let* ((T1 (car vars))
                   (E1 (car (call.args exp))))
              (if (and integrate-usual? (call? E1))
                  (let ((proc (call.proc E1))
                        (args (call.args E1)))
                    (if (variable? proc)
                        (let* ((op (variable.name proc))
                               (entry (prim-entry op))
                               (K1 (if entry
                                       (prim-lives-until entry)
                                       available:killer:dead)))
                          (if (not (= K1 available:killer:dead))
                              ; Must copy the call to avoid problems
                              ; with side effects when mutate? is true.
                              (constraints-add!
                               types
                               constraints
                               (make-constraint T1
                                                (make-call proc args)
                                                K1)))))))
              (update-typevar! T1 (analyze E1 constraints))
              (analyze (lambda.body proc) constraints))
            (analyze-unknown-call exp constraints))))
    
    (define (analyze-primop-call exp constraints entry)
      (let* ((op (prim-opcodename entry))
             (args (call.args exp))
             (argtypes (map (lambda (arg) (analyze arg constraints))
                            args))
             (type (rep-result? op argtypes)))
        (constraints-kill! constraints (prim-kills entry))
        (cond ((and (eq? op 'check!)
                    (variable? (car args)))
               (let ((varname (variable.name (car args))))
                 (if (and mutate?
                          (representation-subtype? (car argtypes) rep:true))
                     (call.args-set! exp
                                     (cons (make-constant #t) (cdr args))))
                 (constraints-add! types
                                   constraints
                                   (make-type-constraint
                                    varname
                                    rep:true
                                    available:killer:immortal))))
              ((and mutate? (rep-specific? op argtypes))
               =>
               (lambda (newop)
                 (call.proc-set! exp (make-variable newop)))))
        (or type rep:object)))
    
    (define (analyze-known-call exp constraints vars)
      (let* ((procname (variable.name (call.proc exp)))
             (args (call.args exp))
             (argtypes (map (lambda (arg) (analyze arg constraints))
                            args)))
        (if (not (known-procedure-is-callable? procname))
            (schedule-known-procedure! procname))
        (for-each (lambda (var type)
                    (if (update-typevar! var type)
                        (schedule-known-procedure! procname)))
                  vars
                  argtypes)
        ; FIXME: We aren't analyzing the effects of known local procedures.
        (constraints-kill! constraints available:killer:all)
        (hashtable-get types procname)))
    
    (define (analyze-unknown-call exp constraints)
      (analyze (call.proc exp) constraints)
      (for-each (lambda (arg) (analyze arg constraints))
                (call.args exp))
      (constraints-kill! constraints available:killer:all)
      rep:object)
    
    (define (analyze-known-local-procedure name)
      (if debugging?
          (begin (display "Analyzing ")
                 (display name)
                 (newline)))
      (let ((L (lookup-code name))
            (constraints (make-constraints-table)))
        (schedule-local-procedures! L)
        (let ((type (analyze (lambda.body L) constraints)))
          (if (update-typevar! name type)
              (schedule-callers! name))
          type)))
    
    (define (analyze-unknown-lambda L)
      (if debugging?
          (begin (display "Analyzing escaping lambda expression")
                 (newline)))
      (schedule-local-procedures! L)
      (let ((vars (make-null-terminated (lambda.args L))))
        (for-each (lambda (var)
                    (hashtable-put! types var rep:object))
                  vars)
        (analyze (lambda.body L)
                 (make-constraints-table))))
    
    ; For debugging.
    
    (define (display-types)
      (hashtable-for-each (lambda (f vars)
                            (write f)
                            (display " : returns ")
                            (write (rep->symbol (hashtable-get types f)))
                            (newline)
                            (for-each (lambda (x)
                                        (display "  ")
                                        (write x)
                                        (display ": ")
                                        (write (rep->symbol
                                                (hashtable-get types x)))
                                        (newline))
                                      vars))
                          known))
    
    (define (display-all-types)
      (let* ((vars (hashtable-map (lambda (x type) x) types))
             (vars (twobit-sort (lambda (var1 var2)
                                  (string<=? (symbol->string var1)
                                             (symbol->string var2)))
                                vars)))
        (for-each (lambda (x)
                    (write x)
                    (display ": ")
                    (write (rep->symbol
                            (hashtable-get types x)))
                    (newline))
                  vars)))
    '
    (if debugging?
        (begin (pretty-print (make-readable (car schedule) #t))
               (newline)))
    (if debugging?
        (view-callgraph g))
    
    (for-each (lambda (node)
                (let* ((name (callgraphnode.name node))
                       (code (callgraphnode.code node))
                       (vars (make-null-terminated (lambda.args code)))
                       (known? (symbol? name))
                       (rep (if known? rep:bottom rep:object)))
                  (callgraphnode.info! node #f)
                  (if known?
                      (begin (hashtable-put! known name vars)
                             (hashtable-put! types name rep)))
                  (for-each (lambda (var)
                              (hashtable-put! types var rep))
                            vars)))
              g)
    
    (let loop ()
      (cond ((not (null? schedule))
             (let ((job (car schedule)))
               (set! schedule (cdr schedule))
               (if (symbol? job)
                   (analyze-known-local-procedure job)
                   (analyze-unknown-lambda job))
               (loop)))
            (changed?
             (set! changed? #f)
             (set! schedule (list (callgraphnode.code (car g))))
             (if debugging?
                 (begin (display-all-types) (newline)))
             (loop))))
    
    (if debugging?
        (display-types))
    
    (set! mutate? #t)
    
    ; We don't want to analyze known procedures that are never called.
    
    (set! schedule
          (cons (callgraphnode.code (car g))
                (map callgraphnode.name
                     (filter (lambda (node)
                               (let* ((name (callgraphnode.name node))
                                      (known? (symbol? name))
                                      (marked?
                                       (known-procedure-is-callable? name)))
                                 (callgraphnode.info! node #f)
                                 (and known? marked?)))
                             g))))
    (let loop ()
      (if (not (null? schedule))
          (let ((job (car schedule)))
            (set! schedule (cdr schedule))
            (if (symbol? job)
                (analyze-known-local-procedure job)
                (analyze-unknown-lambda job))
            (loop))))
    
    (if changed?
        (error "Compiler bug in representation inference"))
    
    (if debugging?
        (pretty-print (make-readable (callgraphnode.code (car g)) #t)))
    
    exp))
; Copyright 1999 William D Clinger.
;
; Permission to copy this software, in whole or in part, to use this
; software for any lawful noncommercial purpose, and to redistribute
; this software is granted subject to the restriction that all copies
; made of this software must include this copyright notice in full.
; 
; I also request that you send me a copy of any improvements that you
; make to this software so that they may be incorporated within it to
; the benefit of the Scheme community.
;
; 11 June 1999.
;
; The third "pass" of the Twobit compiler actually consists of several
; passes, which are related by the common theme of flow analysis:
;   interprocedural inlining of known local procedures
;   interprocedural constant propagation and folding
;   intraprocedural commoning, copy propagation, and dead code elimination
;   representation inference (not yet implemented)
;   register targeting
;
; This pass operates as source-to-source transformations on
; expressions written in the subset of Scheme described by the
; following grammar:
;
; "X ..." means zero or more occurrences of X.
;
; L  -->  (lambda (I_1 ...)
;           (begin D ...)
;           (quote (R F G <decls> <doc>)
;           E)
;      |  (lambda (I_1 ... . I_rest)
;           (begin D ...)
;           (quote (R F G <decls> <doc>))
;           E)
; D  -->  (define I L)
; E  -->  (quote K)                        ; constants
;      |  (begin I)                        ; variable references
;      |  L                                ; lambda expressions
;      |  (E0 E1 ...)                      ; calls
;      |  (set! I E)                       ; assignments
;      |  (if E0 E1 E2)                    ; conditionals
;      |  (begin E0 E1 E2 ...)             ; sequential expressions
; I  -->  <identifier>
;
; R  -->  ((I <references> <assignments> <calls>) ...)
; F  -->  (I ...)
; G  -->  (I ...)
;
; Invariants that hold for the input only:
;   *  There are no assignments except to global variables.
;   *  If I is declared by an internal definition, then the right hand
;      side of the internal definition is a lambda expression and I
;      is referenced only in the procedure position of a call.
;   *  R, F, and G are garbage.
;   *  Variables named IGNORED are neither referenced nor assigned.
;   *  The expression does not share structure with the original input,
;      but might share structure with itself.
;
; Invariants that hold for the output only:
;   *  There are no assignments except to global variables.
;   *  If I is declared by an internal definition, then the right hand
;      side of the internal definition is a lambda expression and I
;      is referenced only in the procedure position of a call.
;   *  R is garbage.
;   *  For each lambda expression, the associated F is a list of all
;      the identifiers that occur free in the body of that lambda
;      expression, and possibly a few extra identifiers that were
;      once free but have been removed by optimization.
;   *  If a lambda expression is declared to be in A-normal form (see
;      pass3anormal.sch), then it really is in A-normal form.
;
; The phases of pass 3 interact with the referencing information R
; and the free variables F as follows:
;
; Inlining               ignores R,   ignores F,  destroys R,  destroys F.
; Constant propagation      uses R,   ignores F, preserves R, preserves F.
; Conversion to ANF      ignores R,   ignores F,  destroys R,  destroys F.
; Commoning              ignores R,   ignores F,  destroys R,  computes F.
; Register targeting     ignores R,   ignores F,  destroys R,  computes F.

(define (pass3 exp)
  
  (define (phase1 exp)
    (if (interprocedural-inlining)
        (let ((g (callgraph exp)))
          (inline-using-callgraph! g)
          exp)
        exp))
  
  (define (phase2 exp)
    (if (interprocedural-constant-propagation)
        (constant-propagation (copy-exp exp))
        exp))
  
  (define (phase3 exp)
    (if (common-subexpression-elimination)
        (let* ((exp (if (interprocedural-constant-propagation)
                        exp
                        ; alpha-conversion
                        (copy-exp exp)))
               (exp (a-normal-form exp)))
          (if (representation-inference)
              (intraprocedural-commoning exp 'commoning)
              (intraprocedural-commoning exp)))
        exp))
  
  (define (phase4 exp)
    (if (representation-inference)
        (let ((exp (cond ((common-subexpression-elimination)
                          exp)
                         ((interprocedural-constant-propagation)
                          (a-normal-form exp))
                         (else
                          ; alpha-conversion
                          (a-normal-form (copy-exp exp))))))
          (intraprocedural-commoning
           (representation-analysis exp)))
        exp))
  
  (define (finish exp)
    (if (and (not (interprocedural-constant-propagation))
             (not (common-subexpression-elimination)))
        (begin (compute-free-variables! exp)
               exp)
        ;(make-begin (list (make-constant 'anf) exp))))
        exp))
  
  (define (verify exp)
    (check-referencing-invariants exp 'free)
    exp)
  
  (if (global-optimization)
      (verify (finish (phase4 (phase3 (phase2 (phase1 exp))))))
      (begin (compute-free-variables! exp)
             (verify exp))))
; Copyright 1991 Lightship Software, Incorporated.
;
; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
;
; 4 June 1999

; Implements the following abstract data types.
;
; labels
;     (init-labels)
;     (make-label)
;     cg-label-counter
;
; assembly streams
;     (make-assembly-stream)
;     (assembly-stream-code as)
;     (gen! as . instruction)
;     (gen-instruction! as instruction)
;     (gen-save! as frame)
;     (gen-restore! as frame)
;     (gen-pop! as frame)
;     (gen-setstk! as frame v)
;     (gen-store! as frame r v)
;     (gen-load! as frame r v)
;     (gen-stack! as frame v)
;
; temporaries
;     (init-temps)
;     (newtemp)
;     (newtemps)
;     newtemp-counter
;
; register environments
;     (cgreg-initial)
;     (cgreg-copy regs)
;     (cgreg-tos regs)
;     (cgreg-liveregs regs)
;     (cgreg-live regs r)
;     (cgreg-vars regs)
;     (cgreg-bind! regs r v)
;     (cgreg-bindregs! regs vars)
;     (cgreg-rename! regs alist)
;     (cgreg-release! regs r)
;     (cgreg-clear! regs)
;     (cgreg-lookup regs var)
;     (cgreg-lookup-reg regs r)
;     (cgreg-join! regs1 regs2)
;
; stack frame environments
;     (cgframe-initial)
;     (cgframe-size-cell frame)
;     (cgframe-size frame)
;     (cgframe-copy frame)
;     (cgframe-join! frame1 frame2)
;     (cgframe-update-stale! frame)
;     (cgframe-used! frame)
;     (cgframe-bind! frame n v instruction)
;     (cgframe-touch! frame v)
;     (cgframe-rename! frame alist)
;     (cgframe-release! frame v)
;     (cgframe-lookup frame v)
;     (cgframe-spilled? frame v)
;
; environments
;     (entry.name entry)
;     (entry.kind entry)
;     (entry.rib entry)
;     (entry.offset entry)
;     (entry.label entry)
;     (entry.regnum entry)
;     (entry.arity entry)
;     (entry.op entry)
;     (entry.imm entry)
;     (cgenv-initial)
;     (cgenv-lookup env id)
;     (cgenv-extend env vars procs)
;     (cgenv-bindprocs env procs)
;     (var-lookup var regs frame env)

; Labels.

(define (init-labels)
  (set! cg-label-counter 1000))

(define (make-label)
  (set! cg-label-counter (+ cg-label-counter 1))
  cg-label-counter)

(define cg-label-counter 1000)

;    an assembly stream into which instructions should be emitted
;    an expression
;    the desired target register ('result, a register number, or '#f)
;    a register environment [cgreg]
;    a stack-frame environment [cgframe]
;      contains size of frame, current top of frame
;    a compile-time environment [cgenv]
;    a flag indicating whether the expression is in tail position

; Assembly streams, into which instructions are emitted by side effect.
; Represented as a list of two things:
;
;     Assembly code, represented as a pair whose car is a nonempty list
;     whose cdr is a possibly empty list of MacScheme machine assembly
;     instructions, and whose cdr is the last pair of the car.
;
;     Any Scheme object that the code generator wants to associate with
;     this code.

(define (make-assembly-stream)
  (let ((code (list (list 0))))
    (set-cdr! code (car code))
    (list code #f)))

(define (assembly-stream-code output)
  (if (local-optimizations)
      (filter-basic-blocks (cdar (car output)))
      (cdar (car output))))

(define (assembly-stream-info output)
  (cadr output))

(define (assembly-stream-info! output x)
  (set-car! (cdr output) x)
  #f)

(define (gen-instruction! output instruction)
  (let ((pair (list instruction))
        (code (car output)))
    (set-cdr! (cdr code) pair)
    (set-cdr! code pair)
    output))

;

(define (gen! output . instruction)
  (gen-instruction! output instruction))

(define (gen-save! output frame t0)
  (let ((size (cgframe-size-cell frame)))
    (gen-instruction! output (cons $save size))
    (gen-store! output frame 0 t0)
    (cgframe:stale-set! frame '())))

(define (gen-restore! output frame)
  (let ((size (cgframe-size-cell frame)))
    (gen-instruction! output (cons $restore size))))

(define (gen-pop! output frame)
  (let ((size (cgframe-size-cell frame)))
    (gen-instruction! output (cons $pop size))))

(define (gen-setstk! output frame tempname)
  (let ((instruction (list $nop $setstk -1)))
    (cgframe-bind! frame tempname instruction)
    (gen-instruction! output instruction)))

(define (gen-store! output frame r tempname)
  (let ((instruction (list $nop $store r -1)))
    (cgframe-bind! frame tempname instruction)
    (gen-instruction! output instruction)))

(define (gen-load! output frame r tempname)
  (cgframe-touch! frame tempname)
  (let ((n (entry.slotnum (cgframe-lookup frame tempname))))
    (gen! output $load r n)))

(define (gen-stack! output frame tempname)
  (cgframe-touch! frame tempname)
  (let ((n (entry.slotnum (cgframe-lookup frame tempname))))
    (gen! output $stack n)))

; Returns a temporary name.
; Temporaries are compared using EQ?, so the use of small
; exact integers as temporary names is implementation-dependent.

(define (init-temps)
  (set! newtemp-counter 5000))

(define (newtemp)
  (set! newtemp-counter
        (+ newtemp-counter 1))
  newtemp-counter)

(define newtemp-counter 5000)

(define (newtemps n)
  (if (zero? n)
      '()
      (cons (newtemp)
            (newtemps (- n 1)))))

; New representation of
; Register environments.
; Represented as a list of three items:
;     an exact integer, one more than the highest index of a live register
;     a mutable vector with *nregs* elements of the form
;         #f        (the register is dead)
;         #t        (the register is live)
;         v         (the register contains variable v)
;         t         (the register contains temporary variable t)
;     a mutable vector of booleans: true if the register might be stale

(define (cgreg-makeregs n v1 v2) (list n v1 v2))

(define (cgreg-liveregs regs)
  (car regs))

(define (cgreg-contents regs)
  (cadr regs))

(define (cgreg-stale regs)
  (caddr regs))

(define (cgreg-liveregs-set! regs n)
  (set-car! regs n)
  regs)

(define (cgreg-initial)
  (let ((v1 (make-vector *nregs* #f))
        (v2 (make-vector *nregs* #f)))
    (cgreg-makeregs 0 v1 v2)))

(define (cgreg-copy regs)
  (let* ((newregs (cgreg-initial))
         (v1a (cgreg-contents regs))
         (v2a (cgreg-stale regs))
         (v1 (cgreg-contents newregs))
         (v2 (cgreg-stale newregs))
         (n (vector-length v1a)))
    (cgreg-liveregs-set! newregs (cgreg-liveregs regs))
    (do ((i 0 (+ i 1)))
        ((= i n)
         newregs)
        (vector-set! v1 i (vector-ref v1a i))
        (vector-set! v2 i (vector-ref v2a i)))))

(define (cgreg-tos regs)
  (- (cgreg-liveregs regs) 1))

(define (cgreg-live regs r)
  (if (eq? r 'result)
      (cgreg-tos regs)
      (max r (cgreg-tos regs))))

(define (cgreg-vars regs)
  (let ((m (cgreg-liveregs regs))
        (v (cgreg-contents regs)))
    (do ((i (- m 1) (- i 1))
         (vars '()
               (cons (vector-ref v i)
                     vars)))
        ((< i 0)
         vars))))

(define (cgreg-bind! regs r t)
  (let ((m (cgreg-liveregs regs))
        (v (cgreg-contents regs)))
    (vector-set! v r t)
    (if (>= r m)
        (cgreg-liveregs-set! regs (+ r 1)))))

(define (cgreg-bindregs! regs vars)
  (do ((m (cgreg-liveregs regs) (+ m 1))
       (v (cgreg-contents regs))
       (vars vars (cdr vars)))
      ((null? vars)
       (cgreg-liveregs-set! regs m)
       regs)
      (vector-set! v m (car vars))))

(define (cgreg-rename! regs alist)
  (do ((i (- (cgreg-liveregs regs) 1) (- i 1))
       (v (cgreg-contents regs)))
      ((negative? i))
      (let ((var (vector-ref v i)))
        (if var
            (let ((probe (assv var alist)))
              (if probe
                  (vector-set! v i (cdr probe))))))))

(define (cgreg-release! regs r)
  (let ((m (cgreg-liveregs regs))
        (v (cgreg-contents regs)))
    (vector-set! v r #f)
    (vector-set! (cgreg-stale regs) r #t)
    (if (= r (- m 1))
        (do ((m r (- m 1)))
            ((or (negative? m)
                 (vector-ref v m))
             (cgreg-liveregs-set! regs (+ m 1)))))))

(define (cgreg-release-except! regs vars)
  (do ((i (- (cgreg-liveregs regs) 1) (- i 1))
       (v (cgreg-contents regs)))
      ((negative? i))
      (let ((var (vector-ref v i)))
        (if (and var (not (memq var vars)))
            (cgreg-release! regs i)))))

(define (cgreg-clear! regs)
  (let ((m (cgreg-liveregs regs))
        (v1 (cgreg-contents regs))
        (v2 (cgreg-stale regs)))
    (do ((r 0 (+ r 1)))
        ((= r m)
         (cgreg-liveregs-set! regs 0))
        (vector-set! v1 r #f)
        (vector-set! v2 r #t))))

(define (cgreg-lookup regs var)
  (let ((m (cgreg-liveregs regs))
        (v (cgreg-contents regs)))
    (define (loop i)
      (cond ((< i 0)
             #f)
            ((eq? var (vector-ref v i))
             (list var 'register i '(object)))
            (else
             (loop (- i 1)))))
    (loop (- m 1))))

(define (cgreg-lookup-reg regs r)
  (let ((m (cgreg-liveregs regs))
        (v (cgreg-contents regs)))
    (if (<= m r)
        #f
        (vector-ref v r))))

(define (cgreg-join! regs1 regs2)
  (let ((m1 (cgreg-liveregs regs1))
        (m2 (cgreg-liveregs regs2))
        (v1 (cgreg-contents regs1))
        (v2 (cgreg-contents regs2))
        (stale1 (cgreg-stale regs1)))
    (do ((i (- (max m1 m2) 1) (- i 1)))
        ((< i 0)
         (cgreg-liveregs-set! regs1 (min m1 m2)))
        (let ((x1 (vector-ref v1 i))
              (x2 (vector-ref v2 i)))
          (cond ((eq? x1 x2)
                 #t)
                ((not x1)
                 (if x2
                     (vector-set! stale1 i #t)))
                (else
                 (vector-set! v1 i #f)
                 (vector-set! stale1 i #t)))))))

; New representation of
; Stack-frame environments.
; Represented as a three-element list.
;
; Its car is a list whose car is a list of slot entries, each
; of the form
;    (v n instruction stale)
; where
;    v is the name of a variable or temporary,
;    n is #f or a slot number,
;    instruction is a possibly phantom store or setstk instruction
;       that stores v into slot n, and
;    stale is a list of stale slot entries, each of the form
;          (#t . n)
;       or (#f . -1)
;       where slot n had been allocated, initialized, and released
;       before the store or setstk instruction was generated.
; Slot entries are updated by side effect.
;
; Its cadr is the list of currently stale slots.
;
; Its caddr is a list of variables that are free in the continuation,
; or #f if that information is unknown.
; This information allows a direct-style code generator to know when
; a slot becomes stale.
;
; Its cadddr is the size of the stack frame, which can be
; increased but not decreased.  The cdddr of the stack frame
; environment is shared with the save instruction that
; created the frame.  What a horrible crock!

; This stuff is private to the implementation of stack-frame
; environments.

(define cgframe:slots car)
(define cgframe:stale cadr)
(define cgframe:livevars caddr)
(define cgframe:slot.name car)
(define cgframe:slot.offset cadr)
(define cgframe:slot.instruction caddr)
(define cgframe:slot.stale cadddr)

(define cgframe:slots-set! set-car!)
(define (cgframe:stale-set! frame stale)
  (set-car! (cdr frame) stale))
(define (cgframe:livevars-set! frame vars)
  (set-car! (cddr frame) vars))

(define cgframe:slot.name-set! set-car!)

(define (cgframe:slot.offset-set! entry n)
  (let ((instruction (caddr entry)))
    (if (or (not (eq? #f (cadr entry)))
            (not (eq? $nop (car instruction))))
        (error "Compiler bug: cgframe" entry)
        (begin
         (set-car! (cdr entry) n)
         (set-car! instruction (cadr instruction))
         (set-cdr! instruction (cddr instruction))
         (if (eq? $setstk (car instruction))
             (set-car! (cdr instruction) n)
             (set-car! (cddr instruction) n))))))

; Reserves a slot offset that was unused where the instruction
; of the slot entry was generated, and returns that offset.

(define (cgframe:unused-slot frame entry)
  (let* ((stale (cgframe:slot.stale entry))
         (probe (assq #t stale)))
    (if probe
        (let ((n (cdr probe)))
          (if (zero? n)
              (cgframe-used! frame))
          (set-car! probe #f)
          n)
        (let* ((cell (cgframe-size-cell frame))
               (n (+ 1 (car cell))))
          (set-car! cell n)
          (if (zero? n)
              (cgframe:unused-slot frame entry)
              n)))))

; Public entry points.

; The runtime system requires slot 0 of a frame to contain
; a closure whose code pointer contains the return address
; of the frame.
; To prevent slot 0 from being used for some other purpose,
; we rely on a complex trick:  Slot 0 is initially stale.
; Gen-save! generates a store instruction for register 0,
; with slot 0 as the only stale slot for that instruction;
; then gen-save! clears the frame's set of stale slots, which
; prevents other store instructions from using slot 0.

(define (cgframe-initial)
  (list '()
        (list (cons #t 0))
        '#f
        -1))

(define cgframe-livevars cgframe:livevars)
(define cgframe-livevars-set! cgframe:livevars-set!)

(define (cgframe-size-cell frame)
  (cdddr frame))

(define (cgframe-size frame)
  (car (cgframe-size-cell frame)))

(define (cgframe-used! frame)
  (if (negative? (cgframe-size frame))
      (set-car! (cgframe-size-cell frame) 0)))

; Called only by gen-store!, gen-setstk!

(define (cgframe-bind! frame var instruction)
  (cgframe:slots-set! frame
                      (cons (list var #f instruction (cgframe:stale frame))
                            (cgframe:slots frame))))

; Called only by gen-load!, gen-stack!

(define (cgframe-touch! frame var)
  (let ((entry (assq var (cgframe:slots frame))))
    (if entry
        (let ((n (cgframe:slot.offset entry)))
          (if (eq? #f n)
              (let ((n (cgframe:unused-slot frame entry)))
                (cgframe:slot.offset-set! entry n))))
        (error "Compiler bug: cgframe-touch!" frame var))))

(define (cgframe-rename! frame alist)
  (for-each (lambda (entry)
              (let ((probe (assq (cgframe:slot.name entry) alist)))
                (if probe
                    (cgframe:slot.name-set! entry (cdr probe)))))
            (cgframe:slots frame)))

(define (cgframe-release! frame var)
  (let* ((slots (cgframe:slots frame))
         (entry (assq var slots)))
    (if entry
        (begin (cgframe:slots-set! frame (remq entry slots))
               (let ((n (cgframe:slot.offset entry)))
                 (if (and (not (eq? #f n))
                          (not (zero? n)))
                     (cgframe:stale-set!
                      frame
                      (cons (cons #t n)
                            (cgframe:stale frame)))))))))

(define (cgframe-release-except! frame vars)
  (let loop ((slots (reverse (cgframe:slots frame)))
             (newslots '())
             (stale (cgframe:stale frame)))
    (if (null? slots)
        (begin (cgframe:slots-set! frame newslots)
               (cgframe:stale-set! frame stale))
        (let ((slot (car slots)))
          (if (memq (cgframe:slot.name slot) vars)
              (loop (cdr slots)
                    (cons slot newslots)
                    stale)
              (let ((n (cgframe:slot.offset slot)))
                (cond ((eq? n #f)
                       (loop (cdr slots)
                             newslots
                             stale))
                      ((zero? n)
                       (loop (cdr slots)
                             (cons slot newslots)
                             stale))
                      (else
                       (loop (cdr slots)
                             newslots
                             (cons (cons #t n) stale))))))))))

(define (cgframe-lookup frame var)
  (let ((entry (assq var (cgframe:slots frame))))
    (if entry
        (let ((n (cgframe:slot.offset entry)))
          (if (eq? #f n)
              (cgframe-touch! frame var))
          (list var 'frame (cgframe:slot.offset entry) '(object)))
        #f)))

(define (cgframe-spilled? frame var)
  (let ((entry (assq var (cgframe:slots frame))))
    (if entry
        (let ((n (cgframe:slot.offset entry)))
          (not (eq? #f n)))
        #f)))

; For a conditional expression, the then and else parts must be
; evaluated using separate copies of the frame environment,
; and those copies must be resolved at the join point.  The
; nature of the resolution depends upon whether the conditional
; expression is in a tail position.
;
; Critical invariant:
; Any store instructions that are generated within either arm of the
; conditional involve variables and temporaries that are local to the
; conditional.
;
; If the conditional expression is in a tail position, then a slot
; that is stale after the test can be allocated independently by the
; two arms of the conditional.  If the conditional expression is in a
; non-tail position, then the slot can be allocated independently
; provided it is not a candidate destination for any previous emitted
; store instruction.

(define (cgframe-copy frame)
  (cons (car frame)
        (cons (cadr frame)
              (cons (caddr frame)
                    (cdddr frame)))))

(define (cgframe-update-stale! frame)
  (let* ((n (cgframe-size frame))
         (v (make-vector (+ 1 n) #t))
         (stale (cgframe:stale frame)))
    (for-each (lambda (x)
                (if (car x)
                    (let ((i (cdr x)))
                      (if (<= i n)
                          (vector-set! v i #f)))))
              stale)
    (for-each (lambda (slot)
                (let ((offset (cgframe:slot.offset slot)))
                  (if offset
                      (vector-set! v offset #f)
                      (for-each (lambda (stale)
                                  (if (car stale)
                                      (let ((i (cdr stale)))
                                        (if (< i n)
                                            (vector-set! v i #f)))))
                                (cgframe:slot.stale slot)))))
              (cgframe:slots frame))
    (do ((i n (- i 1))
         (stale (filter car stale)
                (if (vector-ref v i)
                    (cons (cons #t i) stale)
                    stale)))
        ((<= i 0)
         (cgframe:stale-set! frame stale)))))

(define (cgframe-join! frame1 frame2)
  (let* ((slots1 (cgframe:slots frame1))
         (slots2 (cgframe:slots frame2))
         (slots (intersection slots1 slots2))
         (deadslots (append (difference slots1 slots)
                            (difference slots2 slots)))
         (deadoffsets (make-set
                       (filter (lambda (x) (not (eq? x #f)))
                               (map cgframe:slot.offset deadslots))))
         (stale1 (cgframe:stale frame1))
         (stale2 (cgframe:stale frame2))
         (stale (intersection stale1 stale2))
         (stale (append (map (lambda (n) (cons #t n))
                             deadoffsets)
                        stale)))
    (cgframe:slots-set! frame1 slots)
    (cgframe:stale-set! frame1 stale)))

; Environments.
;
; Each identifier has one of the following kinds of entry.
;
;    (<name> register   <number>                (object))
;    (<name> frame      <slot>                  (object))
;    (<name> lexical    <rib>    <offset>       (object))
;    (<name> procedure  <rib>    <label>        (object))
;    (<name> integrable <arity>  <op>     <imm> (object))
;    (<name> global                             (object))
;
; Implementation.
;
; An environment is represented as a list of the form
;
;    ((<entry> ...)                          ; lexical rib
;     ...)
;
; where each <entry> has one of the forms
;
;    (<name> lexical <offset> (object))
;    (<name> procedure <rib> <label> (object))
;    (<name> integrable <arity> <op> <imm> (object))

(define entry.name car)
(define entry.kind cadr)
(define entry.rib caddr)
(define entry.offset cadddr)
(define entry.label cadddr)
(define entry.regnum caddr)
(define entry.slotnum caddr)
(define entry.arity caddr)
(define entry.op cadddr)
(define (entry.imm entry) (car (cddddr entry)))

(define (cgenv-initial integrable)
  (list (map (lambda (x)
               (list (car x)
                     'integrable
                     (cadr x)
                     (caddr x)
                     (cadddr x)
                     '(object)))
             integrable)))

(define (cgenv-lookup env id)
  (define (loop ribs m)
    (if (null? ribs)
        (cons id '(global (object)))
        (let ((x (assq id (car ribs))))
          (if x
              (case (cadr x)
                ((lexical)
                 (cons id
                       (cons (cadr x)
                             (cons m (cddr x)))))
                ((procedure)
                 (cons id
                       (cons (cadr x)
                             (cons m (cddr x)))))
                ((integrable)
                 (if (integrate-usual-procedures)
                     x
                     (loop '() m)))
                (else ???))
              (loop (cdr ribs) (+ m 1))))))
  (loop env 0))

(define (cgenv-extend env vars procs)
  (cons (do ((n 0 (+ n 1))
             (vars vars (cdr vars))
             (rib (map (lambda (id)
                         (list id 'procedure (make-label) '(object)))
                       procs)
                  (cons (list (car vars) 'lexical n '(object)) rib)))
            ((null? vars) rib))
        env))

(define (cgenv-bindprocs env procs)
  (cons (append (map (lambda (id)
                       (list id 'procedure (make-label) '(object)))
                     procs)
                (car env))
        (cdr env)))

(define (var-lookup var regs frame env)
  (or (cgreg-lookup regs var)
      (cgframe-lookup frame var)
      (cgenv-lookup env var)))

; Compositions.

(define compile
  (lambda (x)
    (pass4 (pass3 (pass2 (pass1 x))) $usual-integrable-procedures$)))

(define compile-block
  (lambda (x)
    (pass4 (pass3 (pass2 (pass1-block x))) $usual-integrable-procedures$)))

; For testing.

(define foo
  (lambda (x)
    (pretty-print (compile x))))

; Find the smallest number of registers such that
; adding more registers does not affect the code
; generated for x (from 4 to 32 registers).

(define (minregs x)
  (define (defregs R)
    (set! *nregs* R)
    (set! *lastreg* (- *nregs* 1))
    (set! *fullregs* (quotient *nregs* 2)))
  (defregs 32)
  (let ((code (assemble (compile x))))
    (define (binary-search m1 m2)
      (if (= (+ m1 1) m2)
          m2
          (let ((midpt (quotient (+ m1 m2) 2)))
            (defregs midpt)
            (if (equal? code (assemble (compile x)))
                (binary-search m1 midpt)
                (binary-search midpt m2)))))
    (defregs 4)
    (let ((newcode (assemble (compile x))))
      (if (equal? code newcode)
          4
          (binary-search 4 32)))))

; Minimums:
;  browse     10
;  triangle    5
;  traverse   10
;  destruct    6
;  puzzle      8,8,10,7
;  tak         6
;  fft        28   (changing the named lets to macros didn't matter)
; Copyright 1991 William Clinger
;
; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
;
; 7 June 1999.
;
; Fourth pass of the Twobit compiler:
;   code generation for the MacScheme machine.
;
; This pass operates on input expressions described by the
; following grammar and the invariants that follow it.
;
; "X ..." means zero or more occurrences of X.
;
; L  -->  (lambda (I_1 ...)
;           (begin D ...)
;           (quote (R F G <decls> <doc>)
;           E)
;      |  (lambda (I_1 ... . I_rest)
;           (begin D ...)
;           (quote (R F G <decls> <doc>))
;           E)
; D  -->  (define I L)
; E  -->  (quote K)                        ; constants
;      |  (begin I)                        ; variable references
;      |  L                                ; lambda expressions
;      |  (E0 E1 ...)                      ; calls
;      |  (set! I E)                       ; assignments
;      |  (if E0 E1 E2)                    ; conditionals
;      |  (begin E0 E1 E2 ...)             ; sequential expressions
; I  -->  <identifier>
;
; R  -->  ((I <references> <assignments> <calls>) ...)
; F  -->  (I ...)
; G  -->  (I ...)
;
; Invariants that hold for the input
;   *  There are no assignments except to global variables.
;   *  If I is declared by an internal definition, then the right hand
;      side of the internal definition is a lambda expression and I
;      is referenced only in the procedure position of a call.
;   *  Every procedure defined by an internal definition takes a
;      fixed number of arguments.
;   *  Every call to a procedure defined by an internal definition
;      passes the correct number of arguments.
;   *  For each lambda expression, the associated F is a list of all
;      the identifiers that occur free in the body of that lambda
;      expression, and possibly a few extra identifiers that were
;      once free but have been removed by optimization.
;   *  For each lambda expression, the associated G is a subset of F
;      that contains every identifier that occurs free within some
;      inner lambda expression that escapes, and possibly a few that
;      don't.  (Assignment-elimination does not calculate G exactly.)
;   *  Variables named IGNORED are neither referenced nor assigned.
;   *  Any lambda expression that is declared to be in A-normal form
;      really is in A-normal form.
;
; 
; Stack frames are created by "save" instructions.
; A save instruction is generated
; 
;     *  at the beginning of each lambda body
;     *  at the beginning of the code for each arm of a conditional,
;        provided:
;          the conditional is in a tail position
;          the frames that were allocated by the save instructions
;            that dominate the arms of the conditional have not been
;            used (those save instructions will be eliminated during
;            assembly)
;
; The operand of a save instruction, and of its matching pop instructions,
; increases automatically as frame slots are allocated.
; 
; The code generated to return from a procedure is
; 
;         pop     n
;         return
; 
; The code generated for a tail call is
; 
;         pop     n
;         invoke  ...
;
; Invariant:  When the code generator reserves an argument register
; to hold a value, that value is named, and is stored into the current
; stack frame.  These store instructions are eliminated during assembly
; unless there is a matching load instruction.  If all of the instructions
; that store into a stack frame are eliminated, then the stack frame
; itself is eliminated.
; Exception:  An argument register may be used without naming or storing
; its value provided the register is not in use and no expressions are
; evaluated while it contains the unnamed and unstored value.


(define (pass4 exp integrable)
  (init-labels)
  (init-temps)
  (let ((output (make-assembly-stream))
        (frame (cgframe-initial))
        (regs (cgreg-initial))
        (t0 (newtemp)))
    (assembly-stream-info! output (make-hashtable equal-hash assoc))
    (cgreg-bind! regs 0 t0)
    (gen-save! output frame t0)
    (cg0 output
         exp
         'result
         regs
         frame
         (cgenv-initial integrable)
         #t)
    (pass4-code output)))

(define (pass4-code output)
  (hashtable-for-each (lambda (situation label)
                        (cg-trap output situation label))
                      (assembly-stream-info output))
  (assembly-stream-code output))

; Given:
;    an assembly stream into which instructions should be emitted
;    an expression
;    the target register
;      ('result, a register number, or '#f; tail position implies 'result)
;    a register environment [cgreg]
;    a stack-frame environment [cgframe]
;    a compile-time environment [cgenv]
;    a flag indicating whether the expression is in tail position
; Returns:
;    the target register ('result or a register number)
; Side effects:
;    may change the register and stack-frame environments
;    may increase the size of the stack frame, which changes previously
;       emitted instructions
;    writes instructions to the assembly stream

(define (cg0 output exp target regs frame env tail?)
  (case (car exp)
    ((quote)    (gen! output $const (constant.value exp))
                (if tail?
                    (begin (gen-pop! output frame)
                           (gen! output $return)
                           'result)
                    (cg-move output frame regs 'result target)))
    ((lambda)   (cg-lambda output exp regs frame env)
                (if tail?
                    (begin (gen-pop! output frame)
                           (gen! output $return)
                           'result)
                    (cg-move output frame regs 'result target)))
    ((set!)     (cg0 output (assignment.rhs exp) 'result regs frame env #f)
                (cg-assignment-result output exp target regs frame env tail?))
    ((if)       (cg-if output exp target regs frame env tail?))
    ((begin)    (if (variable? exp)
                    (cg-variable output exp target regs frame env tail?)
                    (cg-sequential output exp target regs frame env tail?)))
    (else       (cg-call output exp target regs frame env tail?))))

; Lambda expressions that evaluate to closures.
; This is hard because the MacScheme machine's lambda instruction
; closes over the values that are in argument registers 0 through r
; (where r can be larger than *nregs*).
; The set of free variables is calculated and then sorted to minimize
; register shuffling.
;
; Returns: nothing.

(define (cg-lambda output exp regs frame env)
  (let* ((args (lambda.args exp))
         (vars (make-null-terminated args))
         (free (difference (lambda.F exp) vars))
         (free (cg-sort-vars free regs frame env))
         (newenv (cgenv-extend env (cons #t free) '()))
         (newoutput (make-assembly-stream)))
    (assembly-stream-info! newoutput (make-hashtable equal-hash assoc))
    (gen! newoutput $.proc)
    (if (list? args)
        (gen! newoutput $args= (length args))
        (gen! newoutput $args>= (- (length vars) 1)))
    (cg-known-lambda newoutput exp newenv)
    (cg-eval-vars output free regs frame env)
    ; FIXME
    '
    (if (not (ignore-space-leaks))
        ; FIXME: Is this the right constant?
        (begin (gen! output $const #f)
               (gen! output $setreg 0)))
    (gen! output
          $lambda
          (pass4-code newoutput)
          (length free)
          (lambda.doc exp))
    ; FIXME
    '
    (if (not (ignore-space-leaks))
        ; FIXME: This load forces a stack frame to be allocated.
        (gen-load! output frame 0 (cgreg-lookup-reg regs 0)))))

; Given a list of free variables, filters out the ones that
; need to be copied into a closure, and sorts them into an order
; that reduces register shuffling.  Returns a sorted version of
; the list in which the first element (element 0) should go
; into register 1, the second into register 2, and so on.

(define (cg-sort-vars free regs frame env)
  (let* ((free (filter (lambda (var)
                         (case (entry.kind
                                (var-lookup var regs frame env))
                           ((register frame)
                            #t)
                           ((lexical)
                            (not (ignore-space-leaks)))
                           (else #f)))
                       free))
         (n (length free))
         (m (min n (- *nregs* 1)))
         (vec (make-vector m #f)))
    (define (loop1 free free-notregister)
      (if (null? free)
          (loop2 0 free-notregister)
          (let* ((var (car free))
                 (entry (cgreg-lookup regs var)))
            (if entry
                (let ((r (entry.regnum entry)))
                  (if (<= r n)
                      (begin (vector-set! vec (- r 1) var)
                             (loop1 (cdr free)
                                    free-notregister))
                      (loop1 (cdr free)
                             (cons var free-notregister))))
                (loop1 (cdr free)
                       (cons var free-notregister))))))
    (define (loop2 i free)
      (cond ((null? free)
             (vector->list vec))
            ((= i m)
             (append (vector->list vec) free))
            ((vector-ref vec i)
             (loop2 (+ i 1) free))
            (else
             (vector-set! vec i (car free))
             (loop2 (+ i 1) (cdr free)))))
    (loop1 free '())))

; Fetches the given list of free variables into the corresponding
; registers in preparation for a $lambda or $lexes instruction.

(define (cg-eval-vars output free regs frame env)
  (let ((n (length free))
        (R-1 (- *nregs* 1)))
    (if (>= n R-1)
        (begin (gen! output $const '())
               (gen! output $setreg R-1)
               (cgreg-release! regs R-1)))
    (do ((r n (- r 1))
         (vars (reverse free) (cdr vars)))
        ((zero? r))
        (let* ((v (car vars))
               (entry (var-lookup v regs frame env)))
          (case (entry.kind entry)
            ((register)
             (let ((r1 (entry.regnum entry)))
               (if (not (eqv? r r1))
                   (if (< r R-1)
                       (begin (gen! output $movereg r1 r)
                              (cgreg-bind! regs r v))
                       (gen! output $reg r1 v)))))
            ((frame)
             (if (< r R-1)
                 (begin (gen-load! output frame r v)
                        (cgreg-bind! regs r v))
                 (gen-stack! output frame v)))
            ((lexical)
             (gen! output $lexical
                          (entry.rib entry)
                          (entry.offset entry)
                          v)
             (if (< r R-1)
                 (begin (gen! output $setreg r)
                        (cgreg-bind! regs r v)
                        (gen-store! output frame r v))))
            (else
             (error "Bug in cg-close-lambda")))
          (if (>= r R-1)
              (begin (gen! output $op2 $cons R-1)
                     (gen! output $setreg R-1)))))))

; Lambda expressions that appear on the rhs of a definition are
; compiled here.  They don't need an args= instruction at their head.
;
; Returns: nothing.

(define (cg-known-lambda output exp env)
  (let* ((vars (make-null-terminated (lambda.args exp)))
         (regs (cgreg-initial))
         (frame (cgframe-initial))
         (t0 (newtemp)))
    (if (member A-normal-form-declaration (lambda.decls exp))
        (cgframe-livevars-set! frame '()))
    (cgreg-bind! regs 0 t0)
    (gen-save! output frame t0)
    (do ((r 1 (+ r 1))
         (vars vars (cdr vars)))
        ((or (null? vars)
             (= r *lastreg*))
         (if (not (null? vars))
             (begin (gen! output $movereg *lastreg* 1)
                    (cgreg-release! regs 1)
                    (do ((vars vars (cdr vars)))
                        ((null? vars))
                        (gen! output $reg 1)
                        (gen! output $op1 $car:pair)
                        (gen-setstk! output frame (car vars))
                        (gen! output $reg 1)
                        (gen! output $op1 $cdr:pair)
                        (gen! output $setreg 1)))))
        (cgreg-bind! regs r (car vars))
        (gen-store! output frame r (car vars)))
    (cg-body output
             exp
             'result
             regs
             frame
             env
             #t)))

; Compiles a let or lambda body.
; The arguments of the lambda expression L are already in
; registers or the stack frame, as specified by regs and frame.
;
; The problem here is that the free variables of an internal
; definition must be in a heap-allocated environment, so any
; such variables in registers must be copied to the heap.
;
; Returns: destination register.

(define (cg-body output L target regs frame env tail?)
  (let* ((exp (lambda.body L))
         (defs (lambda.defs L))
         (free (apply-union
                      (map (lambda (def)
                             (let ((L (def.rhs def)))
                               (difference (lambda.F L)
                                           (lambda.args L))))
                           defs))))
    (cond ((or (null? defs) (constant? exp) (variable? exp))
           (cg0 output exp target regs frame env tail?))
          ((lambda? exp)
           (let* ((free (cg-sort-vars
                         (union free
                                (difference
                                 (lambda.F exp)
                                 (make-null-terminated (lambda.args exp))))
                         regs frame env))
                  (newenv1 (cgenv-extend env
                                         (cons #t free)
                                         (map def.lhs defs)))
                  (args (lambda.args exp))
                  (vars (make-null-terminated args))
                  (newoutput (make-assembly-stream)))
             (assembly-stream-info! newoutput (make-hashtable equal-hash assoc))
             (gen! newoutput $.proc)
             (if (list? args)
                 (gen! newoutput $args= (length args))
                 (gen! newoutput $args>= (- (length vars) 1)))
             (cg-known-lambda newoutput exp newenv1)
             (cg-defs newoutput defs newenv1)
             (cg-eval-vars output free regs frame env)
             (gen! output
                   $lambda
                   (pass4-code newoutput)
                   (length free)
                   (lambda.doc exp))
             (if tail?
                 (begin (gen-pop! output frame)
                        (gen! output $return)
                        'result)
                 (cg-move output frame regs 'result target))))
          ((every? (lambda (def)
                     (every? (lambda (v)
                               (case (entry.kind
                                      (var-lookup v regs frame env))
                                 ((register frame) #f)
                                 (else #t)))
                             (let ((Ldef (def.rhs def)))
                               (difference (lambda.F Ldef)
                                           (lambda.args Ldef)))))
                   defs)
           (let* ((newenv (cgenv-bindprocs env (map def.lhs defs)))
                  (L (make-label))
                  (r (cg0 output exp target regs frame newenv tail?)))
             (if (not tail?)
                 (gen! output $skip L (cgreg-live regs r)))
             (cg-defs output defs newenv)
             (if (not tail?)
                 (gen! output $.label L))
             r))
          (else
           (let ((free (cg-sort-vars free regs frame env)))
             (cg-eval-vars output free regs frame env)
             ; FIXME: Have to restore it too!
             '
             (if (not (ignore-space-leaks))
                 ; FIXME: Is this constant the right one?
                 (begin (gen! output $const #f)
                        (gen! output $setreg 0)))
             (let ((t0 (cgreg-lookup-reg regs 0))
                   (t1 (newtemp))
                   (newenv (cgenv-extend env
                                         (cons #t free)
                                         (map def.lhs defs)))
                   (L (make-label)))
               (gen! output $lexes (length free) free)
               (gen! output $setreg 0)
               (cgreg-bind! regs 0 t1)
               (if tail?
                   (begin (cgframe-release! frame t0)
                          (gen-store! output frame 0 t1)
                          (cg0 output exp 'result regs frame newenv #t)
                          (cg-defs output defs newenv)
                          'result)
                   (begin (gen-store! output frame 0 t1)
                          (cg0 output exp 'result regs frame newenv #f)
                          (gen! output $skip L (cgreg-tos regs))
                          (cg-defs output defs newenv)
                          (gen! output $.label L)
                          (gen-load! output frame 0 t0)
                          (cgreg-bind! regs 0 t0)
                          (cgframe-release! frame t1)
                          (cg-move output frame regs 'result target)))))))))

(define (cg-defs output defs env)
  (for-each (lambda (def)
              (gen! output $.align 4)
              (gen! output $.label
                           (entry.label
                            (cgenv-lookup env (def.lhs def))))
              (gen! output $.proc)
              (gen! output $.proc-doc (lambda.doc (def.rhs def)))
              (cg-known-lambda output
                               (def.rhs def)
                               env))
            defs))

; The right hand side has already been evaluated into the result register.

(define (cg-assignment-result output exp target regs frame env tail?)
  (gen! output $setglbl (assignment.lhs exp))
  (if tail?
      (begin (gen-pop! output frame)
             (gen! output $return)
             'result)
      (cg-move output frame regs 'result target)))

(define (cg-if output exp target regs frame env tail?)
  ; The test can be a constant, because it is awkward
  ; to remove constant tests from an A-normal form.
  (if (constant? (if.test exp))
      (cg0 output
           (if (constant.value (if.test exp))
               (if.then exp)
               (if.else exp))
           target regs frame env tail?)
      (begin
       (cg0 output (if.test exp) 'result regs frame env #f)
       (cg-if-result output exp target regs frame env tail?))))

; The test expression has already been evaluated into the result register.

(define (cg-if-result output exp target regs frame env tail?)
  (let ((L1 (make-label))
        (L2 (make-label)))
    (gen! output $branchf L1 (cgreg-tos regs))
    (let* ((regs2 (cgreg-copy regs))
           (frame1 (if (and tail?
                            (negative? (cgframe-size frame)))
                       (cgframe-initial)
                       frame))
           (frame2 (if (eq? frame frame1)
                       (cgframe-copy frame1)
                       (cgframe-initial)))
           (t0 (cgreg-lookup-reg regs 0)))
      (if (not (eq? frame frame1))
          (let ((live (cgframe-livevars frame)))
            (cgframe-livevars-set! frame1 live)
            (cgframe-livevars-set! frame2 live)
            (gen-save! output frame1 t0)
            (cg-saveregs output regs frame1)))
      (let ((r (cg0 output (if.then exp) target regs frame1 env tail?)))
        (if (not tail?)
            (gen! output $skip L2 (cgreg-live regs r)))
        (gen! output $.label L1)
        (if (not (eq? frame frame1))
            (begin (gen-save! output frame2 t0)
                   (cg-saveregs output regs2 frame2))
            (cgframe-update-stale! frame2))
        (cg0 output (if.else exp) r regs2 frame2 env tail?)
        (if (not tail?)
            (begin (gen! output $.label L2)
                   (cgreg-join! regs regs2)
                   (cgframe-join! frame1 frame2)))
        (if (and (not target)
                 (not (eq? r 'result))
                 (not (cgreg-lookup-reg regs r)))
            (cg-move output frame regs r 'result)
            r)))))

(define (cg-variable output exp target regs frame env tail?)
  (define (return id)
    (if tail?
        (begin (gen-pop! output frame)
               (gen! output $return)
               'result)
        (if (and target
                 (not (eq? 'result target)))
            (begin (gen! output $setreg target)
                   (cgreg-bind! regs target id)
                   (gen-store! output frame target id)
                   target)
            'result)))
  ; Same as return, but doesn't emit a store instruction.
  (define (return-nostore id)
    (if tail?
        (begin (gen-pop! output frame)
               (gen! output $return)
               'result)
        (if (and target
                 (not (eq? 'result target)))
            (begin (gen! output $setreg target)
                   (cgreg-bind! regs target id)
                   target)
            'result)))
  (let* ((id (variable.name exp))
         (entry (var-lookup id regs frame env)))
    (case (entry.kind entry)
      ((global integrable)
       (gen! output $global id)
       (return (newtemp)))
      ((lexical)
       (let ((m (entry.rib entry))
             (n (entry.offset entry)))
         (gen! output $lexical m n id)
         (if (or (zero? m)
                 (negative? (cgframe-size frame)))
             (return-nostore id)
             (return id))))
      ((procedure) (error "Bug in cg-variable" exp))
      ((register)
       (let ((r (entry.regnum entry)))
         (if (or tail?
                 (and target (not (eqv? target r))))
             (begin (gen! output $reg (entry.regnum entry) id)
                    (return-nostore id))
             r)))
      ((frame)
       (cond ((eq? target 'result)
              (gen-stack! output frame id)
              (return id))
             (target
              ; Must be non-tail.
              (gen-load! output frame target id)
              (cgreg-bind! regs target id)
              target)
             (else
              ; Must be non-tail.
              (let ((r (choose-register regs frame)))
                (gen-load! output frame r id)
                (cgreg-bind! regs r id)
                r))))
      (else (error "Bug in cg-variable" exp)))))

(define (cg-sequential output exp target regs frame env tail?)
  (cg-sequential-loop output (begin.exprs exp) target regs frame env tail?))

(define (cg-sequential-loop output exprs target regs frame env tail?)
  (cond ((null? exprs)
         (gen! output $const unspecified)
         (if tail?
             (begin (gen-pop! output frame)
                    (gen! output $return)
                    'result)
             (cg-move output frame regs 'result target)))
        ((null? (cdr exprs))
         (cg0 output (car exprs) target regs frame env tail?))
        (else (cg0 output (car exprs) #f regs frame env #f)
              (cg-sequential-loop output
                                  (cdr exprs)
                                  target regs frame env tail?))))

(define (cg-saveregs output regs frame)
  (do ((i 1 (+ i 1))
       (vars (cdr (cgreg-vars regs)) (cdr vars)))
      ((null? vars))
      (let ((t (car vars)))
        (if t
            (gen-store! output frame i t)))))

(define (cg-move output frame regs src dst)
  (define (bind dst)
    (let ((temp (newtemp)))
      (cgreg-bind! regs dst temp)
      (gen-store! output frame dst temp)
      dst))
  (cond ((not dst)
         src)
        ((eqv? src dst)
         dst)
        ((eq? dst 'result)
         (gen! output $reg src)
         dst)
        ((eq? src 'result)
         (gen! output $setreg dst)
         (bind dst))
        ((and (not (zero? src))
              (not (zero? dst)))
         (gen! output $movereg src dst)
         (bind dst))
        (else
         (gen! output $reg src)
         (gen! output $setreg dst)
         (bind dst))))

; On-the-fly register allocator.
; Tries to allocate:
;    a hardware register that isn't being used
;    a hardware register whose contents have already been spilled
;    a software register that isn't being used, unless a stack
;       frame has already been created, in which case it is better to use
;    a hardware register that is in use and hasn't yet been spilled
;
; All else equal, it is better to allocate a higher-numbered register
; because the lower-numbered registers are targets when arguments
; are being evaluated.
;
; Invariant:  Every register that is returned by this allocator
; is either not in use or has been spilled.

(define (choose-register regs frame)
  (car (choose-registers regs frame 1)))

(define (choose-registers regs frame n)
  
  ; Find unused hardware registers.
  (define (loop1 i n good)
    (cond ((zero? n)
           good)
          ((zero? i)
           (if (negative? (cgframe-size frame))
               (hardcase)
               (loop2 (- *nhwregs* 1) n good)))
          (else
           (if (cgreg-lookup-reg regs i)
               (loop1 (- i 1) n good)
               (loop1 (- i 1)
                      (- n 1)
                      (cons i good))))))
  
  ; Find already spilled hardware registers.
  (define (loop2 i n good)
    (cond ((zero? n)
           good)
          ((zero? i)
           (hardcase))
          (else
           (let ((t (cgreg-lookup-reg regs i)))
             (if (and t (cgframe-spilled? frame t))
                 (loop2 (- i 1)
                        (- n 1)
                        (cons i good))
                 (loop2 (- i 1) n good))))))
  
  ; This is ridiculous.
  ; Fortunately the correctness of the compiler is independent
  ; of the predicate used for this sort.
  
  (define (hardcase)
    (let* ((frame-exists? (not (negative? (cgframe-size frame))))
           (stufftosort
            (map (lambda (r)
                   (let* ((t (cgreg-lookup-reg regs r))
                          (spilled?
                           (and t
                                (cgframe-spilled? frame t))))
                     (list r t spilled?)))
                 (cdr (iota *nregs*))))
           (registers
            (twobit-sort
             (lambda (x1 x2)
               (let ((r1 (car x1))
                     (r2 (car x2))
                     (t1 (cadr x1))
                     (t2 (cadr x2)))
                 (cond ((< r1 *nhwregs*)
                        (cond ((not t1)                     #t)
                              ((< r2 *nhwregs*)
                               (cond ((not t2)              #f)
                                     ((caddr x1)            #t)
                                     ((caddr x2)            #f)
                                     (else                  #t)))
                              (frame-exists?                #t)
                              (t2                           #t)
                              (else                         #f)))
                       ((< r2 *nhwregs*)
                        (cond (frame-exists?                #f)
                              (t1                           #f)
                              (t2                           #t)
                              (else                         #f)))
                       (t1
                        (if (and (caddr x1)
                                 t2
                                 (not (caddr x2)))
                            #t
                            #f))
                       (else #t))))
             stufftosort)))
      ; FIXME: What was this for?
      '
      (for-each (lambda (register)
                  (let ((t (cadr register))
                        (spilled? (caddr register)))
                    (if (and t (not spilled?))
                        (cgframe-touch! frame t))))
                registers)
      (do ((sorted (map car registers) (cdr sorted))
           (rs '() (cons (car sorted) rs))
           (n n (- n 1)))
          ((zero? n)
           (reverse rs)))))
  
  (if (< n *nregs*)
      (loop1 (- *nhwregs* 1) n '())
      (error (string-append "Compiler bug: can't allocate "
                            (number->string n)
                            " registers on this target."))))
; Copyright 1991 William Clinger
;
; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
;
; 21 May 1999.

; Procedure calls.

(define (cg-call output exp target regs frame env tail?)
  (let ((proc (call.proc exp)))
    (cond ((and (lambda? proc)
                (list? (lambda.args proc)))
           (cg-let output exp target regs frame env tail?))
          ((not (variable? proc))
           (cg-unknown-call output exp target regs frame env tail?))
          (else (let ((entry
                       (var-lookup (variable.name proc) regs frame env)))
                  (case (entry.kind entry)
                    ((global lexical frame register)
                     (cg-unknown-call output
                                      exp
                                      target regs frame env tail?))
                    ((integrable)
                     (cg-integrable-call output
                                         exp
                                         target regs frame env tail?))
                    ((procedure)
                     (cg-known-call output
                                    exp
                                    target regs frame env tail?))
                    (else (error "Bug in cg-call" exp))))))))

(define (cg-unknown-call output exp target regs frame env tail?)
  (let* ((proc (call.proc exp))
         (args (call.args exp))
         (n (length args))
         (L (make-label)))
    (cond ((>= (+ n 1) *lastreg*)
           (cg-big-call output exp target regs frame env tail?))
          (else
           (let ((r0 (cgreg-lookup-reg regs 0)))
             (if (variable? proc)
                 (let ((entry (cgreg-lookup regs (variable.name proc))))
                   (if (and entry
                            (<= (entry.regnum entry) n))
                       (begin (cg-arguments output
                                            (iota1 (+ n 1))
                                            (append args (list proc))
                                            regs frame env)
                              (gen! output $reg (+ n 1)))
                       (begin (cg-arguments output
                                            (iota1 n)
                                            args
                                            regs frame env)
                              (cg0 output proc 'result regs frame env #f)))
                   (if tail?
                       (gen-pop! output frame)
                       (begin (cgframe-used! frame)
                              (gen! output $setrtn L)))
                   (gen! output $invoke n))
                 (begin (cg-arguments output
                                      (iota1 (+ n 1))
                                      (append args (list proc))
                                      regs frame env)
                        (gen! output $reg (+ n 1))
                        (if tail?
                            (gen-pop! output frame)
                            (begin (cgframe-used! frame)
                                   (gen! output $setrtn L)))
                        (gen! output $invoke n)))
             (if tail?
                 'result
                 (begin (gen! output $.align 4)
                        (gen! output $.label L)
                        (gen! output $.cont)
                        (cgreg-clear! regs)
                        (cgreg-bind! regs 0 r0)
                        (gen-load! output frame 0 r0)
                        (cg-move output frame regs 'result target))))))))

(define (cg-known-call output exp target regs frame env tail?)
  (let* ((args (call.args exp))
         (n (length args))
         (L (make-label)))
    (cond ((>= (+ n 1) *lastreg*)
           (cg-big-call output exp target regs frame env tail?))
          (else
           (let ((r0 (cgreg-lookup-reg regs 0)))
             (cg-arguments output (iota1 n) args regs frame env)
             (if tail?
                 (gen-pop! output frame)
                 (begin (cgframe-used! frame)
                        (gen! output $setrtn L)))
             (let* ((entry (cgenv-lookup env (variable.name (call.proc exp))))
                    (label (entry.label entry))
                    (m (entry.rib entry)))
               (if (zero? m)
                   (gen! output $branch label n)
                   (gen! output $jump m label n)))
             (if tail?
                 'result
                 (begin (gen! output $.align 4)
                        (gen! output $.label L)
                        (gen! output $.cont)
                        (cgreg-clear! regs)
                        (cgreg-bind! regs 0 r0)
                        (gen-load! output frame 0 r0)
                        (cg-move output frame regs 'result target))))))))

; Any call can be compiled as follows, even if there are no free registers.
;
; Let T0, T1, ..., Tn be newly allocated stack temporaries.
;
;     <arg0>
;     setstk  T0
;     <arg1>             -|
;     setstk  T1          |
;     ...                 |- evaluate args into stack frame
;     <argn>              |
;     setstk  Tn         -|
;     const   ()
;     setreg  R-1
;     stack   Tn         -|
;     op2     cons,R-1    |
;     setreg  R-1         |
;     ...                 |- cons up overflow args
;     stack   T_{R-1}     |
;     op2     cons,R-1    |
;     setreg  R-1        -|
;     stack   T_{R-2}      -|
;     setreg  R-2           |
;     ...                   |- pop remaining args into registers
;     stack   T1            |
;     setreg  1            -|
;     stack   T0
;     invoke  n

(define (cg-big-call output exp target regs frame env tail?)
  (let* ((proc (call.proc exp))
         (args (call.args exp))
         (n (length args))
         (argslots (newtemps n))
         (procslot (newtemp))
         (r0 (cgreg-lookup-reg regs 0))
         (R-1 (- *nregs* 1))
         (entry (if (variable? proc)
                    (let ((entry
                           (var-lookup (variable.name proc)
                                       regs frame env)))
                      (if (eq? (entry.kind entry) 'procedure)
                          entry
                          #f))
                    #f))
         (L (make-label)))
    (if (not entry)
        (begin
         (cg0 output proc 'result regs frame env #f)
         (gen-setstk! output frame procslot)))
    (for-each (lambda (arg argslot)
                (cg0 output arg 'result regs frame env #f)
                (gen-setstk! output frame argslot))
              args
              argslots)
    (cgreg-clear! regs)
    (gen! output $const '())
    (gen! output $setreg R-1)
    (do ((i n (- i 1))
         (slots (reverse argslots) (cdr slots)))
        ((zero? i))
        (if (< i R-1)
            (gen-load! output frame i (car slots))
            (begin (gen-stack! output frame (car slots))
                   (gen! output $op2 $cons R-1)
                   (gen! output $setreg R-1))))
    (if (not entry)
        (gen-stack! output frame procslot))
    (if tail?
        (gen-pop! output frame)
        (begin (cgframe-used! frame)
               (gen! output $setrtn L)))
    (if entry
        (let ((label (entry.label entry))
              (m (entry.rib entry)))
          (if (zero? m)
              (gen! output $branch label n)
              (gen! output $jump m label n)))
        (gen! output $invoke n))
    (if tail?
        'result
        (begin (gen! output $.align 4)
               (gen! output $.label L)
               (gen! output $.cont)
               (cgreg-clear! regs) ; redundant, see above
               (cgreg-bind! regs 0 r0)
               (gen-load! output frame 0 r0)
               (cg-move output frame regs 'result target)))))

(define (cg-integrable-call output exp target regs frame env tail?)
  (let ((args (call.args exp))
        (entry (var-lookup (variable.name (call.proc exp)) regs frame env)))
    (if (= (entry.arity entry) (length args))
        (begin (case (entry.arity entry)
                 ((0) (gen! output $op1 (entry.op entry)))
                 ((1) (cg0 output (car args) 'result regs frame env #f)
                      (gen! output $op1 (entry.op entry)))
                 ((2) (cg-integrable-call2 output
                                           entry
                                           args
                                           regs frame env))
                 ((3) (cg-integrable-call3 output
                                           entry
                                           args
                                           regs frame env))
                 (else (error "Bug detected by cg-integrable-call"
                              (make-readable exp))))
               (if tail?
                   (begin (gen-pop! output frame)
                          (gen! output $return)
                          'result)
                   (cg-move output frame regs 'result target)))
        (if (negative? (entry.arity entry))
            (cg-special output exp target regs frame env tail?)
            (error "Wrong number of arguments to integrable procedure"
                   (make-readable exp))))))

(define (cg-integrable-call2 output entry args regs frame env)
  (let ((op (entry.op entry)))
    (if (and (entry.imm entry)
             (constant? (cadr args))
             ((entry.imm entry) (constant.value (cadr args))))
        (begin (cg0 output (car args) 'result regs frame env #f)
               (gen! output $op2imm
                            op
                            (constant.value (cadr args))))
        (let* ((reg2 (cg0 output (cadr args) #f regs frame env #f))
               (r2 (choose-register regs frame))
               (t2 (if (eq? reg2 'result)
                       (let ((t2 (newtemp)))
                         (gen! output $setreg r2)
                         (cgreg-bind! regs r2 t2)
                         (gen-store! output frame r2 t2)
                         t2)
                       (cgreg-lookup-reg regs reg2))))
          (cg0 output (car args) 'result regs frame env #f)
          (let* ((r2 (or (let ((entry (cgreg-lookup regs t2)))
                           (if entry
                               (entry.regnum entry)
                               #f))
                         (let ((r2 (choose-register regs frame)))
                           (cgreg-bind! regs r2 t2)
                           (gen-load! output frame r2 t2)
                           r2))))
            (gen! output $op2 (entry.op entry) r2)
            (if (eq? reg2 'result)
                (begin (cgreg-release! regs r2)
                       (cgframe-release! frame t2)))))))
  'result)

(define (cg-integrable-call3 output entry args regs frame env)
  (let* ((reg2 (cg0 output (cadr args) #f regs frame env #f))
         (r2 (choose-register regs frame))
         (t2 (if (eq? reg2 'result)
                 (let ((t2 (newtemp)))
                   (gen! output $setreg r2)
                   (cgreg-bind! regs r2 t2)
                   (gen-store! output frame r2 t2)
                   t2)
                 (cgreg-lookup-reg regs reg2)))
         (reg3 (cg0 output (caddr args) #f regs frame env #f))
         (spillregs (choose-registers regs frame 2))
         (t3 (if (eq? reg3 'result)
                 (let ((t3 (newtemp))
                       (r3 (if (eq? t2 (cgreg-lookup-reg
                                        regs (car spillregs)))
                               (cadr spillregs)
                               (car spillregs))))
                   (gen! output $setreg r3)
                   (cgreg-bind! regs r3 t3)
                   (gen-store! output frame r3 t3)
                   t3)
                 (cgreg-lookup-reg regs reg3))))
    (cg0 output (car args) 'result regs frame env #f)
    (let* ((spillregs (choose-registers regs frame 2))
           (r2 (or (let ((entry (cgreg-lookup regs t2)))
                           (if entry
                               (entry.regnum entry)
                               #f))
                   (let ((r2 (car spillregs)))
                     (cgreg-bind! regs r2 t2)
                     (gen-load! output frame r2 t2)
                     r2)))
           (r3 (or (let ((entry (cgreg-lookup regs t3)))
                           (if entry
                               (entry.regnum entry)
                               #f))
                   (let ((r3 (if (eq? r2 (car spillregs))
                                 (cadr spillregs)
                                 (car spillregs))))
                     (cgreg-bind! regs r3 t3)
                     (gen-load! output frame r3 t3)
                     r3))))
      (gen! output $op3 (entry.op entry) r2 r3)
      (if (eq? reg2 'result)
          (begin (cgreg-release! regs r2)
                 (cgframe-release! frame t2)))
      (if (eq? reg3 'result)
          (begin (cgreg-release! regs r3)
                 (cgframe-release! frame t3)))))
  'result)

; Given a short list of expressions that can be evaluated in any order,
; evaluates the first into the result register and the others into any
; register, and returns an ordered list of the registers that contain
; the arguments that follow the first.
; The number of expressions must be less than the number of argument
; registers.

(define (cg-primop-args output args regs frame env)
  
  ; Given a list of expressions to evaluate, a list of variables
  ; and temporary names for arguments that have already been
  ; evaluated, in reverse order, and a mask of booleans that
  ; indicate which temporaries should be released before returning,
  ; returns the correct result.
  
  (define (eval-loop args temps mask)
    (if (null? args)
        (eval-first-into-result temps mask)
        (let ((reg (cg0 output (car args) #f regs frame env #f)))
          (if (eq? reg 'result)
              (let* ((r (choose-register regs frame))
                     (t (newtemp)))
                (gen! output $setreg r)
                (cgreg-bind! regs r t)
                (gen-store! output frame r t)
                (eval-loop (cdr args)
                           (cons t temps)
                           (cons #t mask)))
              (eval-loop (cdr args)
                         (cons (cgreg-lookup-reg regs reg) temps)
                         (cons #f mask))))))
  
  (define (eval-first-into-result temps mask)
    (cg0 output (car args) 'result regs frame env #f)
    (finish-loop (choose-registers regs frame (length temps))
                 temps
                 mask
                 '()))
  
  ; Given a sufficient number of disjoint registers, a list of
  ; variable and temporary names that may need to be loaded into
  ; registers, a mask of booleans that indicates which temporaries
  ; should be released, and a list of registers in forward order,
  ; returns the correct result.
  
  (define (finish-loop disjoint temps mask registers)
    (if (null? temps)
        registers
        (let* ((t (car temps))
               (entry (cgreg-lookup regs t)))
          (if entry
              (let ((r (entry.regnum entry)))
                (if (car mask)
                    (begin (cgreg-release! regs r)
                           (cgframe-release! frame t)))
                (finish-loop disjoint
                             (cdr temps)
                             (cdr mask)
                             (cons r registers)))
              (let ((r (car disjoint)))
                (if (memv r registers)
                    (finish-loop (cdr disjoint) temps mask registers)
                    (begin (gen-load! output frame r t)
                           (cgreg-bind! regs r t)
                           (if (car mask)
                               (begin (cgreg-release! regs r)
                                      (cgframe-release! frame t)))
                           (finish-loop disjoint
                                        (cdr temps)
                                        (cdr mask)
                                        (cons r registers)))))))))
  
  (if (< (length args) *nregs*)
      (eval-loop (cdr args) '() '())
      (error "Bug detected by cg-primop-args" args)))


; Parallel assignment.

; Given a list of target registers, a list of expressions, and a
; compile-time environment, generates code to evaluate the expressions
; into the registers.
;
; Argument evaluation proceeds as follows:
;
; 1.  Evaluate all but one of the complicated arguments.
; 2.  Evaluate remaining arguments.
; 3.  Load spilled arguments from stack.

(define (cg-arguments output targets args regs frame env)
  
  ; Sorts the args and their targets into complicated and
  ; uncomplicated args and targets.
  ; Then it calls evalargs.
  
  (define (sortargs targets args targets1 args1 targets2 args2)
    (if (null? args)
        (evalargs targets1 args1 targets2 args2)
        (let ((target (car targets))
              (arg (car args))
              (targets (cdr targets))
              (args (cdr args)))
          (if (complicated? arg env)
              (sortargs targets
                        args
                        (cons target targets1)
                        (cons arg args1)
                        targets2
                        args2)
              (sortargs targets
                        args
                        targets1
                        args1
                        (cons target targets2)
                        (cons arg args2))))))
  
  ; Given the complicated args1 and their targets1,
  ; and the uncomplicated args2 and their targets2,
  ; evaluates all the arguments into their target registers.
  
  (define (evalargs targets1 args1 targets2 args2)
    (let* ((temps1 (newtemps (length targets1)))
           (temps2 (newtemps (length targets2))))
      (if (not (null? args1))
          (for-each (lambda (arg temp)
                      (cg0 output arg 'result regs frame env #f)
                      (gen-setstk! output frame temp))
                    (cdr args1)
                    (cdr temps1)))
      (if (not (null? args1))
          (evalargs0 (cons (car targets1) targets2)
                     (cons (car args1) args2)
                     (cons (car temps1) temps2))
          (evalargs0 targets2 args2 temps2))
      (for-each (lambda (r t)
                  (let ((temp (cgreg-lookup-reg regs r)))
                    (if (not (eq? temp t))
                        (let ((entry (var-lookup t regs frame env)))
                          (case (entry.kind entry)
                            ((register)
                             (gen! output $movereg (entry.regnum entry) r))
                            ((frame)
                             (gen-load! output frame r t)))
                          (cgreg-bind! regs r t)))
                    (cgframe-release! frame t)))
                (append targets1 targets2)
                (append temps1 temps2))))
  
  (define (evalargs0 targets args temps)
    (if (not (null? targets))
        (let ((para (let* ((regvars (map (lambda (reg)
                                           (cgreg-lookup-reg regs reg))
                                         targets)))
                      (parallel-assignment targets
                                           (map cons regvars targets)
                                           args))))
          (if para
              (let ((targets para)
                    (args (cg-permute args targets para))
                    (temps (cg-permute temps targets para)))
                (for-each (lambda (arg r t)
                            (cg0 output arg r regs frame env #f)
                            (cgreg-bind! regs r t)
                            (gen-store! output frame r t))
                          args
                          para
                          temps))
              (let ((r (choose-register regs frame))
                    (t (car temps)))
                (cg0 output (car args) r regs frame env #f)
                (cgreg-bind! regs r t)
                (gen-store! output frame r t)
                (evalargs0 (cdr targets)
                           (cdr args)
                           (cdr temps)))))))
  
  (if (parallel-assignment-optimization)
      (sortargs (reverse targets) (reverse args) '() '() '() '())
      (cg-evalargs output targets args regs frame env)))

; Left-to-right evaluation of arguments directly into targets.

(define (cg-evalargs output targets args regs frame env)
  (let ((temps (newtemps (length targets))))
    (for-each (lambda (arg r t)
                (cg0 output arg r regs frame env #f)
                (cgreg-bind! regs r t)
                (gen-store! output frame r t))
              args
              targets
              temps)
    (for-each (lambda (r t)
                (let ((temp (cgreg-lookup-reg regs r)))
                  (if (not (eq? temp t))
                      (begin (gen-load! output frame r t)
                             (cgreg-bind! regs r t)))
                  (cgframe-release! frame t)))
              targets
              temps)))

; For heuristic use only.
; An expression is complicated unless it can probably be evaluated
; without saving and restoring any registers, even if it occurs in
; a non-tail position.

(define (complicated? exp env)
  (case (car exp)
    ((quote)    #f)
    ((lambda)   #t)
    ((set!)     (complicated? (assignment.rhs exp) env))
    ((if)       (or (complicated? (if.test exp) env)
                    (complicated? (if.then exp) env)
                    (complicated? (if.else exp) env)))
    ((begin)    (if (variable? exp)
                    #f
                    (some? (lambda (exp)
                             (complicated? exp env))
                           (begin.exprs exp))))
    (else       (let ((proc (call.proc exp)))
                  (if (and (variable? proc)
                           (let ((entry
                                  (cgenv-lookup env (variable.name proc))))
                             (eq? (entry.kind entry) 'integrable)))
                      (some? (lambda (exp)
                               (complicated? exp env))
                             (call.args exp))
                      #t)))))

; Returns a permutation of the src list, permuted the same way the
; key list was permuted to obtain newkey.

(define (cg-permute src key newkey)
  (let ((alist (map cons key (iota (length key)))))
    (do ((newkey newkey (cdr newkey))
         (dest '()
               (cons (list-ref src (cdr (assq (car newkey) alist)))
                     dest)))
        ((null? newkey) (reverse dest)))))

; Given a list of register numbers,
; an association list with entries of the form (name . regnum) giving
; the variable names by which those registers are known in code,
; and a list of expressions giving new values for those registers,
; returns an ordering of the register assignments that implements a
; parallel assignment if one can be found, otherwise returns #f.

(define parallel-assignment
 (lambda (regnums alist exps)
   (if (null? regnums)
       #t
       (let ((x (toposort (dependency-graph regnums alist exps))))
         (if x (reverse x) #f)))))

(define dependency-graph
 (lambda (regnums alist exps)
   (let ((names (map car alist)))
     (do ((regnums regnums (cdr regnums))
          (exps exps (cdr exps))
          (l '() (cons (cons (car regnums)
                             (map (lambda (var) (cdr (assq var alist)))
                                  (intersection (freevariables (car exps))
                                                names)))
                       l)))
         ((null? regnums) l)))))

; Given a nonempty graph represented as a list of the form
;     ((node1 . <list of nodes that node1 is less than or equal to>)
;      (node2 . <list of nodes that node2 is less than or equal to>)
;      ...)
; returns a topological sort of the nodes if one can be found,
; otherwise returns #f.

(define toposort
 (lambda (graph)
   (cond ((null? (cdr graph)) (list (caar graph)))
         (else (toposort2 graph '())))))

(define toposort2
 (lambda (totry tried)
   (cond ((null? totry) #f)
         ((or (null? (cdr (car totry)))
              (and (null? (cddr (car totry)))
                   (eq? (cadr (car totry))
                        (car (car totry)))))
          (if (and (null? (cdr totry)) (null? tried))
              (list (caar totry))
              (let* ((node (caar totry))
                     (x (toposort2 (map (lambda (y)
                                          (cons (car y) (remove node (cdr y))))
                                        (append (cdr totry) tried))
                                   '())))
                (if x
                    (cons node x)
                    #f))))
         (else (toposort2 (cdr totry) (cons (car totry) tried))))))

(define iota (lambda (n) (iota2 n '())))

(define iota1 (lambda (n) (cdr (iota2 (+ n 1) '()))))

(define iota2
 (lambda (n l)
   (if (zero? n)
       l
       (let ((n (- n 1)))
         (iota2 n (cons n l))))))

(define (freevariables exp)
  (freevars2 exp '()))

(define (freevars2 exp env)
  (cond ((symbol? exp)
         (if (memq exp env) '() (list exp)))
        ((not (pair? exp)) '())
        (else (let ((keyword (car exp)))
                (cond ((eq? keyword 'quote) '())
                      ((eq? keyword 'lambda)
                       (let ((env (append (make-null-terminated (cadr exp))
                                          env)))
                         (apply-union
                          (map (lambda (x) (freevars2 x env))
                               (cddr exp)))))
                      ((memq keyword '(if set! begin))
                       (apply-union
                        (map (lambda (x) (freevars2 x env))
                             (cdr exp))))
                      (else (apply-union
                             (map (lambda (x) (freevars2 x env))
                                  exp))))))))
; Copyright 1991 William Clinger (cg-let and cg-let-body)
; Copyright 1999 William Clinger (everything else)
;
; 10 June 1999.

; Generates code for a let expression.

(define (cg-let output exp target regs frame env tail?)
  (let* ((proc (call.proc exp))
         (vars (lambda.args proc))
         (n (length vars))
         (free (lambda.F proc))
         (live (cgframe-livevars frame)))
    (if (and (null? (lambda.defs proc))
             (= n 1))
        (cg-let1 output exp target regs frame env tail?)
        (let* ((args (call.args exp))
               (temps (newtemps n))
               (alist (map cons temps vars)))
          (for-each (lambda (arg t)
                      (let ((r (choose-register regs frame)))
                        (cg0 output arg r regs frame env #f)
                        (cgreg-bind! regs r t)
                        (gen-store! output frame r t)))
                    args
                    temps)
          (cgreg-rename! regs alist)
          (cgframe-rename! frame alist)
          (cg-let-release! free live regs frame tail?)
          (cg-let-body output proc target regs frame env tail?)))))

; Given the free variables of a let body, and the variables that are
; live after the let expression, and the usual regs, frame, and tail?
; arguments, releases any registers and frame slots that don't need
; to be preserved across the body of the let.

(define (cg-let-release! free live regs frame tail?)
  ; The tail case is easy because there are no live temporaries,
  ; and there are no free variables in the context.
  ; The non-tail case assumes A-normal form.
  (cond (tail?
         (let ((keepers (cons (cgreg-lookup-reg regs 0) free)))
           (cgreg-release-except! regs keepers)
           (cgframe-release-except! frame keepers)))
        (live
         (let ((keepers (cons (cgreg-lookup-reg regs 0)
                              (union live free))))
           (cgreg-release-except! regs keepers)
           (cgframe-release-except! frame keepers)))))

; Generates code for the body of a let.

(define (cg-let-body output L target regs frame env tail?)
  (let ((vars (lambda.args L))
        (free (lambda.F L))
        (live (cgframe-livevars frame)))
    (let ((r (cg-body output L target regs frame env tail?)))
      (for-each (lambda (v)
                  (let ((entry (cgreg-lookup regs v)))
                    (if entry
                        (cgreg-release! regs (entry.regnum entry)))
                    (cgframe-release! frame v)))
                vars)
      (if (and (not target)
               (not (eq? r 'result))
               (not (cgreg-lookup-reg regs r)))
          (cg-move output frame regs r 'result)
          r))))

; Generates code for a let expression that binds exactly one variable
; and has no internal definitions.  These let expressions are very
; common in A-normal form, and there are many special cases with
; respect to register allocation and order of evaluation.

(define (cg-let1 output exp target regs frame env tail?)
  (let* ((proc (call.proc exp))
         (v (car (lambda.args proc)))
         (arg (car (call.args exp)))
         (free (lambda.F proc))
         (live (cgframe-livevars frame))
         (body (lambda.body proc)))
    
    (define (evaluate-into-register r)
      (cg0 output arg r regs frame env #f)
      (cgreg-bind! regs r v)
      (gen-store! output frame r v)
      r)
    
    (define (release-registers!)
      (cgframe-livevars-set! frame live)
      (cg-let-release! free live regs frame tail?))
    
    (define (finish)
      (release-registers!)
      (cg-let-body output proc target regs frame env tail?))
    
    (if live
        (cgframe-livevars-set! frame (union live free)))
    
    (cond ((assq v *regnames*)
           (evaluate-into-register (cdr (assq v *regnames*)))
           (finish))
          ((not (memq v free))
           (cg0 output arg #f regs frame env #f)
           (finish))
          (live
           (cg0 output arg 'result regs frame env #f)
           (release-registers!)
           (cg-let1-result output exp target regs frame env tail?))
          (else
           (evaluate-into-register (choose-register regs frame))
           (finish)))))

; Given a let expression that binds one variable whose value has already
; been evaluated into the result register, generates code for the rest
; of the let expression.
; The main difficulty is an unfortunate interaction between A-normal
; form and the MacScheme machine architecture:  We don't want to move
; a value from the result register into a general register if it has
; only one use and can remain in the result register until that use.

(define (cg-let1-result output exp target regs frame env tail?)
  (let* ((proc (call.proc exp))
         (v (car (lambda.args proc)))
         (free (lambda.F proc))
         (live (cgframe-livevars frame))
         (body (lambda.body proc))
         (pattern (cg-let-used-once v body)))
    
    (define (move-to-register r)
      (gen! output $setreg r)
      (cgreg-bind! regs r v)
      (gen-store! output frame r v)
      r)
    
    (define (release-registers!)
      (cgframe-livevars-set! frame live)
      (cg-let-release! free live regs frame tail?))
    
    ; FIXME: The live variables must be correct in the frame.
    
    (case pattern
      ((if)
       (cg-if-result output body target regs frame env tail?))
      ((let-if)
       (if live
           (cgframe-livevars-set! frame (union live free)))
       (cg-if-result output
                     (car (call.args body))
                     'result regs frame env #f)
       (release-registers!)
       (cg-let1-result output body target regs frame env tail?))
      ((set!)
       (cg-assignment-result output
                             body target regs frame env tail?))
      ((let-set!)
       (cg-assignment-result output
                             (car (call.args body))
                             'result regs frame env #f)
       (cg-let1-result output body target regs frame env tail?))
      ((primop)
       (cg-primop-result output body target regs frame env tail?))
      ((let-primop)
       (cg-primop-result output
                         (car (call.args body))
                         'result regs frame env #f)
       (cg-let1-result output body target regs frame env tail?))
      ; FIXME
      ((_called)
       (cg-call-result output body target regs frame env tail?))
      ; FIXME
      ((_let-called)
       (cg-call-result output
                       (car (call.args body))
                       'result regs frame env #f)
       (cg-let1-result output body target regs frame env tail?))
      (else
       ; FIXME:  The first case was handled by cg-let1.
       (cond ((assq v *regnames*)
              (move-to-register (cdr (assq v *regnames*))))
             ((memq v free)
              (move-to-register (choose-register regs frame))))
       (cg-let-body output proc target regs frame env tail?)))))

; Given a call to a primop whose first argument has already been
; evaluated into the result register and whose remaining arguments
; consist of constants and variable references, generates code for
; the call.

(define (cg-primop-result output exp target regs frame env tail?)
  (let ((args (call.args exp))
        (entry (var-lookup (variable.name (call.proc exp)) regs frame env)))
    (if (= (entry.arity entry) (length args))
        (begin (case (entry.arity entry)
                 ((0) (gen! output $op1 (entry.op entry)))
                 ((1) (gen! output $op1 (entry.op entry)))
                 ((2) (cg-primop2-result! output entry args regs frame env))
                 ((3) (let ((rs (cg-result-args output args regs frame env)))
                        (gen! output
                              $op3 (entry.op entry) (car rs) (cadr rs))))
                 (else (error "Bug detected by cg-primop-result"
                              (make-readable exp))))
               (if tail?
                   (begin (gen-pop! output frame)
                          (gen! output $return)
                          'result)
                   (cg-move output frame regs 'result target)))
        (if (negative? (entry.arity entry))
            (cg-special-result output exp target regs frame env tail?)
            (error "Wrong number of arguments to integrable procedure"
                   (make-readable exp))))))

(define (cg-primop2-result! output entry args regs frame env)
  (let ((op (entry.op entry))
        (arg2 (cadr args)))
    (if (and (constant? arg2)
             (entry.imm entry)
             ((entry.imm entry) (constant.value arg2)))
        (gen! output $op2imm op (constant.value arg2))
        (let ((rs (cg-result-args output args regs frame env)))
          (gen! output $op2 op (car rs))))))

; Given a short list of constants and variable references to be evaluated
; into arbitrary general registers, evaluates them into registers without
; disturbing the result register and returns a list of the registers into
; which they are evaluated.  Before returning, any registers that were
; allocated by this routine are released.

(define (cg-result-args output args regs frame env)
  
  ; Given a list of unevaluated arguments,
  ; a longer list of disjoint general registers,
  ; the register that holds the first evaluated argument,
  ; a list of registers in reverse order that hold other arguments,
  ; and a list of registers to be released afterwards,
  ; generates code to evaluate the arguments,
  ; deallocates any registers that were evaluated to hold the arguments,
  ; and returns the list of registers that contain the arguments.
  
  (define (loop args registers rr rs temps)
    (if (null? args)
        (begin (if (not (eq? rr 'result))
                   (gen! output $reg rr))
               (for-each (lambda (r) (cgreg-release! regs r))
                         temps)
               (reverse rs))
        (let ((arg (car args)))
          (cond ((constant? arg)
                 (let ((r (car registers)))
                   (gen! output $const/setreg (constant.value arg) r)
                   (cgreg-bind! regs r #t)
                   (loop (cdr args)
                         (cdr registers)
                         rr
                         (cons r rs)
                         (cons r temps))))
                ((variable? arg)
                 (let* ((id (variable.name arg))
                        (entry (var-lookup id regs frame env)))
                   (case (entry.kind entry)
                     ((global integrable)
                      (if (eq? rr 'result)
                          (save-result! args registers rr rs temps)
                          (let ((r (car registers)))
                            (gen! output $global id)
                            (gen! output $setreg r)
                            (cgreg-bind! regs r id)
                            (loop (cdr args)
                                  (cdr registers)
                                  rr
                                  (cons r rs)
                                  (cons r temps)))))
                     ((lexical)
                      (if (eq? rr 'result)
                          (save-result! args registers rr rs temps)
                          (let ((m (entry.rib entry))
                                (n (entry.offset entry))
                                (r (car registers)))
                            (gen! output $lexical m n id)
                            (gen! output $setreg r)
                            (cgreg-bind! regs r id)
                            (loop (cdr args)
                                  (cdr registers)
                                  rr
                                  (cons r rs)
                                  (cons r temps)))))
                     ((procedure) (error "Bug in cg-variable" arg))
                     ((register)
                      (let ((r (entry.regnum entry)))
                        (loop (cdr args)
                              registers
                              rr
                              (cons r rs)
                              temps)))
                     ((frame)
                      (let ((r (car registers)))
                        (gen-load! output frame r id)
                        (cgreg-bind! regs r id)
                        (loop (cdr args)
                              (cdr registers)
                              rr
                              (cons r rs)
                              (cons r temps))))
                     (else (error "Bug in cg-result-args" arg)))))
                (else
                 (error "Bug in cg-result-args"))))))
  
  (define (save-result! args registers rr rs temps)
    (let ((r (car registers)))
      (gen! output $setreg r)
      (loop args
            (cdr registers)
            r
            rs
            temps)))
  
  (loop (cdr args)
        (choose-registers regs frame (length args))
        'result '() '()))

; Given a local variable T1 and an expression in A-normal form,
; cg-let-used-once returns a symbol if the local variable is used
; exactly once in the expression and the expression matches one of
; the patterns below.  Otherwise returns #f.  The symbol that is
; returned is the name of the pattern that is matched.
;
;     pattern                         symbol returned
; 
;     (if T1 ... ...)                 if
; 
;     (<primop> T1 ...)               primop
; 
;     (T1 ...)                        called
; 
;     (set! ... T1)                   set!
; 
;     (let ((T2 (if T1 ... ...)))     let-if
;       E3)
; 
;     (let ((T2 (<primop> T1 ...)))   let-primop
;       E3)
; 
;     (let ((T2 (T1 ...)))            let-called
;       E3)
; 
;     (let ((T2 (set! ... T1)))       let-set!
;       E3)
;
; This implementation sometimes returns #f incorrectly, but it always
; returns an answer in constant time (assuming A-normal form).

(define (cg-let-used-once T1 exp)
  (define budget 20)
  (define (cg-let-used-once T1 exp)
    (define (used? T1 exp)
      (set! budget (- budget 1))
      (cond ((negative? budget) #t)
            ((constant? exp) #f)
            ((variable? exp)
             (eq? T1 (variable.name exp)))
            ((lambda? exp)
             (memq T1 (lambda.F exp)))
            ((assignment? exp)
             (used? T1 (assignment.rhs exp)))
            ((call? exp)
             (or (used? T1 (call.proc exp))
                 (used-in-args? T1 (call.args exp))))
            ((conditional? exp)
             (or (used? T1 (if.test exp))
                 (used? T1 (if.then exp))
                 (used? T1 (if.else exp))))
            (else #t)))
    (define (used-in-args? T1 args)
      (if (null? args)
          #f
          (or (used? T1 (car args))
              (used-in-args? T1 (cdr args)))))
    (set! budget (- budget 1))
    (cond ((negative? budget) #f)
          ((call? exp)
           (let ((proc (call.proc exp))
                 (args (call.args exp)))
             (cond ((variable? proc)
                    (let ((f (variable.name proc)))
                      (cond ((eq? f T1)
                             (and (not (used-in-args? T1 args))
                                  'called))
                            ((and (integrable? f)
                                  (not (null? args))
                                  (variable? (car args))
                                  (eq? T1 (variable.name (car args))))
                             (and (not (used-in-args? T1 (cdr args)))
                                  'primop))
                            (else #f))))
                   ((lambda? proc)
                    (and (not (memq T1 (lambda.F proc)))
                         (not (null? args))
                         (null? (cdr args))
                         (case (cg-let-used-once T1 (car args))
                           ((if)       'let-if)
                           ((primop)   'let-primop)
                           ((called)   'let-called)
                           ((set!)     'let-set!)
                           (else       #f))))
                   (else #f))))
          ((conditional? exp)
           (let ((E0 (if.test exp)))
             (and (variable? E0)
                  (eq? T1 (variable.name E0))
                  (not (used? T1 (if.then exp)))
                  (not (used? T1 (if.else exp)))
                  'if)))
          ((assignment? exp)
           (let ((rhs (assignment.rhs exp)))
             (and (variable? rhs)
                  (eq? T1 (variable.name rhs))
                  'set!)))
          (else #f)))
  (cg-let-used-once T1 exp))

; Given the name of a let-body pattern, an expression that matches that
; pattern, and an expression to be substituted for the let variable,
; returns the transformed expression.

; FIXME: No longer used.

(define (cg-let-transform pattern exp E1)
  (case pattern
    ((if)
     (make-conditional E1 (if.then exp) (if.else exp)))
    ((primop)
     (make-call (call.proc exp)
                (cons E1 (cdr (call.args exp)))))
    ((called)
     (make-call E1 (call.args exp)))
    ((set!)
     (make-assignment (assignment.lhs exp) E1))
    ((let-if let-primop let-called let-set!)
     (make-call (call.proc exp)
                (list (cg-let-transform (case pattern
                                          ((let-if)     'if)
                                          ((let-primop) 'primop)
                                          ((let-called) 'called)
                                          ((let-set!)   'set!))
                                        (car (call.args exp))
                                        E1))))
    (else
     (error "Unrecognized pattern in cg-let-transform" pattern)))); Copyright 1999 William Clinger
;
; Code for special primitives, used to generate runtime safety checks,
; efficient code for call-with-values, and other weird things.
;
; 4 June 1999.

(define (cg-special output exp target regs frame env tail?)
  (let ((name (variable.name (call.proc exp))))
    (cond ((eq? name name:CHECK!)
           (if (runtime-safety-checking)
               (cg-check output exp target regs frame env tail?)))
          (else
           (error "Compiler bug: cg-special" (make-readable exp))))))

(define (cg-special-result output exp target regs frame env tail?)
  (let ((name (variable.name (call.proc exp))))
    (cond ((eq? name name:CHECK!)
           (if (runtime-safety-checking)
               (cg-check-result output exp target regs frame env tail?)))
          (else
           (error "Compiler bug: cg-special" (make-readable exp))))))

(define (cg-check output exp target regs frame env tail?)
  (cg0 output (car (call.args exp)) 'result regs frame env #f)
  (cg-check-result output exp target regs frame env tail?))

(define (cg-check-result output exp target regs frame env tail?)
  (let* ((args (call.args exp))
         (nargs (length args))
         (valexps (cddr args)))
    (if (and (<= 2 nargs 5)
             (constant? (cadr args))
             (every? (lambda (exp)
                       (or (constant? exp)
                           (variable? exp)))
                     valexps))
        (let* ((exn (constant.value (cadr args)))
               (vars (filter variable? valexps))
               (rs (cg-result-args output
                                   (cons (car args) vars)
                                   regs frame env)))
          
          ; Construct the trap situation:
          ; the exception number followed by an ordered list of
          ; register numbers and constant expressions.
          
          (let loop ((registers rs)
                     (exps valexps)
                     (operands '()))
            (cond ((null? exps)
                   (let* ((situation (cons exn (reverse operands)))
                          (ht (assembly-stream-info output))
                          (L1 (or (hashtable-get ht situation)
                                  (let ((L1 (make-label)))
                                    (hashtable-put! ht situation L1)
                                    L1))))
                     (define (translate r)
                       (if (number? r) r 0))
                     (case (length operands)
                       ((0) (gen! output $check 0 0 0 L1))
                       ((1) (gen! output $check
                                         (translate (car operands))
                                         0 0 L1))
                       ((2) (gen! output $check
                                         (translate (car operands))
                                         (translate (cadr operands))
                                         0 L1))
                       ((3) (gen! output $check
                                         (translate (car operands))
                                         (translate (cadr operands))
                                         (translate (caddr operands))
                                         L1)))))
                  ((constant? (car exps))
                   (loop registers
                         (cdr exps)
                         (cons (car exps) operands)))
                  (else
                   (loop (cdr registers)
                         (cdr exps)
                         (cons (car registers) operands))))))
        (error "Compiler bug: runtime check" (make-readable exp)))))

; Given an assembly stream and the description of a trap as recorded
; by cg-check above, generates a non-continuable trap at that label for
; that trap, passing the operands to the exception handler.

(define (cg-trap output situation L1)
  (let* ((exn (car situation))
         (operands (cdr situation)))
    (gen! output $.label L1)
    (let ((liveregs (filter number? operands)))
      (define (loop operands registers r)
        (cond ((null? operands)
               (case (length registers)
                 ((0) (gen! output $trap 0 0 0 exn))
                 ((1) (gen! output $trap (car registers) 0 0 exn))
                 ((2) (gen! output $trap
                                   (car registers)
                                   (cadr registers)
                                   0
                                   exn))
                 ((3) (gen! output $trap
                                   (car registers)
                                   (cadr registers)
                                   (caddr registers)
                                   exn))
                 (else "Compiler bug: trap")))
              ((number? (car operands))
               (loop (cdr operands)
                     (cons (car operands) registers)
                     r))
              ((memv r liveregs)
               (loop operands registers (+ r 1)))
              (else
               (gen! output $const (constant.value (car operands)))
               (gen! output $setreg r)
               (loop (cdr operands)
                     (cons r registers)
                     (+ r 1)))))
      (loop (reverse operands) '() 1))))

; Given a short list of expressions that can be evaluated in any order,
; evaluates the first into the result register and the others into any
; register, and returns an ordered list of the registers that contain
; the arguments that follow the first.
; The number of expressions must be less than the number of argument
; registers.

; FIXME: No longer used.

(define (cg-check-args output args regs frame env)
  
  ; Given a list of expressions to evaluate, a list of variables
  ; and temporary names for arguments that have already been
  ; evaluated, in reverse order, and a mask of booleans that
  ; indicate which temporaries should be released before returning,
  ; returns the correct result.
  
  (define (eval-loop args temps mask)
    (if (null? args)
        (eval-first-into-result temps mask)
        (let ((reg (cg0 output (car args) #f regs frame env #f)))
          (if (eq? reg 'result)
              (let* ((r (choose-register regs frame))
                     (t (newtemp)))
                (gen! output $setreg r)
                (cgreg-bind! regs r t)
                (gen-store! output frame r t)
                (eval-loop (cdr args)
                           (cons t temps)
                           (cons #t mask)))
              (eval-loop (cdr args)
                         (cons (cgreg-lookup-reg regs reg) temps)
                         (cons #f mask))))))
  
  (define (eval-first-into-result temps mask)
    (cg0 output (car args) 'result regs frame env #f)
    (finish-loop (choose-registers regs frame (length temps))
                 temps
                 mask
                 '()))
  
  ; Given a sufficient number of disjoint registers, a list of
  ; variable and temporary names that may need to be loaded into
  ; registers, a mask of booleans that indicates which temporaries
  ; should be released, and a list of registers in forward order,
  ; returns the correct result.
  
  (define (finish-loop disjoint temps mask registers)
    (if (null? temps)
        registers
        (let* ((t (car temps))
               (entry (cgreg-lookup regs t)))
          (if entry
              (let ((r (entry.regnum entry)))
                (if (car mask)
                    (begin (cgreg-release! regs r)
                           (cgframe-release! frame t)))
                (finish-loop disjoint
                             (cdr temps)
                             (cdr mask)
                             (cons r registers)))
              (let ((r (car disjoint)))
                (if (memv r registers)
                    (finish-loop (cdr disjoint) temps mask registers)
                    (begin (gen-load! output frame r t)
                           (cgreg-bind! regs r t)
                           (if (car mask)
                               (begin (cgreg-release! regs r)
                                      (cgframe-release! frame t)))
                           (finish-loop disjoint
                                        (cdr temps)
                                        (cdr mask)
                                        (cons r registers)))))))))
  
  (if (< (length args) *nregs*)
      (eval-loop (cdr args) '() '())
      (error "Bug detected by cg-primop-args" args)))
; Copyright 1998 William Clinger.
;
; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
;
; 5 June 1999.
;
; Local optimizations for MacScheme machine assembly code.
;
; Branch tensioning.
; Suppress nop instructions.
; Suppress save, restore, and pop instructions whose operand is -1.
; Suppress redundant stores.
; Suppress definitions (primarily loads) of dead registers.
;
; Note:  Twobit never generates a locally redundant load or store,
; so this code must be tested with a different code generator.
;
; To perform these optimizations, the basic block must be traversed
; both forwards and backwards.
; The forward traversal keeps track of registers that were defined
; by a load.
; The backward traversal keeps track of live registers.

(define filter-basic-blocks
  
  (let* ((suppression-message
          "Local optimization detected a useless instruction.")
         
         ; Each instruction is mapping to an encoding of the actions
         ; to be performed when it is encountered during the forward
         ; or backward traversal.
         
         (forward:normal                   0)
         (forward:nop                      1)
         (forward:ends-block               2)
         (forward:interesting              3)
         (forward:kills-all-registers      4)
         (forward:nop-if-arg1-is-negative  5)
         
         (backward:normal                  0)
         (backward:ends-block              1)
         (backward:begins-block            2)
         (backward:uses-arg1               4)
         (backward:uses-arg2               8)
         (backward:uses-arg3              16)
         (backward:kills-arg1             32)
         (backward:kills-arg2             64)
         (backward:uses-many             128)
         
         ; largest mnemonic + 1
         
         (dispatch-table-size *number-of-mnemonics*)
         
         ; Dispatch table for the forwards traversal.
         
         (forward-table (make-bytevector dispatch-table-size))
         
         ; Dispatch table for the backwards traversal.
         
         (backward-table (make-bytevector dispatch-table-size)))
    
    (do ((i 0 (+ i 1)))
        ((= i dispatch-table-size))
        (bytevector-set! forward-table i forward:normal)
        (bytevector-set! backward-table i backward:normal))
    
    (bytevector-set! forward-table $nop     forward:nop)
    
    (bytevector-set! forward-table $invoke  forward:ends-block)
    (bytevector-set! forward-table $return  forward:ends-block)
    (bytevector-set! forward-table $skip    forward:ends-block)
    (bytevector-set! forward-table $branch  forward:ends-block)
    (bytevector-set! forward-table $branchf forward:ends-block)
    (bytevector-set! forward-table $jump    forward:ends-block)
    (bytevector-set! forward-table $.align  forward:ends-block)
    (bytevector-set! forward-table $.proc   forward:ends-block)
    (bytevector-set! forward-table $.cont   forward:ends-block)
    (bytevector-set! forward-table $.label  forward:ends-block)
    
    (bytevector-set! forward-table $store   forward:interesting)
    (bytevector-set! forward-table $load    forward:interesting)
    (bytevector-set! forward-table $setstk  forward:interesting)
    (bytevector-set! forward-table $setreg  forward:interesting)
    (bytevector-set! forward-table $movereg forward:interesting)
    (bytevector-set! forward-table $const/setreg
                                            forward:interesting)
    
    (bytevector-set! forward-table $args>=  forward:kills-all-registers)
    (bytevector-set! forward-table $popstk  forward:kills-all-registers)
    
    ; These instructions also kill all registers.
    
    (bytevector-set! forward-table $save    forward:nop-if-arg1-is-negative)
    (bytevector-set! forward-table $restore forward:nop-if-arg1-is-negative)
    (bytevector-set! forward-table $pop     forward:nop-if-arg1-is-negative)
  
    (bytevector-set! backward-table $invoke  backward:ends-block)
    (bytevector-set! backward-table $return  backward:ends-block)
    (bytevector-set! backward-table $skip    backward:ends-block)
    (bytevector-set! backward-table $branch  backward:ends-block)
    (bytevector-set! backward-table $branchf backward:ends-block)
    
    (bytevector-set! backward-table $jump    backward:begins-block) ; [sic]
    (bytevector-set! backward-table $.align  backward:begins-block)
    (bytevector-set! backward-table $.proc   backward:begins-block)
    (bytevector-set! backward-table $.cont   backward:begins-block)
    (bytevector-set! backward-table $.label  backward:begins-block)
    
    (bytevector-set! backward-table $op2     backward:uses-arg2)
    (bytevector-set! backward-table $op3     (logior backward:uses-arg2
                                                     backward:uses-arg3))
    (bytevector-set! backward-table $check   (logior
                                              backward:uses-arg1
                                              (logior backward:uses-arg2
                                                      backward:uses-arg3)))
    (bytevector-set! backward-table $trap    (logior
                                              backward:uses-arg1
                                              (logior backward:uses-arg2
                                                      backward:uses-arg3)))
    (bytevector-set! backward-table $store   backward:uses-arg1)
    (bytevector-set! backward-table $reg     backward:uses-arg1)
    (bytevector-set! backward-table $load    backward:kills-arg1)
    (bytevector-set! backward-table $setreg  backward:kills-arg1)
    (bytevector-set! backward-table $movereg (logior backward:uses-arg1
                                                     backward:kills-arg2))
    (bytevector-set! backward-table $const/setreg
                                             backward:kills-arg2)
    (bytevector-set! backward-table $lambda  backward:uses-many)
    (bytevector-set! backward-table $lexes   backward:uses-many)
    (bytevector-set! backward-table $args>=  backward:uses-many)
    
    (lambda (instructions)
      
      (let* ((*nregs* *nregs*) ; locals might be faster than globals
             
             ; During the forwards traversal:
             ;    (vector-ref registers i) = #f
             ;        means the content of register i is unknown
             ;    (vector-ref registers i) = j
             ;        means register was defined by load i,j
             ;
             ; During the backwards traversal:
             ;    (vector-ref registers i) = #f means register i is dead
             ;    (vector-ref registers i) = #t means register i is live
             
             (registers (make-vector *nregs* #f))
             
             ; During the forwards traversal, the label of a block that
             ; falls through into another block or consists of a skip
             ; to another block is mapped to another label.
             ; This mapping is implemented by a hash table.
             ; Before the backwards traversal, the transitive closure
             ; is computed.  The graph has no cycles, and the maximum
             ; out-degree is 1, so this is easy.
             
             (label-table (make-hashtable (lambda (n) n) assv)))
        
        (define (compute-transitive-closure!)
          (define (lookup x)
            (let ((y (hashtable-get label-table x)))
              (if y
                  (lookup y)
                  x)))
          (hashtable-for-each (lambda (x y)
                                (hashtable-put! label-table x (lookup y)))
                              label-table))
        
        ; Don't use this procedure until the preceding procedure
        ; has been called.
        
        (define (lookup-label x)
          (hashtable-fetch label-table x x))
        
        (define (vector-fill! v x)
          (subvector-fill! v 0 (vector-length v) x))
        
        (define (subvector-fill! v i j x)
          (if (< i j)
              (begin (vector-set! v i x)
                     (subvector-fill! v (+ i 1) j x))))
        
        (define (kill-stack! j)
          (do ((i 0 (+ i 1)))
              ((= i *nregs*))
              (let ((x (vector-ref registers i)))
                (if (and x (= x j))
                    (vector-set! registers i #f)))))
        
        ; Dispatch procedure for the forwards traversal.
        
        (define (forwards instructions filtered)
          (if (null? instructions)
              (begin (vector-fill! registers #f)
                     (vector-set! registers 0 #t)
                     (compute-transitive-closure!)
                     (backwards0 filtered '()))
              (let* ((instruction (car instructions))
                     (instructions (cdr instructions))
                     (op (instruction.op instruction))
                     (flags (bytevector-ref forward-table op)))
                (cond ((eqv? flags forward:normal)
                       (forwards instructions (cons instruction filtered)))
                      ((eqv? flags forward:nop)
                       (forwards instructions filtered))
                      ((eqv? flags forward:nop-if-arg1-is-negative)
                       (if (negative? (instruction.arg1 instruction))
                           (forwards instructions filtered)
                           (begin (vector-fill! registers #f)
                                  (forwards instructions
                                            (cons instruction filtered)))))
                      ((eqv? flags forward:kills-all-registers)
                       (vector-fill! registers #f)
                       (forwards instructions
                                 (cons instruction filtered)))
                      ((eqv? flags forward:ends-block)
                       (vector-fill! registers #f)
                       (if (eqv? op $.label)
                           (forwards-label instruction
                                           instructions
                                           filtered)
                           (forwards instructions
                                     (cons instruction filtered))))
                      ((eqv? flags forward:interesting)
                       (cond ((eqv? op $setreg)
                              (vector-set! registers
                                           (instruction.arg1 instruction)
                                           #f)
                              (forwards instructions
                                        (cons instruction filtered)))
                             ((eqv? op $const/setreg)
                              (vector-set! registers
                                           (instruction.arg2 instruction)
                                           #f)
                              (forwards instructions
                                        (cons instruction filtered)))
                             ((eqv? op $movereg)
                              (vector-set! registers
                                           (instruction.arg2 instruction)
                                           #f)
                              (forwards instructions
                                        (cons instruction filtered)))
                             ((eqv? op $setstk)
                              (kill-stack! (instruction.arg1 instruction))
                              (forwards instructions
                                        (cons instruction filtered)))
                             ((eqv? op $load)
                              (let ((i (instruction.arg1 instruction))
                                    (j (instruction.arg2 instruction)))
                                (if (eqv? (vector-ref registers i) j)
                                    ; Suppress redundant load.
                                    ; Should never happen with Twobit.
                                    (suppress-forwards instruction
                                                       instructions
                                                       filtered)
                                    (begin (vector-set! registers i j)
                                           (forwards instructions
                                                     (cons instruction
                                                           filtered))))))
                             ((eqv? op $store)
                              (let ((i (instruction.arg1 instruction))
                                    (j (instruction.arg2 instruction)))
                                (if (eqv? (vector-ref registers i) j)
                                    ; Suppress redundant store.
                                    ; Should never happen with Twobit.
                                    (suppress-forwards instruction
                                                       instructions
                                                       filtered)
                                    (begin (kill-stack! j)
                                           (forwards instructions
                                                     (cons instruction
                                                           filtered))))))
                             (else
                              (local-optimization-error op))))
                      (else
                       (local-optimization-error op))))))
        
        ; Enters labels into a table for branch tensioning.
        
        (define (forwards-label instruction1 instructions filtered)
          (let ((label1 (instruction.arg1 instruction1)))
            (if (null? instructions)
                ; This is ok provided the label is unreachable.
                (forwards instructions (cdr filtered))
                (let loop ((instructions instructions)
                           (filtered (cons instruction1 filtered)))
                  (let* ((instruction (car instructions))
                         (op (instruction.op instruction))
                         (flags (bytevector-ref forward-table op)))
                    (cond ((eqv? flags forward:nop)
                           (loop (cdr instructions) filtered))
                          ((and (eqv? flags forward:nop-if-arg1-is-negative)
                                (negative? (instruction.arg1 instruction)))
                           (loop (cdr instructions) filtered))
                          ((eqv? op $.label)
                           (let ((label2 (instruction.arg1 instruction)))
                             (hashtable-put! label-table label1 label2)
                             (forwards-label instruction
                                             (cdr instructions)
                                             (cdr filtered))))
                          ((eqv? op $skip)
                           (let ((label2 (instruction.arg1 instruction)))
                             (hashtable-put! label-table label1 label2)
                             ; We can't get rid of the skip instruction
                             ; because control might fall into this block,
                             ; but we can get rid of the label.
                             (forwards instructions (cdr filtered))))
                          (else
                           (forwards instructions filtered))))))))
        
        ; Dispatch procedure for the backwards traversal.
        
        (define (backwards instructions filtered)
          (if (null? instructions)
              filtered
              (let* ((instruction (car instructions))
                     (instructions (cdr instructions))
                     (op (instruction.op instruction))
                     (flags (bytevector-ref backward-table op)))
                (cond ((eqv? flags backward:normal)
                       (backwards instructions (cons instruction filtered)))
                      ((eqv? flags backward:ends-block)
                       (backwards0 (cons instruction instructions)
                                   filtered))
                      ((eqv? flags backward:begins-block)
                       (backwards0 instructions
                                   (cons instruction filtered)))
                      ((eqv? flags backward:uses-many)
                       (cond ((or (eqv? op $lambda)
                                  (eqv? op $lexes))
                              (let ((live
                                     (if (eqv? op $lexes)
                                         (instruction.arg1 instruction)
                                         (instruction.arg2 instruction))))
                                (subvector-fill! registers
                                                 0
                                                 (min *nregs* (+ 1 live))
                                                 #t)
                                (backwards instructions
                                           (cons instruction filtered))))
                             ((eqv? op $args>=)
                              (vector-fill! registers #t)
                              (backwards instructions
                                         (cons instruction filtered)))
                             (else
                              (local-optimization-error op))))
                      ((and (eqv? (logand flags backward:kills-arg1)
                                  backward:kills-arg1)
                            (not (vector-ref registers
                                             (instruction.arg1 instruction))))
                       ; Suppress initialization of dead register.
                       (suppress-backwards instruction
                                           instructions
                                           filtered))
                      ((and (eqv? (logand flags backward:kills-arg2)
                                  backward:kills-arg2)
                            (not (vector-ref registers
                                             (instruction.arg2 instruction))))
                       ; Suppress initialization of dead register.
                       (suppress-backwards instruction
                                           instructions
                                           filtered))
                      ((and (eqv? op $movereg)
                            (= (instruction.arg1 instruction)
                               (instruction.arg2 instruction)))
                       (backwards instructions filtered))
                      (else
                       (let ((filtered (cons instruction filtered)))
                         (if (eqv? (logand flags backward:kills-arg1)
                                   backward:kills-arg1)
                             (vector-set! registers
                                          (instruction.arg1 instruction)
                                          #f))
                         (if (eqv? (logand flags backward:kills-arg2)
                                   backward:kills-arg2)
                             (vector-set! registers
                                          (instruction.arg2 instruction)
                                          #f))
                         (if (eqv? (logand flags backward:uses-arg1)
                                   backward:uses-arg1)
                             (vector-set! registers
                                          (instruction.arg1 instruction)
                                          #t))
                         (if (eqv? (logand flags backward:uses-arg2)
                                   backward:uses-arg2)
                             (vector-set! registers
                                          (instruction.arg2 instruction)
                                          #t))
                         (if (eqv? (logand flags backward:uses-arg3)
                                   backward:uses-arg3)
                             (vector-set! registers
                                          (instruction.arg3 instruction)
                                          #t))
                         (backwards instructions filtered)))))))
        
        ; Given a list of instructions in reverse order, whose first
        ; element is the last instruction of a basic block,
        ; and a filtered list of instructions in forward order,
        ; returns a filtered list of instructions in the correct order.
        
        (define (backwards0 instructions filtered)
          (if (null? instructions)
              filtered
              (let* ((instruction (car instructions))
                     (mnemonic (instruction.op instruction)))
                (cond ((or (eqv? mnemonic $.label)
                           (eqv? mnemonic $.proc)
                           (eqv? mnemonic $.cont)
                           (eqv? mnemonic $.align))
                       (backwards0 (cdr instructions)
                                   (cons instruction filtered)))
                      ; all registers are dead at a $return
                      ((eqv? mnemonic $return)
                       (vector-fill! registers #f)
                       (vector-set! registers 0 #t)
                       (backwards (cdr instructions)
                                  (cons instruction filtered)))
                      ; all but the argument registers are dead at an $invoke
                      ((eqv? mnemonic $invoke)
                       (let ((n+1 (min *nregs*
                                       (+ (instruction.arg1 instruction) 1))))
                         (subvector-fill! registers 0 n+1 #t)
                         (subvector-fill! registers n+1 *nregs* #f)
                         (backwards (cdr instructions)
                                    (cons instruction filtered))))
                      ; the compiler says which registers are live at the
                      ; target of $skip, $branch, $branchf, or $jump
                      ((or (eqv? mnemonic $skip)
                           (eqv? mnemonic $branch))
                       (let* ((live (instruction.arg2 instruction))
                              (n+1 (min *nregs* (+ live 1))))
                         (subvector-fill! registers 0 n+1 #t)
                         (subvector-fill! registers n+1 *nregs* #f)
                         (let ((instruction
                                ; FIXME
                                (list mnemonic
                                      (lookup-label
                                       (instruction.arg1 instruction))
                                      live)))
                           (backwards (cdr instructions)
                                      (cons instruction filtered)))))
                      ((eqv? mnemonic $jump)
                       (let ((n+1 (min *nregs*
                                       (+ (instruction.arg3 instruction) 1))))
                         (subvector-fill! registers 0 n+1 #t)
                         (subvector-fill! registers n+1 *nregs* #f)
                         (backwards (cdr instructions)
                                    (cons instruction filtered))))
                      ; the live registers at the target of a $branchf must be
                      ; combined with the live registers at the $branchf
                      ((eqv? mnemonic $branchf)
                       (let* ((live (instruction.arg2 instruction))
                              (n+1 (min *nregs* (+ live 1))))
                         (subvector-fill! registers 0 n+1 #t)
                         (let ((instruction
                                ; FIXME
                                (list mnemonic
                                      (lookup-label
                                       (instruction.arg1 instruction))
                                      live)))
                           (backwards (cdr instructions)
                                      (cons instruction filtered)))))
                      (else (backwards instructions filtered))))))
        
        (define (suppress-forwards instruction instructions filtered)
          (if (issue-warnings)
              '(begin (display suppression-message)
                      (newline)))
          (forwards instructions filtered))
        
        (define (suppress-backwards instruction instructions filtered)
          (if (issue-warnings)
              '(begin (display suppression-message)
                      (newline)))
          (backwards instructions filtered))
        
        (define (local-optimization-error op)
          (error "Compiler bug: local optimization" op))
        
        (vector-fill! registers #f)
        (forwards instructions '())))))
; Copyright 1998 Lars T Hansen.
; 
; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
;
; 28 April 1999
;
; compile313 -- compilation parameters and driver procedures.


; File types -- these may differ between operating systems.

(define *scheme-file-types* '(".sch" ".scm"))
(define *lap-file-type*     ".lap")
(define *mal-file-type*     ".mal")
(define *lop-file-type*     ".lop")
(define *fasl-file-type*    ".fasl")

; Compile and assemble a scheme source file and produce a fastload file.

(define (compile-file infilename . rest)

  (define (doit)
    (let ((outfilename
           (if (not (null? rest))
               (car rest)
               (rewrite-file-type infilename
                                  *scheme-file-types*
                                  *fasl-file-type*)))
          (user
           (assembly-user-data)))
      (if (and (not (integrate-usual-procedures))
               (issue-warnings))
          (begin 
            (display "WARNING from compiler: ")
            (display "integrate-usual-procedures is turned off")
            (newline)
            (display "Performance is likely to be poor.")
            (newline)))
      (if (benchmark-block-mode)
          (process-file-block infilename
                              outfilename
                              dump-fasl-segment-to-port
                              (lambda (forms)
                                (assemble (compile-block forms) user)))
          (process-file infilename
                        outfilename
                        dump-fasl-segment-to-port
                        (lambda (expr)
                          (assemble (compile expr) user))))
      (unspecified)))

  (if (eq? (nbuild-parameter 'target-machine) 'standard-c)
      (error "Compile-file not supported on this target architecture.")
      (doit)))


; Assemble a MAL or LOP file and produce a FASL file.

(define (assemble-file infilename . rest)
  (define (doit)
    (let ((outfilename
           (if (not (null? rest))
               (car rest)
               (rewrite-file-type infilename 
                                  (list *lap-file-type* *mal-file-type*)
                                  *fasl-file-type*)))
          (malfile?
           (file-type=? infilename *mal-file-type*))
          (user
           (assembly-user-data)))
      (process-file infilename
                    outfilename
                    dump-fasl-segment-to-port
                    (lambda (x) (assemble (if malfile? (eval x) x) user)))
      (unspecified)))
  
  (if (eq? (nbuild-parameter 'target-machine) 'standard-c)
      (error "Assemble-file not supported on this target architecture.")
      (doit)))


; Compile and assemble a single expression; return the LOP segment.

(define compile-expression
  (let ()
    
    (define (compile-expression expr env)
      (let ((syntax-env
             (case (environment-tag env)
               ((0 1) (make-standard-syntactic-environment))
               ((2)   global-syntactic-environment)
               (else  
                (error "Invalid environment for compile-expression: " env)
                #t))))
        (let ((current-env global-syntactic-environment))
          (dynamic-wind
           (lambda ()
             (set! global-syntactic-environment syntax-env))
           (lambda ()
             (assemble (compile expr)))
           (lambda ()
             (set! global-syntactic-environment current-env))))))
    
    compile-expression))


(define macro-expand-expression
  (let ()
    
    (define (macro-expand-expression expr env)
      (let ((syntax-env
             (case (environment-tag env)
               ((0 1) (make-standard-syntactic-environment))
               ((2)   global-syntactic-environment)
               (else  
                (error "Invalid environment for compile-expression: " env)
                #t))))
        (let ((current-env global-syntactic-environment))
          (dynamic-wind
           (lambda ()
             (set! global-syntactic-environment syntax-env))
           (lambda ()
             (make-readable
              (macro-expand expr)))
           (lambda ()
             (set! global-syntactic-environment current-env))))))
    
    macro-expand-expression))


; Compile a scheme source file to a LAP file.

(define (compile313 infilename . rest)
  (let ((outfilename
         (if (not (null? rest))
             (car rest)
             (rewrite-file-type infilename
                                *scheme-file-types* 
                                *lap-file-type*)))
        (write-lap
         (lambda (item port)
           (write item port)
           (newline port)
           (newline port))))
    (if (benchmark-block-mode)
        (process-file-block infilename outfilename write-lap compile-block)
        (process-file infilename outfilename write-lap compile))
    (unspecified)))


; Assemble a LAP or MAL file to a LOP file.

(define (assemble313 file . rest)
  (let ((outputfile
         (if (not (null? rest))
             (car rest)
             (rewrite-file-type file 
                                (list *lap-file-type* *mal-file-type*)
                                *lop-file-type*)))
        (malfile?
         (file-type=? file *mal-file-type*))
        (user
         (assembly-user-data)))
    (process-file file
                  outputfile
                  write-lop
                  (lambda (x) (assemble (if malfile? (eval x) x) user)))
    (unspecified)))


; Compile and assemble a Scheme source file to a LOP file.

(define (compile-and-assemble313 input-file . rest)
  (let ((output-file
         (if (not (null? rest))
             (car rest)
             (rewrite-file-type input-file 
                                *scheme-file-types*
                                *lop-file-type*)))
        (user
         (assembly-user-data)))
    (if (benchmark-block-mode)
        (process-file-block input-file
                            output-file
                            write-lop
                            (lambda (x) (assemble (compile-block x) user)))
        (process-file input-file
                      output-file
                      write-lop
                      (lambda (x) (assemble (compile x) user))))
    (unspecified)))


; Convert a LOP file to a FASL file.

(define (make-fasl infilename . rest)
  (define (doit)
    (let ((outfilename
           (if (not (null? rest))
               (car rest)
               (rewrite-file-type infilename
                                  *lop-file-type*
                                  *fasl-file-type*))))
      (process-file infilename
                    outfilename
                    dump-fasl-segment-to-port
                    (lambda (x) x))
      (unspecified)))

  (if (eq? (nbuild-parameter 'target-machine) 'standard-c)
      (error "Make-fasl not supported on this target architecture.")
      (doit)))


; Disassemble a procedure's code vector.

(define (disassemble item . rest)
  (let ((output-port (if (null? rest)
                         (current-output-port)
                         (car rest))))
    (disassemble-item item #f output-port)
    (unspecified)))


; The item can be either a procedure or a pair (assumed to be a segment).

(define (disassemble-item item segment-no port)
  
  (define (print . rest)
    (for-each (lambda (x) (display x port)) rest)
    (newline port))
  
  (define (print-constvector cv)
    (do ((i 0 (+ i 1)))
        ((= i (vector-length cv)))
        (print "------------------------------------------")
        (print "Constant vector element # " i)
        (case (car (vector-ref cv i))
          ((codevector)
           (print "Code vector")
           (print-instructions (disassemble-codevector
                                (cadr (vector-ref cv i)))
                               port))
          ((constantvector)	
           (print "Constant vector")
           (print-constvector (cadr (vector-ref cv i))))
          ((global)
           (print "Global: " (cadr (vector-ref cv i))))
          ((data)
           (print "Data: " (cadr (vector-ref cv i)))))))
  
  (define (print-segment segment)
    (print "Segment # " segment-no)
    (print-instructions (disassemble-codevector (car segment)) port)
    (print-constvector (cdr segment))
    (print "========================================"))
  
  (cond ((procedure? item)
         (print-instructions (disassemble-codevector (procedure-ref item 0))
                             port))
        ((and (pair? item)
              (bytevector? (car item))
              (vector? (cdr item)))
         (print-segment item))
        (else
         (error "disassemble-item: " item " is not disassemblable."))))


; Disassemble a ".lop" or ".fasl" file; dump output to screen or 
; other (optional) file.

(define (disassemble-file file . rest)
  
  (define (doit input-port output-port)
    (display "; From " output-port)
    (display file output-port)
    (newline output-port)
    (do ((segment-no 0 (+ segment-no 1))
         (segment (read input-port) (read input-port)))
        ((eof-object? segment))
        (disassemble-item segment segment-no output-port)))

  ; disassemble313

  (call-with-input-file
   file
   (lambda (input-port)
     (if (null? rest)
         (doit input-port (current-output-port))
         (begin
          (delete-file (car rest))
          (call-with-output-file
           (car rest)
           (lambda (output-port) (doit input-port output-port)))))))
  (unspecified))


; Display and manipulate the compiler switches.

(define (compiler-switches . rest)

  (define (slow-code)
    (set-compiler-flags! 'no-optimization)
    (set-assembler-flags! 'no-optimization))

  (define (standard-code)
    (set-compiler-flags! 'standard)
    (set-assembler-flags! 'standard))

  (define (fast-safe-code)
    (set-compiler-flags! 'fast-safe)
    (set-assembler-flags! 'fast-safe))

  (define (fast-unsafe-code)
    (set-compiler-flags! 'fast-unsafe)
    (set-assembler-flags! 'fast-unsafe))

  (cond ((null? rest)
         (display "Debugging:")
         (newline)
         (display-twobit-flags 'debugging)
         (display-assembler-flags 'debugging)
         (newline)
         (display "Safety:")
         (newline)
         (display-twobit-flags 'safety)
         (display-assembler-flags 'safety)
         (newline)
         (display "Speed:")
         (newline)
         (display-twobit-flags 'optimization)
         (display-assembler-flags 'optimization)
         (if #f #f))
        ((null? (cdr rest))
         (case (car rest)
           ((0 slow)             (slow-code))
           ((1 standard)         (standard-code))
           ((2 fast-safe)        (fast-safe-code))
           ((3 fast-unsafe)      (fast-unsafe-code))
           ((default
             factory-settings)   (fast-safe-code)
                                 (include-source-code #t)
                                 (benchmark-mode #f)
                                 (benchmark-block-mode #f)
                                 (common-subexpression-elimination #f)
                                 (representation-inference #f))
           (else 
            (error "Unrecognized flag " (car rest) " to compiler-switches.")))
         (unspecified))
        (else
         (error "Too many arguments to compiler-switches."))))

; Read and process one file, producing another.
; Preserves the global syntactic environment.

(define (process-file infilename outfilename writer processer)
  (define (doit)
    (delete-file outfilename)
    (call-with-output-file
     outfilename
     (lambda (outport)
       (call-with-input-file
        infilename
        (lambda (inport)
          (let loop ((x (read inport)))
            (if (eof-object? x)
                #t
                (begin (writer (processer x) outport)
                       (loop (read inport))))))))))
  (let ((current-syntactic-environment
         (syntactic-copy global-syntactic-environment)))
    (dynamic-wind
     (lambda () #t)
     (lambda () (doit))
     (lambda ()
       (set! global-syntactic-environment
             current-syntactic-environment)))))

; Same as above, but passes a list of the entire file's contents
; to the processer.
; FIXME:  Both versions of PROCESS-FILE always delete the output file.
; Shouldn't it be left alone if the input file can't be opened?

(define (process-file-block infilename outfilename writer processer)
  (define (doit)
    (delete-file outfilename)
    (call-with-output-file
     outfilename
     (lambda (outport)
       (call-with-input-file
        infilename
        (lambda (inport)
          (do ((x (read inport) (read inport))
               (forms '() (cons x forms)))
              ((eof-object? x)
               (writer (processer (reverse forms)) outport))))))))
  (let ((current-syntactic-environment
         (syntactic-copy global-syntactic-environment)))
    (dynamic-wind
     (lambda () #t)
     (lambda () (doit))
     (lambda ()
       (set! global-syntactic-environment
             current-syntactic-environment)))))


; Given a file name with some type, produce another with some other type.

(define (rewrite-file-type filename matches new)
  (if (not (pair? matches))
      (rewrite-file-type filename (list matches) new)
      (let ((j (string-length filename)))
        (let loop ((m matches))
          (cond ((null? m)
                 (string-append filename new))
                (else
                 (let* ((n (car m))
                        (l (string-length n)))
                   (if (file-type=? filename n)
                       (string-append (substring filename 0 (- j l)) new)
                       (loop (cdr m))))))))))

(define (file-type=? file-name type-name)
  (let ((fl (string-length file-name))
        (tl (string-length type-name)))
    (and (>= fl tl)
         (string-ci=? type-name
                      (substring file-name (- fl tl) fl)))))

; eof
; Copyright 1998 William Clinger.
;
; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
;
; Procedures that make .LAP structures human-readable

(define (readify-lap code)
  (map (lambda (x)
	 (let ((iname (cdr (assv (car x) *mnemonic-names*))))
	   (if (not (= (car x) $lambda))
	       (cons iname (cdr x))
	       (list iname (readify-lap (cadr x)) (caddr x)))))
       code))

(define (readify-file f . o)

  (define (doit)
    (let ((i (open-input-file f)))
      (let loop ((x (read i)))
	(if (not (eof-object? x))
	    (begin (pretty-print (readify-lap x))
		   (loop (read i)))))))

  (if (null? o)
      (doit)
      (begin (delete-file (car o))
	     (with-output-to-file (car o) doit))))

; eof
; Copyright 1991 Lightship Software, Incorporated.
; 
; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
;
; Target-independent part of the assembler.
;
; This is a simple, table-driven, one-pass assembler.
; Part of it assumes a big-endian target machine.
;
; The input to this pass is a list of symbolic MacScheme machine
; instructions and pseudo-instructions.  Each symbolic MacScheme 
; machine instruction or pseudo-instruction is a list whose car
; is a small non-negative fixnum that acts as the mnemonic for the
; instruction.  The rest of the list is interpreted as indicated
; by the mnemonic.
;
; The output is a pair consisting of machine code (a bytevector or 
; string) and a constant vector.
;
; This assembler is table-driven, and may be customized to emit
; machine code for different target machines.  The table consists
; of a vector of procedures indexed by mnemonics.  Each procedure
; in the table should take two arguments: an assembly structure
; and a source instruction.  The procedure should just assemble
; the instruction using the operations defined below.
;
; The table and target can be changed by redefining the following 
; five procedures.

(define (assembly-table) (error "No assembly table defined."))
(define (assembly-start as) #t)
(define (assembly-end as segment) segment)
(define (assembly-user-data) #f)

; The main entry point.

(define (assemble source . rest)
  (let* ((user (if (null? rest) (assembly-user-data) (car rest)))
	 (as   (make-assembly-structure source (assembly-table) user)))
    (assembly-start as)
    (assemble1 as
	       (lambda (as)
		 (let ((segment (assemble-pasteup as)))
		   (assemble-finalize! as)
		   (assembly-end as segment)))
	       #f)))

; The following procedures are to be called by table routines.
;
; The assembly source for nested lambda expressions should be
; assembled by calling this procedure.  This allows an inner
; lambda to refer to labels defined by outer lambdas.
;
; We delay the assembly of the nested lambda until after the outer lambda
; has been finalized so that all labels in the outer lambda are known
; to the inner lambda.
;
; The continuation procedure k is called to backpatch the constant
; vector of the outer lambda after the inner lambda has been
; finalized.  This is necessary because of the delayed evaluation: the
; outer lambda holds code and constants for the inner lambda in its
; constant vector.

(define (assemble-nested-lambda as source doc k . rest)
  (let* ((user (if (null? rest) #f (car rest)))
	 (nested-as (make-assembly-structure source (as-table as) user)))
    (as-parent! nested-as as)
    (as-nested! as (cons (lambda ()
			   (assemble1 nested-as 
				      (lambda (nested-as)
					(let ((segment
					       (assemble-pasteup nested-as)))
					  (assemble-finalize! nested-as)
					  (k nested-as segment)))
				      doc))
			 (as-nested as)))))

(define operand0 car)      ; the mnemonic
(define operand1 cadr)
(define operand2 caddr)
(define operand3 cadddr)
(define (operand4 i) (car (cddddr i)))

; Emits the bits contained in the bytevector bv.

(define (emit! as bv)
  (as-code! as (cons bv (as-code as)))
  (as-lc! as (+ (as-lc as) (bytevector-length bv))))

; Emits the characters contained in the string s as code (for C generation).

(define (emit-string! as s)
  (as-code! as (cons s (as-code as)))
  (as-lc! as (+ (as-lc as) (string-length s))))

; Given any Scheme object that may legally be quoted, returns an
; index into the constant vector for that constant.

(define (emit-constant as x)
  (do ((i 0 (+ i 1))
       (y (as-constants as) (cdr y)))
      ((or (null? y) (equal? x (car y)))
       (if (null? y)
	   (as-constants! as (append! (as-constants as) (list x))))
       i)))

(define (emit-datum as x)
  (emit-constant as (list 'data x)))

(define (emit-global as x)
  (emit-constant as (list 'global x)))

(define (emit-codevector as x)
  (emit-constants as (list 'codevector x)))

(define (emit-constantvector as x)
  (emit-constants as (list 'constantvector x)))

; Set-constant changes the datum stored, without affecting the tag.
; It can operate on the list form because the pair stored in the list
; is shared between the list and any vector created from the list.

(define (set-constant! as n datum)
  (let ((pair (list-ref (as-constants as) n)))
    (set-car! (cdr pair) datum)))

; Guarantees that the constants will not share structure
; with any others, and will occupy consecutive positions
; in the constant vector.  Returns the index of the first
; constant.

(define (emit-constants as x . rest)
  (let* ((constants (as-constants as))
         (i         (length constants)))
    (as-constants! as (append! constants (cons x rest)))
    i))

; Defines the given label using the current location counter.

(define (emit-label! as L)
  (set-cdr! L (as-lc as)))

; Adds the integer n to the size code bytes beginning at the
; given byte offset from the current value of the location counter.

(define (emit-fixup! as offset size n)
  (as-fixups! as (cons (list (+ offset (as-lc as)) size n)
		       (as-fixups as))))

; Adds the value of the label L to the size code bytes beginning
; at the given byte offset from the current location counter.

(define (emit-fixup-label! as offset size L)
  (as-fixups! as (cons (list (+ offset (as-lc as)) size (list L))
		       (as-fixups as))))

; Allows the procedure proc of two arguments (code vector and current
; location counter) to modify the code vector at will, at fixup time.

(define (emit-fixup-proc! as proc)
  (as-fixups! as (cons (list (as-lc as) 0 proc)
		       (as-fixups as))))

; Labels.

; The current value of the location counter.

(define (here as) (as-lc as))

; Given a MAL label (a number), create an assembler label.

(define (make-asm-label as label)
  (let ((probe (find-label as label)))
    (if probe
	probe
	(let ((l (cons label #f)))
	  (as-labels! as (cons l (as-labels as)))
	  l))))

; This can use hashed lookup.

(define (find-label as L)

  (define (lookup-label-loop x labels parent)
    (let ((entry (assq x labels)))
      (cond (entry)
	    ((not parent) #f)
	    (else 
	     (lookup-label-loop x (as-labels parent) (as-parent parent))))))
    
  (lookup-label-loop L (as-labels as) (as-parent as)))

; Create a new assembler label, distinguishable from a MAL label.

(define new-label
  (let ((n 0))
    (lambda ()
      (set! n (- n 1))
      (cons n #f))))

; Given a value name (a number), return the label value or #f.

(define (label-value as L) (cdr L))

; For peephole optimization.

(define (next-instruction as)
  (let ((source (as-source as)))
    (if (null? source)
        '(-1)
        (car source))))

(define (consume-next-instruction! as)
  (as-source! as (cdr (as-source as))))

(define (push-instruction as instruction)
  (as-source! as (cons instruction (as-source as))))

; For use by the machine assembler: assoc lists connected to as structure.

(define (assembler-value as key)
  (let ((probe (assq key (as-values as))))
    (if probe
	(cdr probe)
	#f)))

(define (assembler-value! as key value)
  (let ((probe (assq key (as-values as))))
    (if probe
	(set-cdr! probe value)
	(as-values! as (cons (cons key value) (as-values as))))))

; For documentation.
;
; The value must be a documentation structure (a vector).

(define (add-documentation as doc)
  (let* ((existing-constants (cadr (car (as-constants as))))
	 (new-constants 
	  (twobit-sort (lambda (a b)
			 (< (car a) (car b)))
		       (cond ((not existing-constants)
			      (list (cons (here as) doc)))
			     ((pair? existing-constants)
			      (cons (cons (here as) doc)
				    existing-constants))
			     (else
			      (list (cons (here as) doc)
				    (cons 0 existing-constants)))))))
    (set-car! (cdar (as-constants as)) new-constants)))

; This is called when a value is too large to be handled by the assembler.
; Info is a string, expr an assembler expression, and val the resulting
; value.  The default behavior is to signal an error.

(define (asm-value-too-large as info expr val)
  (if (as-retry as)
      ((as-retry as))
      (asm-error info ": Value too large: " expr " = " val)))

; The implementations of asm-error and disasm-error depend on the host
; system. Sigh.

(define (asm-error msg . rest)
  (cond ((eq? host-system 'chez)
	 (error 'assembler "~a" (list msg rest)))
	(else
	 (apply error msg rest))))

(define (disasm-error msg . rest)
  (cond ((eq? host-system 'chez)
	 (error 'disassembler "~a" (list msg rest)))
	(else
	 (apply error msg rest))))

; The remaining procedures in this file are local to the assembler.

; An assembly structure is a vector consisting of
;
;    table          (a table of assembly routines)
;    source         (a list of symbolic instructions)
;    lc             (location counter; an integer)
;    code           (a list of bytevectors)
;    constants      (a list)
;    labels         (an alist of labels and values)
;    fixups         (an alist of locations, sizes, and labels or fixnums)
;    nested         (a list of assembly procedures for nested lambdas)
;    values         (an assoc list)
;    parent         (an assembly structure or #f)
;    retry          (a thunk or #f)
;    user-data      (anything)
;
; In fixups, labels are of the form (<L>) to distinguish them from fixnums.

(define (label? x) (and (pair? x) (fixnum? (car x))))
(define label.ident car)

(define (make-assembly-structure source table user-data)
  (vector table
          source
          0
          '()
          '()
          '()
          '()
          '()
	  '()
	  #f
	  #f
	  user-data))

(define (as-reset! as source)
  (as-source! as source)
  (as-lc! as 0)
  (as-code! as '())
  (as-constants! as '())
  (as-labels! as '())
  (as-fixups! as '())
  (as-nested! as '())
  (as-values! as '())
  (as-retry! as #f))

(define (as-table as)     (vector-ref as 0))
(define (as-source as)    (vector-ref as 1))
(define (as-lc as)        (vector-ref as 2))
(define (as-code as)      (vector-ref as 3))
(define (as-constants as) (vector-ref as 4))
(define (as-labels as)    (vector-ref as 5))
(define (as-fixups as)    (vector-ref as 6))
(define (as-nested as)    (vector-ref as 7))
(define (as-values as)    (vector-ref as 8))
(define (as-parent as)    (vector-ref as 9))
(define (as-retry as)     (vector-ref as 10))
(define (as-user as)      (vector-ref as 11))

(define (as-source! as x)    (vector-set! as 1 x))
(define (as-lc! as x)        (vector-set! as 2 x))
(define (as-code! as x)      (vector-set! as 3 x))
(define (as-constants! as x) (vector-set! as 4 x))
(define (as-labels! as x)    (vector-set! as 5 x))
(define (as-fixups! as x)    (vector-set! as 6 x))
(define (as-nested! as x)    (vector-set! as 7 x))
(define (as-values! as x)    (vector-set! as 8 x))
(define (as-parent! as x)    (vector-set! as 9 x))
(define (as-retry! as x)     (vector-set! as 10 x))
(define (as-user! as x)      (vector-set! as 11 x))

; The guts of the assembler.

(define (assemble1 as finalize doc)
  (let ((assembly-table (as-table as))
	(peep? (peephole-optimization))
	(step? (single-stepping))
	(step-instr (list $.singlestep))
	(end-instr (list $.end)))

    (define (loop)
      (let ((source (as-source as)))
        (if (null? source)
	    (begin ((vector-ref assembly-table $.end) end-instr as)
		   (finalize as))
            (begin (if step?
		       ((vector-ref assembly-table $.singlestep)
			step-instr
			as))
		   (if peep?
		       (let peeploop ((src1 source))
			 (peep as)
			 (let ((src2 (as-source as)))
			   (if (not (eq? src1 src2))
			       (peeploop src2)))))
		   (let ((source (as-source as)))
		     (as-source! as (cdr source))
		     ((vector-ref assembly-table (caar source))
		      (car source)
		      as)
		     (loop))))))

    (define (doit)
      (emit-datum as doc)
      (loop))

    (let* ((source (as-source as))
	   (r (call-with-current-continuation
	       (lambda (k)
		 (as-retry! as (lambda () (k 'retry)))
		 (doit)))))
      (if (eq? r 'retry)
	  (let ((old (short-effective-addresses)))
	    (as-reset! as source)
	    (dynamic-wind
	     (lambda ()
	       (short-effective-addresses #f))
	     doit
	     (lambda ()
	       (short-effective-addresses old))))
	  r))))

(define (assemble-pasteup as)

  (define (pasteup-code)
    (let ((code      (make-bytevector (as-lc as)))
	  (constants (list->vector (as-constants as))))
    
      ; The bytevectors: byte 0 is most significant.

      (define (paste-code! bvs i)
	(if (not (null? bvs))
	    (let* ((bv (car bvs))
		   (n  (bytevector-length bv)))
	      (do ((i i (- i 1))
		   (j (- n 1) (- j 1)))	; (j 0 (+ j 1))
		  ((< j 0)		; (= j n)
		   (paste-code! (cdr bvs) i))
                (bytevector-set! code i (bytevector-ref bv j))))))
    
      (paste-code! (as-code as) (- (as-lc as) 1))
      (as-code! as (list code))
      (cons code constants)))

  (define (pasteup-strings)
    (let ((code      (make-string (as-lc as)))
	  (constants (list->vector (as-constants as))))

      (define (paste-code! strs i)
	(if (not (null? strs))
	    (let* ((s (car strs))
		   (n (string-length s)))
	      (do ((i i (- i 1))
		   (j (- n 1) (- j 1)))	; (j 0 (+ j 1))
		  ((< j 0)		; (= j n)
		   (paste-code! (cdr strs) i))
                (string-set! code i (string-ref s j))))))

      (paste-code! (as-code as) (- (as-lc as) 1))
      (as-code! as (list code))
      (cons code constants)))

  (if (bytevector? (car (as-code as)))
      (pasteup-code)
      (pasteup-strings)))

(define (assemble-finalize! as)
  (let ((code (car (as-code as))))

    (define (apply-fixups! fixups)
      (if (not (null? fixups))
          (let* ((fixup      (car fixups))
                 (i          (car fixup))
                 (size       (cadr fixup))
                 (adjustment (caddr fixup))  ; may be procedure
                 (n          (if (label? adjustment)
				 (lookup-label adjustment)
				 adjustment)))
            (case size
	      ((0) (fixup-proc code i n))
              ((1) (fixup1 code i n))
              ((2) (fixup2 code i n))
              ((3) (fixup3 code i n))
              ((4) (fixup4 code i n))
              (else ???))
            (apply-fixups! (cdr fixups)))))

    (define (lookup-label L)
      (or (label-value as (label.ident L))
	  (asm-error "Assembler error -- undefined label " L)))

    (apply-fixups! (reverse! (as-fixups as)))

    (for-each (lambda (nested-as-proc)
		(nested-as-proc))
	      (as-nested as))))


; These fixup routines assume a big-endian target machine.

(define (fixup1 code i n)
  (bytevector-set! code i (+ n (bytevector-ref code i))))

(define (fixup2 code i n)
  (let* ((x  (+ (* 256 (bytevector-ref code i))
                (bytevector-ref code (+ i 1))))
         (y  (+ x n))
         (y0 (modulo y 256))
         (y1 (modulo (quotient (- y y0) 256) 256)))
    (bytevector-set! code i y1)
    (bytevector-set! code (+ i 1) y0)))

(define (fixup3 code i n)
  (let* ((x  (+ (* 65536 (bytevector-ref code i))
		(* 256 (bytevector-ref code (+ i 1)))
                (bytevector-ref code (+ i 2))))
         (y  (+ x n))
         (y0 (modulo y 256))
         (y1 (modulo (quotient (- y y0) 256) 256))
         (y2 (modulo (quotient (- y (* 256 y1) y0) 256) 256)))
    (bytevector-set! code i y2)
    (bytevector-set! code (+ i 1) y1)
    (bytevector-set! code (+ i 2) y0)))

(define (fixup4 code i n)
  (let* ((x  (+ (* 16777216 (bytevector-ref code i))
		(* 65536 (bytevector-ref code (+ i 1)))
		(* 256 (bytevector-ref code (+ i 2)))
		(bytevector-ref code (+ i 3))))
         (y  (+ x n))
         (y0 (modulo y 256))
         (y1 (modulo (quotient (- y y0) 256) 256))
         (y2 (modulo (quotient (- y (* 256 y1) y0) 256) 256))
         (y3 (modulo (quotient (- y (* 65536 y2)
                                    (* 256 y1)
                                    y0)
                               256)
                     256)))
    (bytevector-set! code i y3)
    (bytevector-set! code (+ i 1) y2)
    (bytevector-set! code (+ i 2) y1)
    (bytevector-set! code (+ i 3) y0)))

(define (fixup-proc code i p)
  (p code i))

; For testing.

(define (view-segment segment)
  (define (display-bytevector bv)
    (let ((n (bytevector-length bv)))
      (do ((i 0 (+ i 1)))
          ((= i n))
          (if (zero? (remainder i 4))
              (write-char #\space))
          (if (zero? (remainder i 8))
              (write-char #\space))
          (if (zero? (remainder i 32))
              (newline))
          (let ((byte (bytevector-ref bv i)))
            (write-char
	     (string-ref (number->string (quotient byte 16) 16) 0))
            (write-char
	     (string-ref (number->string (remainder byte 16) 16) 0))))))
  (if (and (pair? segment)
           (bytevector? (car segment))
           (vector? (cdr segment)))
      (begin (display-bytevector (car segment))
             (newline)
             (write (cdr segment))
             (newline)
             (do ((constants (vector->list (cdr segment))
                             (cdr constants)))
                 ((or (null? constants)
                      (null? (cdr constants))))
                 (if (and (bytevector? (car constants))
                          (vector? (cadr constants)))
                     (view-segment (cons (car constants)
                                         (cadr constants))))))))

; emit is a procedure that takes an as and emits instructions into it.

(define (test-asm emit)
  (let ((as (make-assembly-structure #f #f #f)))
    (emit as)
    (let ((segment (assemble-pasteup as)))
      (assemble-finalize! as)
      (disassemble segment))))

(define (compile&assemble x)
  (view-segment (assemble (compile x))))

; eof
; Copyright 1998 Lars T Hansen.
;
; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
;
; Common assembler -- miscellaneous utility procedures.

; Given any Scheme object, return its printable representation as a string.
; This code is largely portable (see comments).

(define (format-object x)

  (define (format-list x)
    (define (loop x)
      (cond ((null? x)
	     '(")"))
	    ((null? (cdr x))
	     (list (format-object (car x)) ")"))
	    (else
	     (cons (format-object (car x))
		   (cons " " 
			 (loop (cdr x)))))))
    (apply string-append (cons "(" (loop x))))

  (define (format-improper-list x)
    (define (loop x)
      (if (pair? (cdr x))
	  (cons (format-object (car x))
		(cons " "
		      (loop (cdr x))))
	  (list (format-object (car x))
		" . "
		(format-object (cdr x))
		")")))
    (apply string-append (cons "(" (loop x))))

  (cond ((null? x)             "()")
	((not x)               "#f")
	((eq? x #t)            "#t")
	((symbol? x)           (symbol->string x))
	((number? x)           (number->string x))
	((char? x)             (string x))
	((string? x)           x)
	((procedure? x)        "#<procedure>")
	((bytevector? x)       "#<bytevector>")     ; Larceny
	((eof-object? x)       "#<eof>")
	((port? x)             "#<port>")
	((eq? x (unspecified)) "#!unspecified")     ; Larceny
	((eq? x (undefined))   "#!undefined")       ; Larceny
	((vector? x)
	 (string-append "#" (format-list (vector->list x))))
	((list? x)
	 (format-list x))
	((pair? x)
	 (format-improper-list x))
	(else                  "#<weird>")))

; eof
; Copyright 1998 Lars T Hansen.
;
; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
;
; Larceny assembler -- 32-bit big-endian utility procedures.
;
; 32-bit numbers are represented as 4-byte bytevectors where byte 3
; is the least significant and byte 0 is the most significant.
;
; Logically, the 'big' end is on the left and the 'little' end
; is on the right, so a left shift shifts towards the 'big' end.
;
; Performance: poor, for good reasons.  See asmutil32.sch.

; Identifies the code loaded.

(define asm:endianness 'big)


; Given four bytes, create a length-4 bytevector. 
; N1 is the most significant byte, n4 the least significant.

(define (asm:bv n1 n2 n3 n4)
  (let ((bv (make-bytevector 4)))
    (bytevector-set! bv 0 n1)
    (bytevector-set! bv 1 n2)
    (bytevector-set! bv 2 n3)
    (bytevector-set! bv 3 n4)
    bv))


; Given a length-4 bytevector, convert it to an integer.

(define (asm:bv->int bv)
  (let ((i (+ (* (+ (* (+ (* (bytevector-ref bv 0) 256)
			  (bytevector-ref bv 1))
		       256)
		    (bytevector-ref bv 2))
		 256)
	      (bytevector-ref bv 3))))
    (if (> (bytevector-ref bv 0) 127)
	(- i)
	i)))


; Shift the bits of m left by n bits, shifting in zeroes at the right end.
; Returns a length-4 bytevector.
;
; M may be an exact integer or a length-4 bytevector.
; N must be an exact non-negative integer; it's interpreted modulo 33.

(define (asm:lsh m n)
  (if (not (bytevector? m))
      (asm:lsh (asm:int->bv m) n)
      (let ((m (bytevector-copy m))
	    (n (remainder n 33)))
	(if (>= n 8)
	    (let ((k (quotient n 8)))
	      (do ((i 0 (+ i 1)))
		  ((= (+ i k) 4)
		   (do ((i i (+ i 1)))
		       ((= i 4))
		     (bytevector-set! m i 0)))
		(bytevector-set! m i (bytevector-ref m (+ i k))))))
	(let* ((d0 (bytevector-ref m 0))
	       (d1 (bytevector-ref m 1))
	       (d2 (bytevector-ref m 2))
	       (d3 (bytevector-ref m 3))
	       (n  (remainder n 8))
	       (n- (- 8 n)))
	  (asm:bv (logand (logior (lsh d0 n) (rshl d1 n-)) 255)
		  (logand (logior (lsh d1 n) (rshl d2 n-)) 255)
		  (logand (logior (lsh d2 n) (rshl d3 n-)) 255)
		  (logand (lsh d3 n) 255))))))


; Shift the bits of m right by n bits, shifting in zeroes at the high end.
; Returns a length-4 bytevector.
;
; M may be an exact integer or a length-4 bytevector.
; N must be an exact non-negative integer; it's interpreted modulo 33.

(define (asm:rshl m n)
  (if (not (bytevector? m))
      (asm:rshl (asm:int->bv m) n)
      (let ((m (bytevector-copy m))
	    (n (remainder n 33)))
	(if (>= n 8)
	    (let ((k (quotient n 8)))
	      (do ((i 3 (- i 1)))
		  ((< (- i k) 0)
		   (do ((i i (- i 1)))
		       ((< i 0))
		     (bytevector-set! m i 0)))
		(bytevector-set! m i (bytevector-ref m (- i k))))))
	(let* ((d0 (bytevector-ref m 0))
	       (d1 (bytevector-ref m 1))
	       (d2 (bytevector-ref m 2))
	       (d3 (bytevector-ref m 3))
	       (n  (remainder n 8))
	       (n- (- 8 n)))
	  (asm:bv (rshl d0 n)
		  (logand (logior (rshl d1 n) (lsh d0 n-)) 255)
		  (logand (logior (rshl d2 n) (lsh d1 n-)) 255)
		  (logand (logior (rshl d3 n) (lsh d2 n-)) 255))))))


; Shift the bits of m right by n bits, shifting in the sign bit at the
; high end.  Returns a length-4 bytevector.
;
; M may be an exact integer or a length-4 bytevector.
; N must be an exact non-negative integer; it's interpreted modulo 33.

(define asm:rsha
  (let ((ones (asm:bv #xff #xff #xff #xff)))
    (lambda (m n)
      (let* ((m (if (bytevector? m) m (asm:int->bv m)))
	     (n (remainder n 33))
	     (h (rshl (bytevector-ref m 0) 7))
	     (k (asm:rshl m n)))
;	(format #t "~a ~a ~a~%" h (bytevector-ref m 0) n)
;	(prnx (asm:lsh ones (- 32 n))) (newline)
	(if (zero? h)
	    k
	    (asm:logior k (asm:lsh ones (- 32 n))))))))

; eof
; Copyright 1998 Lars T Hansen.
;
; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
;
; Larceny assembler -- 32-bit endianness-independent utility procedures.
;
; 32-bit numbers are represented as 4-byte bytevectors where the
; exact layout depends on whether the little-endian or big-endian
; module has been loaded.  One of them must be loaded prior to loading
; this module.
;
; Logically, the 'big' end is on the left and the 'little' end
; is on the right, so a left shift shifts towards the big end.
;
; Generally, performance is not a major issue in this module.  The 
; assemblers should use more specialized code for truly good performance.
; These procedures are mainly suitable for one-time construction of 
; instruction templates, and during development.
;
; Endian-ness specific operations are in asmutil32be.sch and asmutil32le.sch:
;
;   (asm:bv n0 n1 n2 n3)    ; Construct bytevector
;   (asm:bv->int bv)        ; Convert bytevector to integer
;   (asm:lsh m k)           ; Shift left logical k bits
;   (asm:rshl m k)          ; Shift right logical k bits
;   (asm:rsha m k)          ; Shirt right arithmetic k bits


; Convert an integer to a length-4 bytevector using two's complement 
; representation for negative numbers.
; Returns length-4 bytevector.
;
; The procedure handles numbers in the range -2^31..2^32-1 [sic].
; It is an error for the number to be outside this range.
;
; FIXME: quotient/remainder may be slow; we could have special fixnum
;        case that uses shifts (that could be in-lined as macro).  It could
;        work for negative numbers too.
; FIXME: should probably check that the number is within range.

(define asm:int->bv
  (let ((two^32 (expt 2 32)))
    (lambda (m)
      (let* ((m  (if (< m 0) (+ two^32 m) m))
	     (b0 (remainder m 256))
	     (m  (quotient m 256))
	     (b1 (remainder m 256))
	     (m  (quotient m 256))
	     (b2 (remainder m 256))
	     (m  (quotient m 256))
	     (b3 (remainder m 256)))
	(asm:bv b3 b2 b1 b0)))))


; `Or' the bits of multiple operands together. 
; Each operand may be an exact integer or a length-4 bytevector.
; Returns a length-4 bytevector.

(define (asm:logior . ops)
  (let ((r (asm:bv 0 0 0 0)))
    (do ((ops ops (cdr ops)))
	((null? ops) r)
      (let* ((op (car ops))
	     (op (if (bytevector? op) op (asm:int->bv op))))
	(bytevector-set! r 0 (logior (bytevector-ref r 0)
				     (bytevector-ref op 0)))
	(bytevector-set! r 1 (logior (bytevector-ref r 1)
				     (bytevector-ref op 1)))
	(bytevector-set! r 2 (logior (bytevector-ref r 2)
				     (bytevector-ref op 2)))
	(bytevector-set! r 3 (logior (bytevector-ref r 3)
				     (bytevector-ref op 3)))))))


; `And' the bits of two operands together.
; Either may be an exact integer or length-4 bytevector.
; Returns length-4 bytevector.

(define (asm:logand op1 op2)
  (let ((op1 (if (bytevector? op1) op1 (asm:int->bv op1)))
	(op2 (if (bytevector? op2) op2 (asm:int->bv op2)))
	(bv  (make-bytevector 4)))
    (bytevector-set! bv 0 (logand (bytevector-ref op1 0)
				  (bytevector-ref op2 0)))
    (bytevector-set! bv 1 (logand (bytevector-ref op1 1)
				  (bytevector-ref op2 1)))
    (bytevector-set! bv 2 (logand (bytevector-ref op1 2)
				  (bytevector-ref op2 2)))
    (bytevector-set! bv 3 (logand (bytevector-ref op1 3)
				  (bytevector-ref op2 3)))
    bv))


; Extract the n low-order bits of m.
; m may be an exact integer or a length-4 bytevector.
; n must be an exact non-negative integer, interpreted modulo 32.
; Returns length-4 bytevector.
;
; Does not depend on endian-ness.

(define asm:lobits 
  (let ((v (make-vector 33)))
    (do ((i 0 (+ i 1)))
	((= i 33))
      (vector-set! v i (asm:int->bv (- (expt 2 i) 1))))
    (lambda (m n)
      (asm:logand m (vector-ref v (remainder n 33))))))

; Extract the n high-order bits of m.
; m may be an exact integer or a length-4 bytevector.
; n must be an exact non-negative integer, interpreted modulo 33.
; Returns length-4 bytevector with the high-order bits of m at low end.
;
; Does not depend on endian-ness.

(define (asm:hibits m n)
  (asm:rshl m (- 32 (remainder n 33))))

; Test that the given number (not! bytevector) m fits in an n-bit 
; signed slot.
;
; Does not depend on endian-ness.

(define asm:fits?
  (let ((v (make-vector 33)))
    (do ((i 0 (+ i 1)))
	((= i 33))
      (vector-set! v i (expt 2 i)))
    (lambda (m n)
      (<= (- (vector-ref v (- n 1))) m (- (vector-ref v (- n 1)) 1)))))

; Test that the given number (not! bytevector) m fits in an n-bit 
; unsigned slot.
;
; Does not depend on endian-ness.

(define asm:fits-unsigned?
  (let ((v (make-vector 33)))
    (do ((i 0 (+ i 1)))
	((= i 33))
      (vector-set! v i (expt 2 i)))
    (lambda (m n)
      (<= 0 m (- (vector-ref v n) 1)))))

; Add two operands (numbers or bytevectors).
;
; Does not depend on endian-ness.

(define (asm:add a b)
  (asm:int->bv (+ (if (bytevector? a) (asm:bv->int a) a)
		  (if (bytevector? b) (asm:bv->int b) b))))

; Given an unsigned 32-bit number, return it as a signed number
; as appropriate.
;
; Does not depend on endian-ness.

(define (asm:signed n)
  (if (< n 2147483647)
      n
      (- n 4294967296)))


(define (asm:print-bv bv)

  (define hex "0123456789abcdef")

  (define (pdig k)
    (display (string-ref hex (quotient k 16)))
    (display (string-ref hex (remainder k 16)))
    (display " "))
  
  (if (eq? asm:endianness 'little)
      (do ((i 3 (- i 1)))
	  ((< i 0))
	(pdig (bytevector-ref bv i)))
      (do ((i 0 (+ i 1)))
	  ((= i 4))
	(pdig (bytevector-ref bv i)))))


; eof
; Copyright 1998 Lars T Hansen.
;
; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
;
; Procedure that writes fastload segment.
;
; The procedure 'dump-fasl-segment-to-port' takes a segment and an output
; port as arguments and dumps the segment in fastload format on that port.
; The port must be a binary (untranslated) port.
;
; A fastload segment looks like a Scheme expression, and in fact, 
; fastload files can mix compiled and uncompiled expressions.  A compiled
; expression (as created by dump-fasl-segment-to-port) is a list with
; a literal procedure in the operator position and no arguments.
;
; A literal procedure is a three-element list prefixed by #^P.  The three
; elements are code (a bytevector), constants (a regular vector), and
; R0/static link slot (always #f).  
;
; A bytevector is a string prefixed by #^B. The string may contain 
; control characters; \ and " must be quoted as usual.
;
; A global variable reference in the constant vector is a symbol prefixed
; by #^G.  On reading, the reference is replaced by (a pointer to) the 
; actual cell.
;
; This code is highly bummed.  The procedure write-bytevector-like has the
; same meaning as display, but in Larceny, the former is currently much
; faster than the latter.

(define (dump-fasl-segment-to-port segment outp . rest)
  (let* ((omit-code? (not (null? rest)))
         (controllify
	  (lambda (char)
	    (integer->char (- (char->integer char) (char->integer #\@)))))
	 (CTRLP       (controllify #\P))
	 (CTRLB       (controllify #\B))
	 (CTRLG       (controllify #\G))
	 (DOUBLEQUOTE (char->integer #\"))
	 (BACKSLASH   (char->integer #\\))
	 (len         1024))

    (define buffer (make-string len #\&))
    (define ptr 0)

    (define (flush)
      (if (< ptr len)
	  (write-bytevector-like (substring buffer 0 ptr) outp)
	  (write-bytevector-like buffer outp))
      (set! ptr 0))

    (define (putc c)
      (if (= ptr len) (flush))
      (string-set! buffer ptr c)
      (set! ptr (+ ptr 1)))

    (define (putb b)
      (if (= ptr len) (flush))
      (string-set! buffer ptr (integer->char b))
      (set! ptr (+ ptr 1)))

    (define (puts s)
      (let ((ls (string-length s)))
	(if (>= (+ ptr ls) len)
	    (begin (flush)
		   (write-bytevector-like s outp))
	    (do ((i (- ls 1) (- i 1))
		 (p (+ ptr ls -1) (- p 1)))
		((< i 0)
		 (set! ptr (+ ptr ls)))
	      (string-set! buffer p (string-ref s i))))))

    (define (putd d)
      (flush)
      (write-fasl-datum d outp))

    (define (dump-codevec bv)
      (if omit-code?
          (puts "#f")
          (begin
            (putc #\#)
            (putc CTRLB)
            (putc #\")
            (let ((limit (bytevector-length bv)))
              (do ((i 0 (+ i 1)))
                  ((= i limit) (putc #\")
                               (putc #\newline))
                (let ((c (bytevector-ref bv i)))
                  (cond ((= c DOUBLEQUOTE) (putc #\\))
                        ((= c BACKSLASH)   (putc #\\)))
                  (putb c)))))))

    (define (dump-constvec cv)
      (puts "#(")
      (for-each (lambda (const)
		  (putc #\space)
		  (case (car const)
		    ((data)
		     (putd (cadr const)))
		    ((constantvector)
		     (dump-constvec (cadr const)))
		    ((codevector)
		     (dump-codevec (cadr const)))
		    ((global)
		     (putc #\#)
		     (putc CTRLG)
		     (putd (cadr const)))
		    ((bits)
		     (error "BITS attribute is not supported in fasl files."))
		    (else
		     (error "Faulty .lop file."))))
		(vector->list cv))
      (puts ")")
      (putc #\newline))

    (define (dump-fasl-segment segment)
      (if (not omit-code?) (putc #\())
      (putc #\#)
      (putc CTRLP)
      (putc #\()
      (dump-codevec (car segment))
      (putc #\space)
      (dump-constvec (cdr segment))
      (puts " #f)")
      (if (not omit-code?) (putc #\)))
      (putc #\newline))

    (dump-fasl-segment segment)
    (flush)))

; eof
; Copyright 1998 Lars T Hansen.
;
; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
;
; Bootstrap heap dumper.
;
; Usage: (build-heap-image outputfile inputfile-list)
;
; Each input file is a sequence of segments, the structure of which 
; depends on the target architecture, but at least segment.code and 
; segment.constants exist as accessors.
;
; The code is a bytevector.  The constant vector contains tagged 
; entries (represented using length-2 lists), where the tags are
; `data', `codevector', `constantvector', `global', or `bits'.
;
; `build-heap-image' reads its file arguments into the heap, creates 
; thunks from the segments, and creates a list of the thunks.  It also 
; creates a list of all symbols present in the loaded files.  Finally, 
; it generates an initialization procedure (the LAP of which is hardcoded
; into this file; see below).  A pointer to this procedure is installed 
; in the SCHEME_ENTRY root pointer; hence, this procedure (a thunk, as 
; it were) is called when the heap image is loaded.
;
; The initialization procedure calls each procedure in the thunk list in 
; order.  It then invokes the procedure `go', which takes one argument:
; the list of symbols.  Typically, `go' will initialize the symbol table
; and other system tables and then call `main', but this is by no means
; required.
;
; The Scheme assembler must be co-resident, since it is used by 
; `build-heap-image' procedure to assemble the final startup code.  This
; could be avoided by pre-assembling the code and patching it here, but 
; the way it is now, this procedure is entirely portable -- no target
; dependencies.
;
; The code is structured to allow most procedures to be overridden for
; target architectures with more complex needs (notably the C backend).

(define generate-global-symbols
  (make-twobit-flag 'generate-global-symbols))
(generate-global-symbols #t)

(define heap.version-number 9)		; Heap version number

(define heap.root-names			; Roots in heap version 9
  '(result argreg2 argreg3 
    reg0 reg1 reg2 reg3 reg3 reg5 reg6 reg7 reg8 reg9 reg10 reg11 reg12
    reg13 reg14 reg15 reg16 reg17 reg18 reg19 reg20 reg21 reg22 reg23
    reg24 reg25 reg26 reg27 reg28 reg29 reg30 reg31 
    cont startup callouts schcall-arg4 alloci-tmp))
    
(define (build-heap-image output-file input-files)

  (define tmp-file "HEAPDATA.dat")

  (define (process-input-files heap)
    (let loop ((files input-files) (inits '()))
      (cond ((null? files)
	     (heap.thunks! heap (apply append inits)))
	    (else
	     (let ((filename (car files)))
	       (display "Loading ")
	       (display filename)
	       (newline)
	       (loop (cdr files)
		     (append inits (list (dump-file! heap filename)))))))))

  (delete-file tmp-file)
  (let ((heap  (make-heap #f (open-output-file tmp-file))))
    (before-all-files heap output-file input-files)
    (process-input-files heap)
    (heap.set-root! heap
		    'startup
		    (dump-startup-procedure! heap))
    (heap.set-root! heap
		    'callouts
		    (dump-global! heap 'millicode-support))
    (write-header heap output-file)
    (after-all-files heap output-file input-files)
    (close-output-port (heap.output-port heap))
    (append-file-shell-command tmp-file output-file)
    (load-map heap)
    (unspecified)))

(define (before-all-files heap output-file-name input-file-names) #t)
(define (after-all-files heap output-file-name input-file-names) #t)

; Public
;
; A 'heap' is a data structure with the following public fields; none
; of them are constant unless so annotated:
;
;  version          a fixnum (constant) - heap type version number
;  roots            an assoc list that maps root names to values
;  top              an exact non-negative integer: the address of the
;                   next byte to be emitted
;  symbol-table     a symbol table abstract data type
;  extra            any value - a client-extension field
;  output-port      an output port (for the data stream)
;  thunks           a list of codevector addresses
;
; Bytes are emitted with the heap.byte! and heap.word! procedures,
; which emit a byte and a 4-byte word respectively.  These update
; the top field.

(define (make-heap extra output-port)
  (vector heap.version-number        ; version
	  '()                        ; roots
	  0                          ; top
	  (make-heap-symbol-table)   ; symtab
	  extra                      ; extra
	  output-port                ; output port
	  '()			     ; thunks
	  ))

(define (heap.version h) (vector-ref h 0))
(define (heap.roots h) (vector-ref h 1))
(define (heap.top h) (vector-ref h 2))
(define (heap.symbol-table h) (vector-ref h 3))
(define (heap.extra h) (vector-ref h 4))
(define (heap.output-port h) (vector-ref h 5))
(define (heap.thunks h) (vector-ref h 6))

(define (heap.roots! h x) (vector-set! h 1 x))
(define (heap.top! h x) (vector-set! h 2 x))
(define (heap.thunks! h x) (vector-set! h 6 x))


; Symbol table.
;
; The symbol table maps names to symbol structures, and a symbol 
; structure contains information about that symbol.
;
; The structure has four fields:
;   name      a symbol - the print name
;   symloc    a fixnum or null - if fixnum, the location in the
;             heap of the symbol structure.
;   valloc    a fixnum or null - if fixnum, the location in the
;             heap of the global variable cell that has this
;             symbol for its name.
;   valno     a fixnum or null - if fixnum, the serial number of
;             the global variable cell (largely obsolete).
;
; Note therefore that the symbol table maintains information about
; whether the symbol is used as a symbol (in a datum), as a global
; variable, or both.

(define (make-heap-symbol-table)
  (vector '() 0))

(define (symtab.symbols st) (vector-ref st 0))
(define (symtab.cell-no st) (vector-ref st 1))

(define (symtab.symbols! st x) (vector-set! st 0 x))
(define (symtab.cell-no! st x) (vector-set! st 1 x))

(define (make-symcell name)
  (vector name '() '() '()))

(define (symcell.name sc) (vector-ref sc 0))    ; name
(define (symcell.symloc sc) (vector-ref sc 1))  ; symbol location (if any)
(define (symcell.valloc sc) (vector-ref sc 2))  ; value cell location (ditto)
(define (symcell.valno sc) (vector-ref sc 3))   ; value cell number (ditto)

(define (symcell.symloc! sc x) (vector-set! sc 1 x))
(define (symcell.valloc! sc x) (vector-set! sc 2 x))
(define (symcell.valno! sc x) (vector-set! sc 3 x))

; Find a symcell in the table, or make a new one if there's none.

(define (symbol-cell h name)
  (let ((symtab (heap.symbol-table h)))
    (let loop ((symbols (symtab.symbols symtab)))
      (cond ((null? symbols)
	     (let ((new-sym (make-symcell name)))
	       (symtab.symbols! symtab (cons new-sym
					     (symtab.symbols symtab)))
	       new-sym))
	    ((eq? name (symcell.name (car symbols)))
	     (car symbols))
	    (else
	     (loop (cdr symbols)))))))


; Fundamental data emitters

(define twofiftysix^3 (* 256 256 256))
(define twofiftysix^2 (* 256 256))
(define twofiftysix   256)

(define (heap.word-be! h w)
  (heap.byte! h (quotient w twofiftysix^3))
  (heap.byte! h (quotient (remainder w twofiftysix^3) twofiftysix^2))
  (heap.byte! h (quotient (remainder w twofiftysix^2) twofiftysix))
  (heap.byte! h (remainder w twofiftysix)))

(define (heap.word-el! h w)
  (heap.byte! h (remainder w twofiftysix))
  (heap.byte! h (quotient (remainder w twofiftysix^2) twofiftysix))
  (heap.byte! h (quotient (remainder w twofiftysix^3) twofiftysix^2))
  (heap.byte! h (quotient w twofiftysix^3)))

(define heap.word! heap.word-be!)

(define (dumpheap.set-endianness! which)
  (case which
    ((big) (set! heap.word! heap.word-be!))
    ((little) (set! heap.word! heap.word-el!))
    (else ???)))

(define (heap.byte! h b)
  (write-char (integer->char b) (heap.output-port h))
  (heap.top! h (+ 1 (heap.top h))))


; Useful abstractions and constants.

(define (heap.header-word! h immediate length)
  (heap.word! h (+ (* length 256) immediate)))

(define (heap.adjust! h)
  (let ((p (heap.top h)))
    (let loop ((i (- (* 8 (quotient (+ p 7) 8)) p)))
      (if (zero? i)
	  '()
	  (begin (heap.byte! h 0)
		 (loop (- i 1)))))))
  
(define heap.largest-fixnum (- (expt 2 29) 1))
(define heap.smallest-fixnum (- (expt 2 29)))

(define (heap.set-root! h name value)
  (heap.roots! h (cons (cons name value) (heap.roots h))))


;;; The segment.* procedures may be overridden by custom code.

(define segment.code car)
(define segment.constants cdr)

;;; The dump-*! procedures may be overridden by custom code.

; Load a LOP file into the heap, create a thunk in the heap to hold the
; code and constant vector, and return the list of thunk addresses in
; the order dumped.

(define (dump-file! h filename)
  (before-dump-file h filename)
  (call-with-input-file filename
    (lambda (in)
      (do ((segment (read in) (read in))
	   (thunks  '() (cons (dump-segment! h segment) thunks)))
	  ((eof-object? segment)
	   (after-dump-file h filename)
	   (reverse thunks))))))

(define (before-dump-file h filename) #t)
(define (after-dump-file h filename) #t)

; Dump a segment and return the heap address of the resulting thunk.

(define (dump-segment! h segment)
  (let* ((the-code   (dump-codevector! h (segment.code segment)))
	 (the-consts (dump-constantvector! h (segment.constants segment))))
    (dump-thunk! h the-code the-consts)))

(define (dump-tagged-item! h item)
  (case (car item)
    ((codevector)
     (dump-codevector! h (cadr item)))
    ((constantvector)
     (dump-constantvector! h (cadr item)))
    ((data)
     (dump-datum! h (cadr item)))
    ((global)
     (dump-global! h (cadr item)))
    ((bits)
     (cadr item))
    (else
     (error 'dump-tagged-item! "Unknown item ~a" item))))

(define (dump-datum! h datum)

  (define (fixnum? x)
    (and (integer? x)
	 (exact? x)
	 (<= heap.smallest-fixnum x heap.largest-fixnum)))

  (define (bignum? x)
    (and (integer? x)
	 (exact? x)
	 (or (> x heap.largest-fixnum)
	     (< x heap.smallest-fixnum))))

  (define (ratnum? x)
    (and (rational? x) (exact? x) (not (integer? x))))

  (define (flonum? x)
    (and (real? x) (inexact? x)))

  (define (compnum? x)
    (and (complex? x) (inexact? x) (not (real? x))))

  (define (rectnum? x)
    (and (complex? x) (exact? x) (not (real? x))))

  (cond ((fixnum? datum)
	 (dump-fixnum! h datum))
	((bignum? datum)
	 (dump-bignum! h datum))
	((ratnum? datum)
	 (dump-ratnum! h datum))
	((flonum? datum)
	 (dump-flonum! h datum))
	((compnum? datum)
	 (dump-compnum! h datum))
	((rectnum? datum)
	 (dump-rectnum! h datum))
	((char? datum)
	 (dump-char! h datum))
	((null? datum)
	 $imm.null)
	((eq? datum #t)
	 $imm.true)
	((eq? datum #f)
	 $imm.false)
	((equal? datum (unspecified))
	 $imm.unspecified)
	((equal? datum (undefined))
	 $imm.undefined)
	((vector? datum)
	 (dump-vector! h datum $tag.vector-typetag))
	((bytevector? datum)
	 (dump-bytevector! h datum $tag.bytevector-typetag))
	((pair? datum)
	 (dump-pair! h datum))
	((string? datum)
	 (dump-string! h datum))
	((symbol? datum)
	 (dump-symbol! h datum))
	(else
	 (error 'dump-datum! "Unsupported type of datum ~a" datum))))

; Returns the two's complement representation as a positive number.

(define (dump-fixnum! h f)
  (if (negative? f)
      (- #x100000000 (* (abs f) 4))
      (* 4 f)))

(define (dump-char! h c)
  (+ (* (char->integer c) twofiftysix^2) $imm.character))

(define (dump-bignum! h b)
  (dump-bytevector! h (bignum->bytevector b) $tag.bignum-typetag))

(define (dump-ratnum! h r)
  (dump-vector! h 
		(vector (numerator r) (denominator r)) 
		$tag.ratnum-typetag))

(define (dump-flonum! h f)
  (dump-bytevector! h (flonum->bytevector f) $tag.flonum-typetag))

(define (dump-compnum! h c)
  (dump-bytevector! h (compnum->bytevector c) $tag.compnum-typetag))

(define (dump-rectnum! h r)
  (dump-vector! h
		(vector (real-part r) (imag-part r))
		$tag.rectnum-typetag))

(define (dump-string! h s)
  (dump-bytevector! h (string->bytevector s) $tag.string-typetag))

(define (dump-pair! h p)
  (let ((the-car (dump-datum! h (car p)))
	(the-cdr (dump-datum! h (cdr p))))
    (let ((base (heap.top h)))
      (heap.word! h the-car)
      (heap.word! h the-cdr)
      (+ base $tag.pair-tag))))

(define (dump-bytevector! h bv variation)
  (let ((base (heap.top h))
	(l    (bytevector-length bv)))
    (heap.header-word! h (+ $imm.bytevector-header variation) l)
    (let loop ((i 0))
      (if (< i l)
	  (begin (heap.byte! h (bytevector-ref bv i))
		 (loop (+ i 1)))
	  (begin (heap.adjust! h)
		 (+ base $tag.bytevector-tag))))))

(define (dump-vector! h v variation)
  (dump-vector-like! h v dump-datum! variation))

(define (dump-vector-like! h cv recur! variation)
  (let* ((l (vector-length cv))
	 (v (make-vector l '())))
    (let loop ((i 0))
      (if (< i l)
	  (begin (vector-set! v i (recur! h (vector-ref cv i)))
		 (loop (+ i 1)))
	  (let ((base (heap.top h)))
	    (heap.header-word! h (+ $imm.vector-header variation) (* l 4))
	    (let loop ((i 0))
	      (if (< i l)
		  (begin (heap.word! h (vector-ref v i))
			 (loop (+ i 1)))
		  (begin (heap.adjust! h)
			 (+ base $tag.vector-tag)))))))))

(define (dump-codevector! h cv)
  (dump-bytevector! h cv $tag.bytevector-typetag))

(define (dump-constantvector! h cv)
  (dump-vector-like! h cv dump-tagged-item! $tag.vector-typetag))

(define (dump-symbol! h s)
  (let ((x (symbol-cell h s)))
    (if (null? (symcell.symloc x))
	(symcell.symloc! x (create-symbol! h s)))
    (symcell.symloc x)))

(define (dump-global! h g)
  (let ((x (symbol-cell h g)))
    (if (null? (symcell.valloc x))
	(let ((cell (create-cell! h g)))
	  (symcell.valloc! x (car cell))
	  (symcell.valno! x (cdr cell))))
    (symcell.valloc x)))

(define (dump-thunk! h code constants)
  (let ((base (heap.top h)))
    (heap.header-word! h $imm.procedure-header 8)
    (heap.word! h code)
    (heap.word! h constants)
    (heap.adjust! h)
    (+ base $tag.procedure-tag)))

; The car's are all heap pointers, so they should not be messed with.
; The cdr must be dumped, and then the pair.

(define (dump-list-spine! h l)
  (if (null? l)
      $imm.null
      (let ((the-car (car l))
	    (the-cdr (dump-list-spine! h (cdr l))))
	(let ((base (heap.top h)))
	  (heap.word! h the-car)
	  (heap.word! h the-cdr)
	  (+ base $tag.pair-tag)))))

(define (dump-startup-procedure! h)
  (let ((thunks  (dump-list-spine! h (heap.thunks h)))
	(symbols (dump-list-spine! h (symbol-locations h))))
    (dump-segment! h (construct-startup-procedure symbols thunks))))

; The initialization procedure. The lists are magically patched into
; the constant vector after the procedure has been assembled but before
; it is dumped into the heap. See below.
;
; (define (init-proc argv)
;   (let loop ((l <list-of-thunks>))
;     (if (null? l)
;         (go <list-of-symbols> argv)
;         (begin ((car l))
;                (loop (cdr l))))))

(define init-proc
  `((,$.proc)
    (,$args= 1)
    (,$reg 1)				; argv into
    (,$setreg 2)			;   register 2
    (,$const (thunks))			; dummy list of thunks.
    (,$setreg 1)
    (,$.label 0)
    (,$reg 1)
    (,$op1 null?)			; (null? l)
    (,$branchf 2)
    (,$const (symbols))			; dummy list of symbols
    (,$setreg 1)
    (,$global go)
    ;(,$op1 break)
    (,$invoke 2)			; (go <list of symbols> argv)
    (,$.label 2)
    (,$save 2)
    (,$store 0 0)
    (,$store 1 1)
    (,$store 2 2)
    (,$setrtn 3)
    (,$reg 1)
    (,$op1 car)
    (,$invoke 0)			; ((car l))
    (,$.label 3)
    (,$.cont)
    (,$restore 2)
    (,$pop 2)
    (,$reg 1)
    (,$op1 cdr)
    (,$setreg 1)
    (,$branch 0)))			; (loop (cdr l))


;;; Non-overridable code beyond this point

; Stuff a new symbol into the heap, return its location.

(define (create-symbol! h s)
  (dump-vector-like!
   h 
   (vector `(bits ,(dump-string! h (symbol->string s)))
	   '(data 0)
	   '(data ()))
   dump-tagged-item!
   $tag.symbol-typetag))


; Stuff a value cell into the heap, return a pair of its location
; and its cell number.

(define (create-cell! h s)
  (let* ((symtab (heap.symbol-table h))
	 (n (symtab.cell-no symtab))
	 (p (dump-pair! h (cons (undefined)
				(if (generate-global-symbols)
				    s
				    n)))))
    (symtab.cell-no! symtab (+ n 1))
    (cons p n)))


(define (construct-startup-procedure symbol-list-addr init-list-addr)

  ; Given some value which might appear in the constant vector, 
  ; replace the entries matching that value with a new value.

  (define (patch-constant-vector! v old new)
    (let loop ((i (- (vector-length v) 1)))
      (if (>= i 0)
	  (begin (if (equal? (vector-ref v i) old)
		     (vector-set! v i new))
		 (loop (- i 1))))))

  ; Assemble the startup thunk, patch it, and return it.

  (display "Assembling final procedure") (newline)
  (let ((e (single-stepping)))
    (single-stepping #f)
    (let ((segment (assemble init-proc)))
      (single-stepping e)
      (patch-constant-vector! (segment.constants segment)
			      '(data (thunks))
			      `(bits ,init-list-addr))
      (patch-constant-vector! (segment.constants segment)
			      '(data (symbols))
			      `(bits ,symbol-list-addr))
      segment)))


; Return a list of symbol locations for symbols in the heap, in order.

(define (symbol-locations h)
  (let loop ((symbols (symtab.symbols (heap.symbol-table h))) (res '()))
    (cond ((null? symbols)
	   (reverse res))
	  ((not (null? (symcell.symloc (car symbols))))
	   (loop (cdr symbols)
		 (cons (symcell.symloc (car symbols)) res)))
	  (else
	   (loop (cdr symbols) res)))))

; Return list of variable name to cell number mappings for global vars.

(define (load-map h)
  (let loop ((symbols (symtab.symbols (heap.symbol-table h))) (res '()))
    (cond ((null? symbols)
	   (reverse res))
	  ((not (null? (symcell.valloc (car symbols))))
	   (loop (cdr symbols)
		 (cons (cons (symcell.name (car symbols))
			     (symcell.valno (car symbols)))
		       res)))
	  (else
	   (loop (cdr symbols) res)))))


(define (write-header h output-file)
  (delete-file output-file)
  (call-with-output-file output-file
    (lambda (out)

      (define (write-word w)
	(display (integer->char (quotient w twofiftysix^3)) out)
	(display (integer->char (quotient (remainder w twofiftysix^3) 
					  twofiftysix^2))
		 out)
	(display (integer->char (quotient (remainder w twofiftysix^2) 
					  twofiftysix))
		 out)
	(display (integer->char (remainder w twofiftysix)) out))

      (define (write-roots)
	(let ((assigned-roots (heap.roots h)))
	  (for-each (lambda (root-name)
		      (let ((probe (assq root-name assigned-roots)))
			(if probe
			    (write-word (cdr probe))
			    (write-word $imm.false))))
		    heap.root-names)))

      (write-word heap.version-number)
      (write-roots)
      (write-word (quotient (heap.top h) 4)))))


; This is a gross hack that happens to work very well.

(define (append-file-shell-command file-to-append file-to-append-to)

  (define (message)
    (display "You must execute the command") (newline)
    (display "   cat ") (display file-to-append) 
    (display " >> ") (display file-to-append-to) (newline)
    (display "to create the final heap image.") (newline))

  (case host-system
    ((chez larceny)
     (display "Creating final image in \"")
     (display file-to-append-to) (display "\"...") (newline)
     (if (zero? (system (string-append "cat " file-to-append " >> " 
				       file-to-append-to)))
	 (delete-file file-to-append)
	 (begin (display "Failed to create image!")
		(newline))))
    (else
     (message))))

; eof
; Copyright 1991 Lightship Software, Incorporated.
;
; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
;
; 11 June 1999 / wdc
;
; Asm/Sparc/pass5p2.sch -- Sparc machine assembler, top level

; Overrides the procedure of the same name in Asm/Common/pass5p1.sch.

(define (assembly-table) $sparc-assembly-table$)

; Controls listing of instructions during assembly.

(define listify? #f)

; Table of assembler procedures.

(define $sparc-assembly-table$
  (make-vector
   *number-of-mnemonics*
   (lambda (instruction as)
     (asm-error "Unrecognized mnemonic " instruction))))

(define (define-instruction i proc)
  (vector-set! $sparc-assembly-table$ i proc)
  #t)

(define (list-instruction name instruction)
  (if listify?
      (begin (display list-indentation)
             (display "        ")
             (display name)
             (display (make-string (max (- 12 (string-length name)) 1)
                                   #\space))
             (if (not (null? (cdr instruction)))
                 (begin (write (cadr instruction))
                        (do ((operands (cddr instruction)
                                       (cdr operands)))
                            ((null? operands))
                            (write-char #\,)
                            (write (car operands)))))
             (newline)
             (flush-output-port))))

(define (list-label instruction)
  (if listify?
      (begin (display list-indentation)
             (write-char #\L)
             (write (cadr instruction))
             (newline))))

(define (list-lambda-start instruction)
  (list-instruction "lambda" (list $lambda '* (operand2 instruction)))
  (set! list-indentation (string-append list-indentation "|   ")))

(define (list-lambda-end)
  (set! list-indentation
        (substring list-indentation
                   0
                   (- (string-length list-indentation) 4))))

(define list-indentation "")

; Utilities

; Pseudo-instructions.

(define-instruction $.label
  (lambda (instruction as)
    (list-label instruction)
    (sparc.label as (make-asm-label as (operand1 instruction)))))

(define-instruction $.proc
  (lambda (instruction as)
    (list-instruction ".proc" instruction)
    #t))

(define-instruction $.proc-doc
  (lambda (instruction as)
    (list-instruction ".proc-doc" instruction)
    (add-documentation as (operand1 instruction))
    #t))

(define-instruction $.cont
  (lambda (instruction as)
    (list-instruction ".cont" instruction)
    #t))

(define-instruction $.align
  (lambda (instruction as)
    (list-instruction ".align" instruction)
    #t))

(define-instruction $.end
  (lambda (instruction as)
    #t))

(define-instruction $.singlestep
  (lambda (instruction as)
    (let ((instr (car (as-source as))))
      
      (define (special?)
        (let ((op (operand0 instr)))
          (or (= op $.label)
              (= op $.proc)
              (= op $.cont)
              (= op $.align)
              (and (= op $load) (= 0 (operand1 instr))))))
      
      (define (readify-instr)
        (if (= (operand0 instr) $lambda)
            (list 'lambda '(...) (caddr instr) (cadddr instr))
            (car (readify-lap (list instr)))))
      
      (if (not (special?))
          (let ((repr   (format-object (readify-instr)))
                (funky? (= (operand0 instr) $restore)))
            (let ((o (emit-datum as repr)))
              (emit-singlestep-instr! as funky? 0 o)))))))


; Instructions.

(define-instruction $op1
  (lambda (instruction as)
    (list-instruction "op1" instruction)
    (emit-primop.1arg! as (operand1 instruction))))

(define-instruction $op2
  (lambda (instruction as)
    (list-instruction "op2" instruction)
    (emit-primop.2arg! as
                       (operand1 instruction)
                       (regname (operand2 instruction)))))

(define-instruction $op3
  (lambda (instruction as)
    (list-instruction "op3" instruction)
    (emit-primop.3arg! as
                       (operand1 instruction)
                       (regname (operand2 instruction))
                       (regname (operand3 instruction)))))

(define-instruction $op2imm
  (lambda (instruction as)
    (list-instruction "op2imm" instruction)
    (let ((op (case (operand1 instruction)
                ((+)    'internal:+/imm)
                ((-)    'internal:-/imm)
                ((fx+)  'internal:fx+/imm)
                ((fx-)  'internal:fx-/imm)
                ((fx=)  'internal:fx=/imm)
                ((fx<)  'internal:fx</imm)
                ((fx<=) 'internal:fx<=/imm)
                ((fx>)  'internal:fx>/imm)
                ((fx>=) 'internal:fx>=/imm)
                ((=:fix:fix)  'internal:=:fix:fix/imm)
                ((<:fix:fix)  'internal:<:fix:fix/imm)
                ((<=:fix:fix) 'internal:<=:fix:fix/imm)
                ((>:fix:fix)  'internal:>:fix:fix/imm)
                ((>=:fix:fix) 'internal:>=:fix:fix/imm)
                (else #f))))
      (if op
          (emit-primop.4arg! as op $r.result (operand2 instruction) $r.result)
          (begin
           (emit-constant->register as (operand2 instruction) $r.argreg2)
           (emit-primop.2arg! as
                              (operand1 instruction)
                              $r.argreg2))))))

(define-instruction $const
  (lambda (instruction as)
    (list-instruction "const" instruction)
    (emit-constant->register as (operand1 instruction) $r.result)))

(define-instruction $global
  (lambda (instruction as)
    (list-instruction "global" instruction)
    (emit-global->register! as
                            (emit-global as (operand1 instruction))
                            $r.result)))

(define-instruction $setglbl
  (lambda (instruction as)
    (list-instruction "setglbl" instruction)
    (emit-register->global! as
                            $r.result
                            (emit-global as (operand1 instruction)))))

; FIXME: A problem is that the listing is messed up because of the delayed
; assembly; somehow we should fix this by putting an identifying label
; in the listing and emitting this label later, with the code.

(define-instruction $lambda
  (lambda (instruction as)
    (let ((code-offset  #f)
          (const-offset #f))
      (list-lambda-start instruction)
      (assemble-nested-lambda as
                              (operand1 instruction)
                              (operand3 instruction)   ; documentation
                              (lambda (nested-as segment)
                                (set-constant! as code-offset (car segment))
                                (set-constant! as const-offset (cdr segment))))
      (list-lambda-end)
      (set! code-offset  (emit-codevector as 0))
      (set! const-offset (emit-constantvector as 0))
      (emit-lambda! as
                    code-offset
                    const-offset
                    (operand2 instruction)))))

(define-instruction $lexes
  (lambda (instruction as)
    (list-instruction "lexes" instruction)
    (emit-lexes! as (operand1 instruction))))

(define-instruction $args=
  (lambda (instruction as)
    (list-instruction "args=" instruction)
    (emit-args=! as (operand1 instruction))))

(define-instruction $args>=
  (lambda (instruction as)
    (list-instruction "args>=" instruction)
    (emit-args>=! as (operand1 instruction))))

(define-instruction $invoke
  (lambda (instruction as)
    (list-instruction "invoke" instruction)
    (emit-invoke as (operand1 instruction) #f $m.invoke-ex)))

(define-instruction $restore
  (lambda (instruction as)
    (if (not (negative? (operand1 instruction)))
        (begin
         (list-instruction "restore" instruction)
         (emit-restore! as (operand1 instruction))))))

(define-instruction $pop
  (lambda (instruction as)
    (if (not (negative? (operand1 instruction)))
        (begin
         (list-instruction "pop" instruction)
         (let ((next (next-instruction as)))
           (if (and (peephole-optimization)
                    (eqv? $return (operand0 next)))
               (begin (list-instruction "return" next)
                      (consume-next-instruction! as)
                      (emit-pop! as (operand1 instruction) #t))
               (emit-pop! as (operand1 instruction) #f)))))))

(define-instruction $stack
  (lambda (instruction as)
    (list-instruction "stack" instruction)
    (emit-load! as (operand1 instruction) $r.result)))

(define-instruction $setstk
  (lambda (instruction as)
    (list-instruction "setstk" instruction)
    (emit-store! as $r.result (operand1 instruction))))

(define-instruction $load
  (lambda (instruction as)
    (list-instruction "load" instruction)
    (emit-load! as (operand2 instruction) (regname (operand1 instruction)))))

(define-instruction $store
  (lambda (instruction as)
    (list-instruction "store" instruction)
    (emit-store! as (regname (operand1 instruction)) (operand2 instruction))))

(define-instruction $lexical
  (lambda (instruction as)
    (list-instruction "lexical" instruction)
    (emit-lexical! as (operand1 instruction) (operand2 instruction))))

(define-instruction $setlex
  (lambda (instruction as)
    (list-instruction "setlex" instruction)
    (emit-setlex! as (operand1 instruction) (operand2 instruction))))

(define-instruction $reg
  (lambda (instruction as)
    (list-instruction "reg" instruction)
    (emit-register->register! as (regname (operand1 instruction)) $r.result)))

(define-instruction $setreg
  (lambda (instruction as)
    (list-instruction "setreg" instruction)
    (emit-register->register! as $r.result (regname (operand1 instruction)))))

(define-instruction $movereg
  (lambda (instruction as)
    (list-instruction "movereg" instruction)
    (emit-register->register! as 
                              (regname (operand1 instruction))
                              (regname (operand2 instruction)))))

(define-instruction $return
  (lambda (instruction as)
    (list-instruction "return" instruction)
    (emit-return! as)))

(define-instruction $reg/return
  (lambda (instruction as)
    (list-instruction "reg/return" instruction)
    (emit-return-reg! as (regname (operand1 instruction)))))

(define-instruction $const/return
  (lambda (instruction as)
    (list-instruction "const/return" instruction)
    (emit-return-const! as (operand1 instruction))))

(define-instruction $nop
  (lambda (instruction as)
    (list-instruction "nop" instruction)))

(define-instruction $save
  (lambda (instruction as)
    (if (not (negative? (operand1 instruction)))
        (begin
         (list-instruction "save" instruction)
         (let* ((n (operand1 instruction))
                (v (make-vector (+ n 1) #t)))
           (emit-save0! as n)
           (if (peephole-optimization)
               (let loop ((instruction (next-instruction as)))
                 (if (eqv? $store (operand0 instruction))
                     (begin (list-instruction "store" instruction)
                            (emit-store! as
                                         (regname (operand1 instruction))
                                         (operand2 instruction))
                            (consume-next-instruction! as)
                            (vector-set! v (operand2 instruction) #f)
                            (loop (next-instruction as))))))
           (emit-save1! as v))))))

(define-instruction $setrtn
  (lambda (instruction as)
    (list-instruction "setrtn" instruction)
    (emit-setrtn! as (make-asm-label as (operand1 instruction)))))

(define-instruction $apply
  (lambda (instruction as)
    (list-instruction "apply" instruction)
    (emit-apply! as
                 (regname (operand1 instruction))
                 (regname (operand2 instruction)))))

(define-instruction $jump
  (lambda (instruction as)
    (list-instruction "jump" instruction)
    (emit-jump! as
                (operand1 instruction)
                (make-asm-label as (operand2 instruction)))))

(define-instruction $skip
  (lambda (instruction as)
    (list-instruction "skip" instruction)
    (emit-branch! as #f (make-asm-label as (operand1 instruction)))))

(define-instruction $branch
  (lambda (instruction as)
    (list-instruction "branch" instruction)
    (emit-branch! as #t (make-asm-label as (operand1 instruction)))))

(define-instruction $branchf
  (lambda (instruction as)
    (list-instruction "branchf" instruction)
    (emit-branchf! as (make-asm-label as (operand1 instruction)))))

(define-instruction $check
  (lambda (instruction as)
    (list-instruction "check" instruction)
    (if (not (unsafe-code))
        (emit-check! as $r.result
                        (make-asm-label as (operand4 instruction))
                        (list (regname (operand1 instruction))
                              (regname (operand2 instruction))
                              (regname (operand3 instruction)))))))

(define-instruction $trap
  (lambda (instruction as)
    (list-instruction "trap" instruction)
    (emit-trap! as
                (regname (operand1 instruction))
                (regname (operand2 instruction))
                (regname (operand3 instruction))
                (operand4 instruction))))

(define-instruction $const/setreg
  (lambda (instruction as)
    (list-instruction "const/setreg" instruction)
    (let ((x (operand1 instruction))
          (r (operand2 instruction)))
      (if (hwreg? r)
          (emit-constant->register as x (regname r))
          (begin (emit-constant->register as x $r.tmp0)
                 (emit-register->register! as $r.tmp0 (regname r)))))))

; Operations introduced by the peephole optimizer.

(define (peep-regname r)
  (if (eq? r 'RESULT) $r.result (regname r)))

(define-instruction $reg/op1/branchf
  (lambda (instruction as)
    (list-instruction "reg/op1/branchf" instruction)
    (emit-primop.3arg! as
                       (operand1 instruction)
                       (peep-regname (operand2 instruction))
                       (make-asm-label as (operand3 instruction)))))

(define-instruction $reg/op2/branchf
  (lambda (instruction as)
    (list-instruction "reg/op2/branchf" instruction)
    (emit-primop.4arg! as
                       (operand1 instruction)
                       (peep-regname (operand2 instruction))
                       (peep-regname (operand3 instruction))
                       (make-asm-label as (operand4 instruction)))))

(define-instruction $reg/op2imm/branchf
  (lambda (instruction as)
    (list-instruction "reg/op2imm/branchf" instruction)
    (emit-primop.4arg! as
                       (operand1 instruction)
                       (peep-regname (operand2 instruction))
                       (operand3 instruction)
                       (make-asm-label as (operand4 instruction)))))

; These three are like the corresponding branchf sequences except that
; there is a strong prediction that the branch will not be taken.

(define-instruction $reg/op1/check
  (lambda (instruction as)
    (list-instruction "reg/op1/check" instruction)
    (emit-primop.4arg! as
                       (operand1 instruction)
                       (peep-regname (operand2 instruction))
                       (make-asm-label as (operand3 instruction))
                       (map peep-regname (operand4 instruction)))))

(define-instruction $reg/op2/check
  (lambda (instruction as)
    (list-instruction "reg/op2/check" instruction)
    (emit-primop.5arg! as
                       (operand1 instruction)
                       (peep-regname (operand2 instruction))
                       (peep-regname (operand3 instruction))
                       (make-asm-label as (operand4 instruction))
                       (map peep-regname (operand5 instruction)))))

(define-instruction $reg/op2imm/check
  (lambda (instruction as)
    (list-instruction "reg/op2imm/check" instruction)
    (emit-primop.5arg! as
                       (operand1 instruction)
                       (peep-regname (operand2 instruction))
                       (operand3 instruction)
                       (make-asm-label as (operand4 instruction))
                       (map peep-regname (operand5 instruction)))))

;

(define-instruction $reg/op1/setreg
  (lambda (instruction as)
    (list-instruction "reg/op1/setreg" instruction)
    (emit-primop.3arg! as
                       (operand1 instruction)
                       (peep-regname (operand2 instruction))
                       (peep-regname (operand3 instruction)))))

(define-instruction $reg/op2/setreg
  (lambda (instruction as)
    (list-instruction "reg/op2/setreg" instruction)
    (emit-primop.4arg! as
                       (operand1 instruction)
                       (peep-regname (operand2 instruction))
                       (peep-regname (operand3 instruction))
                       (peep-regname (operand4 instruction)))))

(define-instruction $reg/op2imm/setreg
  (lambda (instruction as)
    (list-instruction "reg/op2imm/setreg" instruction)
    (emit-primop.4arg! as
                       (operand1 instruction)
                       (peep-regname (operand2 instruction))
                       (operand3 instruction)
                       (peep-regname (operand4 instruction)))))

(define-instruction $reg/op3 
  (lambda (instruction as)
    (list-instruction "reg/op3" instruction)
    (emit-primop.4arg! as
                       (operand1 instruction)
                       (peep-regname (operand2 instruction))
                       (peep-regname (operand3 instruction))
                       (peep-regname (operand4 instruction)))))

(define-instruction $reg/branchf
  (lambda (instruction as)
    (list-instruction "reg/branchf" instruction)
    (emit-branchfreg! as 
                      (regname (operand1 instruction))
                      (make-asm-label as (operand2 instruction)))))

(define-instruction $setrtn/branch
  (lambda (instruction as)
    (list-instruction "setrtn/branch" instruction)
    (emit-branch-with-setrtn! as (make-asm-label as (operand1 instruction)))))

(define-instruction $setrtn/invoke
  (lambda (instruction as)
    (list-instruction "setrtn/invoke" instruction)
    (emit-invoke as (operand1 instruction) #t $m.invoke-ex)))

(define-instruction $global/setreg
  (lambda (instruction as)
    (list-instruction "global/setreg" instruction)
    (emit-global->register! as
                            (emit-global as (operand1 instruction))
                            (regname (operand2 instruction)))))

(define-instruction $global/invoke
  (lambda (instruction as)
    (list-instruction "global/invoke" instruction)
    (emit-load-global as
                      (emit-global as (operand1 instruction))
                      $r.result
                      #f)
    (emit-invoke as (operand2 instruction) #f $m.global-invoke-ex)))

(define-instruction $reg/setglbl
  (lambda (instruction as)
    (list-instruction "reg/setglbl" instruction)
    (emit-register->global! as
                            (regname (operand1 instruction))
                            (emit-global as (operand2 instruction)))))

; eof
; Copyright 1998 Lars T Hansen.
;
; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
;
; 9 May 1999.
;
; Asm/Sparc/peepopt.sch -- MAL peephole optimizer, for the SPARC assembler.
;
; The procedure `peep' is called on the as structure before every
; instruction is assembled.  It may replace the prefix of the instruction
; stream by some other instruction sequence.
;
; Invariant: if the peephole optimizer doesn't change anything, then 
;
;  (let ((x (as-source as)))
;    (peep as)
;    (eq? x (as-source as)))     => #t
;
; Note this still isn't right -- it should be integrated with pass5p2 --
; but it's a step in the right direction.

(define *peephole-table* (make-vector *number-of-mnemonics* #f))

(define (define-peephole n p)
  (vector-set! *peephole-table* n p)
  (unspecified))

(define (peep as)
  (let ((t0 (as-source as)))
    (if (not (null? t0))
        (let ((i1 (car t0)))
          (let ((p (vector-ref *peephole-table* (car i1))))
            (if p
                (let* ((t1 (if (null? t0) t0 (cdr t0)))
                       (i2 (if (null? t1) '(-1 0 0 0) (car t1)))
                       (t2 (if (null? t1) t1 (cdr t1)))
                       (i3 (if (null? t2) '(-1 0 0 0) (car t2)))
                       (t3 (if (null? t2) t2 (cdr t2))))
                  (p as i1 i2 i3 t1 t2 t3))))))))

(define-peephole $reg
  (lambda (as i1 i2 i3 t1 t2 t3)
    (cond ((= (car i2) $return)
           (reg-return as i1 i2 t2))
          ((= (car i2) $setglbl)
           (reg-setglbl as i1 i2 t2))
          ((= (car i2) $op1)
           (cond ((= (car i3) $setreg)
                  (reg-op1-setreg as i1 i2 i3 t2 t3))
                 ((= (car i3) $branchf)
                  (reg-op1-branchf as i1 i2 i3 t3))
                 ((= (car i3) $check)
                  (reg-op1-check as i1 i2 i3 t3))
                 (else
                  (reg-op1 as i1 i2 t2))))
          ((= (car i2) $op2)
           (cond ((= (car i3) $setreg)
                  (reg-op2-setreg as i1 i2 i3 t2 t3))
                 ((= (car i3) $branchf)
                  (reg-op2-branchf as i1 i2 i3 t3))
                 ((= (car i3) $check)
                  (reg-op2-check as i1 i2 i3 t3))
                 (else
                  (reg-op2 as i1 i2 t2))))
          ((= (car i2) $op2imm)
           (cond ((= (car i3) $setreg)
                  (reg-op2imm-setreg as i1 i2 i3 t2 t3))
                 ((= (car i3) $branchf)
                  (reg-op2imm-branchf as i1 i2 i3 t3))
                 ((= (car i3) $check)
                  (reg-op2imm-check as i1 i2 i3 t3))
                 (else
                  (reg-op2imm as i1 i2 t2))))
          ((= (car i2) $op3)
           (reg-op3 as i1 i2 t2))
          ((= (car i2) $setreg)
           (reg-setreg as i1 i2 t2))
          ((= (car i2) $branchf)
           (reg-branchf as i1 i2 t2)))))

(define-peephole $op1
  (lambda (as i1 i2 i3 t1 t2 t3)
    (cond ((= (car i2) $branchf)
           (op1-branchf as i1 i2 t2))
          ((= (car i2) $setreg)
           (op1-setreg as i1 i2 t2))
          ((= (car i2) $check)
           (op1-check as i1 i2 t2)))))

(define-peephole $op2
  (lambda (as i1 i2 i3 t1 t2 t3)
    (cond ((= (car i2) $branchf)
           (op2-branchf as i1 i2 t2))
          ((= (car i2) $setreg)
           (op2-setreg as i1 i2 t2))
          ((= (car i2) $check)
           (op2-check as i1 i2 t2)))))

(define-peephole $op2imm
  (lambda (as i1 i2 i3 t1 t2 t3)
    (cond ((= (car i2) $branchf)
           (op2imm-branchf as i1 i2 t2))
          ((= (car i2) $setreg)
           (op2imm-setreg as i1 i2 t2))
          ((= (car i2) $check)
           (op2imm-check as i1 i2 t2)))))

(define-peephole $const
  (lambda (as i1 i2 i3 t1 t2 t3)
    (cond ((= (car i2) $setreg)
           (const-setreg as i1 i2 t2))
          ((= (car i2) $op2)
           (const-op2 as i1 i2 t2))
          ((= (car i2) $return)
           (const-return as i1 i2 t2)))))

(define-peephole $setrtn
  (lambda (as i1 i2 i3 t1 t2 t3)
    (cond ((= (car i2) $branch)
           (cond ((= (car i3) $.align)
                  (if (not (null? t3))
                      (let ((i4 (car t3))
                            (t4 (cdr t3)))
                        (cond ((= (car i4) $.label)
                               (setrtn-branch as i1 i2 i3 i4 t4))))))))
          ((= (car i2) $invoke)
           (cond ((= (car i3) $.align)
                  (if (not (null? t3))
                      (let ((i4 (car t3))
                            (t4 (cdr t3)))
                        (cond ((= (car i4) $.label)
                               (setrtn-invoke as i1 i2 i3 i4 t4)))))))))))

(define-peephole $branch
  (lambda (as i1 i2 i3 t1 t2 t3)
    (cond ((= (car i2) $.align)
           (cond ((= (car i3) $.label)
                  (branch-and-label as i1 i2 i3 t3)))))))

(define-peephole $global
  (lambda (as i1 i2 i3 t1 t2 t3)
    (cond ((= (car i2) $setreg)
           (global-setreg as i1 i2 t2))
          ((= (car i2) $invoke)
           (global-invoke as i1 i2 t2))
          ((= (car i2) $setrtn)
           (cond ((= (car i3) $invoke)
                  (global-setrtn-invoke as i1 i2 i3 t3)))))))

(define-peephole $reg/op1/check
  (lambda (as i1 i2 i3 t1 t2 t3)
    (cond ((= (car i2) $reg)
           (cond ((= (car i3) $op1)
                  (if (not (null? t3))
                      (let ((i4 (car t3))
                            (t4 (cdr t3)))
                        (cond ((= (car i4) $setreg)
                               (reg/op1/check-reg-op1-setreg
                                as i1 i2 i3 i4 t4)))))))))))

(define-peephole $reg/op2/check
  (lambda (as i1 i2 i3 t1 t2 t3)
    (cond ((= (car i2) $reg)
           (cond ((= (car i3) $op2imm)
                  (if (not (null? t3))
                      (let ((i4 (car t3))
                            (t4 (cdr t3)))
                        (cond ((= (car i4) $check)
                               (reg/op2/check-reg-op2imm-check
                                as i1 i2 i3 i4 t4)))))))))))

; Worker procedures.

(define (reg-return as i:reg i:return tail)
  (let ((rs (operand1 i:reg)))
    (if (hwreg? rs)
        (as-source! as (cons (list $reg/return rs) tail)))))

(define (reg-op1-setreg as i:reg i:op1 i:setreg tail-1 tail)
  (let ((rs (operand1 i:reg))
        (rd (operand1 i:setreg))
        (op (operand1 i:op1)))
    (if (hwreg? rs)
        (if (hwreg? rd)
            (peep-reg/op1/setreg as op rs rd tail)
            (peep-reg/op1/setreg as op rs 'RESULT tail-1)))))

(define (reg-op1 as i:reg i:op1 tail)
  (let ((rs (operand1 i:reg))
        (op (operand1 i:op1)))
    (if (hwreg? rs)
        (peep-reg/op1/setreg as op rs 'RESULT tail))))

(define (op1-setreg as i:op1 i:setreg tail)
  (let ((op (operand1 i:op1))
        (rd (operand1 i:setreg)))
    (if (hwreg? rd)
        (peep-reg/op1/setreg as op 'RESULT rd tail))))

(define (peep-reg/op1/setreg as op rs rd tail)
  (let ((op (case op
              ((car)               'internal:car)
              ((cdr)               'internal:cdr)
              ((car:pair)          'internal:car:pair)
              ((cdr:pair)          'internal:cdr:pair)
              ((cell-ref)          'internal:cell-ref)
              ((vector-length)     'internal:vector-length)
              ((vector-length:vec) 'internal:vector-length:vec)
              ((string-length)     'internal:string-length)
              ((--)                'internal:--)
              ((fx--)              'internal:fx--)
              ((fxpositive?)       'internal:fxpositive?)
              ((fxnegative?)       'internal:fxnegative?)
              ((fxzero?)           'internal:fxzero?)
              (else #f))))
    (if op
        (as-source! as (cons (list $reg/op1/setreg op rs rd) tail)))))

(define (reg-op2-setreg as i:reg i:op2 i:setreg tail-1 tail)
  (let ((rs1 (operand1 i:reg))
        (rs2 (operand2 i:op2))
        (op  (operand1 i:op2))
        (rd  (operand1 i:setreg)))
    (if (hwreg? rs1)
        (if (hwreg? rd)
            (peep-reg/op2/setreg as op rs1 rs2 rd tail)
            (peep-reg/op2/setreg as op rs1 rs2 'RESULT tail-1)))))

(define (reg-op2 as i:reg i:op2 tail)
  (let ((rs1 (operand1 i:reg))
        (rs2 (operand2 i:op2))
        (op  (operand1 i:op2)))
    (if (hwreg? rs1)
        (peep-reg/op2/setreg as op rs1 rs2 'RESULT tail))))

(define (op2-setreg as i:op2 i:setreg tail)
  (let ((op  (operand1 i:op2))
        (rs2 (operand2 i:op2))
        (rd  (operand1 i:setreg)))
    (if (hwreg? rd)
        (peep-reg/op2/setreg as op 'RESULT rs2 rd tail))))

(define (peep-reg/op2/setreg as op rs1 rs2 rd tail)
  (let ((op (case op
              ((+)                  'internal:+)
              ((-)                  'internal:-)
              ((fx+)                'internal:fx+)
              ((fx-)                'internal:fx-)
              ((fx=)                'internal:fx=)
              ((fx>)                'internal:fx>)
              ((fx>=)               'internal:fx>=)
              ((fx<)                'internal:fx<)
              ((fx<=)               'internal:fx<=)
              ((eq?)                'internal:eq?)
              ((cons)               'internal:cons)
              ((vector-ref)         'internal:vector-ref)
              ((vector-ref:trusted) 'internal:vector-ref:trusted)
              ((string-ref)         'internal:string-ref)
              ((set-car!)           'internal:set-car!)
              ((set-cdr!)           'internal:set-cdr!)
              ((cell-set!)          'internal:cell-set!)
              (else #f))))
    (if op
        (as-source! as (cons (list $reg/op2/setreg op rs1 rs2 rd) tail)))))

(define (reg-op2imm-setreg as i:reg i:op2imm i:setreg tail-1 tail)
  (let ((rs  (operand1 i:reg))
        (imm (operand2 i:op2imm))
        (op  (operand1 i:op2imm))
        (rd  (operand1 i:setreg)))
    (if (hwreg? rs)
        (if (hwreg? rd)
            (peep-reg/op2imm/setreg as op rs imm rd tail)
            (peep-reg/op2imm/setreg as op rs imm 'RESULT tail-1)))))

(define (reg-op2imm as i:reg i:op2imm tail)
  (let ((rs  (operand1 i:reg))
        (imm (operand2 i:op2imm))
        (op  (operand1 i:op2imm)))
    (if (hwreg? rs)
        (peep-reg/op2imm/setreg as op rs imm 'RESULT tail))))

(define (op2imm-setreg as i:op2imm i:setreg tail)
  (let ((op  (operand1 i:op2imm))
        (imm (operand2 i:op2imm))
        (rd  (operand1 i:setreg)))
    (if (hwreg? rd)
        (peep-reg/op2imm/setreg as op 'RESULT imm rd tail))))

(define (peep-reg/op2imm/setreg as op rs imm rd tail)
  (let ((op (case op
              ((+)          'internal:+/imm)
              ((-)          'internal:-/imm)
              ((fx+)        'internal:fx+/imm)
              ((fx-)        'internal:fx-/imm)
              ((fx=)        'internal:fx=/imm)
              ((fx<)        'internal:fx</imm)
              ((fx<=)       'internal:fx<=/imm)
              ((fx>)        'internal:fx>/imm)
              ((fx>=)       'internal:fx>=/imm)
              ((eq?)        'internal:eq?/imm)
              ((vector-ref) 'internal:vector-ref/imm)
              ((string-ref) 'internal:string-ref/imm)
              (else #f))))
    (if op
        (as-source! as (cons (list $reg/op2imm/setreg op rs imm rd) tail)))))

(define (reg-op1-branchf as i:reg i:op1 i:branchf tail)
  (let ((rs (operand1 i:reg))
        (op (operand1 i:op1))
        (L  (operand1 i:branchf)))
    (if (hwreg? rs)
        (peep-reg/op1/branchf as op rs L tail))))

(define (op1-branchf as i:op1 i:branchf tail)
  (let ((op (operand1 i:op1))
        (L  (operand1 i:branchf)))
    (peep-reg/op1/branchf as op 'RESULT L tail)))

(define (peep-reg/op1/branchf as op rs L tail)
  (let ((op (case op
              ((null?)       'internal:branchf-null?)
              ((pair?)       'internal:branchf-pair?)
              ((zero?)       'internal:branchf-zero?)
              ((eof-object?) 'internal:branchf-eof-object?)
              ((fixnum?)     'internal:branchf-fixnum?)
              ((char?)       'internal:branchf-char?)
              ((fxzero?)     'internal:branchf-fxzero?)
              ((fxnegative?) 'internal:branchf-fxnegative?)
              ((fxpositive?) 'internal:branchf-fxpositive?)
              (else #f))))
    (if op
        (as-source! as (cons (list $reg/op1/branchf op rs L) tail)))))

(define (reg-op2-branchf as i:reg i:op2 i:branchf tail)
  (let ((rs1 (operand1 i:reg))
        (rs2 (operand2 i:op2))
        (op  (operand1 i:op2))
        (L   (operand1 i:branchf)))
    (if (hwreg? rs1)
        (peep-reg/op2/branchf as op rs1 rs2 L tail))))

(define (op2-branchf as i:op2 i:branchf tail)
  (let ((op  (operand1 i:op2))
        (rs2 (operand2 i:op2))
        (L   (operand1 i:branchf)))
    (peep-reg/op2/branchf as op 'RESULT rs2 L tail)))

(define (peep-reg/op2/branchf as op rs1 rs2 L tail)
  (let ((op (case op
              ((<)       'internal:branchf-<)
              ((>)       'internal:branchf->)
              ((>=)      'internal:branchf->=)
              ((<=)      'internal:branchf-<=)
              ((=)       'internal:branchf-=)
              ((eq?)     'internal:branchf-eq?)
              ((char=?)  'internal:branchf-char=?)
              ((char>=?) 'internal:branchf-char>=?)
              ((char>?)  'internal:branchf-char>?)
              ((char<=?) 'internal:branchf-char<=?)
              ((char<?)  'internal:branchf-char<?)
              ((fx=)     'internal:branchf-fx=)
              ((fx>)     'internal:branchf-fx>)
              ((fx>=)    'internal:branchf-fx>=)
              ((fx<)     'internal:branchf-fx<)
              ((fx<=)    'internal:branchf-fx<=)
              (else #f))))
    (if op
        (as-source! as
                    (cons (list $reg/op2/branchf op rs1 rs2 L)
                          tail)))))

(define (reg-op2imm-branchf as i:reg i:op2imm i:branchf tail)
  (let ((rs  (operand1 i:reg))
        (imm (operand2 i:op2imm))
        (op  (operand1 i:op2imm))
        (L   (operand1 i:branchf)))
    (if (hwreg? rs)
        (peep-reg/op2imm/branchf as op rs imm L tail))))

(define (op2imm-branchf as i:op2imm i:branchf tail)
  (let ((op  (operand1 i:op2imm))
        (imm (operand2 i:op2imm))
        (L   (operand1 i:branchf)))
    (peep-reg/op2imm/branchf as op 'RESULT imm L tail)))

(define (peep-reg/op2imm/branchf as op rs imm L tail)
  (let ((op (case op
              ((<)       'internal:branchf-</imm)
              ((>)       'internal:branchf->/imm)
              ((>=)      'internal:branchf->=/imm)
              ((<=)      'internal:branchf-<=/imm)
              ((=)       'internal:branchf-=/imm)
              ((eq?)     'internal:branchf-eq?/imm)
              ((char=?)  'internal:branchf-char=?/imm)
              ((char>=?) 'internal:branchf-char>=?/imm)
              ((char>?)  'internal:branchf-char>?/imm)
              ((char<=?) 'internal:branchf-char<=?/imm)
              ((char<?)  'internal:branchf-char<?/imm)
              ((fx=)     'internal:branchf-fx=/imm)
              ((fx>)     'internal:branchf-fx>/imm)
              ((fx>=)    'internal:branchf-fx>=/imm)
              ((fx<)     'internal:branchf-fx</imm)
              ((fx<=)    'internal:branchf-fx<=/imm)
              (else #f))))
    (if op
        (as-source! as
                    (cons (list $reg/op2imm/branchf op rs imm L)
                          tail)))))

; Check optimization.

(define (reg-op1-check as i:reg i:op1 i:check tail)
  (let ((rs (operand1 i:reg))
        (op (operand1 i:op1)))
    (if (hwreg? rs)
        (peep-reg/op1/check as
                            op
                            rs
                            (operand4 i:check)
                            (list (operand1 i:check)
                                  (operand2 i:check)
                                  (operand3 i:check))
                            tail))))

(define (op1-check as i:op1 i:check tail)
  (let ((op (operand1 i:op1)))
    (peep-reg/op1/check as
                        op
                        'RESULT
                        (operand4 i:check)
                        (list (operand1 i:check)
                              (operand2 i:check)
                              (operand3 i:check))
                        tail)))

(define (peep-reg/op1/check as op rs L1 liveregs tail)
  (let ((op (case op
              ((fixnum?)      'internal:check-fixnum?)
              ((pair?)        'internal:check-pair?)
              ((vector?)      'internal:check-vector?)
              (else #f))))
    (if op
        (as-source! as
                    (cons (list $reg/op1/check op rs L1 liveregs)
                          tail)))))

(define (reg-op2-check as i:reg i:op2 i:check tail)
  (let ((rs1 (operand1 i:reg))
        (rs2 (operand2 i:op2))
        (op (operand1 i:op2)))
    (if (hwreg? rs1)
        (peep-reg/op2/check as
                            op
                            rs1
                            rs2
                            (operand4 i:check)
                            (list (operand1 i:check)
                                  (operand2 i:check)
                                  (operand3 i:check))
                            tail))))

(define (op2-check as i:op2 i:check tail)
  (let ((rs2 (operand2 i:op2))
        (op (operand1 i:op2)))
    (peep-reg/op2/check as
                        op
                        'RESULT
                        rs2
                        (operand4 i:check)
                        (list (operand1 i:check)
                              (operand2 i:check)
                              (operand3 i:check))
                        tail)))

(define (peep-reg/op2/check as op rs1 rs2 L1 liveregs tail)
  (let ((op (case op
              ((<:fix:fix)   'internal:check-<:fix:fix)
              ((<=:fix:fix)  'internal:check-<=:fix:fix)
              ((>=:fix:fix)  'internal:check->=:fix:fix)
              (else #f))))
    (if op
        (as-source! as
                    (cons (list $reg/op2/check op rs1 rs2 L1 liveregs)
                          tail)))))

(define (reg-op2imm-check as i:reg i:op2imm i:check tail)
  (let ((rs1 (operand1 i:reg))
        (op (operand1 i:op2imm))
        (imm (operand2 i:op2imm)))
    (if (hwreg? rs1)
        (peep-reg/op2imm/check as
                               op
                               rs1
                               imm
                               (operand4 i:check)
                               (list (operand1 i:check)
                                     (operand2 i:check)
                                     (operand3 i:check))
                               tail))))

(define (op2imm-check as i:op2imm i:check tail)
  (let ((op (operand1 i:op2imm))
        (imm (operand2 i:op2imm)))
    (peep-reg/op2imm/check as
                           op
                           'RESULT
                           imm
                           (operand4 i:check)
                           (list (operand1 i:check)
                                 (operand2 i:check)
                                 (operand3 i:check))
                           tail)))

(define (peep-reg/op2imm/check as op rs1 imm L1 liveregs tail)
  (let ((op (case op
              ((<:fix:fix)   'internal:check-<:fix:fix/imm)
              ((<=:fix:fix)  'internal:check-<=:fix:fix/imm)
              ((>=:fix:fix)  'internal:check->=:fix:fix/imm)
              (else #f))))
    (if op
        (as-source! as
                    (cons (list $reg/op2imm/check op rs1 imm L1 liveregs)
                          tail)))))

(define (reg/op1/check-reg-op1-setreg as i:ro1check i:reg i:op1 i:setreg tail)
  (let ((o1 (operand1 i:ro1check))
        (r1 (operand2 i:ro1check))
        (r2 (operand1 i:reg))
        (o2 (operand1 i:op1))
        (r3 (operand1 i:setreg)))
    (if (and (eq? o1 'internal:check-vector?)
             (eq? r1 r2)
             (eq? o2 'vector-length:vec)
             (hwreg? r1)
             (hwreg? r3))
        (as-source! as
                    (cons (list $reg/op2/check
                                'internal:check-vector?/vector-length:vec
                                r1
                                r3
                                (operand3 i:ro1check)
                                (operand4 i:ro1check))
                          tail)))))

; Range checks of the form 0 <= i < n can be performed by a single check.
; This peephole optimization recognizes
;         reg     rs1
;         op2     <:fix:fix,rs2
;         check   r1,r2,r3,L
;         reg     rs1                     ; must match earlier reg
;         op2imm  >=:fix:fix,0
;         check   r1,r2,r3,L              ; label must match earlier check

(define (reg/op2/check-reg-op2imm-check
         as i:ro2check i:reg i:op2imm i:check tail)
  (let ((o1   (operand1 i:ro2check))
        (rs1  (operand2 i:ro2check))
        (rs2  (operand3 i:ro2check))
        (L1   (operand4 i:ro2check))
        (live (operand5 i:ro2check))
        (rs3  (operand1 i:reg))
        (o2   (operand1 i:op2imm))
        (x    (operand2 i:op2imm))
        (L2   (operand4 i:check)))
    (if (and (eq? o1 'internal:check-<:fix:fix)
             (eq? o2 '>=:fix:fix)
             (eq? rs1 rs3)
             (eq? x 0)
             (eq? L1 L2))
        (as-source! as
                    (cons (list $reg/op2/check 'internal:check-range
                                                rs1 rs2 L1 live)
                          tail)))))

; End of check optimization.

(define (reg-op3 as i:reg i:op3 tail)
  (let ((rs1 (operand1 i:reg))
        (rs2 (operand2 i:op3))
        (rs3 (operand3 i:op3))
        (op  (operand1 i:op3)))
    (if (hwreg? rs1)
        (let ((op (case op
                    ((vector-set!) 'internal:vector-set!)
                    ((string-set!) 'internal:string-set!)
                    (else #f))))
          (if op
              (as-source! as (cons (list $reg/op3 op rs1 rs2 rs3) tail)))))))

; Reg-setreg is not restricted to hardware registers, as $movereg is 
; a standard instruction.

(define (reg-setreg as i:reg i:setreg tail)
  (let ((rs (operand1 i:reg))
        (rd (operand1 i:setreg)))
    (if (= rs rd)
        (as-source! as tail)
        (as-source! as (cons (list $movereg rs rd) tail)))))

(define (reg-branchf as i:reg i:branchf tail)
  (let ((rs (operand1 i:reg))
        (L  (operand1 i:branchf)))
    (if (hwreg? rs)
        (as-source! as (cons (list $reg/branchf rs L) tail)))))

(define (const-setreg as i:const i:setreg tail)
  (let ((c  (operand1 i:const))
        (rd (operand1 i:setreg)))
    (if (hwreg? rd)
        (as-source! as (cons (list $const/setreg c rd) tail)))))

; Make-vector on vectors of known short length.

(define (const-op2 as i:const i:op2 tail)
  (let ((vn '#(make-vector:0 make-vector:1 make-vector:2 make-vector:3
               make-vector:4 make-vector:5 make-vector:6 make-vector:7
               make-vector:8 make-vector:9))
        (c  (operand1 i:const))
        (op (operand1 i:op2))
        (r  (operand2 i:op2)))
    (if (and (eq? op 'make-vector)
             (fixnum? c)
             (<= 0 c 9))
        (as-source! as (cons (list $op2 (vector-ref vn c) r) tail)))))

; Constants that can be synthesized in a single instruction can be
; moved into RESULT in the delay slot of the return instruction.

(define (const-return as i:const i:return tail)
  (let ((c (operand1 i:const)))
    (if (or (and (number? c) (immediate-int? c))
            (null? c)
            (boolean? c))
        (as-source! as (cons (list $const/return c) tail)))))

; This allows the use of hardware 'call' instructions.
;    (setrtn Lx)
;    (branch Ly k)
;    (.align k)            Ignored on SPARC
;    (.label Lx)
; => (setrtn/branch Ly k)
;    (.label Lx)

(define (setrtn-branch as i:setrtn i:branch i:align i:label tail)
  (let ((return-label (operand1 i:setrtn))
        (branch-ops   (cdr i:branch))
        (label        (operand1 i:label)))
    (if (= return-label label)
        (as-source! as (cons (cons $setrtn/branch branch-ops)
                             (cons i:label
                                   tail))))))

; Ditto for 'invoke'.
;
; Disabled because it does _not_ pay off on the SPARC currently -- 
; probably, the dependency created between 'jmpl' and 'st' is not 
; handled well on the test machine (an Ultrasparc).  Might work 
; better if the return address were to be kept in a register always.

(define (setrtn-invoke as i:setrtn i:invoke i:align i:label tail)
  (let ((return-label (operand1 i:setrtn))
        (invoke-ops   (operand1 i:invoke))
        (label        (operand1 i:label)))
    (if (and #f				; DISABLED
             (= return-label label))
        (as-source! as (cons (cons $setrtn/invoke invoke-ops)
                             (cons i:label
                                   tail))))))

; Gets rid of spurious branch-to-next-instruction
;    (branch Lx k)
;    (.align y)
;    (.label Lx)
; => (.align y)
;    (.label Lx)

(define (branch-and-label as i:branch i:align i:label tail)
  (let ((branch-label (operand1 i:branch))
        (label        (operand1 i:label)))
    (if (= branch-label label)
        (as-source! as (cons i:align (cons i:label tail))))))

(define (global-setreg as i:global i:setreg tail)
  (let ((global (operand1 i:global))
        (rd     (operand1 i:setreg)))
    (if (hwreg? rd)
        (as-source! as (cons (list $global/setreg global rd) tail)))))

; Obscure guard: unsafe-code = #t implies that global/invoke will not
; check the value of the global variable, yet unsafe-code and
; catch-undefined-globals are supposed to be independent.

(define (global-invoke as i:global i:invoke tail)
  (let ((global (operand1 i:global))
        (argc   (operand1 i:invoke)))
    (if (not (and (unsafe-code) (catch-undefined-globals)))
        (as-source! as (cons (list $global/invoke global argc) tail)))))

; Obscure guard: see comment for previous procedure.
; FIXME!  This implementation is temporary until setrtn-invoke is enabled.

(define (global-setrtn-invoke as i:global i:setrtn i:invoke tail)
  (let ((global (operand1 i:global))
        (argc   (operand1 i:invoke)))
    (if (not (and (unsafe-code) (catch-undefined-globals)))
        (as-source! as (cons i:setrtn 
                             (cons (list $global/invoke global argc)
                                   tail))))))

(define (reg-setglbl as i:reg i:setglbl tail)
  (let ((rs     (operand1 i:reg))
        (global (operand1 i:setglbl)))
    (if (hwreg? rs)
        (as-source! as (cons (list $reg/setglbl rs global) tail)))))



; Test code

(define (peeptest istream)
  (let ((as (make-assembly-structure istream)))
    (let loop ((l '()))
      (if (null? (as-source as))
          (reverse l)
          (begin (peep as)
                 (let ((a (car (as-source as))))
                   (as-source! as (cdr (as-source as)))
                   (loop (cons a l))))))))


; eof
; Copyright 1998 Lars T Hansen.
;
; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
;
; SPARC assembler machine parameters & utility procedures.
;
; 13 May 1999 / wdc

; Round up to nearest 8.

(define (roundup8 n)
  (* (quotient (+ n 7) 8) 8))

; Given an integer code for a register, return its register label.
; This register label is the register number for a h.w. register and the
; offsets from GLOBALS[ r0 ] for a s.w. register.

(define regname
  (let ((v (vector $r.reg0  $r.reg1  $r.reg2  $r.reg3  $r.reg4  $r.reg5
                   $r.reg6  $r.reg7  $r.reg8  $r.reg9  $r.reg10 $r.reg11
                   $r.reg12 $r.reg13 $r.reg14 $r.reg15 $r.reg16 $r.reg17
                   $r.reg18 $r.reg19 $r.reg20 $r.reg21 $r.reg22 $r.reg23
                   $r.reg24 $r.reg25 $r.reg26 $r.reg27 $r.reg28 $r.reg29
                   $r.reg30 $r.reg31)))
    (lambda (r)
      (vector-ref v r))))

; Is a general-purpose register mapped to a hardware register?
; This is fragile! FIXME.

(define (hardware-mapped? r)
  (or (and (>= r $r.reg0) (<= r $r.reg7))
      (= r $r.argreg2)
      (= r $r.argreg3)
      (= r $r.result)
      (= r $r.g0)
      (= r $r.tmp0)
      (= r $r.tmp1)
      (= r $r.tmp2)))

; Used by peephole optimizer

(define (hwreg? x)
  (<= 0 x 7))

(define (immediate-int? x)
  (and (exact? x)
       (integer? x)
       (<= -1024 x 1023)))

; Given an exact integer, can it be represented as a fixnum?

(define fixnum-range?
  (let ((-two^29  (- (expt 2 29)))
        (two^29-1 (- (expt 2 29) 1)))
    (lambda (x)
      (<= -two^29 x two^29-1))))

; Does the integer x fit in the immediate field of an instruction?

(define (immediate-literal? x)
  (<= -4096 x 4095))

; Return the offset in the %GLOBALS table of the given memory-mapped 
; register. A memory-mapped register is represented by an integer which 
; is its offet, so just return the value.

(define (swreg-global-offset r) r)

; Return a bit representation of a character constant.

(define (char->immediate c)
  (+ (* (char->integer c) 65536) $imm.character))

; Convert an integer to a fixnum.

(define (thefixnum x) (* x 4))

; The offset of data slot 'n' within a procedure structure, not adjusting 
; for tag. The proc is a header followed by code, const, and then data.

(define (procedure-slot-offset n)
  (+ 12 (* n 4)))

; Src is a register, hwreg is a hardware register. If src is a
; hardware register, return src. Otherwise, emit an instruction to load
; src into hwreg and return hwreg.

(define (force-hwreg! as src hwreg)
  (if (hardware-mapped? src)
      src
      (emit-load-reg! as src hwreg)))

; Given an arbitrary constant opd, generate code to load it into a
; register r.

(define (emit-constant->register as opd r)
  (cond ((and (integer? opd) (exact? opd))
         (if (fixnum-range? opd)	
             (emit-immediate->register! as (thefixnum opd) r)
             (emit-const->register! as (emit-datum as opd) r)))
        ((boolean? opd)
         (emit-immediate->register! as
                                    (if (eq? opd #t)
                                        $imm.true
                                        $imm.false)
                                    r))
        ((equal? opd (eof-object))
         (emit-immediate->register! as $imm.eof r))
        ((equal? opd (unspecified))
         (emit-immediate->register! as $imm.unspecified r))
        ((equal? opd (undefined))
         (emit-immediate->register! as $imm.undefined r))
        ((null? opd)
         (emit-immediate->register! as $imm.null r))
        ((char? opd)
         (emit-immediate->register! as (char->immediate opd) r))
        (else
         (emit-const->register! as (emit-datum as opd) r))))


; Stuff a bitpattern or symbolic expression into a register.
; (CONST, for immediate constants.)
;
; FIXME(?): if this had access to eval-expr (currently hidden inside the
; sparc assembler) it could attempt to evaluate symbolic expressions,
; thereby selecting better code sequences when possible.

(define (emit-immediate->register! as i r)
  (let ((dest (if (not (hardware-mapped? r)) $r.tmp0 r)))
    (cond ((and (number? i) (immediate-literal? i))
           (sparc.set as i dest))
          ((and (number? i) (zero? (remainder (abs i) 1024)))
           (sparc.sethi as `(hi ,i) dest))
          (else
           (sparc.sethi as `(hi ,i) dest)
           (sparc.ori as dest `(lo ,i) dest)))
    (if (not (hardware-mapped? r))
        (emit-store-reg! as r dest))))


; Reference the constants vector and put the constant reference in a register.
; `offset' is an integer offset into the constants vector (a constant) for
; the current procedure.
; Destroys $r.tmp0 and $r.tmp1, but either can be the destination register.
; (CONST, for structured constants, GLOBAL, SETGLBL, LAMBDA).

(define (emit-const->register! as offset r)
  (let ((cvlabel (+ 4 (- (* offset 4) $tag.vector-tag))))
    (cond ((hardware-mapped? r)
           (sparc.ldi as $r.reg0 $p.constvector $r.tmp0)
           (if (asm:fits? cvlabel 13)
               (sparc.ldi as $r.tmp0 cvlabel r)
               (begin (sparc.sethi as `(hi ,cvlabel) $r.tmp1)
                      (sparc.addr  as $r.tmp0 $r.tmp1 $r.tmp0)
                      (sparc.ldi   as $r.tmp0 `(lo ,cvlabel) r))))
          (else
           (emit-const->register! as offset $r.tmp0)
           (emit-store-reg! as $r.tmp0 r)))))



; Emit single instruction to load sw-mapped reg into another reg, and return
; the destination reg.

(define (emit-load-reg! as from to)
  (if (or (hardware-mapped? from) (not (hardware-mapped? to)))
      (asm-error "emit-load-reg: " from to)
      (begin (sparc.ldi as $r.globals (swreg-global-offset from) to)
             to)))

(define (emit-store-reg! as from to)
  (if (or (not (hardware-mapped? from)) (hardware-mapped? to))
      (asm-error "emit-store-reg: " from to)
      (begin (sparc.sti as from (swreg-global-offset to) $r.globals)
             to)))

; Generic move-reg-to-HW-reg

(define (emit-move2hwreg! as from to)
  (if (hardware-mapped? from)
      (sparc.move as from to)
      (emit-load-reg! as from to))
  to)

; Evaluation of condition code for value or control.
;
; branchf.a is an annulled conditional branch that tests the condition codes
;     and branches if some condition is false.
; rd is #f or a hardware register.
; target is #f or a label.
; Exactly one of rd and target must be #f.
;
; (Why isn't this split into two separate procedures?  Because dozens of
; this procedure's callers have the value/control duality, and it saves
; space to put the test here instead of putting it in each caller.)

(define (emit-evaluate-cc! as branchf.a rd target)
  (if target
      (begin (branchf.a   as target)
             (sparc.slot  as))
      (let ((target (new-label)))
        (branchf.a   as target)
        (sparc.set   as $imm.false rd)
        (sparc.set   as $imm.true rd)
        (sparc.label as target))))

; Code for runtime safety checking.

(define (emit-check! as rs0 L1 liveregs)
  (sparc.cmpi as rs0 $imm.false)
  (emit-checkcc! as sparc.be L1 liveregs))

; FIXME:  This should call the exception handler for non-continuable exceptions.

(define (emit-trap! as rs1 rs2 rs3 exn)
  (if (not (= rs3 $r.reg0))
      (emit-move2hwreg! as rs3 $r.argreg3))
  (if (not (= rs2 $r.reg0))
      (emit-move2hwreg! as rs2 $r.argreg2))
  (if (not (= rs1 $r.reg0))
      (emit-move2hwreg! as rs1 $r.result))
  (millicode-call/numarg-in-reg as $m.exception (thefixnum exn) $r.tmp0))

; Given:
;     an annulled conditional branch that branches
;         if the check is ok
;     a non-annulled conditional branch that branches
;         if the check is not ok
;     #f, or a procedure that takes an assembly segment as
;         argument and emits an instruction that goes into
;         the delay slot of either branch
;     three registers whose contents should be passed to the
;         exception handler if the check is not ok
;     the exception code
; Emits code to call the millicode exception routine with
; the given exception code if the condition is false.
;
; FIXME:  The nop can often be replaced by the instruction that
; follows it.

(begin
 '
(define (emit-checkcc-and-fill-slot!
         as branch-ok.a branch-bad slot-filler L1)
  (let* ((situation (list exn rs1 rs2 rs3))
         (L1 (exception-label as situation)))
    (if L1
        (begin (branch-bad as L1)
               (if slot-filler
                   (slot-filler as)
                   (sparc.nop as)))
        (let* ((L1 (new-label))
               (L2 (new-label)))
          (exception-label-set! as situation L1)
          (branch-ok.a as L2)
          (if slot-filler
              (slot-filler as)
              (sparc.slot  as))
          (sparc.label as L1)
          (cond ((= rs3 $r.reg0)
                 #f)
                ((hardware-mapped? $r.argreg3)
                 (emit-move2hwreg! as rs3 $r.argreg3))
                ((hardware-mapped? rs3)
                 (emit-store-reg! as rs3 $r.argreg3))
                (else
                 (emit-move2hwreg! as rs3 $r.tmp0)
                 (emit-store-reg! as $r.tmp0 $r.argreg3)))
          (if (not (= rs2 $r.reg0))
              (emit-move2hwreg! as rs2 $r.argreg2))
          (if (not (= rs1 $r.reg0))
              (emit-move2hwreg! as rs1 $r.result))
          ; FIXME:  This should be a non-continuable exception.
          (sparc.jmpli as $r.millicode $m.exception $r.o7)
          (emit-immediate->register! as (thefixnum exn) $r.tmp0)
          (sparc.label as L2)))))
#f
)

(define (emit-checkcc! as branch-bad L1 liveregs)
  (branch-bad as L1)
  (apply sparc.slot2 as liveregs))

; Generation of millicode calls for non-continuable exceptions.

(begin
 '
; To create only one millicode call per code segment per non-continuable
; exception situation, we use the "as-user" feature of assembly segments.
; Could use a hash table here.

(define (exception-label as situation)
  (let ((user-data (as-user as)))
    (if user-data
        (let ((exception-labels (assq 'exception-labels user-data)))
          (if exception-labels
              (let ((probe (assoc situation (cdr exception-labels))))
                (if probe
                    (cdr probe)
                    #f))
              #f))
        #f)))
'
(define (exception-label-set! as situation label)
  (let ((user-data (as-user as)))
    (if user-data
        (let ((exception-labels (assq 'exception-labels user-data)))
          (if exception-labels
              (let ((probe (assoc situation (cdr exception-labels))))
                (if probe
                    (error "COMPILER BUG: Exception situation defined twice")
                    (set-cdr! exception-labels
                              (cons (cons situation label)
                                    (cdr exception-labels)))))
              (begin (as-user! as
                               (cons (list 'exception-labels)
                                     user-data))
                     (exception-label-set! as situation label))))
        (begin (as-user! as '())
               (exception-label-set! as situation label)))))
#f
)

; Millicode calling

(define (millicode-call/0arg as mproc)
  (sparc.jmpli as $r.millicode mproc $r.o7)
  (sparc.nop   as))

(define (millicode-call/1arg as mproc r)
  (sparc.jmpli as $r.millicode mproc $r.o7)
  (emit-move2hwreg! as r $r.argreg2))

(define (millicode-call/1arg-in-result as mproc r)
  (millicode-call/1arg-in-reg as mproc r $r.result))

(define (millicode-call/1arg-in-reg as mproc rs rd)
  (sparc.jmpli as $r.millicode mproc $r.o7)
  (emit-move2hwreg! as rs rd))

(define (millicode-call/numarg-in-result as mproc num)
  (sparc.jmpli as $r.millicode mproc $r.o7)
  (sparc.set   as num $r.result))

(define (millicode-call/numarg-in-reg as mproc num reg)
  (if (not (hardware-mapped? reg))
      (asm-error "millicode-call/numarg-in-reg requires HW register: " reg))
  (sparc.jmpli as $r.millicode mproc $r.o7)
  (sparc.set   as num reg))

(define (millicode-call/2arg as mproc r1 r2)
  (emit-move2hwreg! as r1 $r.argreg2)
  (sparc.jmpli      as $r.millicode mproc $r.o7)
  (emit-move2hwreg! as r2 $r.argreg3))

; NOTE: Don't use TMP0 since TMP0 is sometimes a millicode argument
; register (for example to m_exception).
;
; NOTE: Don't use sparc.set rather than sethi/ori; we need to know that
; two instructions get generated.
;
; FIXME: Should calculate the value if possible to get better precision
; and to avoid generating a fixup.  See emit-return-address! in gen-msi.sch.

(define (millicode-call/ret as mproc label)
  (cond ((short-effective-addresses)
         (sparc.jmpli as $r.millicode mproc $r.o7)
         (sparc.addi  as $r.o7 `(- ,label (- ,(here as) 4) 8) $r.o7))
        (else
         (let ((val `(- ,label (+ ,(here as) 8) 8)))
           (sparc.sethi as `(hi ,val) $r.tmp1)
           (sparc.ori   as $r.tmp1 `(lo ,val) $r.tmp1)
           (sparc.jmpli as $r.millicode mproc $r.o7)
           (sparc.addr  as $r.o7 $r.tmp1 $r.o7)))))

(define (check-timer as DESTINATION RETRY)
  (sparc.subicc as $r.timer 1 $r.timer)
  (sparc.bne.a  as DESTINATION)
  (sparc.slot   as)
  (millicode-call/ret as $m.timer-exception RETRY))

; When the destination and retry labels are the same, and follow the
; timer check immediately, then this code saves two static instructions.

(define (check-timer0 as)
  (sparc.subicc as $r.timer 1 $r.timer)
  (sparc.bne.a  as (+ (here as) 16))
  (sparc.slot   as)
  (sparc.jmpli as $r.millicode $m.timer-exception $r.o7)
  (sparc.nop as))

; eof
; Copyright 1998 Lars T Hansen.
;
; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
;
; 9 May 1999 / wdc
;
; SPARC machine assembler.
;
; The procedure `sparc-instruction' takes an instruction class keyword and
; some operands and returns an assembler procedure for the instruction
; denoted by the class and the operands.
;
; All assembler procedures for SPARC mnemonics are defined in sparcasm2.sch.
;
; The SPARC has 32-bit, big-endian words.  All instructions are 1 word.
; This assembler currently accepts a subset of the SPARC v8 instruction set.
;
; Each assembler procedure takes an `as' assembly structure (see 
; Asm/Common/pass5p1.sch) and operands relevant to the instruction, and
; side-effects the assembly structure by emitting bits for the instruction
; and any necessary fixups.  There are separate instruction mnemonics and
; assembler procedures for instructions which in the SPARC instruction set 
; are normally considered the "same".  For example, the `add' instruction is
; split into two operations here: `sparc.addr' takes a register as operand2,
; and `sparc.addi' takes an immediate.  We could remove this restriction
; by using objects with identity rather than numbers for registers, but it
; does not seem to be an important problem.
;
; Operands that denote values (addresses, immediates, offsets) may be
; expressed using symbolic expressions. These expressions must conform
; to the following grammar:
;
;   <expr> --> ( <number> . <obj> )        ; label
;            | <number>                    ; literal value (exact integer)
;            | (+ <expr> ... )             ; sum
;            | (- <expr> ... )             ; difference
;            | (hi <expr>)                 ; high 22 bits
;            | (lo <expr>)                 ; low 10 bits
;
; Each assembler procedure will check that its value operand(s) fit in 
; their instruction fields.  It is a fatal error for an operand not 
; to fit, and the assembler calls `asm-error' to signal this error.  
; However, in some cases the assembler will instead call the error 
; procedure `asm-value-too-large', which allows the higher-level assembler 
; to retry the assembly with different settings (typically, by splitting 
; a jump instruction into an offset calculation and a jump).
;
; Note: the idiom that is seen in this file,
;   (emit-fixup-proc! as (lambda (b l) (fixup b l)))
; when `fixup' is a local procedure, avoids allocation of the closure
; except in the cases where the fixup is in fact needed, for gains in
; speed and reduction in allocation.  (Ask me if you want numbers.)
;
; If FILL-DELAY-SLOTS returns true, then this assembler supports two
; distinct mechanisms for filling branch delay slots.
;
; An annulled conditional branch or an un-annulled unconditional branch
; may be followed by the strange instruction SPARC.SLOT, which turns into
; a nop in the delay slot that may be replaced by copying the instruction
; at the target of the branch into the delay slot and increasing the branch
; offset by 4.
;
; An un-annulled conditional branch whose target depends upon a known set
; of general registers, and does not depend upon the condition codes, may
; be followed by the strange instruction SPARC.SLOT2, which takes any
; number of registers as operands.  This strange instruction turns into
; nothing at all if the following instruction has no side effects except
; to the condition codes and/or to a destination register that is distinct
; from the specified registers plus the stack pointer and %o7; otherwise
; the SPARC.SLOT2 instruction becomes a nop in the delay slot.  The
; implementation of this uses a buffer that must be cleared when a label
; is emitted or when the current offset is obtained.

(define sparc-instruction)

(let ((original-emit-label! emit-label!)
      (original-here here))
  (set! emit-label!
        (lambda (as L)
          (assembler-value! as 'slot2-info #f)
          (original-emit-label! as L)))
  (set! here
        (lambda (as)
          (assembler-value! as 'slot2-info #f)
          (original-here as)))
  'emit-label!)

(let ((emit! (lambda (as bits)
               (assembler-value! as 'slot2-info #f)
               (emit! as bits)))
      (emit-fixup-proc! (lambda (as proc)
                          (assembler-value! as 'slot2-info #f)
                          (emit-fixup-proc! as proc)))
      (goes-in-delay-slot2? (lambda (as rd)
                              (let ((regs (assembler-value as 'slot2-info)))
                                (and regs
                                     (fill-delay-slots)
                                     (not (= rd $r.stkp))
                                     (not (= rd $r.o7))
                                     (not (memv rd regs)))))))
  
  (define ibit (asm:bv 0 0 #x20 0))     ; immediate bit: 2^13
  (define abit (asm:bv #x20 0 0 0))     ; annul bit: 2^29
  (define zero (asm:bv 0 0 0 0))        ; all zero bits
  
  (define two^32 (expt 2 32))
  
  ; Constant expression evaluation. If the expression cannot be 
  ; evaluated, eval-expr returns #f, otherwise a number.
  ; The symbol table lookup must fail by returning #f.
  
  (define (eval-expr as e)
    
    (define (complement x)
      (modulo (+ two^32 x) two^32))
    
    (define (hibits e)
      (cond ((not e) e)
            ((< e 0)
             (complement (quotient (complement e) 1024)))
            (else
             (quotient e 1024))))
    
    (define (lobits e)
      (cond ((not e) e)
            ((< e 0)
             (remainder (complement e) 1024))
            (else
             (remainder e 1024))))
    
    (define (evaluate e)
      (cond ((integer? e)      e)
            ((label? e)        (label-value as e))
            ((eq? 'hi (car e)) (hibits (evaluate (cadr e))))
            ((eq? 'lo (car e)) (lobits (evaluate (cadr e))))
            ((eq? '+ (car e))
             (let loop ((e (cdr e)) (s 0))
               (if (null? e) s
                             (let ((op (evaluate (car e))))
                               (if (not op) op
                                            (loop (cdr e) (+ s op)))))))
            ((eq? '- (car e))  
             (let loop ((e (cdr e)) (d #f))
               (if (null? e) d
                             (let ((op (evaluate (car e))))
                               (if (not op) op
                                            (loop (cdr e) (if d (- d op) op)))))))
            (else
             (signal-error 'badexpr e))))
    
    (evaluate e))
  
  ; Common error handling.
  
  (define (signal-error code . rest)
    (define msg "SPARC assembler: ")
    (case code
      ((badexpr)
       (asm-error msg "invalid expression " (car rest)))
      ((toolarge)
       (asm-error msg "value too large in " (car rest) ": "
                  (cadr rest) " = " (caddr rest)))
      ((fixup)
       (asm-error msg "fixup failed in " (car rest) " for " (cadr rest)))
      ((unaligned)
       (asm-error msg "unaligned target in " (car rest) ": " (cadr rest)))
      (else 
       (error "Invalid error code in assembler: " code))))
  
  ; The following procedures construct instructions by depositing field
  ; values directly into bytevectors; the location parameter in the dep-*!
  ; procedures is the address in the bytevector of the most significant byte.
  
  (define (copy! bv k bits)
    (bytevector-set! bv k (bytevector-ref bits 0))
    (bytevector-set! bv (+ k 1) (bytevector-ref bits 1))
    (bytevector-set! bv (+ k 2) (bytevector-ref bits 2))
    (bytevector-set! bv (+ k 3) (bytevector-ref bits 3))
    bv)
  
  (define (copy bits)
    (let ((bv (make-bytevector 4)))
      (bytevector-set! bv 0 (bytevector-ref bits 0))
      (bytevector-set! bv 1 (bytevector-ref bits 1))
      (bytevector-set! bv 2 (bytevector-ref bits 2))
      (bytevector-set! bv 3 (bytevector-ref bits 3))
      bv))
  
  (define (copy-instr bv from to)
    (bytevector-set! bv to (bytevector-ref bv from))
    (bytevector-set! bv (+ to 1) (bytevector-ref bv (+ from 1)))
    (bytevector-set! bv (+ to 2) (bytevector-ref bv (+ from 2)))
    (bytevector-set! bv (+ to 3) (bytevector-ref bv (+ from 3))))
  
  (define (dep-rs1! bits k rs1)
    (bytevector-set! bits (+ k 1)
                          (logior (bytevector-ref bits (+ k 1))
                                  (rshl rs1 2)))
    (bytevector-set! bits (+ k 2)
                          (logior (bytevector-ref bits (+ k 2))
                                  (lsh (logand rs1 3) 6))))
  
  (define (dep-rs2! bits k rs2)
    (bytevector-set! bits (+ k 3)
                          (logior (bytevector-ref bits (+ k 3)) rs2)))
  
  (define (dep-rd! bits k rd)
    (bytevector-set! bits k
                          (logior (bytevector-ref bits k) (lsh rd 1))))
  
  (define (dep-imm! bits k imm)
    (cond ((fixnum? imm)
           (bytevector-set! bits (+ k 3) (logand imm 255))
           (bytevector-set! bits (+ k 2)
                                 (logior (bytevector-ref bits (+ k 2))
                                         (logand (rsha imm 8) 31))))
          ((bytevector? imm)
           (bytevector-set! bits (+ k 3) (bytevector-ref imm 0))
           (bytevector-set! bits (+ k 2)
                                 (logior (bytevector-ref bits (+ k 2))
                                         (logand (bytevector-ref imm 1)
                                                 31))))
          (else
           (dep-imm! bits k (asm:int->bv imm)))))
  
  (define (dep-branch-offset! bits k offs)
    (cond ((fixnum? offs)
           (if (not (= (logand offs 3) 0))
               (signal-error 'unaligned "branch" offs))
           (dep-imm22! bits k (rsha offs 2)))
          ((bytevector? offs)
           (if (not (= (logand (bytevector-ref offs 3) 3) 0))
               (signal-error 'unaligned "branch" (asm:bv->int offs)))
           (dep-imm22! bits k (asm:rsha offs 2)))
          (else
           (dep-branch-offset! bits k (asm:int->bv offs)))))
  
  (define (dep-imm22! bits k imm)
    (cond ((fixnum? imm)
           (bytevector-set! bits (+ k 3) (logand imm 255))
           (bytevector-set! bits (+ k 2)
                                 (logand (rsha imm 8) 255))
           (bytevector-set! bits (+ k 1)
                                 (logior (bytevector-ref bits (+ k 1))
                                         (logand (rsha imm 16) 63))))
          ((bytevector? imm)
           (bytevector-set! bits (+ k 3) (bytevector-ref imm 3))
           (bytevector-set! bits (+ k 2) (bytevector-ref imm 2))
           (bytevector-set! bits (+ k 1)
                                 (logior (bytevector-ref bits (+ k 1))
                                         (logand (bytevector-ref imm 1)
                                                 63))))
          (else
           (dep-imm22! bits k (asm:int->bv imm)))))
  
  (define (dep-call-offset! bits k offs)
    (cond ((fixnum? offs)
           (if (not (= (logand offs 3) 0))
               (signal-error 'unaligned "call" offs))
           (bytevector-set! bits (+ k 3) (logand (rsha offs 2) 255))
           (bytevector-set! bits (+ k 2) (logand (rsha offs 10) 255))
           (bytevector-set! bits (+ k 1) (logand (rsha offs 18) 255))
           (bytevector-set! bits k (logior (bytevector-ref bits k)
                                           (logand (rsha offs 26) 63))))
          ((bytevector? offs)
           (if (not (= (logand (bytevector-ref offs 3) 3) 0))
               (signal-error 'unaligned "call" (asm:bv->int offs)))
           (let ((offs (asm:rsha offs 2)))
             (bytevector-set! bits (+ k 3) (bytevector-ref offs 3))
             (bytevector-set! bits (+ k 2) (bytevector-ref offs 2))
             (bytevector-set! bits (+ k 1) (bytevector-ref offs 1))
             (bytevector-set! bits k (logior (bytevector-ref bits k)
                                             (logand (bytevector-ref offs 0)
                                                     63)))))
          (else
           (dep-call-offset! bits k (asm:int->bv offs)))))
  
  ; Add 1 to an instruction (to bump a branch offset by 4).
  ; FIXME: should check for field overflow.
  
  (define (add1 bv loc)
    (let* ((r0 (+ (bytevector-ref bv (+ loc 3)) 1))
           (d0 (logand r0 255))
           (c0 (rshl r0 8)))
      (bytevector-set! bv (+ loc 3) d0)
      (let* ((r1 (+ (bytevector-ref bv (+ loc 2)) c0))
             (d1 (logand r1 255))
             (c1 (rshl r1 8)))
        (bytevector-set! bv (+ loc 2) d1)
        (let* ((r2 (+ (bytevector-ref bv (+ loc 1)) c1))
               (d2 (logand r2 255)))
          (bytevector-set! bv (+ loc 1) d2)))))
  
  ; For delay slot filling -- uses the assembler value scratchpad in
  ; the as structure.  Delay slot filling is discussed in the comments
  ; for `branch' and `class-slot', below.
  
  (define (remember-branch-target as obj)
    (assembler-value! as 'branch-target obj))
  
  (define (recover-branch-target as)
    (assembler-value as 'branch-target))
  
  ; Mark the instruction at the current address as not being eligible 
  ; for being lifted into a branch delay slot.
  ;
  ; FIXME: should perhaps be a hash table; see BOOT-STATUS file for details.
  
  (define (not-a-delay-slot-instruction as)
    (assembler-value! as 'not-dsi
                         (cons (here as)
                               (or (assembler-value as 'not-dsi) '()))))
  
  (define (is-a-delay-slot-instruction? as bv addr)
    (and (not (memv addr (or (assembler-value as 'not-dsi) '())))
         (< addr (bytevector-length bv))))
  
  ; SETHI, etc.
  
  (define (class-sethi bits)
    (let ((bits (asm:lsh bits 22)))
      (lambda (as val rd)
        
        (define (fixup bv loc)
          (dep-imm22! bv loc
                         (or (eval-expr as val)
                             (signal-error 'fixup "sethi" val))))
        
        (define (fixup2 bv loc)
          (copy! bv loc bits)
          (dep-rd! bv loc rd)
          (fixup bv loc))
        
        (if (goes-in-delay-slot2? as rd)
            (emit-fixup-proc! as
                              (lambda (b l)
                                (fixup2 b (- l 4))))
            
            (let ((bits (copy bits))
                  (e    (eval-expr as val)))
              (if e
                  (dep-imm22! bits 0 e)
                  (emit-fixup-proc! as (lambda (b l) (fixup b l))))
              (dep-rd! bits 0 rd)
              (emit! as bits))))))
  
  ; NOP is a peculiar sethi
  
  (define (class-nop i)
    (let ((instr (class-sethi i)))
      (lambda (as)
        (instr as 0 $r.g0))))
  
  
  ; Branches
  
  (define (class00b i) (branch #b010 i zero))    ; Un-annulled IU branches.
  (define (class00a i) (branch #b010 i abit))    ; Annulled IU branches.
  (define (classf00b i) (branch #b110 i zero))   ; Un-annulled FP branches.
  (define (classf00a i) (branch #b110 i abit))   ; Annulled FP branches.
  
  ; The `type' parameter is #b010 for IU branches, #b110 for FP branches.
  ; The `bits' parameter is the bits for the cond field.
  ; The `annul' parameter is either `zero' or `abit' (see top of file).
  ;
  ; Annuled branches require special treatement for delay slot
  ; filling based on the `slot' pseudo-instruction.
  ;
  ; Strategy: when a branch with the annul bit set is assembled, remember 
  ; its target in a one-element cache in the AS structure. When a slot
  ; instruction is found (it has its own class) then the cached
  ; value (possibly a delayed expression) is gotten, and a fixup for the
  ; slot is registered.  When the fixup is later evaluated, the branch
  ; target instruction can be found, examined, and evaluated. 
  ; 
  ; The cached value is always valid when the slot instruction is assembled,
  ; because a slot instruction is always directly preceded by an annulled
  ; branch (which will always set the cache).
  
  (define (branch type bits annul)
    ; The delay slot should be filled if this is an annulled branch
    ; or an unconditional branch.
    (let ((fill-delay-slot? (or (not (eq? annul zero))
                                (eq? bits #b1000)))
          (bits (asm:logior (asm:lsh bits 25) (asm:lsh type 22) annul)))
      (lambda (as target0)
        (let ((target `(- ,target0 ,(here as))))
          
          (define (expr)
            (let ((e (eval-expr as target)))
              (cond ((not e)
                     e)
                    ((not (zero? (logand e 3)))
                     (signal-error 'unaligned "branch" target0))
                    ((asm:fits? e 24)
                     e)
                    (else
                     (asm-value-too-large as "branch" target e)))))
          
          (define (fixup bv loc)
            (let ((e (expr)))
              (if e
                  (dep-branch-offset! bv loc e)
                  (signal-error 'fixup "branch" target0))))
          
          (if fill-delay-slot?
              (remember-branch-target as target0)
              (remember-branch-target as #f)) ; Clears the cache.
          (not-a-delay-slot-instruction as)
          (let ((bits (copy bits))
                (e    (expr)))
            (if e
                (dep-branch-offset! bits 0 e)
                (emit-fixup-proc! as (lambda (b l) (fixup b l))))
            (emit! as bits))))))
  
  ; Branch delay slot pseudo-instruction.
  ;
  ; Get the branch target expression from the cache in the AS structure,
  ; and if it is not #f, register a fixup procedure for the delay slot that 
  ; will copy the target instruction to the slot and add 4 to the branch
  ; offset (unless that will overflow the offset or the instruction at the
  ; target is not suitable for lifting).
  ;
  ; It's important that this fixup run _after_ any fixups for the branch
  ; instruction itself!
  
  (define (class-slot)
    (let ((nop-instr (class-nop #b100)))
      (lambda (as)
        
        ; The branch target is the expression denoting the target location.
        
        (define branch-target (recover-branch-target as))
        
        (define (fixup bv loc)
          (let ((bt (or (eval-expr as branch-target)
                        (asm-error "Branch fixup: can't happen: " 
                                   branch-target))))
            (if (is-a-delay-slot-instruction? as bv bt)
                (begin
                 (copy-instr bv bt loc)
                 (add1 bv (- loc 4))))))
        
        (if (and branch-target (fill-delay-slots))
            (emit-fixup-proc! as (lambda (b l) (fixup b l))))
        (nop-instr as))))
  
  ; Branch delay slot pseudo-instruction 2.
  ;
  ; Emit a nop, but record the information that will allow this nop to be
  ; replaced by a sufficiently harmless ALU instruction.
  
  (define (class-slot2)
    (let ((nop-instr (class-nop #b100)))
      (lambda (as . regs)
        (nop-instr as)
        (assembler-value! as 'slot2-info regs))))
  
  ; ALU stuff, register operand, rdy, wryr. Also: jump.
  
  (define (class10r bits . extra)
    (cond ((and (not (null? extra)) (eq? (car extra) 'rdy))
           (let ((op (class10r bits)))
             (lambda (as rd)
               (op as 0 0 rd))))
          ((and (not (null? extra)) (eq? (car extra) 'wry))
           (let ((op (class10r bits)))
             (lambda (as rs)
               (op as rs 0 0))))
          (else
           (let ((bits  (asm:logior (asm:lsh #b10 30) (asm:lsh bits 19)))
                 (jump? (and (not (null? extra)) (eq? (car extra) 'jump))))
             (lambda (as rs1 rs2 rd)
               (let ((bits (copy bits)))
                 (dep-rs1! bits 0 rs1)
                 (dep-rs2! bits 0 rs2)
                 (dep-rd! bits 0 rd)
                 (cond (jump?
                        (not-a-delay-slot-instruction as)
                        (emit! as bits))
                       ((goes-in-delay-slot2? as rd)
                        (emit-fixup-proc!
                         as
                         (lambda (bv loc)
                           (copy! bv (- loc 4) bits))))
                       (else
                        (emit! as bits)))))))))
  
  
  ; ALU stuff, immediate operand, wryi. Also: jump.
  
  (define (class10i bits  . extra)
    (if (and (not (null? extra)) (eq? (car extra) 'wry))
        (let ((op (class10i bits)))
          (lambda (as src)
            (op as 0 src 0)))
        (let ((bits  (asm:logior (asm:lsh #b10 30) (asm:lsh bits 19) ibit))
              (jump? (and (not (null? extra)) (eq? (car extra) 'jump))))
          (lambda (as rs1 e rd)
            
            (define (expr)
              (let ((imm (eval-expr as e)))
                (cond ((not imm)
                       imm)
                      ((asm:fits? imm 13)
                       imm)
                      (jump?
                       (asm-value-too-large as "`jmpli'" e imm))
                      (else
                       (asm-value-too-large as "ALU instruction" e imm)))))
            
            (define (fixup bv loc)
              (let ((e (expr)))
                (if e
                    (dep-imm! bv loc e)
                    (signal-error 'fixup "ALU instruction" e))))
            
            (let ((bits (copy bits))
                  (e    (expr)))
              (if e
                  (dep-imm! bits 0 e)
                  (emit-fixup-proc! as (lambda (b l) (fixup b l))))
              (dep-rs1! bits 0 rs1)
              (dep-rd! bits 0 rd)
              (cond (jump?
                     (not-a-delay-slot-instruction as)
                     (emit! as bits))
                    ((goes-in-delay-slot2? as rd)
                     (emit-fixup-proc!
                      as
                      (lambda (bv loc)
                        (copy! bv (- loc 4) bits))))
                    (else
                     (emit! as bits))))))))
  
  ; Memory stuff, register operand.
  
  (define (class11r bits)
    (let ((bits (asm:logior (asm:lsh #b11 30) (asm:lsh bits 19))))
      (lambda (as rs1 rs2 rd)
        (let ((bits (copy bits)))
          (dep-rs1! bits 0 rs1)
          (dep-rs2! bits 0 rs2)
          (dep-rd! bits 0 rd)
          (emit! as bits)))))
  
  ; Memory stuff, immediate operand.
  
  (define (class11i bits)
    (let ((bits (asm:logior (asm:lsh #b11 30) (asm:lsh bits 19) ibit)))
      (lambda (as rs1 e rd)
        
        (define (expr)
          (let ((imm (eval-expr as e)))
            (cond ((not imm) imm)
                  ((asm:fits? imm 13) imm)
                  (else 
                   (signal-error 'toolarge "Memory instruction" e imm)))))
        
        (define (fixup bv loc)
          (let ((e (expr)))
            (if e
                (dep-imm! bv loc e)
                (signal-error 'fixup "Memory instruction" e))))
        
        (let ((bits (copy bits))
              (e    (expr)))
          (dep-rs1! bits 0 rs1)
          (dep-rd! bits 0 rd)
          (if e
              (dep-imm! bits 0 e)
              (emit-fixup-proc! as (lambda (b l) (fixup b l))))
          (emit! as bits)))))
  
  ; For store instructions.  The syntax is (st a b c) meaning m[ b+c ] <- a.
  ; However, on the Sparc, the destination (rd) field is  the source of
  ; a store, so we transform the instruction into (st c b a) and pass it
  ; to the real store procedure.
  
  (define (class11sr bits)
    (let ((store-instr (class11r bits)))
      (lambda (as a b c)
        (store-instr as c b a))))
  
  (define (class11si bits)
    (let ((store-instr (class11i bits)))
      (lambda (as a b c)
        (store-instr as c b a))))
  
  ; Call is a class all by itself.
  
  (define (class-call)
    (let ((code (asm:lsh #b01 30)))
      (lambda (as target0)
        (let ((target `(- ,target0 ,(here as))))
          
          (define (fixup bv loc)
            (let ((e (eval-expr as target)))
              (if e
                  (dep-call-offset! bv loc e)
                  (signal-error 'fixup "call" target0))))
          
          (let ((bits (copy code))
                (e    (eval-expr as target)))
            (not-a-delay-slot-instruction as)
            (if e
                (dep-call-offset! bits 0 e)
                (emit-fixup-proc! as (lambda (b l) (fixup b l))))
            (emit! as bits))))))
  
  (define (class-label)
    (lambda (as label)
      (emit-label! as label)))
  
  ; FP operation, don't set CC.
  
  (define (class-fpop1 i) (fpop #b110100 i))
  
  ; FP operation, set CC
  
  (define (class-fpop2 i) (fpop #b110101 i))
  
  (define (fpop type opf)
    (let ((bits (asm:logior (asm:lsh #b10 30)
                            (asm:lsh type 19)
                            (asm:lsh opf 5))))
      (lambda (as rs1 rs2 rd)
        (let ((bits (copy bits)))
          (dep-rs1! bits 0 rs1)
          (dep-rs2! bits 0 rs2)
          (dep-rd! bits 0 rd)
          (emit! as bits)))))
  
  (set! sparc-instruction
        (lambda (kwd . ops)
          (case kwd
            ((i11)   (apply class11i ops))
            ((r11)   (apply class11r ops))
            ((si11)  (apply class11si ops))
            ((sr11)  (apply class11sr ops))
            ((sethi) (apply class-sethi ops))
            ((r10)   (apply class10r ops))
            ((i10)   (apply class10i ops))
            ((b00)   (apply class00b ops))
            ((a00)   (apply class00a ops))
            ((call)  (apply class-call ops))
            ((label) (apply class-label ops))
            ((nop)   (apply class-nop ops))
            ((slot)  (apply class-slot ops))
            ((slot2) (apply class-slot2 ops))
            ((fb00)  (apply classf00b ops))
            ((fa00)  (apply classf00a ops))
            ((fp)    (apply class-fpop1 ops))
            ((fpcc)  (apply class-fpop2 ops))
            (else
             (asm-error "sparc-instruction: unrecognized class: " kwd)))))
  'sparc-instruction)

; eof
; Instruction mnemonics

(define sparc.lddi    (sparc-instruction 'i11 #b000011))
(define sparc.lddr    (sparc-instruction 'r11 #b000011))
(define sparc.ldi     (sparc-instruction 'i11 #b000000))
(define sparc.ldr     (sparc-instruction 'r11 #b000000))
(define sparc.ldhi    (sparc-instruction 'i11 #b000010))
(define sparc.ldhr    (sparc-instruction 'r11 #b000010))
(define sparc.ldbi    (sparc-instruction 'i11 #b000001))
(define sparc.ldbr    (sparc-instruction 'r11 #b000001))
(define sparc.lddfi   (sparc-instruction 'i11 #b100011))
(define sparc.lddfr   (sparc-instruction 'r11 #b100011))
(define sparc.stdi    (sparc-instruction 'si11 #b000111))
(define sparc.stdr    (sparc-instruction 'sr11 #b000111))
(define sparc.sti     (sparc-instruction 'si11 #b000100))
(define sparc.str     (sparc-instruction 'sr11 #b000100))
(define sparc.sthi    (sparc-instruction 'si11 #b000110))
(define sparc.sthr    (sparc-instruction 'sr11 #b000110))
(define sparc.stbi    (sparc-instruction 'si11 #b000101))
(define sparc.stbr    (sparc-instruction 'sr11 #b000101))
(define sparc.stdfi   (sparc-instruction 'si11 #b100111))
(define sparc.stdfr   (sparc-instruction 'sr11 #b100111))
(define sparc.sethi   (sparc-instruction 'sethi #b100))
(define sparc.andr    (sparc-instruction 'r10 #b000001))
(define sparc.andrcc  (sparc-instruction 'r10 #b010001))
(define sparc.andi    (sparc-instruction 'i10 #b000001))
(define sparc.andicc  (sparc-instruction 'i10 #b010001))
(define sparc.orr     (sparc-instruction 'r10 #b000010))
(define sparc.orrcc   (sparc-instruction 'r10 #b010010))
(define sparc.ori     (sparc-instruction 'i10 #b000010))
(define sparc.oricc   (sparc-instruction 'i10 #b010010))
(define sparc.xorr    (sparc-instruction 'r10 #b000011))
(define sparc.xorrcc  (sparc-instruction 'r10 #b010011))
(define sparc.xori    (sparc-instruction 'i10 #b000011))
(define sparc.xoricc  (sparc-instruction 'i10 #b010011))
(define sparc.sllr    (sparc-instruction 'r10 #b100101))
(define sparc.slli    (sparc-instruction 'i10 #b100101))
(define sparc.srlr    (sparc-instruction 'r10 #b100110))
(define sparc.srli    (sparc-instruction 'i10 #b100110))
(define sparc.srar    (sparc-instruction 'r10 #b100111))
(define sparc.srai    (sparc-instruction 'i10 #b100111))
(define sparc.addr    (sparc-instruction 'r10 #b000000))
(define sparc.addrcc  (sparc-instruction 'r10 #b010000))
(define sparc.addi    (sparc-instruction 'i10 #b000000))
(define sparc.addicc  (sparc-instruction 'i10 #b010000))
(define sparc.taddrcc (sparc-instruction 'r10 #b100000))
(define sparc.taddicc (sparc-instruction 'i10 #b100000))
(define sparc.subr    (sparc-instruction 'r10 #b000100))
(define sparc.subrcc  (sparc-instruction 'r10 #b010100))
(define sparc.subi    (sparc-instruction 'i10 #b000100))
(define sparc.subicc  (sparc-instruction 'i10 #b010100))
(define sparc.tsubrcc (sparc-instruction 'r10 #b100001))
(define sparc.tsubicc (sparc-instruction 'i10 #b100001))
(define sparc.smulr   (sparc-instruction 'r10 #b001011))
(define sparc.smulrcc (sparc-instruction 'r10 #b011011))
(define sparc.smuli   (sparc-instruction 'i10 #b001011))
(define sparc.smulicc (sparc-instruction 'i10 #b011011))
(define sparc.sdivr   (sparc-instruction 'r10 #b001111))
(define sparc.sdivrcc (sparc-instruction 'r10 #b011111))
(define sparc.sdivi   (sparc-instruction 'i10 #b001111))
(define sparc.sdivicc (sparc-instruction 'i10 #b011111))
(define sparc.b       (sparc-instruction 'b00 #b1000))
(define sparc.b.a     (sparc-instruction 'a00 #b1000))
(define sparc.bne     (sparc-instruction 'b00 #b1001))
(define sparc.bne.a   (sparc-instruction 'a00 #b1001))
(define sparc.be      (sparc-instruction 'b00 #b0001))
(define sparc.be.a    (sparc-instruction 'a00 #b0001))
(define sparc.bg      (sparc-instruction 'b00 #b1010))
(define sparc.bg.a    (sparc-instruction 'a00 #b1010))
(define sparc.ble     (sparc-instruction 'b00 #b0010))
(define sparc.ble.a   (sparc-instruction 'a00 #b0010))
(define sparc.bge     (sparc-instruction 'b00 #b1011))
(define sparc.bge.a   (sparc-instruction 'a00 #b1011))
(define sparc.bl      (sparc-instruction 'b00 #b0011))
(define sparc.bl.a    (sparc-instruction 'a00 #b0011))
(define sparc.bgu     (sparc-instruction 'b00 #b1100))
(define sparc.bgu.a   (sparc-instruction 'a00 #b1100))
(define sparc.bleu    (sparc-instruction 'b00 #b0100))
(define sparc.bleu.a  (sparc-instruction 'a00 #b0100))
(define sparc.bcc     (sparc-instruction 'b00 #b1101))
(define sparc.bcc.a   (sparc-instruction 'a00 #b1101))
(define sparc.bcs     (sparc-instruction 'b00 #b0101))
(define sparc.bcs.a   (sparc-instruction 'a00 #b0101))
(define sparc.bpos    (sparc-instruction 'b00 #b1110))
(define sparc.bpos.a  (sparc-instruction 'a00 #b1110))
(define sparc.bneg    (sparc-instruction 'b00 #b0110))
(define sparc.bneg.a  (sparc-instruction 'a00 #b0110))
(define sparc.bvc     (sparc-instruction 'b00 #b1111))
(define sparc.bvc.a   (sparc-instruction 'a00 #b1111))
(define sparc.bvs     (sparc-instruction 'b00 #b0111))
(define sparc.bvs.a   (sparc-instruction 'a00 #b0111))
(define sparc.call    (sparc-instruction 'call))
(define sparc.jmplr   (sparc-instruction 'r10 #b111000 'jump))
(define sparc.jmpli   (sparc-instruction 'i10 #b111000 'jump))
(define sparc.nop     (sparc-instruction 'nop #b100))
(define sparc.ornr    (sparc-instruction 'r10 #b000110))
(define sparc.orni    (sparc-instruction 'i10 #b000110))
(define sparc.ornrcc  (sparc-instruction 'r10 #b010110))
(define sparc.ornicc  (sparc-instruction 'i10 #b010110))
(define sparc.andni   (sparc-instruction 'i10 #b000101))
(define sparc.andnr   (sparc-instruction 'r10 #b000101))
(define sparc.andnicc (sparc-instruction 'i10 #b010101))
(define sparc.andnrcc (sparc-instruction 'r10 #b010101))
(define sparc.rdy     (sparc-instruction 'r10 #b101000 'rdy))
(define sparc.wryr    (sparc-instruction 'r10 #b110000 'wry))
(define sparc.wryi    (sparc-instruction 'i10 #b110000 'wry))
(define sparc.fb      (sparc-instruction 'fb00 #b1000))
(define sparc.fb.a    (sparc-instruction 'fa00 #b1000))
(define sparc.fbn     (sparc-instruction 'fb00 #b0000))
(define sparc.fbn.a   (sparc-instruction 'fa00 #b0000))
(define sparc.fbu     (sparc-instruction 'fb00 #b0111))
(define sparc.fbu.a   (sparc-instruction 'fa00 #b0111))
(define sparc.fbg     (sparc-instruction 'fb00 #b0110))
(define sparc.fbg.a   (sparc-instruction 'fa00 #b0110))
(define sparc.fbug    (sparc-instruction 'fb00 #b0101))
(define sparc.fbug.a  (sparc-instruction 'fa00 #b0101))
(define sparc.fbl     (sparc-instruction 'fb00 #b0100))
(define sparc.fbl.a   (sparc-instruction 'fa00 #b0100))
(define sparc.fbul    (sparc-instruction 'fb00 #b0011))
(define sparc.fbul.a  (sparc-instruction 'fa00 #b0011))
(define sparc.fblg    (sparc-instruction 'fb00 #b0010))
(define sparc.fblg.a  (sparc-instruction 'fa00 #b0010))
(define sparc.fbne    (sparc-instruction 'fb00 #b0001))
(define sparc.fbne.a  (sparc-instruction 'fa00 #b0001))
(define sparc.fbe     (sparc-instruction 'fb00 #b1001))
(define sparc.fbe.a   (sparc-instruction 'fa00 #b1001))
(define sparc.fbue    (sparc-instruction 'fb00 #b1010))
(define sparc.fbue.a  (sparc-instruction 'fa00 #b1010))
(define sparc.fbge    (sparc-instruction 'fb00 #b1011))
(define sparc.fbge.a  (sparc-instruction 'fa00 #b1011))
(define sparc.fbuge   (sparc-instruction 'fb00 #b1100))
(define sparc.fbuge.a (sparc-instruction 'fa00 #b1100))
(define sparc.fble    (sparc-instruction 'fb00 #b1101))
(define sparc.fble.a  (sparc-instruction 'fa00 #b1101))
(define sparc.fbule   (sparc-instruction 'fb00 #b1110))
(define sparc.fbule.a (sparc-instruction 'fa00 #b1110))
(define sparc.fbo     (sparc-instruction 'fb00 #b1111))
(define sparc.fbo.a   (sparc-instruction 'fa00 #b1111))
(define sparc.faddd   (sparc-instruction 'fp   #b001000010))
(define sparc.fsubd   (sparc-instruction 'fp   #b001000110))
(define sparc.fmuld   (sparc-instruction 'fp   #b001001010))
(define sparc.fdivd   (sparc-instruction 'fp   #b001001110))
(define sparc%fnegs   (sparc-instruction 'fp   #b000000101)) ; See below
(define sparc%fmovs   (sparc-instruction 'fp   #b000000001)) ; See below
(define sparc%fabss   (sparc-instruction 'fp   #b000001001)) ; See below
(define sparc%fcmpdcc (sparc-instruction 'fpcc #b001010010)) ; See below

; Strange instructions.

(define sparc.slot    (sparc-instruction 'slot))
(define sparc.slot2   (sparc-instruction 'slot2))
(define sparc.label   (sparc-instruction 'label))

; Aliases.

(define sparc.bnz     sparc.bne)
(define sparc.bnz.a   sparc.bne.a)
(define sparc.bz      sparc.be)
(define sparc.bz.a    sparc.be.a)
(define sparc.bgeu    sparc.bcc)
(define sparc.bgeu.a  sparc.bcc.a)
(define sparc.blu     sparc.bcs)
(define sparc.blu.a   sparc.bcs.a)

; Abstractions.

(define (sparc.cmpr as r1 r2) (sparc.subrcc as r1 r2 $r.g0))
(define (sparc.cmpi as r imm) (sparc.subicc as r imm $r.g0))
(define (sparc.move as rs rd) (sparc.orr as $r.g0 rs rd))
(define (sparc.set as imm rd) (sparc.ori as $r.g0 imm rd))
(define (sparc.btsti as rs imm) (sparc.andicc as rs imm $r.g0))
(define (sparc.clr as rd) (sparc.move as $r.g0 rd))

(define (sparc.deccc as rs . rest)
  (let ((k (cond ((null? rest) 1)
                 ((null? (cdr rest)) (car rest))
                 (else (asm-error "sparc.deccc: too many operands: " rest)))))
    (sparc.subicc as rs k rs)))

; Floating-point abstractions
;
; For fmovd, fnegd, and fabsd, we must synthesize the instruction from
; fmovs, fnegs, and fabss -- SPARC V8 has only the latter.  (SPARC V9 add
; the former.)

(define (sparc.fmovd as rs rd)
  (sparc%fmovs as rs 0 rd)
  (sparc%fmovs as (+ rs 1) 0 (+ rd 1)))

(define (sparc.fnegd as rs rd)
  (sparc%fnegs as rs 0 rd)
  (if (not (= rs rd))
      (sparc%fmovs as (+ rs 1) 0 (+ rd 1))))

(define (sparc.fabsd as rs rd)
  (sparc%fabss as rs 0 rd)
  (if (not (= rs rd))
      (sparc%fmovs as (+ rs 1) 0 (+ rd 1))))

(define (sparc.fcmpd as rs1 rs2)
  (sparc%fcmpdcc as rs1 rs2 0))

; eof
; Copyright 1998 Lars T Hansen.
;
; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
;
; Asm/Sparc/gen-msi.sch -- SPARC assembler code emitters for 
;    core MacScheme instructions
;
; 9 May 1999 / wdc


; SETGLBL
;
; RS must be a hardware register.
;
; A global cell is a pair, where the car holds the value.

(define (emit-register->global! as rs offset)
  (cond ((= rs $r.result)
	 (sparc.move as $r.result $r.argreg2)
	 (emit-const->register! as offset $r.result)
	 (if (write-barrier)
	     (sparc.jmpli as $r.millicode $m.addtrans $r.o7))
	 (sparc.sti as $r.argreg2 (- $tag.pair-tag) $r.result))
	(else
	 (emit-const->register! as offset $r.result)
	 (sparc.sti as rs (- $tag.pair-tag) $r.result)
	 (if (write-barrier)
	     (millicode-call/1arg as $m.addtrans rs)))))


; GLOBAL
;
; A global cell is a pair, where the car holds the value.
; If (catch-undefined-globals) is true, then code will be emitted to
; check whether the global is #!undefined when loaded. If it is, 
; an exception will be taken, with the global in question in $r.result.

(define (emit-global->register! as offset r)
  (emit-load-global as offset r (catch-undefined-globals)))

; This leaves the cell in ARGREG2.  That fact is utilized by global/invoke
; to signal an appropriate error message.

(define (emit-load-global as offset r check?)
  
  (define (emit-undef-check! as r)
    (if check?
	(let ((GLOBAL-OK (new-label)))
	  (sparc.cmpi   as r $imm.undefined)
	  (sparc.bne.a  as GLOBAL-OK)
	  (sparc.slot   as)
	  (millicode-call/0arg as $m.global-ex)            ; Cell in ARGREG2.
	  (sparc.label  as GLOBAL-OK))))

  (emit-const->register! as offset $r.argreg2)             ; Load cell.
  (if (hardware-mapped? r)
      (begin (sparc.ldi as $r.argreg2 (- $tag.pair-tag) r)
	     (emit-undef-check! as r))
      (begin (sparc.ldi as $r.argreg2 (- $tag.pair-tag) $r.tmp0)
	     (emit-store-reg! as $r.tmp0 r)
	     (emit-undef-check! as $r.tmp0))))


; MOVEREG

(define (emit-register->register! as from to)
  (if (not (= from to))
      (cond ((and (hardware-mapped? from) (hardware-mapped? to))
	     (sparc.move as from to))
	    ((hardware-mapped? from)
	     (emit-store-reg! as from to))
	    ((hardware-mapped? to)
	     (emit-load-reg! as from to))
	    (else
	     (emit-load-reg! as from $r.tmp0)
	     (emit-store-reg! as $r.tmp0 to)))))


; ARGS=

(define (emit-args=! as n)
  (if (not (unsafe-code))
      (let ((L2 (new-label)))
	(sparc.cmpi   as $r.result (thefixnum n))  ; FIXME: limit 1023 args
	(sparc.be.a   as L2)
	(sparc.slot   as)
	(millicode-call/numarg-in-reg as $m.argc-ex (thefixnum n) $r.argreg2)
	(sparc.label  as L2))))


; ARGS>=
;
; The cases for 0 and 1 rest arguments are handled in-line; all other
; cases, including too few, are handled in millicode (really: a C call-out).
;
; The fast path only applies when we don't have to mess with the last
; register, hence the test.

(define (emit-args>=! as n)
  (let ((L0  (new-label))
	(L99 (new-label))
	(L98 (new-label)))
    (if (< n (- *lastreg* 1))
	(let ((dest (regname (+ n 1))))
	  (sparc.cmpi   as $r.result (thefixnum n)) ; n args
	  (if (hardware-mapped? dest)
	      (begin
		(sparc.be.a as L99)
		(sparc.set  as $imm.null dest))
	      (begin
		(sparc.set  as $imm.null $r.tmp0)
		(sparc.be.a as L99)
		(sparc.sti  as $r.tmp0 (swreg-global-offset dest) $r.globals)))
	  (sparc.cmpi   as $r.result (thefixnum (+ n 1))) ; n+1 args
	  (sparc.bne.a  as L98)
	  (sparc.nop    as)
	  (millicode-call/numarg-in-result as $m.alloc 8)
	  (let ((src1 (force-hwreg! as dest $r.tmp1)))
	    (sparc.set as $imm.null $r.tmp0)
	    (sparc.sti as src1 0 $r.result)
	    (sparc.sti as $r.tmp0 4 $r.result)
	    (sparc.addi as $r.result $tag.pair-tag $r.result)
	    (sparc.b as L99)
	    (if (hardware-mapped? dest)
		(sparc.move as $r.result dest)
		(sparc.sti  as $r.result (swreg-global-offset dest)
			    $r.globals)))))
    ; General case
    (sparc.label  as L98)
    (sparc.move   as $r.reg0 $r.argreg3)  ; FIXME in Sparc/mcode.s
    (millicode-call/numarg-in-reg as $m.varargs (thefixnum n) $r.argreg2)
    (sparc.label  as L99)))


; INVOKE
; SETRTN/INVOKE
;
; Bummed.  Can still do better when the procedure to call is in a general
; register (avoids the redundant move to RESULT preceding INVOKE).
;
; Note we must set up the argument count even in unsafe mode, because we 
; may be calling code that was not compiled unsafe.

(define (emit-invoke as n setrtn? mc-exception)
  (let ((START    (new-label))
        (TIMER-OK (new-label))
        (PROC-OK  (new-label)))
    (cond ((not (unsafe-code))
           (sparc.label        as START)
           (sparc.subicc       as $r.timer 1 $r.timer)
           (sparc.bne          as TIMER-OK)
           (sparc.andi         as $r.result $tag.tagmask $r.tmp0)
           (millicode-call/ret as $m.timer-exception START)
           (sparc.label        as TIMER-OK)
           (sparc.cmpi         as $r.tmp0 $tag.procedure-tag)
           (sparc.be.a         as PROC-OK)
           (sparc.ldi          as $r.result $p.codevector $r.tmp0)
           (millicode-call/ret as mc-exception START)
           (sparc.label        as PROC-OK))
          (else
           (sparc.label        as START)
           (sparc.subicc       as $r.timer 1 $r.timer)
           (sparc.bne.a        as TIMER-OK)
           (sparc.ldi          as $r.result $p.codevector $r.tmp0)
           (millicode-call/ret as $m.timer-exception START)
           (sparc.label        as TIMER-OK)))
    (sparc.move                as $r.result $r.reg0)
    ;; FIXME: limit 1023 args
    (cond (setrtn?
           (sparc.set          as (thefixnum n) $r.result)
           (sparc.jmpli        as $r.tmp0 $p.codeoffset $r.o7)
           (sparc.sti          as $r.o7 4 $r.stkp))
          (else
           (sparc.jmpli        as $r.tmp0 $p.codeoffset $r.g0)
           (sparc.set          as (thefixnum n) $r.result)))))

; SAVE -- for new compiler
;
; Create stack frame.  To avoid confusing the garbage collector, the
; slots must be initialized to something definite unless they will
; immediately be initialized by a MacScheme machine store instruction.
; The creation is done by emit-save0!, and the initialization is done
; by emit-save1!.

(define (emit-save0! as n)
  (let* ((L1        (new-label))
	 (L0        (new-label))
	 (framesize (+ 8 (* (+ n 1) 4)))
	 (realsize  (roundup8 (+ framesize 4))))
    (sparc.label  as L0)
    (sparc.subi   as $r.stkp realsize $r.stkp)
    (sparc.cmpr   as $r.stklim $r.stkp)
    (sparc.ble.a  as L1)
    (sparc.set    as framesize $r.tmp0)
    (sparc.addi   as $r.stkp realsize $r.stkp)
    (millicode-call/ret as $m.stkoflow L0)
    (sparc.label  as L1)
    ; initialize size and return fields of stack frame
    (sparc.sti    as $r.tmp0 0 $r.stkp)
    (sparc.sti    as $r.g0 4 $r.stkp)))

; Given a vector v of booleans, initializes slot i of the stack frame
; if and only if (vector-ref v i).

(define (emit-save1! as v)
  (let ((n (vector-length v)))
    (let loop ((i 0) (offset 12))
      (cond ((= i n)
             #t)
            ((vector-ref v i)
	     (sparc.sti as $r.g0 offset $r.stkp)
	     (loop (+ i 1) (+ offset 4)))
	    (else
	     (loop (+ i 1) (+ offset 4)))))))


; RESTORE
;
; Restore registers from stack frame
; FIXME: Use ldd/std here; see comments for emit-save!, above.
; We pop only actual registers.

(define (emit-restore! as n)
  (let ((n (min n 31)))
    (do ((i      0  (+ i 1))
	 (offset 12 (+ offset 4)))
	((> i n))
      (let ((r (regname i)))
	(if (hardware-mapped? r)
	    (sparc.ldi as $r.stkp offset r)
	    (begin (sparc.ldi as $r.stkp offset $r.tmp0)
		   (emit-store-reg! as $r.tmp0 r)))))))

; POP -- for new compiler
;
; Pop frame.
; If returning?, then emit the return as well and put the pop
; in its delay slot.

(define (emit-pop! as n returning?)
  (let* ((framesize (+ 8 (* (+ n 1) 4)))
	 (realsize  (roundup8 (+ framesize 4))))
    (if returning?
        (begin (sparc.ldi   as $r.stkp (+ realsize 4) $r.o7)
	       (sparc.jmpli as $r.o7 8 $r.g0)
	       (sparc.addi  as $r.stkp realsize $r.stkp))
        (sparc.addi as $r.stkp realsize $r.stkp))))


; SETRTN
;
; Change the return address in the stack frame.

(define (emit-setrtn! as label)
  (emit-return-address! as label)
  (sparc.sti as $r.o7 4 $r.stkp))


; APPLY
;
; `apply' falls into millicode.
;
; The timer check is performed here because it is not very easy for the
; millicode to do this.

(define (emit-apply! as r1 r2)
  (let ((L0 (new-label)))
    (check-timer0        as)
    (sparc.label         as L0)
    (emit-move2hwreg!    as r1 $r.argreg2)
    (emit-move2hwreg!    as r2 $r.argreg3)
    (millicode-call/0arg as $m.apply)))


; LOAD

(define (emit-load! as slot dest-reg)
  (if (hardware-mapped? dest-reg)
      (sparc.ldi as $r.stkp (+ 12 (* slot 4)) dest-reg)
      (begin (sparc.ldi as $r.stkp (+ 12 (* slot 4)) $r.tmp0)
	     (emit-store-reg! as $r.tmp0 dest-reg))))


; STORE

(define (emit-store! as k n)
  (if (hardware-mapped? k)
      (sparc.sti as k (+ 12 (* n 4)) $r.stkp)
      (begin (emit-load-reg! as k $r.tmp0)
	     (sparc.sti as $r.tmp0 (+ 12 (* n 4)) $r.stkp))))


; LEXICAL

(define (emit-lexical! as m n)
  (let ((base (emit-follow-chain! as m)))
    (sparc.ldi as base (- (procedure-slot-offset n) $tag.procedure-tag)
	       $r.result)))


; SETLEX
; FIXME: should allow an in-line barrier

(define (emit-setlex! as m n)
  (let ((base (emit-follow-chain! as m)))
    (sparc.sti as $r.result (- (procedure-slot-offset n) $tag.procedure-tag)
	       base)
    (if (write-barrier)
	(begin
	  (sparc.move as $r.result $r.argreg2)
	  (millicode-call/1arg-in-result as $m.addtrans base)))))


; Follow static links.
;
; By using and leaving the result in ARGREG3 rather than in RESULT, 
; we save a temporary register.

(define (emit-follow-chain! as m)
  (let loop ((q m))
    (cond ((not (zero? q))
	   (sparc.ldi as
		      (if (= q m) $r.reg0 $r.argreg3)
		      $p.linkoffset
		      $r.argreg3)
	   (loop (- q 1)))
	  ((zero? m) 
	   $r.reg0)
	  (else 
	   $r.argreg3))))

; RETURN

(define (emit-return! as)
  (sparc.ldi   as $r.stkp 4 $r.o7)
  (sparc.jmpli as $r.o7 8 $r.g0)
  (sparc.nop   as))


; RETURN-REG k

(define (emit-return-reg! as r)
  (sparc.ldi   as $r.stkp 4 $r.o7)
  (sparc.jmpli as $r.o7 8 $r.g0)
  (sparc.move  as r $r.result))


; RETURN-CONST k
;
; The constant c must be synthesizable in a single instruction.

(define (emit-return-const! as c)
  (sparc.ldi   as $r.stkp 4 $r.o7)
  (sparc.jmpli as $r.o7 8 $r.g0)
  (emit-constant->register as c $r.result))


; MVRTN

(define (emit-mvrtn! as)
  (asm-error "multiple-value return has not been implemented (yet)."))


; LEXES

(define (emit-lexes! as n-slots)
  (emit-alloc-proc! as n-slots)
  (sparc.ldi as $r.reg0 $p.codevector $r.tmp0)
  (sparc.ldi as $r.reg0 $p.constvector $r.tmp1)
  (sparc.sti as $r.tmp0 $p.codevector $r.result)
  (sparc.sti as $r.tmp1 $p.constvector $r.result)
  (emit-init-proc-slots! as n-slots))


; LAMBDA

(define (emit-lambda! as code-offs0 const-offs0 n-slots)
  (let* ((code-offs  (+ 4 (- (* 4 code-offs0) $tag.vector-tag)))
         (const-offs (+ 4 (- (* 4 const-offs0) $tag.vector-tag)))
         (fits? (asm:fits? const-offs 13)))
    (emit-alloc-proc! as n-slots)
    (if fits?
        (begin (sparc.ldi as $r.reg0 $p.constvector $r.tmp0)
               (sparc.ldi as $r.tmp0 code-offs $r.tmp1))
        (emit-const->register! as code-offs0 $r.tmp1))
    (sparc.sti as $r.tmp1 $p.codevector $r.result)
    (if fits?
        (begin (sparc.ldi as $r.reg0 $p.constvector $r.tmp0)
               (sparc.ldi as $r.tmp0 const-offs $r.tmp1))
        (emit-const->register! as const-offs0 $r.tmp1))
    (sparc.sti as $r.tmp1 $p.constvector $r.result)
    (emit-init-proc-slots! as n-slots)))
 
; Allocate procedure with room for n register slots; return tagged pointer.

(define emit-alloc-proc!
  (let ((two^12 (expt 2 12)))
    (lambda (as n)
      (millicode-call/numarg-in-result as $m.alloc (* (+ n 4) 4))
      (let ((header (+ (* (* (+ n 3) 4) 256) $imm.procedure-header)))
	(emit-immediate->register! as header $r.tmp0)
	(sparc.sti  as $r.tmp0 0 $r.result)
	(sparc.addi as $r.result $tag.procedure-tag $r.result)))))

; Initialize data slots in procedure from current registers as specified for
; `lamba' and `lexes'. If there are more data slots than registers, then
; we must generate code to cdr down the list in the last register to obtain
; the rest of the data. The list is expected to have at least the minimal
; length.
;
; The tagged pointer to the procedure is in $r.result.

(define (emit-init-proc-slots! as n)

  (define (save-registers lo hi offset)
    (do ((lo     lo     (+ lo 1))
	 (offset offset (+ offset 4)))
	((> lo hi))
      (let ((r (force-hwreg! as (regname lo) $r.tmp0)))
	(sparc.sti as r offset $r.result))))

  (define (save-list lo hi offset)
    (emit-load-reg! as $r.reg31 $r.tmp0)
    (do ((lo     lo      (+ lo 1))
	 (offset offset (+ offset 4)))
	((> lo hi))
      (sparc.ldi as $r.tmp0 (- $tag.pair-tag) $r.tmp1)
      (sparc.sti as $r.tmp1 offset $r.result)
      (if (< lo hi)
	  (begin 
	    (sparc.ldi as $r.tmp0 (+ (- $tag.pair-tag) 4) $r.tmp0)))))
      
  (cond ((< n *lastreg*)
	 (save-registers 0 n $p.reg0))
	(else
	 (save-registers 0 (- *lastreg* 1) $p.reg0)
	 (save-list      *lastreg* n (+ $p.reg0 (* *lastreg* 4))))))

; BRANCH

(define (emit-branch! as check-timer? label)
  (if check-timer?
      (check-timer as label label)
      (begin (sparc.b    as label)
             (sparc.slot as))))


; BRANCHF

(define (emit-branchf! as label)
  (emit-branchfreg! as $r.result label))


; BRANCHFREG -- introduced by peephole optimization.

(define (emit-branchfreg! as hwreg label)
  (sparc.cmpi as hwreg $imm.false)
  (sparc.be.a as label)
  (sparc.slot as))


; BRANCH-WITH-SETRTN -- introduced by peephole optimization

(define (emit-branch-with-setrtn! as label)
  (check-timer0 as)
  (sparc.call   as label)
  (sparc.sti    as $r.o7 4 $r.stkp))

; JUMP
;
; Given the finalization order (outer is finalized before inner is assembled)
; the label value will always be available when a jump is assembled.  The
; only exception is when m = 0, but does this ever happen?  This code handles
; the case anyway.

(define (emit-jump! as m label)
  (let* ((r      (emit-follow-chain! as m))
	 (labelv (label-value as label))
	 (v      (if (number? labelv)
		     (+ labelv $p.codeoffset)
		     (list '+ label $p.codeoffset))))
    (sparc.ldi as r $p.codevector $r.tmp0)
    (if (and (number? v) (immediate-literal? v))
	(sparc.jmpli as $r.tmp0 v $r.g0)
	(begin (emit-immediate->register! as v $r.tmp1)
	       (sparc.jmplr as $r.tmp0 $r.tmp1 $r.g0)))
    (sparc.move  as r $r.reg0)))


; .SINGLESTEP
;
; Single step: jump to millicode; pass index of documentation string in
; %TMP0. Some instructions execute when reg0 is not a valid pointer to
; the current procedure (because this is just after returning); in this
; case we restore reg0 from the stack location given by 'funkyloc'.

(define (emit-singlestep-instr! as funky? funkyloc cvlabel)
  (if funky?
      (sparc.ldi as $r.stkp (+ (thefixnum funkyloc) 12) $r.reg0))
  (millicode-call/numarg-in-reg as $m.singlestep
				   (thefixnum cvlabel)
				   $r.argreg2))


; Emit the effective address of a label-8 into %o7.
;
; There are multiple ways to do this.  If the call causes an expensive
; bubble in the pipeline it is probably much less expensive to grub
; the code vector address out of the procedure in REG0 and calculate it
; that way.  FIXME: We need to benchmark these options.
;
; In general the point is moot as the common-case sequence
;       setrtn L1
;       invoke n
;   L1:
; should be peephole-optimized into the obvious fast code.

(define (emit-return-address! as label)
  (let* ((loc  (here as))
	 (lloc (label-value as label)))

    (define (emit-short val)
      (sparc.call as (+ loc 8))
      (sparc.addi as $r.o7 val $r.o7))

    (define (emit-long val)
      ; Don't use sparc.set: we need to know that two instructions get
      ; generated.
      (sparc.sethi as `(hi ,val) $r.tmp0)
      (sparc.ori   as $r.tmp0 `(lo ,val) $r.tmp0)
      (sparc.call  as (+ loc 16))
      (sparc.addr  as $r.o7 $r.tmp0 $r.o7))

    (cond (lloc
	   (let ((target-rel-addr (- lloc loc 8)))
	     (if (immediate-literal? target-rel-addr)
		 (emit-short target-rel-addr)
		 (emit-long (- target-rel-addr 8)))))
	  ((short-effective-addresses)
	   (emit-short `(- ,label ,loc 8)))
	  (else
	   (emit-long `(- ,label ,loc 16))))))

; eof
; Copyright 1998 Lars T Hansen.
; 
; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
;
; 22 April 1999 / wdc
;
; SPARC code generation macros for primitives, part 1:
;   primitives defined in Compiler/sparc.imp.sch.

; These extend Asm/Common/pass5p1.sch.

(define (operand5 instruction)
  (car (cddddr (cdr instruction))))

(define (operand6 instruction)
  (cadr (cddddr (cdr instruction))))

(define (operand7 instruction)
  (caddr (cddddr (cdr instruction))))


; Primop emitters.

(define (emit-primop.1arg! as op)
  ((find-primop op) as))

(define (emit-primop.2arg! as op r)
  ((find-primop op) as r))

(define (emit-primop.3arg! as a1 a2 a3)
  ((find-primop a1) as a2 a3))

(define (emit-primop.4arg! as a1 a2 a3 a4)
  ((find-primop a1) as a2 a3 a4))

(define (emit-primop.5arg! as a1 a2 a3 a4 a5)
  ((find-primop a1) as a2 a3 a4 a5))

(define (emit-primop.6arg! as a1 a2 a3 a4 a5 a6)
  ((find-primop a1) as a2 a3 a4 a5 a6))

(define (emit-primop.7arg! as a1 a2 a3 a4 a5 a6 a7)
  ((find-primop a1) as a2 a3 a4 a5 a6 a7))


; Hash table of primops

(define primop-vector (make-vector 256 '()))

(define (define-primop name proc)
  (let ((h (logand (symbol-hash name) 255)))
    (vector-set! primop-vector h (cons (cons name proc)
				       (vector-ref primop-vector h)))
    name))

(define (find-primop name)
  (let ((h (logand (symbol-hash name) 255)))
    (cdr (assq name (vector-ref primop-vector h)))))

(define (for-each-primop proc)
  (do ((i 0 (+ i 1)))
      ((= i (vector-length primop-vector)))
    (for-each (lambda (p)
                (proc (cdr p)))
              (vector-ref primop-vector i))))

; Primops

(define-primop 'unspecified
  (lambda (as)
    (emit-immediate->register! as $imm.unspecified $r.result)))

(define-primop 'undefined
  (lambda (as)
    (emit-immediate->register! as $imm.undefined $r.result)))

(define-primop 'eof-object
  (lambda (as)
    (emit-immediate->register! as $imm.eof $r.result)))

(define-primop 'enable-interrupts
  (lambda (as)
    (millicode-call/0arg as $m.enable-interrupts)))

(define-primop 'disable-interrupts
  (lambda (as)
    (millicode-call/0arg as $m.disable-interrupts)))

(define-primop 'gc-counter
  (lambda (as)
    (sparc.ldi as $r.globals $g.gccnt $r.result)))

(define-primop 'zero?
  (lambda (as)
    (emit-cmp-primop! as sparc.be.a $m.zerop $r.g0)))

(define-primop '=
  (lambda (as r)
    (emit-cmp-primop! as sparc.be.a $m.numeq r)))

(define-primop '<
  (lambda (as r)
    (emit-cmp-primop! as sparc.bl.a $m.numlt r)))

(define-primop '<=
  (lambda (as r)
    (emit-cmp-primop! as sparc.ble.a $m.numle r)))

(define-primop '>
  (lambda (as r)
    (emit-cmp-primop! as sparc.bg.a $m.numgt r)))

(define-primop '>=
  (lambda (as r)
    (emit-cmp-primop! as sparc.bge.a $m.numge r)))

(define-primop 'complex?
  (lambda (as)
    (millicode-call/0arg as $m.complexp)))

(define-primop 'real?
  (lambda (as)
    (millicode-call/0arg as $m.realp)))

(define-primop 'rational?
  (lambda (as)
    (millicode-call/0arg as $m.rationalp)))

(define-primop 'integer?
  (lambda (as)
    (millicode-call/0arg as $m.integerp)))

(define-primop 'exact?
  (lambda (as)
    (millicode-call/0arg as $m.exactp)))

(define-primop 'inexact?
  (lambda (as)
    (millicode-call/0arg as $m.inexactp)))

(define-primop 'fixnum?
  (lambda (as)
    (sparc.btsti as $r.result 3)
    (emit-set-boolean! as)))

(define-primop '+
  (lambda (as r)
    (emit-primop.4arg! as 'internal:+ $r.result r $r.result)))

(define-primop '-
  (lambda (as r)
    (emit-primop.4arg! as 'internal:- $r.result r $r.result)))

(define-primop '*
  (lambda (as rs2)
    (emit-multiply-code as rs2 #f)))

(define (emit-multiply-code as rs2 fixnum-arithmetic?)
  (if (and (unsafe-code) fixnum-arithmetic?)
      (begin
	(sparc.srai    as $r.result 2 $r.tmp0)
	(sparc.smulr   as $r.tmp0 rs2 $r.result))
      (let ((rs2    (force-hwreg! as rs2 $r.argreg2))
	    (Lstart (new-label))
	    (Ltagok (new-label))
	    (Loflo  (new-label))
	    (Ldone  (new-label)))
	(sparc.label   as Lstart)
	(sparc.orr     as $r.result rs2 $r.tmp0)
	(sparc.btsti   as $r.tmp0 3)
	(sparc.be.a    as Ltagok)
	(sparc.srai    as $r.result 2 $r.tmp0)
	(sparc.label   as Loflo)
	(if (not (= rs2 $r.argreg2)) (sparc.move as rs2 $r.argreg2))
	(if (not fixnum-arithmetic?)
	    (begin
	      (millicode-call/ret as $m.multiply Ldone))
	    (begin
	      (sparc.set as (thefixnum $ex.fx*) $r.tmp0)
	      (millicode-call/ret as $m.exception Lstart)))
	(sparc.label   as Ltagok)
	(sparc.smulr   as $r.tmp0 rs2 $r.tmp0)
	(sparc.rdy     as $r.tmp1)
	(sparc.srai    as $r.tmp0 31 $r.tmp2)
	(sparc.cmpr    as $r.tmp1 $r.tmp2)
	(sparc.bne.a   as Loflo)
	(sparc.slot    as)
	(sparc.move    as $r.tmp0 $r.result)
	(sparc.label   as Ldone))))

(define-primop '/
  (lambda (as r)
    (millicode-call/1arg as $m.divide r)))

(define-primop 'quotient
  (lambda (as r)
    (millicode-call/1arg as $m.quotient r)))

(define-primop 'remainder
  (lambda (as r)
    (millicode-call/1arg as $m.remainder r)))

(define-primop '--
  (lambda (as)
    (emit-negate as $r.result $r.result)))

(define-primop 'round
  (lambda (as)
    (millicode-call/0arg as $m.round)))

(define-primop 'truncate
  (lambda (as)
    (millicode-call/0arg as $m.truncate)))

(define-primop 'lognot
  (lambda (as)
    (if (not (unsafe-code))
	(emit-assert-fixnum! as $r.result $ex.lognot))
    (sparc.ornr as $r.g0 $r.result $r.result)  ; argument order matters
    (sparc.xori as $r.result 3 $r.result)))

(define-primop 'logand
  (lambda (as x)
    (logical-op as $r.result x $r.result sparc.andr $ex.logand)))

(define-primop 'logior
  (lambda (as x)
    (logical-op as $r.result x $r.result sparc.orr $ex.logior)))

(define-primop 'logxor
  (lambda (as x)
    (logical-op as $r.result x $r.result sparc.xorr $ex.logxor)))

; Fixnum shifts.
;
; Only positive shifts are meaningful.
; FIXME: These are incompatible with MacScheme and MIT Scheme.
; FIXME: need to return to start of sequence after fault.

(define-primop 'lsh
  (lambda (as x)
    (emit-shift-operation as $ex.lsh $r.result x $r.result)))

(define-primop 'rshl
  (lambda (as x)
    (emit-shift-operation as $ex.rshl $r.result x $r.result)))

(define-primop 'rsha
  (lambda (as x)
    (emit-shift-operation as $ex.rsha $r.result x $r.result)))


; fixnums only.
; FIXME: for symmetry with shifts there should be rotl and rotr (?)
;        or perhaps rot should only ever rotate one way.
; FIXME: implement.

(define-primop 'rot
  (lambda (as x)
    (asm-error "Sparcasm: ROT primop is not implemented.")))

(define-primop 'null?
  (lambda (as)
    (sparc.cmpi as $r.result $imm.null)
    (emit-set-boolean! as)))

(define-primop 'pair?
  (lambda (as)
    (emit-single-tagcheck->bool! as $tag.pair-tag)))

(define-primop 'eof-object?
  (lambda (as)
    (sparc.cmpi as $r.result $imm.eof)
    (emit-set-boolean! as)))

; Tests the specific representation, not 'flonum or compnum with 0i'.

(define-primop 'flonum?
  (lambda (as)
    (emit-double-tagcheck->bool! as $tag.bytevector-tag
				 (+ $imm.bytevector-header
				    $tag.flonum-typetag))))

(define-primop 'compnum?
  (lambda (as)
    (emit-double-tagcheck->bool! as $tag.bytevector-tag
				 (+ $imm.bytevector-header
				    $tag.compnum-typetag))))

(define-primop 'symbol?
  (lambda (as)
    (emit-double-tagcheck->bool! as $tag.vector-tag
				 (+ $imm.vector-header
				    $tag.symbol-typetag))))

(define-primop 'port?
  (lambda (as)
    (emit-double-tagcheck->bool! as $tag.vector-tag
				 (+ $imm.vector-header
				    $tag.port-typetag))))

(define-primop 'structure?
  (lambda (as)
    (emit-double-tagcheck->bool! as $tag.vector-tag
				 (+ $imm.vector-header
				    $tag.structure-typetag))))

(define-primop 'char?
  (lambda (as)
    (sparc.andi as $r.result #xFF $r.tmp0)
    (sparc.cmpi as $r.tmp0 $imm.character)
    (emit-set-boolean! as)))

(define-primop 'string?
  (lambda (as)
    (emit-double-tagcheck->bool! as
				 $tag.bytevector-tag
				 (+ $imm.bytevector-header
				    $tag.string-typetag))))

(define-primop 'bytevector?
  (lambda (as)
    (emit-double-tagcheck->bool! as
				 $tag.bytevector-tag
				 (+ $imm.bytevector-header
				    $tag.bytevector-typetag))))

(define-primop 'bytevector-like?
  (lambda (as)
    (emit-single-tagcheck->bool! as $tag.bytevector-tag)))

(define-primop 'vector?
  (lambda (as)
    (emit-double-tagcheck->bool! as
				 $tag.vector-tag
				 (+ $imm.vector-header
				    $tag.vector-typetag))))

(define-primop 'vector-like?
  (lambda (as)
    (emit-single-tagcheck->bool! as $tag.vector-tag)))

(define-primop 'procedure?
  (lambda (as)
    (emit-single-tagcheck->bool! as $tag.procedure-tag)))

(define-primop 'cons
  (lambda (as r)
    (emit-primop.4arg! as 'internal:cons $r.result r $r.result)))

(define-primop 'car
  (lambda (as)
    (emit-primop.3arg! as 'internal:car $r.result $r.result)))

(define-primop 'cdr
  (lambda (as)
    (emit-primop.3arg! as 'internal:cdr $r.result $r.result)))

(define-primop 'car:pair
  (lambda (as)
    (sparc.ldi as $r.result (- $tag.pair-tag) $r.result)))

(define-primop 'cdr:pair
  (lambda (as)
    (sparc.ldi as $r.result (- 4 $tag.pair-tag) $r.result)))

(define-primop 'set-car!
  (lambda (as x)
    (if (not (unsafe-code))
	(emit-single-tagcheck-assert! as $tag.pair-tag $ex.car #f))
    (emit-setcar/setcdr! as $r.result x 0)))

(define-primop 'set-cdr!
  (lambda (as x)
    (if (not (unsafe-code))
	(emit-single-tagcheck-assert! as $tag.pair-tag $ex.cdr #f))
    (emit-setcar/setcdr! as $r.result x 4)))

; Cells are internal data structures, represented using pairs.
; No error checking is done on cell references.

(define-primop 'make-cell
  (lambda (as)
    (emit-primop.4arg! as 'internal:cons $r.result $r.g0 $r.result)))

(define-primop 'cell-ref
  (lambda (as)
    (emit-primop.3arg! as 'internal:cell-ref $r.result $r.result)))

(define-primop 'cell-set!
  (lambda (as r)
    (emit-setcar/setcdr! as $r.result r 0)))

(define-primop 'syscall
  (lambda (as)
    (millicode-call/0arg as $m.syscall)))

(define-primop 'break
  (lambda (as)
    (millicode-call/0arg as $m.break)))

(define-primop 'creg
  (lambda (as)
    (millicode-call/0arg as $m.creg)))

(define-primop 'creg-set!
  (lambda (as)
    (millicode-call/0arg as $m.creg-set!)))

(define-primop 'typetag
  (lambda (as)
    (millicode-call/0arg as $m.typetag)))

(define-primop 'typetag-set!
  (lambda (as r)
    (millicode-call/1arg as $m.typetag-set r)))

(define-primop 'exact->inexact
  (lambda (as)
    (millicode-call/0arg as $m.exact->inexact)))

(define-primop 'inexact->exact
  (lambda (as)
    (millicode-call/0arg as $m.inexact->exact)))

(define-primop 'real-part
  (lambda (as)
    (millicode-call/0arg as $m.real-part)))

(define-primop 'imag-part
  (lambda (as)
    (millicode-call/0arg as $m.imag-part)))

(define-primop 'char->integer
  (lambda (as)
    (if (not (unsafe-code))
	(emit-assert-char! as $ex.char2int #f))
    (sparc.srli as $r.result 14 $r.result)))

(define-primop 'integer->char
  (lambda (as)
    (if (not (unsafe-code))
	(emit-assert-fixnum! as $r.result $ex.int2char))
    (sparc.andi as $r.result #x3FF $r.result)
    (sparc.slli as $r.result 14 $r.result)
    (sparc.ori  as $r.result $imm.character $r.result)))

(define-primop 'not
  (lambda (as)
    (sparc.cmpi as $r.result $imm.false)
    (emit-set-boolean! as)))

(define-primop 'eq?
  (lambda (as x)
    (emit-primop.4arg! as 'internal:eq? $r.result x $r.result)))

(define-primop 'eqv?
  (lambda (as x)
    (let ((tmp (force-hwreg! as x $r.tmp0))
	  (L1  (new-label)))
      (sparc.cmpr as $r.result tmp)
      (sparc.be.a as L1)
      (sparc.set  as $imm.true $r.result)
      (millicode-call/1arg as $m.eqv tmp)
      (sparc.label as L1))))

(define-primop 'make-bytevector
  (lambda (as)
    (if (not (unsafe-code))
	(emit-assert-positive-fixnum! as $r.result $ex.mkbvl))
    (emit-allocate-bytevector as
			      (+ $imm.bytevector-header
				 $tag.bytevector-typetag)
			      #f)
    (sparc.addi as $r.result $tag.bytevector-tag $r.result)))

(define-primop 'bytevector-fill!
  (lambda (as rs2)
    (let* ((fault (emit-double-tagcheck-assert! as
						$tag.bytevector-tag
						(+ $imm.bytevector-header
						   $tag.bytevector-typetag)
						$ex.bvfill
						rs2))
	   (rs2 (force-hwreg! as rs2 $r.argreg2)))
      (sparc.btsti  as rs2 3)
      (sparc.bne    as fault)
      (sparc.srai   as rs2 2 $r.tmp2)
      (sparc.ldi    as $r.result (- $tag.bytevector-tag) $r.tmp0)
      (sparc.addi   as $r.result (- 4 $tag.bytevector-tag) $r.tmp1)
      (sparc.srai   as $r.tmp0 8 $r.tmp0)
      (emit-bytevector-fill as $r.tmp0 $r.tmp1 $r.tmp2))))

(define-primop 'bytevector-length
  (lambda (as)
    (emit-get-length! as 
		      $tag.bytevector-tag
		      (+ $imm.bytevector-header $tag.bytevector-typetag)
		      $ex.bvlen
		      $r.result
		      $r.result)))

(define-primop 'bytevector-like-length
  (lambda (as)
    (emit-get-length! as
		      $tag.bytevector-tag
		      #f
		      $ex.bvllen
		      $r.result
		      $r.result)))

(define-primop 'bytevector-ref
  (lambda (as r)
    (let ((fault (if (not (unsafe-code))
		     (emit-double-tagcheck-assert!
		      as
		      $tag.bytevector-tag
		      (+ $imm.bytevector-header $tag.bytevector-typetag)
		      $ex.bvref
		      r)
		     #f)))
      (emit-bytevector-like-ref! as $r.result r $r.result fault #f #t))))

(define-primop 'bytevector-like-ref
  (lambda (as r)
    (let ((fault (if (not (unsafe-code))
		     (emit-single-tagcheck-assert! as
						   $tag.bytevector-tag
						   $ex.bvlref
						   r)
		     #f)))
      (emit-bytevector-like-ref! as $r.result r $r.result fault #f #f))))

(define-primop 'bytevector-set!
  (lambda (as r1 r2)
    (let ((fault (if (not (unsafe-code))
		     (emit-double-tagcheck-assert!
		      as
		      $tag.bytevector-tag
		      (+ $imm.bytevector-header $tag.bytevector-typetag)
		      $ex.bvset
		      r1)
		     #f)))
      (emit-bytevector-like-set! as r1 r2 fault #t))))

(define-primop 'bytevector-like-set!
  (lambda (as r1 r2)
    (let ((fault (if (not (unsafe-code))
		     (emit-single-tagcheck-assert! as
						   $tag.bytevector-tag
						   $ex.bvlset
						   r1)
		     #f)))
      (emit-bytevector-like-set! as r1 r2 fault #f))))

(define-primop 'sys$bvlcmp
  (lambda (as x)
    (millicode-call/1arg as $m.bvlcmp x)))

; Strings

; RESULT must have non-negative fixnum.
; RS2 must have character.

(define-primop 'make-string
  (lambda (as rs2)
    (let ((FAULT (new-label))
	  (START (new-label)))
      (sparc.label as START)
      (let ((rs2 (force-hwreg! as rs2 $r.argreg2)))
	(if (not (unsafe-code))
	    (let ((L1 (new-label))
		  (L2 (new-label)))
	      (sparc.tsubrcc as $r.result $r.g0 $r.g0)
	      (sparc.bvc.a   as L1)
	      (sparc.andi    as rs2 255 $r.tmp0)
	      (sparc.label   as FAULT)
	      (if (not (= rs2 $r.argreg2))
		  (sparc.move as rs2 $r.argreg2))
	      (sparc.set     as (thefixnum $ex.mkbvl) $r.tmp0) ; Wrong code.
	      (millicode-call/ret as $m.exception START)
	      (sparc.label   as L1)
	      (sparc.bl      as FAULT)
	      (sparc.cmpi    as $r.tmp0 $imm.character)
	      (sparc.bne     as FAULT)
	      (sparc.move as $r.result $r.argreg3))
	    (begin
	      (sparc.move as $r.result $r.argreg3)))
	(emit-allocate-bytevector as
				  (+ $imm.bytevector-header
				     $tag.string-typetag)
				  $r.argreg3)
	(sparc.srai   as rs2 16 $r.tmp1)
	(sparc.addi   as $r.result 4 $r.result)
	(sparc.srai   as $r.argreg3 2 $r.tmp0)
	(emit-bytevector-fill as $r.tmp0 $r.result $r.tmp1)
	(sparc.addi as $r.result (- $tag.bytevector-tag 4) $r.result)))))

(define-primop 'string-length
  (lambda (as)
    (emit-primop.3arg! as 'internal:string-length $r.result $r.result)))

(define-primop 'string-ref
  (lambda (as r)
    (emit-primop.4arg! as 'internal:string-ref $r.result r $r.result)))

(define-primop 'string-set!
  (lambda (as r1 r2)
    (emit-string-set! as $r.result r1 r2)))

(define-primop 'sys$partial-list->vector
  (lambda (as r)
    (millicode-call/1arg as $m.partial-list->vector r)))

(define-primop 'make-procedure
  (lambda (as)
    (emit-make-vector-like! as
			    '()
			    $imm.procedure-header
			    $tag.procedure-tag)))

(define-primop 'make-vector
  (lambda (as r)
    (emit-make-vector-like! as
			    r
			    (+ $imm.vector-header $tag.vector-typetag)
			    $tag.vector-tag)))

(define-primop 'make-vector:0
  (lambda (as r) (make-vector-n as 0 r)))

(define-primop 'make-vector:1
  (lambda (as r) (make-vector-n as 1 r)))

(define-primop 'make-vector:2
  (lambda (as r) (make-vector-n as 2 r)))

(define-primop 'make-vector:3
  (lambda (as r) (make-vector-n as 3 r)))

(define-primop 'make-vector:4
  (lambda (as r) (make-vector-n as 4 r)))

(define-primop 'make-vector:5
  (lambda (as r) (make-vector-n as 5 r)))

(define-primop 'make-vector:6
  (lambda (as r) (make-vector-n as 6 r)))

(define-primop 'make-vector:7
  (lambda (as r) (make-vector-n as 7 r)))

(define-primop 'make-vector:8
  (lambda (as r) (make-vector-n as 8 r)))

(define-primop 'make-vector:9
  (lambda (as r) (make-vector-n as 9 r)))

(define-primop 'vector-length
  (lambda (as)
    (emit-primop.3arg! as 'internal:vector-length $r.result $r.result)))

(define-primop 'vector-like-length
  (lambda (as)
    (emit-get-length! as $tag.vector-tag #f $ex.vllen $r.result $r.result)))

(define-primop 'vector-length:vec
  (lambda (as)
    (emit-get-length-trusted! as $tag.vector-tag $r.result $r.result)))

(define-primop 'procedure-length
  (lambda (as)
    (emit-get-length! as $tag.procedure-tag #f $ex.plen $r.result $r.result)))

(define-primop 'vector-ref
  (lambda (as r)
    (emit-primop.4arg! as 'internal:vector-ref $r.result r $r.result)))

(define-primop 'vector-like-ref
  (lambda (as r)
    (let ((fault (if (not (unsafe-code))
		     (emit-single-tagcheck-assert! as
						   $tag.vector-tag
						   $ex.vlref
						   r)
		     #f)))
      (emit-vector-like-ref!
       as $r.result r $r.result fault $tag.vector-tag #f))))

(define-primop 'vector-ref:trusted
  (lambda (as rs2)
    (emit-vector-like-ref-trusted!
     as $r.result rs2 $r.result $tag.vector-tag)))

(define-primop 'procedure-ref
  (lambda (as r)
    (let ((fault (if (not (unsafe-code))
		     (emit-single-tagcheck-assert! as
						   $tag.procedure-tag
						   $ex.pref
						   r)
		     #f)))
      (emit-vector-like-ref!
       as $r.result r $r.result fault $tag.procedure-tag #f))))

(define-primop 'vector-set!
  (lambda (as r1 r2)
    (emit-primop.4arg! as 'internal:vector-set! $r.result r1 r2)))

(define-primop 'vector-like-set!
  (lambda (as r1 r2)
    (let ((fault (if (not (unsafe-code))
		     (emit-single-tagcheck-assert! as
						   $tag.vector-tag
						   $ex.vlset
						   r1)
		     #f)))
      (emit-vector-like-set! as $r.result r1 r2 fault $tag.vector-tag #f))))

(define-primop 'vector-set!:trusted
  (lambda (as rs2 rs3)
    (emit-vector-like-set-trusted! as $r.result rs2 rs3 $tag.vector-tag)))

(define-primop 'procedure-set!
  (lambda (as r1 r2)
    (let ((fault (if (not (unsafe-code))
		     (emit-single-tagcheck-assert! as
						   $tag.procedure-tag
						   $ex.pset
						   r1)
		     #f)))
      (emit-vector-like-set! as $r.result r1 r2 fault $tag.procedure-tag #f))))

(define-primop 'char<?
  (lambda (as x)
    (emit-char-cmp as x sparc.bl.a $ex.char<?)))

(define-primop 'char<=?
  (lambda (as x)
    (emit-char-cmp as x sparc.ble.a $ex.char<=?)))

(define-primop 'char=?
  (lambda (as x)
    (emit-char-cmp as x sparc.be.a $ex.char=?)))

(define-primop 'char>?
  (lambda (as x)
    (emit-char-cmp as x sparc.bg.a $ex.char>?)))

(define-primop 'char>=?
  (lambda (as x)
    (emit-char-cmp as x sparc.bge.a $ex.char>=?)))

; Experimental (for performance).
; This makes massive assumptions about the layout of the port structure:
; A port is a vector-like where
;   #0 = port.input?
;   #4 = port.buffer
;   #7 = port.rd-lim
;   #8 = port.rd-ptr
; See Lib/iosys.sch for more information.

(define-primop 'sys$read-char
  (lambda (as)
    (let ((Lfinish (new-label))
	  (Lend    (new-label)))
      (if (not (unsafe-code))
	  (begin
	    (sparc.andi as $r.result $tag.tagmask $r.tmp0) ; mask argument tag
	    (sparc.cmpi as $r.tmp0 $tag.vector-tag); vector-like? 
	    (sparc.bne as Lfinish)		   ; skip if not vector-like
	    (sparc.nop as)
	    (sparc.ldbi as $r.RESULT 0 $r.tmp1)))   ; header byte
      (sparc.ldi  as $r.RESULT 1 $r.tmp2)	    ; port.input? or garbage
      (if (not (unsafe-code))
	  (begin
	    (sparc.cmpi as $r.tmp1 $hdr.port)       ; port?
	    (sparc.bne as Lfinish)))		    ; skip if not port
      (sparc.cmpi as $r.tmp2 $imm.false)  	    ; [slot] input port?
      (sparc.be as Lfinish)			    ; skip if not active port
      (sparc.ldi as $r.RESULT (+ 1 32) $r.tmp1)	    ; [slot] port.rd-ptr 
      (sparc.ldi as $r.RESULT (+ 1 28) $r.tmp2)	    ; port.rd-lim
      (sparc.ldi as $r.RESULT (+ 1 16) $r.tmp0)	    ; port.buffer
      (sparc.cmpr as $r.tmp1 $r.tmp2)		    ; rd-ptr < rd-lim?
      (sparc.bge as Lfinish)			    ; skip if rd-ptr >= rd-lim
      (sparc.subi as $r.tmp0 1 $r.tmp0)		    ; [slot] addr of string@0
      (sparc.srai as $r.tmp1 2 $r.tmp2)		    ; rd-ptr as native int
      (sparc.ldbr as $r.tmp0 $r.tmp2 $r.tmp2)	    ; get byte from string
      (sparc.addi as $r.tmp1 4 $r.tmp1)		    ; bump rd-ptr
      (sparc.sti as $r.tmp1 (+ 1 32) $r.RESULT)	    ; store rd-ptr in port
      (sparc.slli as $r.tmp2 16 $r.tmp2)	    ; convert to char #1
      (sparc.b as Lend)
      (sparc.ori as $r.tmp2 $imm.character $r.RESULT) ; [slot] convert to char
      (sparc.label as Lfinish)
      (sparc.set as $imm.false $r.RESULT)	    ; failed
      (sparc.label as Lend))))


; eof
; Copyright 1998 Lars T Hansen.
; 
; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
;
; 9 May 1999 / wdc
;
; SPARC code generation macros for primitives, part 2:
;   primitives introduced by peephole optimization.

(define-primop 'internal:car
  (lambda (as src1 dest)
    (internal-primop-invariant2 'internal:car src1 dest)
    (if (not (unsafe-code))
	(emit-single-tagcheck-assert-reg! as
					  $tag.pair-tag src1 #f $ex.car))
    (sparc.ldi as src1 (- $tag.pair-tag) dest)))

(define-primop 'internal:cdr
  (lambda (as src1 dest)
    (internal-primop-invariant2 'internal:cdr src1 dest)
    (if (not (unsafe-code))
	(emit-single-tagcheck-assert-reg! as
					  $tag.pair-tag src1 #f $ex.cdr))
    (sparc.ldi as src1 (- 4 $tag.pair-tag) dest)))

(define-primop 'internal:cell-ref
  (lambda (as src1 dest)
    (internal-primop-invariant2 'internal:cell-ref src1 dest)
    (sparc.ldi as src1 (- $tag.pair-tag) dest)))

(define-primop 'internal:set-car!
  (lambda (as rs1 rs2 dest-ignored)
    (internal-primop-invariant2 'internal:set-car! rs1 dest-ignored)
    (if (not (unsafe-code))
	(emit-single-tagcheck-assert-reg! as $tag.pair-tag rs1 rs2 $ex.car))
    (emit-setcar/setcdr! as rs1 rs2 0)))

(define-primop 'internal:set-cdr!
  (lambda (as rs1 rs2 dest-ignored)
    (internal-primop-invariant2 'internal:set-cdr! rs1 dest-ignored)
    (if (not (unsafe-code))
	(emit-single-tagcheck-assert-reg! as $tag.pair-tag rs1 rs2 $ex.cdr))
    (emit-setcar/setcdr! as rs1 rs2 4)))

(define-primop 'internal:cell-set!
  (lambda (as rs1 rs2 dest-ignored)
    (internal-primop-invariant2 'internal:cell-set! rs1 dest-ignored)
    (emit-setcar/setcdr! as rs1 rs2 0)))

; CONS
;
; One instruction reduced here translates into about 2.5KB reduction in the
; size of the basic heap image. :-)
;
; In the out-of-line case, if rd != RESULT then a garbage value is left 
; in RESULT, but it always looks like a fixnum, so it's OK.

(define-primop 'internal:cons
  (lambda (as rs1 rs2 rd)
    (if (inline-allocation)
	(let ((ENOUGH-MEMORY (new-label))
	      (START (new-label)))
	  (sparc.label   as START)
	  (sparc.addi    as $r.e-top 8 $r.e-top)
	  (sparc.cmpr    as $r.e-top $r.e-limit)
	  (sparc.ble.a   as ENOUGH-MEMORY)
	  (sparc.sti     as rs1 -8 $r.e-top)
	  (millicode-call/ret as $m.gc START)
	  (sparc.label   as ENOUGH-MEMORY)
	  (sparc.sti     as (force-hwreg! as rs2 $r.tmp0) -4 $r.e-top)
	  (sparc.subi    as $r.e-top (- 8 $tag.pair-tag) rd))
	(begin
	  (if (= rs1 $r.result)
	      (sparc.move as $r.result $r.argreg2))
	  (millicode-call/numarg-in-result as $m.alloc 8)
	  (if (= rs1 $r.result)
	      (sparc.sti as $r.argreg2 0 $r.result)
	      (sparc.sti as rs1 0 $r.result))
	  (sparc.sti as (force-hwreg! as rs2 $r.tmp1) 4 $r.result)
	  (sparc.addi as $r.result $tag.pair-tag rd)))))

(define-primop 'internal:car:pair
  (lambda (as src1 dest)
    (internal-primop-invariant2 'internal:car src1 dest)
    (sparc.ldi as src1 (- $tag.pair-tag) dest)))

(define-primop 'internal:cdr:pair
  (lambda (as src1 dest)
    (internal-primop-invariant2 'internal:cdr src1 dest)
    (sparc.ldi as src1 (- 4 $tag.pair-tag) dest)))

; Vector operations.

(define-primop 'internal:vector-length
  (lambda (as rs rd)
    (internal-primop-invariant2 'internal:vector-length rs rd)
    (emit-get-length! as
		      $tag.vector-tag
		      (+ $imm.vector-header $tag.vector-typetag)
		      $ex.vlen
		      rs
		      rd)))

(define-primop 'internal:vector-ref
  (lambda (as rs1 rs2 rd)
    (internal-primop-invariant2 'internal:vector-ref rs1 rd)
    (let ((fault (if (not (unsafe-code))
		     (emit-double-tagcheck-assert-reg/reg!
		      as
		      $tag.vector-tag
		      (+ $imm.vector-header $tag.vector-typetag)
		      rs1 
		      rs2
		      $ex.vref))))
      (emit-vector-like-ref! as rs1 rs2 rd fault $tag.vector-tag #t))))

(define-primop 'internal:vector-ref/imm
  (lambda (as rs1 imm rd)
    (internal-primop-invariant2 'internal:vector-ref/imm rs1 rd)
    (let ((fault (if (not (unsafe-code))
		     (emit-double-tagcheck-assert-reg/imm!
		      as
		      $tag.vector-tag
		      (+ $imm.vector-header $tag.vector-typetag)
		      rs1 
		      imm
		      $ex.vref))))
      (emit-vector-like-ref/imm! as rs1 imm rd fault $tag.vector-tag #t))))

(define-primop 'internal:vector-set!
  (lambda (as rs1 rs2 rs3)
    (internal-primop-invariant1 'internal:vector-set! rs1)
    (let ((fault (if (not (unsafe-code))
		     (emit-double-tagcheck-assert-reg/reg!
		      as
		      $tag.vector-tag
		      (+ $imm.vector-header $tag.vector-typetag)
		      rs1
		      rs2
		      $ex.vset))))
      (emit-vector-like-set! as rs1 rs2 rs3 fault $tag.vector-tag #t))))

(define-primop 'internal:vector-length:vec
  (lambda (as rs1 dst)
    (internal-primop-invariant2 'internal:vector-length:vec rs1 dst)
    (emit-get-length-trusted! as $tag.vector-tag rs1 dst)))

(define-primop 'internal:vector-ref:trusted
  (lambda (as rs1 rs2 dst)
    (emit-vector-like-ref-trusted! as rs1 rs2 dst $tag.vector-tag)))

(define-primop 'internal:vector-set!:trusted
  (lambda (as rs1 rs2 rs3)
    (emit-vector-like-ref-trusted! as rs1 rs2 rs3 $tag.vector-tag)))

; Strings.

(define-primop 'internal:string-length
  (lambda (as rs rd)
    (internal-primop-invariant2 'internal:string-length rs rd)
    (emit-get-length! as
		      $tag.bytevector-tag
		      (+ $imm.bytevector-header $tag.string-typetag)
		      $ex.slen
		      rs
		      rd)))

(define-primop 'internal:string-ref
  (lambda (as rs1 rs2 rd)
    (internal-primop-invariant2 'internal:string-ref rs1 rd)
    (let ((fault (if (not (unsafe-code))
		     (emit-double-tagcheck-assert-reg/reg!
		      as
		      $tag.bytevector-tag
		      (+ $imm.bytevector-header $tag.string-typetag)
		      rs1 
		      rs2
		      $ex.sref))))
      (emit-bytevector-like-ref! as rs1 rs2 rd fault #t #t))))

(define-primop 'internal:string-ref/imm
  (lambda (as rs1 imm rd)
    (internal-primop-invariant2 'internal:string-ref/imm rs1 rd)
    (let ((fault (if (not (unsafe-code))
		     (emit-double-tagcheck-assert-reg/imm!
		      as
		      $tag.bytevector-tag
		      (+ $imm.bytevector-header $tag.string-typetag)
		      rs1 
		      imm
		      $ex.sref))))
      (emit-bytevector-like-ref/imm! as rs1 imm rd fault #t #t))))

(define-primop 'internal:string-set!
  (lambda (as rs1 rs2 rs3)
    (internal-primop-invariant1 'internal:string-set! rs1)
      (emit-string-set! as rs1 rs2 rs3)))

(define-primop 'internal:+
  (lambda (as src1 src2 dest)
    (internal-primop-invariant2 'internal:+ src1 dest)
    (emit-arith-primop! as sparc.taddrcc sparc.subr $m.add src1 src2 dest #t)))

(define-primop 'internal:+/imm
  (lambda (as src1 imm dest)
    (internal-primop-invariant2 'internal:+/imm src1 dest)
    (emit-arith-primop! as sparc.taddicc sparc.subi $m.add src1 imm dest #f)))

(define-primop 'internal:-
  (lambda (as src1 src2 dest)
    (internal-primop-invariant2 'internal:- src1 dest)
    (emit-arith-primop! as sparc.tsubrcc sparc.addr $m.subtract 
			src1 src2 dest #t)))

(define-primop 'internal:-/imm
  (lambda (as src1 imm dest)
    (internal-primop-invariant2 'internal:-/imm src1 dest)
    (emit-arith-primop! as sparc.tsubicc sparc.addi $m.subtract
			src1 imm dest #f)))

(define-primop 'internal:--
  (lambda (as rs rd)
    (internal-primop-invariant2 'internal:-- rs rd)
    (emit-negate as rs rd)))

(define-primop 'internal:branchf-null?
  (lambda (as reg label)
    (internal-primop-invariant1 'internal:branchf-null? reg)
    (sparc.cmpi  as reg $imm.null)
    (sparc.bne.a as label)
    (sparc.slot  as)))

(define-primop 'internal:branchf-pair?
  (lambda (as reg label)
    (internal-primop-invariant1 'internal:branchf-pair? reg)
    (sparc.andi  as reg $tag.tagmask $r.tmp0)
    (sparc.cmpi  as $r.tmp0 $tag.pair-tag)
    (sparc.bne.a as label)
    (sparc.slot  as)))

(define-primop 'internal:branchf-zero?
  (lambda (as reg label)
    (internal-primop-invariant1 'internal:brancf-zero? reg)
    (emit-bcmp-primop! as sparc.bne.a reg $r.g0 label $m.zerop #t)))

(define-primop 'internal:branchf-eof-object?
  (lambda (as rs label)
    (internal-primop-invariant1 'internal:branchf-eof-object? rs)
    (sparc.cmpi  as rs $imm.eof)
    (sparc.bne.a as label)
    (sparc.slot  as)))

(define-primop 'internal:branchf-fixnum?
  (lambda (as rs label)
    (internal-primop-invariant1 'internal:branchf-fixnum? rs)
    (sparc.btsti as rs 3)
    (sparc.bne.a as label)
    (sparc.slot  as)))

(define-primop 'internal:branchf-char?
  (lambda (as rs label)
    (internal-primop-invariant1 'internal:branchf-char? rs)
    (sparc.andi  as rs 255 $r.tmp0)
    (sparc.cmpi  as $r.tmp0 $imm.character)
    (sparc.bne.a as label)
    (sparc.slot  as)))

(define-primop 'internal:branchf-=
  (lambda (as src1 src2 label)
    (internal-primop-invariant1 'internal:branchf-= src1)
    (emit-bcmp-primop! as sparc.bne.a src1 src2 label $m.numeq #t)))

(define-primop 'internal:branchf-<
  (lambda (as src1 src2 label)
    (internal-primop-invariant1 'internal:branchf-< src1)
    (emit-bcmp-primop! as sparc.bge.a src1 src2 label $m.numlt #t)))

(define-primop 'internal:branchf-<=
  (lambda (as src1 src2 label)
    (internal-primop-invariant1 'internal:branchf-<= src1)
    (emit-bcmp-primop! as sparc.bg.a src1 src2 label $m.numle #t)))

(define-primop 'internal:branchf->
  (lambda (as src1 src2 label)
    (internal-primop-invariant1 'internal:branchf-> src1)
    (emit-bcmp-primop! as sparc.ble.a src1 src2 label $m.numgt #t)))

(define-primop 'internal:branchf->=
  (lambda (as src1 src2 label)
    (internal-primop-invariant1 'internal:branchf->= src1)
    (emit-bcmp-primop! as sparc.bl.a src1 src2 label $m.numge #t)))

(define-primop 'internal:branchf-=/imm
  (lambda (as src1 imm label)
    (internal-primop-invariant1 'internal:branchf-=/imm src1)
    (emit-bcmp-primop! as sparc.bne.a src1 imm label $m.numeq #f)))

(define-primop 'internal:branchf-</imm
  (lambda (as src1 imm label)
    (internal-primop-invariant1 'internal:branchf-</imm src1)
    (emit-bcmp-primop! as sparc.bge.a src1 imm label $m.numlt #f)))

(define-primop 'internal:branchf-<=/imm
  (lambda (as src1 imm label)
    (internal-primop-invariant1 'internal:branchf-<=/imm src1)
    (emit-bcmp-primop! as sparc.bg.a src1 imm label $m.numle #f)))

(define-primop 'internal:branchf->/imm
  (lambda (as src1 imm label)
    (internal-primop-invariant1 'internal:branchf->/imm src1)
    (emit-bcmp-primop! as sparc.ble.a src1 imm label $m.numgt #f)))

(define-primop 'internal:branchf->=/imm
  (lambda (as src1 imm label)
    (internal-primop-invariant1 'internal:branchf->=/imm src1)
    (emit-bcmp-primop! as sparc.bl.a src1 imm label $m.numge #f)))

(define-primop 'internal:branchf-char=?
  (lambda (as src1 src2 label)
    (internal-primop-invariant1 'internal:branchf-char=? src1)
    (emit-char-bcmp-primop! as sparc.bne.a src1 src2 label $ex.char=?)))

(define-primop 'internal:branchf-char<=?
  (lambda (as src1 src2 label)
    (internal-primop-invariant1 'internal:branchf-char<=? src1)
    (emit-char-bcmp-primop! as sparc.bg.a src1 src2 label $ex.char<=?)))

(define-primop 'internal:branchf-char<?
  (lambda (as src1 src2 label)
    (internal-primop-invariant1 'internal:branchf-char<? src1)
    (emit-char-bcmp-primop! as sparc.bge.a src1 src2 label $ex.char<?)))

(define-primop 'internal:branchf-char>=?
  (lambda (as src1 src2 label)
    (internal-primop-invariant1 'internal:branchf-char>=? src1)
    (emit-char-bcmp-primop! as sparc.bl.a src1 src2 label $ex.char>=?)))

(define-primop 'internal:branchf-char>?
  (lambda (as src1 src2 label)
    (internal-primop-invariant1 'internal:branchf-char>=? src1)
    (emit-char-bcmp-primop! as sparc.ble.a src1 src2 label $ex.char>?)))

(define-primop 'internal:branchf-char=?/imm
  (lambda (as src imm label)
    (internal-primop-invariant1 'internal:branchf-char=?/imm src)
    (emit-char-bcmp-primop! as sparc.bne.a src imm label $ex.char=?)))

(define-primop 'internal:branchf-char>=?/imm
  (lambda (as src imm label)
    (internal-primop-invariant1 'internal:branchf-char>=?/imm src)
    (emit-char-bcmp-primop! as sparc.bl.a src imm label $ex.char>=?)))

(define-primop 'internal:branchf-char>?/imm
  (lambda (as src imm label)
    (internal-primop-invariant1 'internal:branchf-char>?/imm src)
    (emit-char-bcmp-primop! as sparc.ble.a src imm label $ex.char>?)))

(define-primop 'internal:branchf-char<=?/imm
  (lambda (as src imm label)
    (internal-primop-invariant1 'internal:branchf-char<=?/imm src)
    (emit-char-bcmp-primop! as sparc.bg.a src imm label $ex.char<=?)))

(define-primop 'internal:branchf-char<?/imm
  (lambda (as src imm label)
    (internal-primop-invariant1 'internal:branchf-char<?/imm src)
    (emit-char-bcmp-primop! as sparc.bge.a src imm label $ex.char<?)))

(define-primop 'internal:eq?
  (lambda (as src1 src2 dest)
    (internal-primop-invariant2 'internal:eq? src1 dest)
    (let ((tmp (force-hwreg! as src2 $r.tmp0)))
      (sparc.cmpr as src1 tmp)
      (emit-set-boolean-reg! as dest))))

(define-primop 'internal:eq?/imm
  (lambda (as rs imm rd)
    (internal-primop-invariant2 'internal:eq?/imm rs rd)
    (cond ((fixnum? imm) (sparc.cmpi as rs (thefixnum imm)))
	  ((eq? imm #t)  (sparc.cmpi as rs $imm.true))
	  ((eq? imm #f)  (sparc.cmpi as rs $imm.false))
	  ((null? imm)   (sparc.cmpi as rs $imm.null))
	  (else ???))
    (emit-set-boolean-reg! as rd)))

(define-primop 'internal:branchf-eq?
  (lambda (as src1 src2 label)
    (internal-primop-invariant1 'internal:branchf-eq? src1)
    (let ((src2 (force-hwreg! as src2 $r.tmp0)))
      (sparc.cmpr  as src1 src2)
      (sparc.bne.a as label)
      (sparc.slot  as))))

(define-primop 'internal:branchf-eq?/imm
  (lambda (as rs imm label)
    (internal-primop-invariant1 'internal:branchf-eq?/imm rs)
    (cond ((fixnum? imm) (sparc.cmpi as rs (thefixnum imm)))
	  ((eq? imm #t)  (sparc.cmpi as rs $imm.true))
	  ((eq? imm #f)  (sparc.cmpi as rs $imm.false))
	  ((null? imm)   (sparc.cmpi as rs $imm.null))
	  (else ???))
    (sparc.bne.a as label)
    (sparc.slot  as)))

; Unary predicates followed by a check.

(define-primop 'internal:check-fixnum?
  (lambda (as src L1 liveregs)
    (sparc.btsti   as src 3)
    (emit-checkcc! as sparc.bne L1 liveregs)))

(define-primop 'internal:check-pair?
  (lambda (as src L1 liveregs)
    (sparc.andi    as src $tag.tagmask $r.tmp0)
    (sparc.cmpi    as $r.tmp0 $tag.pair-tag)
    (emit-checkcc! as sparc.bne L1 liveregs)))

(define-primop 'internal:check-vector?
  (lambda (as src L1 liveregs)
    (sparc.andi    as src $tag.tagmask $r.tmp0)
    (sparc.cmpi    as $r.tmp0 $tag.vector-tag)
    (sparc.bne     as L1)
    (sparc.nop     as)
    (sparc.ldi     as src (- $tag.vector-tag) $r.tmp0)
    (sparc.andi    as $r.tmp0 255 $r.tmp1)
    (sparc.cmpi    as $r.tmp1 $imm.vector-header)
    (emit-checkcc! as sparc.bne L1 liveregs)))

(define-primop 'internal:check-vector?/vector-length:vec
  (lambda (as src dst L1 liveregs)
    (sparc.andi    as src     $tag.tagmask        $r.tmp0)
    (sparc.cmpi    as $r.tmp0 $tag.vector-tag)
    (sparc.bne     as L1)
    (sparc.nop     as)
    (sparc.ldi     as src     (- $tag.vector-tag) $r.tmp0)
    (sparc.andi    as $r.tmp0 255                 $r.tmp1)
    (sparc.cmpi    as $r.tmp1 $imm.vector-header)
    (sparc.bne     as L1)
    (apply sparc.slot2 as liveregs)
    (sparc.srli    as $r.tmp0 8 dst)))

(define (internal-primop-invariant2 name a b)
    (if (not (and (hardware-mapped? a) (hardware-mapped? b)))
	(asm-error "SPARC assembler internal invariant violated by " name
		   " on operands " a " and " b)))

(define (internal-primop-invariant1 name a)
    (if (not (hardware-mapped? a))
	(asm-error "SPARC assembler internal invariant violated by " name
		   " on operand " a)))

; eof
; Copyright 1998 Lars T Hansen.
;
; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
;
; SPARC code generation macros for primitives, part 3a:
;   helper procedures for scalars.


; LOGAND, LOGIOR, LOGXOR: logical operations on fixnums.
;
; Input:  Registers rs1 and rs2, both of which can be general registers.
;         In addition, rs1 can be RESULT, and rs2 can be ARGREG2.
; Output: Register dest, which can be a general register or RESULT.

(define (logical-op as rs1 rs2 dest op excode)

  (define (fail rs1 rs2 L0)
    (if (not (= rs1 $r.result))  (sparc.move as rs1 $r.result))
    (if (not (= rs2 $r.argreg2)) (sparc.move as rs2 $r.argreg2))
    (sparc.set as (thefixnum excode) $r.tmp0)
    (millicode-call/ret as $m.exception L0))

  (let ((L0  (new-label))
        (L1  (new-label)))
    (sparc.label     as L0)
    (let ((rs1 (force-hwreg! as rs1 $r.result))
          (rs2 (force-hwreg! as rs2 $r.argreg2))
          (u   (unsafe-code))
          (d   (hardware-mapped? dest)))
      (cond ((and u d)
             (op as rs1 rs2 dest))
            ((and u (not d))
             (op as rs1 rs2 $r.tmp0)
             (emit-store-reg! as $r.tmp0 dest))
            ((and (not u) d)
             (sparc.orr     as rs1 rs2 $r.tmp0)
             (sparc.btsti   as $r.tmp0 3)
             (sparc.bz.a    as L1)
             (op            as rs1 rs2 dest)
             (fail rs1 rs2 L0)
             (sparc.label   as L1))
            (else
             (sparc.orr     as rs1 rs2 $r.tmp0)
             (sparc.btsti   as $r.tmp0 3)
             (sparc.bz.a    as L1)
             (op            as rs1 rs2 $r.tmp0)
             (fail rs1 rs2 L0)
             (sparc.label   as L1)
             (emit-store-reg! as $r.tmp0 dest))))))


; LSH, RSHA, RSHL: Bitwise shifts on fixnums.
;
; Notes for future contemplation:
;   - The semantics do not match those of MIT Scheme or MacScheme: only 
;     positive shifts are allowed.
;   - The names do not match the fixnum-specific procedures of Chez Scheme
;     that have the same semantics: fxsll, fxsra, fxsrl.
;   - This code checks that the second argument is in range; if it did
;     not, then we could get a MOD for free.  Probably too hardware-dependent
;     to worry about.
;   - The range 0..31 for the shift count is curious given that the fixnum
;     is 30-bit.

(define (emit-shift-operation as exn rs1 rs2 rd)
  (let ((rs2 (force-hwreg! as rs2 $r.argreg2)))
    (if (not (unsafe-code))
        (let ((L0 (new-label))
              (FAULT (new-label))
              (START (new-label)))
          (sparc.label as START)
          (sparc.btsti as rs1 3)          ; RS1 fixnum?
          (sparc.be.a  as L0)
          (sparc.andi  as rs2 #x7c $r.g0) ; RS2 fixnum and 0 <= RS2 < 32?
          (sparc.label as FAULT)
          (if (not (= rs1 $r.result))
              (sparc.move as rs1 $r.result))
          (if (not (= rs2 $r.argreg2))
              (emit-move2hwreg! as rs2 $r.argreg2))
          (sparc.set   as (thefixnum exn) $r.tmp0)
          (millicode-call/ret as $m.exception START)
          (sparc.label as L0)
          (sparc.bne   as FAULT)
          (sparc.srai  as rs2 2 $r.tmp1))
        (begin
          (sparc.srai  as rs2 2 $r.tmp1)))
    (cond ((= exn $ex.lsh)
           (sparc.sllr as rs1 $r.tmp1 rd))
          ((= exn $ex.rshl)
           (sparc.srlr  as rs1 $r.tmp1 rd)
           (sparc.andni as rd 3 rd))
          ((= exn $ex.rsha)
           (sparc.srar  as rs1 $r.tmp1 rd)
           (sparc.andni as rd 3 rd))
          (else ???))))


; Set result on condition code.
;
; The processor's zero bit has been affected by a previous instruction.
; If the bit is set, store #t in RESULT, otherwise store #f in RESULT.

(define (emit-set-boolean! as)
  (emit-set-boolean-reg! as $r.result))


; Set on condition code.
;
; The processor's zero bit has been affected by a previous instruction.
; If the bit is set, store #t in the processor register 'dest', otherwise
; store #f in 'dest'.

(define (emit-set-boolean-reg! as dest)
  (let ((L1 (new-label)))
    (sparc.set   as $imm.true dest)
    (sparc.bne.a as L1)
    (sparc.set   as $imm.false dest)
    (sparc.label as L1)))


; Representation predicate.

(define (emit-single-tagcheck->bool! as tag)
  (sparc.andi as $r.result $tag.tagmask $r.tmp0)
  (sparc.cmpi as $r.tmp0 tag)
  (emit-set-boolean! as))

(define (emit-single-tagcheck-assert! as tag1 excode reg2)
  (emit-single-tagcheck-assert-reg! as tag1 $r.result reg2 excode))

(define (emit-single-tagcheck-assert-reg! as tag1 reg reg2 excode)
  (let ((L0    (new-label))
        (L1    (new-label))
        (FAULT (new-label)))
    (sparc.label as L0)
    (sparc.andi  as reg $tag.tagmask $r.tmp0)
    (sparc.cmpi  as $r.tmp0 tag1)
    (fault-if-ne as excode #f #f reg reg2 L0)))

; Assert that a machine register has a fixnum in it.
; Returns the label of the fault code.

(define (emit-assert-fixnum! as reg excode)
  (let ((L0    (new-label))
        (L1    (new-label))
        (FAULT (new-label)))
    (sparc.label  as L0)
    (sparc.btsti  as reg 3)
    (fault-if-ne as excode #f #f reg #f L0)))

; Assert that RESULT has a character in it.
; Returns the label of the fault code.

(define (emit-assert-char! as excode fault-label)
  (let ((L0    (new-label))
        (L1    (new-label))
        (FAULT (new-label)))
    (sparc.label as L0)
    (sparc.andi  as $r.result #xFF $r.tmp0)
    (sparc.cmpi  as $r.tmp0 $imm.character)
    (fault-if-ne as excode #f fault-label #f #f L0)))

; Generate code for fault handling if the zero flag is not set.
; - excode is the nativeint exception code.
; - cont-label, if not #f, is the label to go to if there is no fault.
; - fault-label, if not #f, is the label of an existing fault handler.
; - reg1, if not #f, is the number of a register which must be
;   moved into RESULT before the fault handler is called.
; - reg2, if not #f, is the number of a register which must be moved
;   into ARGREG2 before the fault handler is called.
; - ret-label, if not #f, is the return address to be set up before calling
;   the fault handler.
;
; Ret-label and fault-label cannot simultaneously be non-#f; in this case
; the ret-label is ignored (since the existing fault handler most likely
; sets up the return in the desired manner).

(define (fault-if-ne as excode cont-label fault-label reg1 reg2 ret-label)
  (if fault-label
      (begin 
        (if (and reg2 (not (= reg2 $r.argreg2)))
            (emit-move2hwreg! as reg2 $r.argreg2))
        (sparc.bne as fault-label)
        (if (and reg1 (not (= reg1 $r.result)))
            (sparc.move as reg1 $r.result)
            (sparc.nop as))
        fault-label)
      (let ((FAULT (new-label))
            (L1    (new-label)))
        (sparc.be.a  as (or cont-label L1))
        (sparc.slot  as)
        (sparc.label as FAULT)
        (if (and reg1 (not (= reg1 $r.result)))
            (sparc.move as reg1 $r.result))
        (if (and reg2 (not (= reg2 $r.argreg2)))
            (emit-move2hwreg! as reg2 $r.argreg2))
        (sparc.set   as (thefixnum excode) $r.tmp0)
        (millicode-call/ret as $m.exception (or ret-label L1))
        (if (or (not cont-label) (not ret-label))
            (sparc.label as L1))
        FAULT)))

; This is more expensive than what is good for it (5 cycles in the usual case),
; but there does not seem to be a better way.

(define (emit-assert-positive-fixnum! as reg excode)
  (let ((L1 (new-label))
        (L2 (new-label))
        (L3 (new-label))) 
    (sparc.label   as L2)
    (sparc.tsubrcc as reg $r.g0 $r.g0)
    (sparc.bvc     as L1)
    (sparc.nop     as)
    (sparc.label   as L3)
    (if (not (= reg $r.result))
        (sparc.move as reg $r.result))
    (sparc.set     as (thefixnum excode) $r.tmp0)
    (millicode-call/ret as $m.exception l2)
    (sparc.label   as L1)
    (sparc.bl      as L3)
    (sparc.nop     as)
    L3))


; Arithmetic comparison with boolean result.

(define (emit-cmp-primop! as branch_t.a generic r)
  (let ((Ltagok (new-label))
        (Lcont  (new-label))
        (r      (force-hwreg! as r $r.argreg2)))
    (sparc.tsubrcc as $r.result r $r.g0)
    (sparc.bvc.a   as Ltagok)
    (sparc.set     as $imm.false $r.result)
    (if (not (= r $r.argreg2))
        (sparc.move    as r $r.argreg2))
    (millicode-call/ret as generic Lcont)
    (sparc.label   as Ltagok)
    (branch_t.a    as Lcont)
    (sparc.set     as $imm.true $r.result)
    (sparc.label   as Lcont)))


; Arithmetic comparison and branch.
;
; This code does not use the chained branch trick (DCTI) that was documented
; in the Sparc v8 manual and deprecated in the v9 manual.  This code executes
; _much_ faster on the Ultra than the code using DCTI, even though it executes
; the same instructions.
;
; Parameters and preconditions.
;   Src1 is a general register, RESULT, ARGREG2, or ARGREG3.
;   Src2 is a general register, RESULT, ARGREG2, ARGREG3, or an immediate.
;   Src2 is an immediate iff src2isreg = #f.
;   Branch_f.a is a branch on condition code that branches if the condition
;     is not true.
;   Generic is the millicode table offset of the generic procedure.

(define (emit-bcmp-primop! as branch_f.a src1 src2 Lfalse generic src2isreg)
  (let ((Ltagok (new-label))
        (Ltrue  (new-label))
        (op2    (if src2isreg
                    (force-hwreg! as src2 $r.tmp1)
                    (thefixnum src2)))
        (sub   (if src2isreg sparc.tsubrcc sparc.tsubicc))
        (mov   (if src2isreg sparc.move sparc.set)))
    (sub         as src1 op2 $r.g0)
    (sparc.bvc.a as Ltagok)
    (sparc.slot  as)

    ; Not both fixnums.
    ; Must move src1 to result if src1 is not result.
    ; Must move src2 to argreg2 if src2 is not argreg2.

    (let ((move-res  (not (= src1 $r.result)))
          (move-arg2 (or (not src2isreg) (not (= op2 $r.argreg2)))))
      (if (and move-arg2 move-res)
          (mov     as op2 $r.argreg2))
      (sparc.jmpli as $r.millicode generic $r.o7)
      (cond (move-res   (sparc.move as src1 $r.result))
            (move-arg2  (mov        as op2 $r.argreg2))
            (else       (sparc.nop  as)))
      (sparc.cmpi  as $r.result $imm.false)
      (sparc.bne.a as Ltrue)
      (sparc.slot  as)
      (sparc.b     as Lfalse)
      (sparc.slot  as))

    (sparc.label as Ltagok)
    (branch_f.a   as Lfalse)
    (sparc.slot  as)
    (sparc.label as Ltrue)))


; Generic arithmetic for + and -.
; Some rules:
;   We have two HW registers src1 and dest.
;   If src2isreg is #t then src2 may be a HW reg or a SW reg
;   If src2isreg is #f then src2 is an immediate fixnum, not shifted.
;   Src1 and dest may be RESULT, but src2 may not.
;   Src2 may be ARGREG2, the others may not.
;
; FIXME! This is incomprehensible.

; New code below.

'(define (emit-arith-primop! as op invop generic src1 src2 dest src2isreg)
  (let ((L1  (new-label))
        (op2 (if src2isreg
                 (force-hwreg! as src2 $r.tmp1)
                 (thefixnum src2))))
    (if (and src2isreg (= op2 dest))
        (begin (op          as src1 op2 $r.tmp0)
               (sparc.bvc.a as L1)
               (sparc.move  as $r.tmp0 dest))
        (begin (op          as src1 op2 dest)
               (sparc.bvc.a as L1)
               (sparc.slot  as)
               (invop       as dest op2 dest)))
    (let ((n    (+ (if (not (= src1 $r.result)) 1 0)
                   (if (or (not src2isreg) (not (= op2 $r.argreg2))) 1 0)))
          (mov2 (if src2isreg sparc.move sparc.set)))
      (if (= n 2)
          (mov2 as op2 $r.argreg2))
      (sparc.jmpli as $r.millicode generic $r.o7)
      (cond ((= n 0) (sparc.nop  as))
            ((= n 1) (mov2       as op2 $r.argreg2))
            (else    (sparc.move as src1 $r.result)))
      ; Generic arithmetic leaves stuff in RESULT, must move to dest if
      ; dest is not RESULT.
      (if (not (= dest $r.result))
          (sparc.move as $r.result dest))
      (sparc.label as L1))))

; Comprehensible, but longer.
;
; Important to be careful not to clobber arguments, and not to leave garbage
; in rd, if millicode is called.
;
; op is the appropriate operation.
; invop is the appropriate inverse operation.
; RS1 can be any general hw register or RESULT.
; RS2/IMM can be any general register or ARGREG2 (op2isreg=#t), or 
;         an immediate (op2isreg=#f)
; RD can be any general hw register or RESULT.
;
; FIXME: split this into two procedures.

(define (emit-arith-primop! as op invop generic rs1 rs2/imm rd op2isreg)
  (let ((L1 (new-label)))
    (if op2isreg
        (let ((rs2 (force-hwreg! as rs2/imm $r.argreg2)))
          (cond ((or (= rs1 rs2 rd)
                     (and (= rs2 rd)
                          (= generic $m.subtract)))
                 (op          as rs1 rs2 $r.tmp0)
                 (sparc.bvc.a as L1)
                 (sparc.move  as $r.tmp0 rd))
                ((= rs1 rd)
                 (op          as rs1 rs2 rs1)
                 (sparc.bvc.a as L1)
                 (sparc.slot  as)
                 (invop       as rs1 rs2 rs1))
                ((= rs2 rd)
                 (op          as rs1 rs2 rs2)
                 (sparc.bvc.a as L1)
                 (sparc.slot  as)
                 (invop       as rs2 rs1 rs2))
                (else
                 (op          as rs1 rs2 rd)
                 (sparc.bvc.a as L1)
                 (sparc.slot  as)
                 (if (and (not (= rd $r.result)) (not (= rd $r.argreg2)))
                     (sparc.clr as rd))))
          (cond ((and (= rs1 $r.result) (= rs2 $r.argreg2))
                 ;; Could peephole the INVOP or CLR into the slot here.
                 (millicode-call/0arg as generic))
                ((= rs1 $r.result)
                 (millicode-call/1arg as generic rs2))
                ((= rs2 $r.argreg2)
                 (millicode-call/1arg-in-result as generic rs1))
                (else
                 (sparc.move as rs2 $r.argreg2)
                 (millicode-call/1arg-in-result as generic rs1))))
        (let ((imm (thefixnum rs2/imm)))
          (op          as rs1 imm rd)
          (sparc.bvc.a as L1)
          (sparc.slot  as)
          (invop       as rd imm rd)
          (if (not (= rs1 $r.result))
              (sparc.move as rs1 $r.result))
          (millicode-call/numarg-in-reg as generic imm $r.argreg2)))
    (if (not (= rd $r.result))
        (sparc.move as $r.result rd))
    (sparc.label as L1)))


; Important to be careful not to leave garbage in rd if millicode is called.

(define (emit-negate as rs rd)
  (let ((L1 (new-label)))
    (cond ((= rs rd)
           (sparc.tsubrcc as $r.g0 rs rs)
           (sparc.bvc.a   as L1)
           (sparc.slot    as)
           (if (= rs $r.result)
               (begin 
                 (sparc.jmpli as $r.millicode $m.negate $r.o7)
                 (sparc.subr  as $r.g0 $r.result $r.result))
               (begin
                 (sparc.subr  as $r.g0 rs rs)
                 (sparc.jmpli as $r.millicode $m.negate $r.o7)
                 (sparc.move  as rs $r.result))))
          (else
           (sparc.tsubrcc as $r.g0 rs rd)
           (sparc.bvc.a   as L1)
           (sparc.slot    as)
           (cond ((= rs $r.result)
                  (sparc.jmpli as $r.millicode $m.negate $r.o7)
                  (sparc.clr   as rd))
                 ((= rd $r.result)
                  (sparc.jmpli as $r.millicode $m.negate $r.o7)
                  (sparc.move  as rs $r.result))
                 (else
                  (sparc.clr   as rd)
                  (sparc.jmpli as $r.millicode $m.negate $r.o7)
                  (sparc.move  as rs $r.result)))))
    (if (not (= rd $r.result))
        (sparc.move as $r.result rd))
    (sparc.label   as L1)))

; Character comparison.

; r is a register or a character constant.

(define (emit-char-cmp as r btrue.a excode)
  (emit-charcmp! as (lambda ()
                      (let ((l2 (new-label)))
                        (sparc.set   as $imm.false $r.result)
                        (btrue.a     as L2)
                        (sparc.set   as $imm.true $r.result)
                        (sparc.label as L2)))
                 $r.result
                 r
                 excode))
 
; op1 is a hw register
; op2 is a register or a character constant

(define (emit-char-bcmp-primop! as bfalse.a op1 op2 L0 excode)
  (emit-charcmp! as (lambda ()
                      (bfalse.a   as L0)
                      (sparc.slot as))
                 op1
                 op2
                 excode))

; We check the tags of both by xoring them and seeing if the low byte is 0.
; If so, then we can subtract one from the other (tag and all) and check the
; condition codes.  
;
; The branch-on-true instruction must have the annull bit set. (???)
;
; op1 is a hw register
; op2 is a register or a character constant.

(define (emit-charcmp! as tail op1 op2 excode)
  (let ((op2 (if (char? op2)
                 op2
                 (force-hwreg! as op2 $r.argreg2))))
    (cond ((not (unsafe-code))
           (let ((L0 (new-label))
                 (L1 (new-label))
                 (FAULT (new-label)))
             (sparc.label as L0)
             (cond ((char? op2)
                    (sparc.xori  as op1 $imm.character $r.tmp0)
                    (sparc.btsti as $r.tmp0 #xFF)
                    (sparc.srli  as op1 16 $r.tmp0)
                    (sparc.be.a  as L1)
                    (sparc.cmpi  as $r.tmp0 (char->integer op2)))
                   (else
                    (sparc.andi  as op1 #xFF $r.tmp0)
                    (sparc.andi  as op2 #xFF $r.tmp1)
                    (sparc.cmpr  as $r.tmp0 $r.tmp1)
                    (sparc.bne   as FAULT)
                    (sparc.cmpi  as $r.tmp0 $imm.character)
                    (sparc.be.a  as L1)
                    (sparc.cmpr  as op1 op2)))
             (sparc.label as FAULT)
             (if (not (eqv? op1 $r.result))
                 (sparc.move as op1 $r.result))
             (cond ((char? op2) 
                    (emit-immediate->register! as
                                               (char->immediate op2)
                                               $r.argreg2))
                   ((not (eqv? op2 $r.argreg2))
                    (sparc.move as op2 $r.argreg2)))
             (sparc.set   as (thefixnum excode) $r.tmp0)
             (millicode-call/ret as $m.exception L0)
             (sparc.label as L1)))
          ((not (char? op2))
           (sparc.cmpr as op1 op2))
          (else
           (sparc.srli as op1 16 $r.tmp0)
           (sparc.cmpi as $r.tmp0 (char->integer op2))))
    (tail)))

; eof
; Copyright 1998 Lars T Hansen.
;
; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
;
; SPARC code generation macros for primitives, part 3b:
;   helper procedures for data structures.


; SET-CAR!, SET-CDR!, CELL-SET!
;
; Input:  RS1: a hardware register; has pair pointer (tag check must be
;         performed by the caller).
;         RS2: any register; has value to store.
; Output: None.
;
; Having rs1 != RESULT is pretty silly with the current write barrier
; but will be less silly with the new barrier.

(define (emit-setcar/setcdr! as rs1 rs2 offs)
  (cond ((and (write-barrier) (hardware-mapped? rs2))
	 (sparc.sti as rs2 (- offs $tag.pair-tag) rs1)
         (if (not (= rs1 $r.result))
             (sparc.move as rs1 $r.result))
         (millicode-call/1arg as $m.addtrans rs2))
        ((write-barrier)
         (emit-move2hwreg! as rs2 $r.argreg2)
         (sparc.sti as $r.argreg2 (- offs $tag.pair-tag) rs1)
         (millicode-call/1arg-in-result as $m.addtrans rs1))
        ((hardware-mapped? rs2)
         (sparc.sti as rs2 (- offs $tag.pair-tag) rs1))
        (else
         (emit-move2hwreg! as rs2 $r.argreg2)
         (sparc.sti as $r.argreg2 (- offs $tag.pair-tag) rs1))))




; Representation predicate.
;
; RESULT has an object.  If the tag of RESULT is 'tag1' and the 
; header byte of the object is 'tag2' then set RESULT to #t, else
; set it to #f.

(define (emit-double-tagcheck->bool! as tag1 tag2)
  (let ((L1 (new-label)))
    (sparc.andi  as $r.result $tag.tagmask $r.tmp0)
    (sparc.cmpi  as $r.tmp0 tag1)
    (sparc.bne.a as L1)
    (sparc.set   as $imm.false $r.result)
    (sparc.ldbi  as $r.result (+ (- tag1) 3) $r.tmp0)
    (sparc.set   as $imm.true $r.result)
    (sparc.cmpi  as $r.tmp0 tag2)
    (sparc.bne.a as L1)
    (sparc.set   as $imm.false $r.result)
    (sparc.label as L1)))


; Check structure tag.
;
; RS1 has an object.  If the tag of RS1 is not 'tag1', or if the tag is 
; 'tag1' but the header byte of the object header is not 'tag2', then an
; exception with code 'excode' is signaled.  The exception call is set
; up to return to the first instruction of the emitted code.
;
; If RS1 is not RESULT then it is moved to RESULT before the exception 
; is signaled.
;
; If RS2/IMM is not #f, then it is a register or immediate that is moved
; to ARGREG2 before the exception is signaled; it is an immediate iff
; imm? = #t.  
;
; RS1 must be a hardware register.
; RS2/IMM is a general register, ARGREG2, an immediate, or #f.
; RS3 is a general register, ARGREG3, or #f.
;
; The procedure returns the label of the fault address.  If the execution
; falls off the end of the emitted instruction sequence, then the following
; are true:
;  - the tag of the object in RS1 was 'tag1' and its header byte was 'tag2'
;  - the object header word is in TMP0.

(define (double-tagcheck-assert as tag1 tag2 rs1 rs2/imm rs3 excode imm?)
  (let ((L0    (new-label))
        (L1    (new-label))
        (FAULT (new-label)))
    (sparc.label as L0)
    (sparc.andi  as rs1 $tag.tagmask $r.tmp0)
    (sparc.cmpi  as $r.tmp0 tag1)
    (sparc.be.a  as L1)
    (sparc.ldi   as rs1 (- tag1) $r.tmp0)
    (sparc.label as FAULT)
    (if (not (= rs1 $r.result))
        (sparc.move as rs1 $r.result))
    (if rs2/imm 
        (cond (imm?
               (sparc.set as (thefixnum rs2/imm) $r.argreg2))
              ((= rs2/imm $r.argreg2))
              (else
               (emit-move2hwreg! as rs2/imm $r.argreg2))))
    (if (and rs3 (not (= rs3 $r.argreg3)))
        (emit-move2hwreg! as rs3 $r.argreg3))
    (sparc.set   as (thefixnum excode) $r.tmp0)
    (millicode-call/ret as $m.exception L0)
    (sparc.label as L1)
    (sparc.andi  as $r.tmp0 255 $r.tmp1)
    (sparc.cmpi  as $r.tmp1 tag2)
    (sparc.bne.a as FAULT)
    (sparc.slot  as)
    FAULT))

(define (emit-double-tagcheck-assert! as tag1 tag2 excode reg2)
  (double-tagcheck-assert as tag1 tag2 $r.result reg2 #f excode #f))

(define (emit-double-tagcheck-assert-reg/reg! as tag1 tag2 rs1 rs2 excode)
  (double-tagcheck-assert as tag1 tag2 rs1 rs2 #f excode #f))
  
(define (emit-double-tagcheck-assert-reg/imm! as tag1 tag2 rs1 imm excode)
  (double-tagcheck-assert as tag1 tag2 rs1 imm #f excode #t))
  



; Get the length of a vector or bytevector structure, with tag checking
; included.
;
; Input: RS and RD are both hardware registers.

(define (emit-get-length! as tag1 tag2 excode rs rd)
  (if (not (unsafe-code))
      (if tag2
          (emit-double-tagcheck-assert-reg/reg! as tag1 tag2 rs rd excode)
          (emit-single-tagcheck-assert-reg! as tag1 rs rd excode)))
  (emit-get-length-trusted! as tag1 rs rd))

; Get the length of a vector or bytevector structure, without tag checking.
;
; Input: RS and RD are both hardware registers.

(define (emit-get-length-trusted! as tag1 rs rd)
  (sparc.ldi  as rs (- tag1) $r.tmp0)
  (sparc.srli as $r.tmp0 8 rd)
  (if (= tag1 $tag.bytevector-tag)
      (sparc.slli as rd 2 rd)))


; Allocate a bytevector, leave untagged pointer in RESULT.

(define (emit-allocate-bytevector as hdr preserved-result)

  ; Preserve the length field, then calculate the number of words
  ; to allocate.  The value `28' is an adjustment of 3 (for rounding 
  ; up) plus another 4 bytes for the header, all represented as a fixnum.

  (if (not preserved-result)
      (sparc.move as $r.result $r.argreg2))
  (sparc.addi as $r.result 28 $r.result)
  (sparc.andi as $r.result (asm:signed #xFFFFFFF0) $r.result)

  ; Allocate space

  (sparc.jmpli as $r.millicode $m.alloc-bv $r.o7)
  (sparc.srai  as $r.result 2 $r.result)
  
  ; Setup the header.

  (if (not preserved-result)
      (sparc.slli as $r.argreg2 6 $r.tmp0)
      (sparc.slli as preserved-result 6 $r.tmp0))
  (sparc.addi as $r.tmp0 hdr $r.tmp0)
  (sparc.sti  as $r.tmp0 0 $r.result))


; Given a nativeint count, a pointer to the first element of a 
; bytevector-like structure, and a byte value, fill the bytevector
; with the byte value.

(define (emit-bytevector-fill as r-bytecount r-pointer r-value)
  (let ((L2 (new-label))
        (L1 (new-label)))
    (sparc.label  as L2)
    (sparc.deccc  as r-bytecount)
    (sparc.bge.a  as L2)
    (sparc.stbr   as r-value r-bytecount r-pointer)
    (sparc.label  as L1)))


; BYTEVECTOR-REF, BYTEVECTOR-LIKE-REF, STRING-REF.
;
; The pointer in RS1 is known to be bytevector-like.  RS2 is the fixnum
; index into the structure.  Get the RS2'th element and place it in RD.
;
; RS1 and RD are hardware registers.
; RS2 is a general register or ARGREG2.
; 'fault' is defined iff (unsafe-code) = #f
; header is in TMP0 iff (unsafe-code) = #f and 'header-loaded?' = #t
; if 'charize?' is #t then store result as char, otherwise as fixnum.

(define (emit-bytevector-like-ref! as rs1 rs2 rd fault charize? header-loaded?)
  (let ((rs2 (force-hwreg! as rs2 $r.argreg2)))
    (if (not (unsafe-code))
        (begin
          ; check that index is fixnum
          (sparc.btsti  as rs2 3)
          (sparc.bne    as fault)
          (if (not header-loaded?)
              (sparc.ldi as rs1 (- $tag.bytevector-tag) $r.tmp0))
          ; check length
          (sparc.srai   as rs2 2 $r.tmp1)
          (sparc.srli   as $r.tmp0 8 $r.tmp0)
          (sparc.cmpr   as $r.tmp0 $r.tmp1)
          (sparc.bleu as fault)
          ; No NOP or SLOT -- the SUBI below goes into the slot.
          )
        (begin
          (sparc.srai   as rs2 2 $r.tmp1)))
    ; Pointer is in RS1.
    ; Shifted index is in TMP1.
    (sparc.addi as rs1 (- 4 $tag.bytevector-tag) $r.tmp0)
    (sparc.ldbr as $r.tmp0 $r.tmp1 $r.tmp0)
    (if (not charize?)
        (sparc.slli as $r.tmp0 2 rd)
        (begin (sparc.slli as $r.tmp0 16 rd)
               (sparc.ori  as rd $imm.character rd)))))

; As above, but RS2 is replaced by an immediate, IMM.
;
; The immediate, represented as a fixnum, is guaranteed fit in the 
; instruction's immediate field.

(define (emit-bytevector-like-ref/imm! as rs1 imm rd fault charize?
                                       header-loaded?)
  (if (not (unsafe-code))
      (begin
        (if (not header-loaded?)
            (sparc.ldi as rs1 (- $tag.bytevector-tag) $r.tmp0))
        ; Range check.
        (sparc.srli   as $r.tmp0 8 $r.tmp0)
        (sparc.cmpi   as $r.tmp0 imm)
        (sparc.bleu.a as fault)
        (sparc.slot   as)))

  ; Pointer is in RS1.

  (let ((adjusted-offset (+ (- 4 $tag.bytevector-tag) imm)))
    (if (immediate-literal? adjusted-offset)
        (begin
          (sparc.ldbi as rs1 adjusted-offset $r.tmp0))
        (begin
          (sparc.addi as rs1 (- 4 $tag.bytevector-tag) $r.tmp0)
          (sparc.ldbr as $r.tmp0 imm $r.tmp0)))
    (if (not charize?)
        (sparc.slli as $r.tmp0 2 rd)
        (begin (sparc.slli as $r.tmp0 16 rd)
               (sparc.ori  as rd $imm.character rd)))))


; BYTEVECTOR-SET!, BYTEVECTOR-LIKE-SET!
;
; Input:  RESULT -- a pointer to a bytevector-like structure.
;         TMP0   -- the header iff (unsafe-code) = #f and header-loaded? = #t
;         IDX    -- a register that holds the second argument
;         BYTE   -- a register that holds the third argument
; Output: Nothing.
;
; 'Fault' is the address of the error code iff (unsafe-code) = #f
;
; FIXME: 
;   - Argument values passed to error handler appear to be bogus 
;     (error message is very strange).
;   - There's no check that the value actually fits in a byte.
;   - Uses ARGREG3 and and TMP2.

(define (emit-bytevector-like-set! as idx byte fault header-loaded?)
  (let ((r1 (force-hwreg! as idx $r.tmp1))
        (r2 (force-hwreg! as byte $r.argreg3)))
    (if (not (unsafe-code))
        (begin
          (if (not header-loaded?)
              (sparc.ldi     as $r.result (- $tag.bytevector-tag) $r.tmp0))
          ; Both index and byte must be fixnums.  
          ; Can't use tsubcc because the computation may really overflow.
          (sparc.orr     as r1 r2 $r.tmp2)
          (sparc.btsti   as $r.tmp2 3)
          (sparc.bnz     as fault)
          ; No NOP -- next instruction is OK in slot.
          ; Index must be in range.
          (sparc.srli    as $r.tmp0 8 $r.tmp0)    ; limit - in slot
          (sparc.srai    as r1 2 $r.tmp1)         ; index
          (sparc.cmpr    as $r.tmp1 $r.tmp0)
          (sparc.bgeu    as fault)
          ; No NOP -- next instruction is OK in slot.
          )
        (begin
          (sparc.srai   as r1 2 $r.tmp1)))
    (sparc.srli as r2 2 $r.tmp0)
    ; Using ARGREG2 as the destination is OK because the resulting pointer
    ; value always looks like a fixnum.  By doing so, we avoid needing TMP2.
    (sparc.addi as $r.result (- 4 $tag.bytevector-tag) $r.argreg2)
    (sparc.stbr as $r.tmp0 $r.tmp1 $r.argreg2)))


; STRING-SET!

(define (emit-string-set! as rs1 rs2 rs3)
  (let* ((rs2 (force-hwreg! as rs2 $r.argreg2))
         (rs3 (force-hwreg! as rs3 $r.argreg3))
         (FAULT (if (not (unsafe-code))
                    (double-tagcheck-assert 
                     as 
                     $tag.bytevector-tag
                     (+ $imm.bytevector-header $tag.string-typetag)
                     rs1 rs2 rs3
                     $ex.sset
                     #f))))
    ; Header is in TMP0; TMP1 and TMP2 are free.
    (if (not (unsafe-code))
        (begin
          ; RS2 must be a fixnum.
          (sparc.btsti  as rs2 3)
          (sparc.bne    as FAULT)
          ; Index (in RS2) must be valid; header is in tmp0.
          (sparc.srli   as $r.tmp0 8 $r.tmp0) ; limit
          (sparc.srai   as rs2 2 $r.tmp1) ; index
          (sparc.cmpr   as $r.tmp1 $r.tmp0)
          (sparc.bgeu   as FAULT)
          ; RS3 must be a character.
          (sparc.andi   as rs3 #xFF $r.tmp0)
          (sparc.cmpi   as $r.tmp0 $imm.character)
          (sparc.bne    as FAULT)
          ; No NOP -- the SRLI below goes in the slot
          )
        (begin
          (sparc.srai as rs2 2 $r.tmp1)))
    ; tmp1 has nativeint index. 
    ; rs3/argreg3 has character.
    ; tmp0 is garbage.
    (sparc.subi as $r.tmp1 (- $tag.bytevector-tag 4) $r.tmp1)
    (sparc.srli as rs3 16 $r.tmp0)
    (sparc.stbr as $r.tmp0 rs1 $r.tmp1)))


; VECTORS and PROCEDURES

; Allocate short vectors of known length; faster than the general case.
; FIXME: can also allocate in-line.

(define (make-vector-n as length r)
  (sparc.jmpli as $r.millicode $m.alloc $r.o7)
  (sparc.set  as (thefixnum (+ length 1)) $r.result)
  (emit-immediate->register! as (+ (* 256 (thefixnum length))
                                   $imm.vector-header
                                   $tag.vector-typetag)
                             $r.tmp0)
  (sparc.sti  as $r.tmp0 0 $r.result)
  (let ((dest (force-hwreg! as r $r.argreg2)))
    (do ((i 0 (+ i 1)))
        ((= i length))
      (sparc.sti as dest (* (+ i 1) 4) $r.result)))
  (sparc.addi as $r.result $tag.vector-tag $r.result))


; emit-make-vector-like! assumes argreg3 is not destroyed by alloci.
; FIXME: bug: $ex.mkvl is not right if the operation is make-procedure
; or make-vector.

(define (emit-make-vector-like! as r hdr ptrtag)
  (let ((FAULT (emit-assert-positive-fixnum! as $r.result $ex.mkvl)))
    (sparc.move  as $r.result $r.argreg3)
    (sparc.addi  as $r.result 4 $r.result)
    (sparc.jmpli as $r.millicode $m.alloci $r.o7)
    (if (null? r)
        (sparc.set as $imm.null $r.argreg2)
        (emit-move2hwreg! as r $r.argreg2))
    (sparc.slli  as $r.argreg3 8 $r.tmp0)
    (sparc.addi  as $r.tmp0 hdr $r.tmp0)
    (sparc.sti   as $r.tmp0 0 $r.result)
    (sparc.addi  as $r.result ptrtag $r.result)))


; VECTOR-REF, VECTOR-LIKE-REF, PROCEDURE-REF
;
; FAULT is valid iff (unsafe-code) = #f
; Header is in TMP0 iff (unsafe-code) = #f and header-loaded? = #t.

(define (emit-vector-like-ref! as rs1 rs2 rd FAULT tag header-loaded?)
  (let ((index (force-hwreg! as rs2 $r.argreg2)))
    (if (not (unsafe-code))
        (begin
         (if (not header-loaded?)
             (sparc.ldi   as rs1 (- tag) $r.tmp0))
         ; Index must be fixnum.
         (sparc.btsti as index 3)
         (sparc.bne   as FAULT)
         ; Index must be within bounds.
         (sparc.srai  as $r.tmp0 8 $r.tmp0)
         (sparc.cmpr  as $r.tmp0 index)
         (sparc.bleu  as FAULT)
         ; No NOP; the following instruction is valid in the slot.
         ))
    (emit-vector-like-ref-trusted! as rs1 index rd tag)))

(define (emit-vector-like-ref-trusted! as rs1 rs2 rd tag)
  (let ((index (force-hwreg! as rs2 $r.argreg2)))
    (sparc.addi as rs1 (- 4 tag) $r.tmp0)
    (sparc.ldr  as $r.tmp0 index rd)))


; VECTOR-REF/IMM, VECTOR-LIKE-REF/IMM, PROCEDURE-REF/IMM
;
; 'rs1' is a hardware register containing a vectorish pointer (to a
;       vector-like or procedure).
; 'imm' is a fixnum s.t. (immediate-literal? imm) => #t.
; 'rd' is a hardware register.
; 'FAULT' is the label of the error code iff (unsafe-code) => #f
; 'tag' is the tag of the pointer in rs1.
; 'header-loaded?' is #t iff the structure header word is in $r.tmp0.

(define (emit-vector-like-ref/imm! as rs1 imm rd FAULT tag header-loaded?)
  (if (not (unsafe-code))
      (begin
        (if (not header-loaded?) (sparc.ldi as rs1 (- tag) $r.tmp0))
        ; Check bounds.
        (sparc.srai  as $r.tmp0 10 $r.tmp0)
        (sparc.cmpi  as $r.tmp0 imm)
        (sparc.bleu  as FAULT)
        (sparc.nop   as)))
  (emit-vector-like-ref/imm-trusted! as rs1 imm rd tag))

; 'rs1' is a hardware register containing a vectorish pointer (to a
;       vector-like or procedure).
; 'imm' is a fixnum s.t. (immediate-literal? imm) => #t.
; 'rd' is a hardware register.
; 'tag' is the tag of the pointer in rs1.

(define (emit-vector-like-ref/imm-trusted! as rs1 imm rd tag)
  (let* ((offset (* imm 4))                       ; words->bytes
         (adjusted-offset (+ (- 4 tag) offset)))
    (if (immediate-literal? adjusted-offset)
        (begin
          (sparc.ldi as rs1 adjusted-offset rd))
        (begin
          (sparc.addi as rs1 (- 4 tag) $r.tmp0)
          (sparc.ldi  as $r.tmp0 offset rd)))))



; VECTOR-SET!, VECTOR-LIKE-SET!, PROCEDURE-SET!
;
; It is assumed that the pointer in RESULT is valid. We must check the index
; in register x for validity and then perform the side effect (by calling
; millicode). The tag is the pointer tag to be adjusted for.
;
; The use of vector-set is ok even if it is a procedure.

; fault is valid iff (unsafe-code) = #f
; header is in tmp0 iff (unsafe-code) = #f and header-loaded? = #t

(define (emit-vector-like-set! as rs1 rs2 rs3 fault tag header-loaded?)
  (let ((rs2 (force-hwreg! as rs2 $r.tmp1))
        (rs3 (force-hwreg! as rs3 $r.argreg2)))
    (if (not (unsafe-code))
        (begin 
         (if (not header-loaded?)
             (sparc.ldi as $r.result (- tag) $r.tmp0))
         (sparc.btsti as rs2 3)
         (sparc.bne   as fault)
         (sparc.srai  as $r.tmp0 8 $r.tmp0)
         (sparc.cmpr  as $r.tmp0 rs2)
         (sparc.bleu  as fault)))
    (emit-vector-like-set-trusted! as rs1 rs2 rs3 tag)))

; rs1 must be a hardware register.
; tag is the pointer tag to be adjusted for.

(define (emit-vector-like-set-trusted! as rs1 rs2 rs3 tag)
  (let ((rs2 (force-hwreg! as rs2 $r.tmp1))
        (rs3 (force-hwreg! as rs3 $r.argreg2)))
    ;; The ADDR can go in the delay slot of a preceding BLEU.
    (sparc.addr as rs1 rs2 $r.tmp0)
    (cond ((not (write-barrier))
           (sparc.sti  as rs3 (- 4 tag) $r.tmp0))
          ((= rs1 $r.result)
           (cond ((= rs3 $r.argreg2)
                  (sparc.jmpli as $r.millicode $m.addtrans $r.o7)
                  (sparc.sti  as rs3 (- 4 tag) $r.tmp0))
                 (else
                  (sparc.sti  as rs3 (- 4 tag) $r.tmp0)
                  (millicode-call/1arg as $m.addtrans rs3))))
          (else
           (cond ((= rs3 $r.argreg2)
                  (sparc.sti  as rs3 (- 4 tag) $r.tmp0)
                  (millicode-call/1arg-in-result as $m.addtrans rs1))
                 (else
                  (sparc.sti  as rs3 (- 4 tag) $r.tmp0)
                  (sparc.move as rs1 $r.result)
                  (millicode-call/1arg as $m.addtrans rs3)))))))

; eof
; Copyright 1998 Lars T Hansen.
;
; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
;
; 9 May 1999 / wdc
;
; SPARC code generation macros for primitives, part 3:
;   fixnum-specific operations.
;
; Constraints for all the primops.
;
; RS1 is a general hardware register or RESULT.
; RS2 is a general register or ARGREG2.
; IMM is an exact integer in the range -1024 .. 1023.
; RD is a general hardware register or RESULT.

; FIXME
;   Missing fxquotient, fxremainder
;   When new pass1 in place:
;     Must add code to pass1 to allow n-ary calls to be rewritten as binary
;     Must add compiler macro for fxabs.


; most-negative-fixnum, most-positive-fixnum.

(define-primop 'most-negative-fixnum
  (lambda (as)
    (emit-immediate->register! as (asm:signed #x80000000) $r.result)))

(define-primop 'most-positive-fixnum
  (lambda (as)
    (emit-immediate->register! as (asm:signed #x7FFFFFFC) $r.result)))


; fx+, fx- w/o immediates

(define-primop 'fx+
  (lambda (as rs2)
    (emit-fixnum-arithmetic as sparc.taddrcc sparc.addr $r.result rs2 $r.result
			    $ex.fx+)))

(define-primop 'internal:fx+
  (lambda (as rs1 rs2 rd)
    (emit-fixnum-arithmetic as sparc.taddrcc sparc.addr rs1 rs2 rd $ex.fx+)))

(define-primop 'fx-
  (lambda (as rs2)
    (emit-fixnum-arithmetic as sparc.tsubrcc sparc.subr $r.result rs2 $r.result
			    $ex.fx-)))

(define-primop 'internal:fx-
  (lambda (as rs1 rs2 rd)
    (emit-fixnum-arithmetic as sparc.tsubrcc sparc.subr rs1 rs2 rd $ex.fx-)))

(define-primop 'fx--
  (lambda (as)
    (emit-fixnum-arithmetic as sparc.tsubrcc sparc.subr
			    $r.g0 $r.result $r.result $ex.fx--)))

(define-primop 'internal:fx--
  (lambda (as rs rd)
    (emit-fixnum-arithmetic as sparc.tsubrcc sparc.subr $r.g0 rs rd $ex.fx--)))

(define (emit-fixnum-arithmetic as op-check op-nocheck rs1 rs2 rd exn)
  (if (unsafe-code)
      (let ((rs2 (force-hwreg! as rs2 $r.argreg2)))
	(op-nocheck as rs1 rs2 rd))
      (let ((rs2 (force-hwreg! as rs2 $r.argreg2))
	    (L0  (new-label))
	    (L1  (new-label)))
	(sparc.label  as L0)
	(op-check     as rs1 rs2 $r.tmp0)
	(sparc.bvc.a  as L1)
	(sparc.move   as $r.tmp0 rd)
        (if (not (= exn $ex.fx--))
            (begin
              (if (not (= rs1 $r.result)) (sparc.move as rs1 $r.result))
              (if (not (= rs2 $r.argreg2)) (sparc.move as rs2 $r.argreg2)))
            (begin
              (if (not (= rs2 $r.result)) (sparc.move as rs2 $r.result))))
	(sparc.set    as (thefixnum exn) $r.tmp0)
	(millicode-call/ret as $m.exception L0)
	(sparc.label  as L1))))

; fx* w/o immediate

(define-primop 'fx*
  (lambda (as rs2)
    (emit-multiply-code as rs2 #t)))

; fx+, fx- w/immediates

(define-primop 'internal:fx+/imm
  (lambda (as rs imm rd)
    (emit-fixnum-arithmetic/imm as sparc.taddicc sparc.addi
				rs imm rd $ex.fx+)))

(define-primop 'internal:fx-/imm
  (lambda (as rs imm rd)
    (emit-fixnum-arithmetic/imm as sparc.tsubicc sparc.subi
				rs imm rd $ex.fx-)))

(define (emit-fixnum-arithmetic/imm as op-check op-nocheck rs imm rd exn)
  (if (unsafe-code)
      (op-nocheck as rs (thefixnum imm) rd)
      (let ((L0  (new-label))
	    (L1  (new-label)))
	(sparc.label  as L0)
	(op-check     as rs (thefixnum imm) $r.tmp0)
	(sparc.bvc.a  as L1)
	(sparc.move   as $r.tmp0 rd)
	(if (not (= rs $r.result)) (sparc.move as rs $r.result))
	(sparc.set    as (thefixnum imm) $r.argreg2)
	(sparc.set    as (thefixnum exn) $r.tmp0)
	(millicode-call/ret as $m.exception L0)
	(sparc.label  as L1))))


; fx=, fx<, fx<=, fx>, fx>=, fxpositive?, fxnegative?, fxzero? w/o immediates

(define-primop 'fx=
  (lambda (as rs2)
    (emit-fixnum-compare as sparc.bne.a $r.result rs2 $r.result $ex.fx= #f)))

(define-primop 'fx<
  (lambda (as rs2)
    (emit-fixnum-compare as sparc.bge.a $r.result rs2 $r.result $ex.fx< #f)))

(define-primop 'fx<=
  (lambda (as rs2)
    (emit-fixnum-compare as sparc.bg.a $r.result rs2 $r.result $ex.fx<= #f)))

(define-primop 'fx>
  (lambda (as rs2)
    (emit-fixnum-compare as sparc.ble.a $r.result rs2 $r.result $ex.fx> #f)))

(define-primop 'fx>=
  (lambda (as rs2)
    (emit-fixnum-compare as sparc.bl.a $r.result rs2 $r.result $ex.fx>= #f)))

(define-primop 'internal:fx=
  (lambda (as rs1 rs2 rd)
    (emit-fixnum-compare as sparc.bne.a rs1 rs2 rd $ex.fx= #f)))

(define-primop 'internal:fx<
  (lambda (as rs1 rs2 rd)
    (emit-fixnum-compare as sparc.bge.a rs1 rs2 rd $ex.fx< #f)))

(define-primop 'internal:fx<=
  (lambda (as rs1 rs2 rd)
    (emit-fixnum-compare as sparc.bg.a rs1 rs2 rd $ex.fx<= #f)))

(define-primop 'internal:fx>
  (lambda (as rs1 rs2 rd)
    (emit-fixnum-compare as sparc.ble.a rs1 rs2 rd $ex.fx> #f)))

(define-primop 'internal:fx>=
  (lambda (as rs1 rs2 rd)
    (emit-fixnum-compare as sparc.bl.a rs1 rs2 rd $ex.fx>= #f)))


; Use '/imm' code for these because the generated code is better.

(define-primop 'fxpositive?
  (lambda (as)
    (emit-fixnum-compare/imm as sparc.ble.a $r.result 0 $r.result
			     $ex.fxpositive? #f)))

(define-primop 'fxnegative?
  (lambda (as)
    (emit-fixnum-compare/imm as sparc.bge.a $r.result 0 $r.result
				$ex.fxnegative? #f)))

(define-primop 'fxzero?
  (lambda (as)
    (emit-fixnum-compare/imm as sparc.bne.a $r.result 0 $r.result
				$ex.fxzero? #f)))

(define-primop 'internal:fxpositive?
  (lambda (as rs rd)
    (emit-fixnum-compare/imm as sparc.ble.a rs 0 rd $ex.fxpositive? #f)))

(define-primop 'internal:fxnegative?
  (lambda (as rs rd)
    (emit-fixnum-compare/imm as sparc.bge.a rs 0 rd $ex.fxnegative? #f)))

(define-primop 'internal:fxzero?
  (lambda (as rs rd)
    (emit-fixnum-compare/imm as sparc.bne.a rs 0 rd $ex.fxzero? #f)))


; fx=, fx<, fx<=, fx>, fx>=  w/immediates

(define-primop 'internal:fx=/imm
  (lambda (as rs imm rd)
    (emit-fixnum-compare/imm as sparc.bne.a rs imm rd $ex.fx= #f)))

(define-primop 'internal:fx</imm
  (lambda (as rs imm rd)
    (emit-fixnum-compare/imm as sparc.bge.a rs imm rd $ex.fx< #f)))

(define-primop 'internal:fx<=/imm
  (lambda (as rs imm rd)
    (emit-fixnum-compare/imm as sparc.bg.a rs imm rd $ex.fx<= #f)))

(define-primop 'internal:fx>/imm
  (lambda (as rs imm rd)
    (emit-fixnum-compare/imm as sparc.ble.a rs imm rd $ex.fx> #f)))

(define-primop 'internal:fx>=/imm
  (lambda (as rs imm rd)
    (emit-fixnum-compare/imm as sparc.bl.a rs imm rd $ex.fx>= #f)))

; fx=, fx<, fx<=, fx>, fx>=, fxpositive?, fxnegative?, fxzero? w/o immediates
; for control.

(define-primop 'internal:branchf-fx=
  (lambda (as rs1 rs2 L)
    (emit-fixnum-compare as sparc.bne.a rs1 rs2 #f $ex.fx= L)))

(define-primop 'internal:branchf-fx<
  (lambda (as rs1 rs2 L)
    (emit-fixnum-compare as sparc.bge.a rs1 rs2 #f $ex.fx< L)))

(define-primop 'internal:branchf-fx<=
  (lambda (as rs1 rs2 L)
    (emit-fixnum-compare as sparc.bg.a rs1 rs2 #f $ex.fx<= L)))

(define-primop 'internal:branchf-fx>
  (lambda (as rs1 rs2 L)
    (emit-fixnum-compare as sparc.ble.a rs1 rs2 #f $ex.fx> L)))

(define-primop 'internal:branchf-fx>=
  (lambda (as rs1 rs2 L)
    (emit-fixnum-compare as sparc.bl.a rs1 rs2 #f $ex.fx>= L)))

(define-primop 'internal:branchf-fxpositive?
  (lambda (as rs1 L)
    (emit-fixnum-compare/imm as sparc.ble.a rs1 0 #f $ex.fxpositive? L)))

(define-primop 'internal:branchf-fxnegative?
  (lambda (as rs1 L)
    (emit-fixnum-compare/imm as sparc.bge.a rs1 0 #f $ex.fxnegative? L)))

(define-primop 'internal:branchf-fxzero?
  (lambda (as rs1 L)
    (emit-fixnum-compare/imm as sparc.bne.a rs1 0 #f $ex.fxzero? L)))


; fx=, fx<, fx<=, fx>, fx>=  w/immediates for control.

(define-primop 'internal:branchf-fx=/imm
  (lambda (as rs imm L)
    (emit-fixnum-compare/imm as sparc.bne.a rs imm #f $ex.fx= L)))

(define-primop 'internal:branchf-fx</imm
  (lambda (as rs imm L)
    (emit-fixnum-compare/imm as sparc.bge.a rs imm #f $ex.fx< L)))

(define-primop 'internal:branchf-fx<=/imm
  (lambda (as rs imm L)
    (emit-fixnum-compare/imm as sparc.bg.a rs imm #f $ex.fx<= L)))

(define-primop 'internal:branchf-fx>/imm
  (lambda (as rs imm L)
    (emit-fixnum-compare/imm as sparc.ble.a rs imm #f $ex.fx> L)))

(define-primop 'internal:branchf-fx>=/imm
  (lambda (as rs imm L)
    (emit-fixnum-compare/imm as sparc.bl.a rs imm #f $ex.fx>= L)))


; Trusted fixnum comparisons.

(define-primop '=:fix:fix
  (lambda (as rs2)
    (emit-fixnum-compare-trusted as sparc.bne.a $r.result rs2 $r.result #f)))

(define-primop '<:fix:fix
  (lambda (as rs2)
    (emit-fixnum-compare-trusted as sparc.bge.a $r.result rs2 $r.result #f)))

(define-primop '<=:fix:fix
  (lambda (as rs2)
    (emit-fixnum-compare-trusted as sparc.bg.a $r.result rs2 $r.result #f)))

(define-primop '>:fix:fix
  (lambda (as rs2)
    (emit-fixnum-compare-trusted as sparc.ble.a $r.result rs2 $r.result #f)))

(define-primop '>=:fix:fix
  (lambda (as rs2)
    (emit-fixnum-compare-trusted as sparc.bl.a $r.result rs2 $r.result #f)))

(define-primop 'internal:=:fix:fix
  (lambda (as rs1 rs2 rd)
    (emit-fixnum-compare-trusted as sparc.bne.a rs1 rs2 rd #f)))

(define-primop 'internal:<:fix:fix
  (lambda (as rs1 rs2 rd)
    (emit-fixnum-compare-trusted as sparc.bge.a rs1 rs2 rd #f)))

(define-primop 'internal:<=:fix:fix
  (lambda (as rs1 rs2 rd)
    (emit-fixnum-compare-trusted as sparc.bg.a rs1 rs2 rd #f)))

(define-primop 'internal:>:fix:fix
  (lambda (as rs1 rs2 rd)
    (emit-fixnum-compare-trusted as sparc.ble.a rs1 rs2 rd #f)))

(define-primop 'internal:>=:fix:fix
  (lambda (as rs1 rs2 rd)
    (emit-fixnum-compare-trusted as sparc.bl.a rs1 rs2 rd #f)))

; With immediates.

(define-primop 'internal:=:fix:fix/imm
  (lambda (as rs imm rd)
    (emit-fixnum-compare/imm-trusted as sparc.bne.a rs imm rd #f)))

(define-primop 'internal:<:fix:fix/imm
  (lambda (as rs imm rd)
    (emit-fixnum-compare/imm-trusted as sparc.bge.a rs imm rd #f)))

(define-primop 'internal:<=:fix:fix/imm
  (lambda (as rs imm rd)
    (emit-fixnum-compare/imm-trusted as sparc.bg.a rs imm rd #f)))

(define-primop 'internal:>:fix:fix/imm
  (lambda (as rs imm rd)
    (emit-fixnum-compare/imm-trusted as sparc.ble.a rs imm rd #f)))

(define-primop 'internal:>=:fix:fix/imm
  (lambda (as rs imm rd)
    (emit-fixnum-compare/imm-trusted as sparc.bl.a rs imm rd #f)))

; Without immediates, for control.

(define-primop 'internal:branchf-=:fix:fix
  (lambda (as rs1 rs2 L)
    (emit-fixnum-compare-trusted as sparc.bne.a rs1 rs2 #f L)))

(define-primop 'internal:branchf-<:fix:fix
  (lambda (as rs1 rs2 L)
    (emit-fixnum-compare-trusted as sparc.bge.a rs1 rs2 #f L)))

(define-primop 'internal:branchf-<=:fix:fix
  (lambda (as rs1 rs2 L)
    (emit-fixnum-compare-trusted as sparc.bg.a rs1 rs2 #f L)))

(define-primop 'internal:branchf->:fix:fix
  (lambda (as rs1 rs2 L)
    (emit-fixnum-compare-trusted as sparc.ble.a rs1 rs2 #f L)))

(define-primop 'internal:branchf->=:fix:fix
  (lambda (as rs1 rs2 L)
    (emit-fixnum-compare-trusted as sparc.bl.a rs1 rs2 #f L)))

; With immediates, for control.

(define-primop 'internal:branchf-=:fix:fix/imm
  (lambda (as rs imm L)
    (emit-fixnum-compare/imm-trusted as sparc.bne.a rs imm #f L)))

(define-primop 'internal:branchf-<:fix:fix/imm
  (lambda (as rs imm L)
    (emit-fixnum-compare/imm-trusted as sparc.bge.a rs imm #f L)))

(define-primop 'internal:branchf-<=:fix:fix/imm
  (lambda (as rs imm L)
    (emit-fixnum-compare/imm-trusted as sparc.bg.a rs imm #f L)))

(define-primop 'internal:branchf->:fix:fix/imm
  (lambda (as rs imm L)
    (emit-fixnum-compare/imm-trusted as sparc.ble.a rs imm #f L)))

(define-primop 'internal:branchf->=:fix:fix/imm
  (lambda (as rs imm L)
    (emit-fixnum-compare/imm-trusted as sparc.bl.a rs imm #f L)))

; Range check:  0 <= src1 < src2

(define-primop 'internal:check-range
  (lambda (as src1 src2 L1 livregs)
    (let ((src2 (force-hwreg! as src2 $r.argreg2)))
      (emit-fixnum-compare-check
       as src2 src1 sparc.bleu L1 livregs))))

; Trusted fixnum comparisons followed by a check.

(define-primop 'internal:check-=:fix:fix
  (lambda (as src1 src2 L1 liveregs)
    (emit-fixnum-compare-check
     as src1 src2 sparc.bne L1 liveregs)))

(define-primop 'internal:check-<:fix:fix
  (lambda (as src1 src2 L1 liveregs)
    (emit-fixnum-compare-check
     as src1 src2 sparc.bge L1 liveregs)))

(define-primop 'internal:check-<=:fix:fix
  (lambda (as src1 src2 L1 liveregs)
    (emit-fixnum-compare-check
     as src1 src2 sparc.bg L1 liveregs)))

(define-primop 'internal:check->:fix:fix
  (lambda (as src1 src2 L1 liveregs)
    (emit-fixnum-compare-check
     as src1 src2 sparc.ble L1 liveregs)))

(define-primop 'internal:check->=:fix:fix
  (lambda (as src1 src2 L1 liveregs)
    (emit-fixnum-compare-check
     as src1 src2 sparc.bl L1 liveregs)))

(define-primop 'internal:check-=:fix:fix/imm
  (lambda (as src1 imm L1 liveregs)
    (emit-fixnum-compare/imm-check
     as src1 imm sparc.bne L1 liveregs)))

(define-primop 'internal:check-<:fix:fix/imm
  (lambda (as src1 imm L1 liveregs)
    (emit-fixnum-compare/imm-check
     as src1 imm sparc.bge L1 liveregs)))

(define-primop 'internal:check-<=:fix:fix/imm
  (lambda (as src1 imm L1 liveregs)
    (emit-fixnum-compare/imm-check
     as src1 imm sparc.bg L1 liveregs)))

(define-primop 'internal:check->:fix:fix/imm
  (lambda (as src1 imm L1 liveregs)
    (emit-fixnum-compare/imm-check
     as src1 imm sparc.ble L1 liveregs)))

(define-primop 'internal:check->=:fix:fix/imm
  (lambda (as src1 imm L1 liveregs)
    (emit-fixnum-compare/imm-check
     as src1 imm sparc.bl L1 liveregs)))

; Below, 'target' is a label or #f.  If #f, RD must be a general hardware
; register or RESULT, and a boolean result is generated in RD.

(define (emit-fixnum-compare as branchf.a rs1 rs2 rd exn target)
  (if (unsafe-code)
      (emit-fixnum-compare-trusted as branchf.a rs1 rs2 rd target)
      (let ((rs2 (force-hwreg! as rs2 $r.argreg2))
            (L0 (new-label))
            (L1 (new-label)))
        (sparc.label as L0)
        (sparc.orr   as rs1 rs2 $r.tmp0)
        (sparc.btsti as $r.tmp0 3)
        (sparc.be.a  as L1)
        (sparc.cmpr  as rs1 rs2)
        (if (not (= rs1 $r.result)) (sparc.move as rs1 $r.result))
        (if (not (= rs2 $r.argreg2)) (sparc.move as rs2 $r.argreg2))
        (sparc.set   as (thefixnum exn) $r.tmp0)
        (millicode-call/ret as $m.exception L0)
        (sparc.label as L1)
        (emit-evaluate-cc! as branchf.a rd target))))

; Below, 'target' is a label or #f.  If #f, RD must be a general hardware
; register or RESULT, and a boolean result is generated in RD.

(define (emit-fixnum-compare-trusted as branchf.a rs1 rs2 rd target)
  (let ((rs2 (force-hwreg! as rs2 $r.argreg2)))
    (sparc.cmpr  as rs1 rs2)
    (emit-evaluate-cc! as branchf.a rd target)))

; rs must be a hardware register.

(define (emit-fixnum-compare/imm as branchf.a rs imm rd exn target)
  (if (unsafe-code)
      (emit-fixnum-compare/imm-trusted as branchf.a rs imm rd target)
      (let ((L0 (new-label))
            (L1 (new-label)))
        (sparc.label as L0)
        (sparc.btsti as rs 3)
        (sparc.be.a  as L1)
        (sparc.cmpi  as rs (thefixnum imm))
        (if (not (= rs $r.result)) (sparc.move as rs $r.result))
        (sparc.set   as (thefixnum imm) $r.argreg2)
        (sparc.set   as (thefixnum exn) $r.tmp0)
        (millicode-call/ret as $m.exception L0)
        (sparc.label as L1)))
  (emit-evaluate-cc! as branchf.a rd target))

; rs must be a hardware register.

(define (emit-fixnum-compare/imm-trusted as branchf.a rs imm rd target)
  (sparc.cmpi  as rs (thefixnum imm))
  (emit-evaluate-cc! as branchf.a rd target))

; Range checks.

(define (emit-fixnum-compare-check
         as src1 src2 branch-bad L1 liveregs)
  (internal-primop-invariant1 'emit-fixnum-compare-check src1)
  (let ((src2 (force-hwreg! as src2 $r.argreg2)))
    (sparc.cmpr    as src1 src2)
    (emit-checkcc! as branch-bad L1 liveregs)))

(define (emit-fixnum-compare/imm-check
         as src1 imm branch-bad L1 liveregs)
  (internal-primop-invariant1 'emit-fixnum-compare/imm-check src1)
  (sparc.cmpi    as src1 imm)
  (emit-checkcc! as branch-bad L1 liveregs))

; eof
; Copyright 1998 Lars T Hansen.
;
; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
;
; SPARC machine assembler flags.
;
; 12 April 1999


; INTERNAL!
(define short-effective-addresses
  (make-twobit-flag 'short-effective-addresses))

(define runtime-safety-checking
  (make-twobit-flag 'runtime-safety-checking))

(define catch-undefined-globals
  (make-twobit-flag 'catch-undefined-globals))

(define inline-allocation
  (make-twobit-flag 'inline-allocation))
  
;(define inline-assignment
;  (make-twobit-flag 'inline-assignment))

(define write-barrier
  (make-twobit-flag 'write-barrier))  

(define peephole-optimization
  (make-twobit-flag 'peephole-optimization))

(define single-stepping
  (make-twobit-flag 'single-stepping))

(define fill-delay-slots
  (make-twobit-flag 'fill-delay-slots))

; For backward compatibility.

;(define unsafe-code
;  (make-twobit-flag 'unsafe-code))

(define (unsafe-code . args)
  (if (null? args)
      (not (runtime-safety-checking))
      (runtime-safety-checking (not (car args)))))

(define (display-assembler-flags which)
  (case which
    ((debugging)
     (display-twobit-flag single-stepping))
    ((safety)
     (display-twobit-flag write-barrier)
     ;(display-twobit-flag unsafe-code)
     (display-twobit-flag runtime-safety-checking)
     (if (runtime-safety-checking)
         (begin (display "  ")
                (display-twobit-flag catch-undefined-globals))))
    ((optimization)
     (display-twobit-flag peephole-optimization)
     (display-twobit-flag inline-allocation)
     ;  (display-twobit-flag inline-assignment)
     (display-twobit-flag fill-delay-slots))
    (else #t)))

(define (set-assembler-flags! mode)
  (case mode
    ((no-optimization)
     (set-assembler-flags! 'standard)
     (peephole-optimization #f)
     (fill-delay-slots #f))
    ((standard)
     (short-effective-addresses #t)
     (catch-undefined-globals #t)
     (inline-allocation #f)
     ; (inline-assignment #f)
     (peephole-optimization #t)
     (runtime-safety-checking #t)
     (write-barrier #t)
     (single-stepping #f)
     (fill-delay-slots #t))
    ((fast-safe default)
     (set-assembler-flags! 'standard)
     ; (inline-assignment #t)
     (inline-allocation #t))
    ((fast-unsafe)
     (set-assembler-flags! 'fast-safe)
     (catch-undefined-globals #f)
     (runtime-safety-checking #f))
    (else
     (error "set-assembler-flags!: unknown mode " mode))))

(set-assembler-flags! 'default)

; eof
; Copyright 1998 Lars T Hansen.
;
; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
;
; SPARC disassembler.
;
; (disassemble-instruction instruction address)
;     => decoded-instruction
;
; (disassemble-codevector codevector)
;     => decoded-instruction-list
;
; (print-instructions decoded-instruction-list)
;     => unspecified
;     Also takes an optional port and optionally the symbol "native-names".
;
; (format-instruction decoded-instruction address larceny-names?) 
;     => string
; 
; A `decoded-instruction' is a list where the car is a mnemonic and
; the operands are appropriate for that mnemonic.
;
; A `mnemonic' is an exact non-negative integer.  It encodes the name of
; the instruction as well as its attributes (operand pattern and instruction
; type).  See below for specific operations on mnemonics.

(define (disassemble-codevector cv)
  (define (loop addr ilist)
    (if (< addr 0)
	ilist
	(loop (- addr 4)
	      (cons (disassemble-instruction (bytevector-word-ref cv addr)
					     addr)
		    ilist))))
  (loop (- (bytevector-length cv) 4) '()))

(define disassemble-instruction)	    ; Defined below.

; Mnemonics

(define *asm-annul* 1)
(define *asm-immed* 2)
(define *asm-store* 4)
(define *asm-load* 8)
(define *asm-branch* 16)
(define *asm-freg* 32)
(define *asm-fpop* 64)
(define *asm-no-op2* 128)
(define *asm-no-op3* 256)

(define *asm-bits*
  `((a . ,*asm-annul*) (i . ,*asm-immed*) (s . ,*asm-store*)
    (l . ,*asm-load*) (b . ,*asm-branch*) (f . ,*asm-freg*)
    (fpop . ,*asm-fpop*) (no-op2 . ,*asm-no-op2*) (no-op3 . ,*asm-no-op3*)))

(define *asm-mnemonic-table* '())

(define mnemonic 
  (let ((n 0))
    (lambda (name . rest)
      (let* ((probe (assq name *asm-mnemonic-table*))
	     (code  (* 1024 
		       (if probe
			   (cdr probe)
			   (let ((code n))
			     (set! n (+ n 1))
			     (set! *asm-mnemonic-table*
				   (cons (cons name code)
					 *asm-mnemonic-table*))
			     code)))))
	(for-each (lambda (x)
		    (set! code (+ code (cdr (assq x *asm-bits*)))))
		  rest)
	code))))

(define (mnemonic:name mnemonic)
  (let ((mnemonic (quotient mnemonic 1024)))
    (let loop ((t *asm-mnemonic-table*))
      (cond ((null? t) #f)
	    ((= (cdar t) mnemonic) (caar t))
	    (else (loop (cdr t)))))))

(define (mnemonic=? m name)
  (= (quotient m 1024) (quotient (mnemonic name) 1024)))

(define (mnemonic:test bit)
  (lambda (mnemonic)
    (not (zero? (logand mnemonic bit)))))

(define (mnemonic:test-not bit)
  (lambda (mnemonic)
    (zero? (logand mnemonic bit))))

(define mnemonic:annul? (mnemonic:test *asm-annul*))
(define mnemonic:immediate? (mnemonic:test *asm-immed*))
(define mnemonic:store? (mnemonic:test *asm-store*))
(define mnemonic:load? (mnemonic:test *asm-load*))
(define mnemonic:branch? (mnemonic:test *asm-branch*))
(define mnemonic:freg? (mnemonic:test *asm-freg*))
(define mnemonic:fpop? (mnemonic:test *asm-fpop*))
(define mnemonic:op2? (mnemonic:test-not *asm-no-op2*))
(define mnemonic:op3? (mnemonic:test-not *asm-no-op3*))

; Instruction disassembler.

(let ()

  ;; Useful constants

  (define two^3 (expt 2 3))
  (define two^5 (expt 2 5))
  (define two^6 (expt 2 6))
  (define two^8 (expt 2 8))
  (define two^9 (expt 2 9))
  (define two^12 (expt 2 12))
  (define two^13 (expt 2 13))
  (define two^14 (expt 2 14))
  (define two^16 (expt 2 16))
  (define two^19 (expt 2 19))
  (define two^21 (expt 2 21))
  (define two^22 (expt 2 22))
  (define two^24 (expt 2 24))
  (define two^25 (expt 2 25))
  (define two^29 (expt 2 29))
  (define two^30 (expt 2 30))
  (define two^32 (expt 2 32))

  ;; Class 0 has branches and weirdness, like sethi and nop.
  ;; We dispatch first on the op2 field and then on the op3 field.

  (define class00
    (let ((b-table
	   (vector (mnemonic 'bn 'b)
		   (mnemonic 'be 'b)
		   (mnemonic 'ble 'b)
		   (mnemonic 'bl 'b)
		   (mnemonic 'bleu 'b)
		   (mnemonic 'bcs 'b)
		   (mnemonic 'bneg 'b)
		   (mnemonic 'bvs 'b)
		   (mnemonic 'ba 'b)
		   (mnemonic 'bne 'b)
		   (mnemonic 'bg 'b)
		   (mnemonic 'bge 'b)
		   (mnemonic 'bgu 'b)
		   (mnemonic 'bcc 'b)
		   (mnemonic 'bpos 'b)
		   (mnemonic 'bvc 'b)
		   (mnemonic 'bn 'a 'b)
		   (mnemonic 'be 'a 'b)
		   (mnemonic 'ble 'a 'b)
		   (mnemonic 'bl 'a 'b)
		   (mnemonic 'bleu 'a 'b)
		   (mnemonic 'bcs 'a 'b)
		   (mnemonic 'bneg 'a 'b)
		   (mnemonic 'bvs 'a 'b)
		   (mnemonic 'ba 'a 'b)
		   (mnemonic 'bne 'a 'b)
		   (mnemonic 'bg 'a 'b)
		   (mnemonic 'bge 'a 'b)
		   (mnemonic 'bgu 'a 'b)
		   (mnemonic 'bcc 'a 'b)
		   (mnemonic 'bpos 'a 'b)
		   (mnemonic 'bvc 'a 'b)))
	  (fb-table
	   (vector (mnemonic 'fbn 'b)
		   (mnemonic 'fbne 'b)
		   (mnemonic 'fblg 'b)
		   (mnemonic 'fbul 'b)
		   (mnemonic 'fbl 'b)
		   (mnemonic 'fbug 'b)
		   (mnemonic 'fbg 'b)
		   (mnemonic 'fbu 'b)
		   (mnemonic 'fba 'b)
		   (mnemonic 'fbe 'b)
		   (mnemonic 'fbue 'b)
		   (mnemonic 'fbge 'b)
		   (mnemonic 'fbuge 'b)
		   (mnemonic 'fble 'b)
		   (mnemonic 'fbule 'b)
		   (mnemonic 'fbo 'b)
		   (mnemonic 'fbn 'a 'b)
		   (mnemonic 'fbne 'a 'b)
		   (mnemonic 'fblg 'a 'b)
		   (mnemonic 'fbul 'a 'b)
		   (mnemonic 'fbl 'a 'b)
		   (mnemonic 'fbug 'a 'b)
		   (mnemonic 'fbg 'a 'b)
		   (mnemonic 'fbu 'a 'b)
		   (mnemonic 'fba 'a 'b)
		   (mnemonic 'fbe 'a 'b)
		   (mnemonic 'fbue 'a 'b)
		   (mnemonic 'fbge 'a 'b)
		   (mnemonic 'fbuge 'a 'b)
		   (mnemonic 'fble 'a 'b)
		   (mnemonic 'fbule 'a 'b)
		   (mnemonic 'fbo 'a 'b)))
	  (nop (mnemonic 'nop))
	  (sethi (mnemonic 'sethi)))

      (lambda (ip instr)
	(let ((op2 (op2field instr)))
	  (cond ((= op2 #b100)
		 (if (zero? (rdfield instr))
		     `(,nop)
		     `(,sethi ,(imm22field instr) ,(rdfield instr))))
		((= op2 #b010)
		 `(,(vector-ref b-table (rdfield instr))
		   ,(* 4 (imm22field instr))))
		((= op2 #b110)
		 `(,(vector-ref fb-table (rdfield instr))
		   ,(* 4 (imm22field instr))))
		(else
		 (disasm-error "Can't disassemble " (number->string instr 16)
			       " at ip=" ip
			       " with op2=" op2)))))))

  ;; Class 1 is the call instruction; there's no choice.

  (define (class01 ip instr)
    `(,(mnemonic 'call) ,(* 4 (imm30field instr))))

  ;; Class 2 is for the ALU. Dispatch on op3 field.

  (define class10
    (let ((op3-table
	   `#((,(mnemonic 'add)   ,(mnemonic 'add 'i))
	      (,(mnemonic 'and)   ,(mnemonic 'and 'i))
	      (,(mnemonic 'or)    ,(mnemonic 'or 'i))
	      (,(mnemonic 'xor)   ,(mnemonic 'xor 'i))
	      (,(mnemonic 'sub)   ,(mnemonic 'sub 'i))
	      (,(mnemonic 'andn)  ,(mnemonic 'andn 'i))
	      (,(mnemonic 'orn)   ,(mnemonic 'orn 'i))
	      (,(mnemonic 'xnor)  ,(mnemonic 'xnor 'i))
	      (0          0)
	      (0          0)
	      (0          0)                              ; 10
	      (,(mnemonic 'smul)  ,(mnemonic 'smul 'i))
	      (0          0)
	      (0          0)
	      (0          0)
	      (,(mnemonic 'sdiv)  ,(mnemonic 'sdiv 'i))
	      (,(mnemonic 'addcc) ,(mnemonic 'addcc 'i))
	      (,(mnemonic 'andcc) ,(mnemonic 'andcc 'i))
	      (,(mnemonic 'orcc)  ,(mnemonic 'orcc 'i))
	      (,(mnemonic 'xorcc) ,(mnemonic 'xorcc 'i))
	      (,(mnemonic 'subcc) ,(mnemonic 'subcc 'i))  ; 20
	      (0          0)
	      (0          0)
	      (0          0)
	      (0          0)
	      (0          0)
	      (0          0)
	      (,(mnemonic 'smulcc) ,(mnemonic 'smulcc 'i))
	      (0          0)
	      (0          0)
	      (0          0)                               ; 30
	      (,(mnemonic 'sdivcc) ,(mnemonic 'sdivcc 'i))
	      (,(mnemonic 'taddcc) ,(mnemonic 'taddcc 'i))
	      (,(mnemonic 'tsubcc) ,(mnemonic 'tsubcc 'i))
	      (0          0)
	      (0          0)
	      (0          0)
	      (,(mnemonic 'sll)   ,(mnemonic 'sll 'i))
	      (,(mnemonic 'srl)   ,(mnemonic 'srl 'i))
	      (,(mnemonic 'sra)   ,(mnemonic 'sra 'i))
	      (,(mnemonic 'rd)   0)                       ; 40
	      (0          0)
	      (0          0)
	      (0          0)
	      (0          0)
	      (0          0)
	      (0          0)
	      (0          0)
	      (,(mnemonic 'wr)  ,(mnemonic 'wr 'i))
	      (0          0)
	      (0          0)                               ; 50
	      (0          0)
	      (0          0)
	      (0          0)
	      (0          0)
	      (0          0)
	      (,(mnemonic 'jmpl)  ,(mnemonic 'jmpl 'i))
	      (0          0)
	      (0          0)
	      (0          0)
	      (,(mnemonic 'save)  ,(mnemonic 'save 'i))   ; 60
	      (,(mnemonic 'restore) ,(mnemonic 'restore 'i))
	      (0          0)
	      (0          0))))

      (lambda (ip instr)
	(let ((op3 (op3field instr)))
	  (if (or (= op3 #b110100) (= op3 #b110101))
	      (fpop-instruction ip instr)
	      (nice-instruction op3-table ip instr))))))


  ;; Class 3 is memory stuff.

  (define class11
    (let ((op3-table
	   `#((,(mnemonic 'ld 'l)    ,(mnemonic 'ld 'i 'l))
	      (,(mnemonic 'ldb 'l)   ,(mnemonic 'ldb 'i 'l))
	      (,(mnemonic 'ldh 'l)   ,(mnemonic 'ldh 'i 'l))
	      (,(mnemonic 'ldd 'l)   ,(mnemonic 'ldd 'i 'l))
	      (,(mnemonic 'st 's)    ,(mnemonic 'st 'i 's))
	      (,(mnemonic 'stb 's)   ,(mnemonic 'stb 'i 's))
	      (,(mnemonic 'sth 's)   ,(mnemonic 'sth 'i 's))
	      (,(mnemonic 'std 's)   ,(mnemonic 'std 'i 's))
	      (0          0)
	      (0          0)
	      (0          0)		; 10
	      (0          0)
	      (0          0)
	      (0          0)
	      (0          0)
	      (0          0)
	      (0          0)
	      (0          0)
	      (0          0)
	      (0          0)
	      (0          0)		; 20
	      (0          0)
	      (0          0)
	      (0          0)
	      (0          0)
	      (0          0)
	      (0          0)
	      (0          0)
	      (0          0)
	      (0          0)
	      (0          0)		; 30
	      (0          0)
	      (,(mnemonic 'ldf 'f 'l) ,(mnemonic 'ldf 'i 'f 'l))
	      (0          0)
	      (0          0)
	      (,(mnemonic 'lddf 'f 'l) ,(mnemonic 'lddf 'i 'f 'l))
	      (,(mnemonic 'stf 'f 's)  ,(mnemonic 'stf 'i 'f 's))
	      (0          0)
	      (0          0)
	      (,(mnemonic 'stdf 'f 's) ,(mnemonic 'stdf 'i 'f 's))
	      (0          0)		; 40
	      (0          0)
	      (0          0)
	      (0          0)
	      (0          0)
	      (0          0)
	      (0          0)
	      (0          0)
	      (0          0)
	      (0          0)
	      (0          0)		; 50
	      (0          0)
	      (0          0)
	      (0          0)
	      (0          0)
	      (0          0)
	      (0          0)
	      (0          0)
	      (0          0)
	      (0          0)
	      (0          0)		; 60
	      (0          0)
	      (0          0)
	      (0          0))))

      (lambda (ip instr)
	(nice-instruction op3-table ip instr))))

  ;; For classes 2 and 3

  (define (nice-instruction op3-table ip instr)
    (let* ((op3  (op3field instr))
	   (imm  (ifield instr))
	   (rd   (rdfield instr))
	   (rs1  (rs1field instr))
	   (src2 (if (zero? imm)
		     (rs2field instr)
		     (imm13field instr))))
      (let ((op ((if (zero? imm) car cadr) (vector-ref op3-table op3))))
	`(,op ,rs1 ,src2 ,rd))))

  ;; Floating-point operate instructions

  (define (fpop-instruction ip instr)
    (let ((rd  (rdfield instr))
	  (rs1 (rs1field instr))
	  (rs2 (rs2field instr))
	  (fpop (fpop-field instr)))
      `(,(cdr (assv fpop fpop-names)) ,rs1 ,rs2 ,rd)))

  (define fpop-names
    `((#b000000001 . ,(mnemonic 'fmovs 'fpop 'no-op2))
      (#b000000101 . ,(mnemonic 'fnegs 'fpop 'no-op2))
      (#b000001001 . ,(mnemonic 'fabss 'fpop 'no-op2))
      (#b001000010 . ,(mnemonic 'faddd 'fpop))
      (#b001000110 . ,(mnemonic 'fsubd 'fpop))
      (#b001001010 . ,(mnemonic 'fmuld 'fpop))
      (#b001001110 . ,(mnemonic 'fdivd 'fpop))
      (#b001010010 . ,(mnemonic 'fcmpd 'fpop 'no-op3))))
      

  ;; The following procedures pick apart an instruction

  (define (op2field instr)
    (remainder (quotient instr two^22) two^3))

  (define (op3field instr)
    (remainder (quotient instr two^19) two^6))

  (define (ifield instr)
    (remainder (quotient instr two^13) 2))

  (define (rs2field instr)
    (remainder instr two^5))

  (define (rs1field instr)
    (remainder (quotient instr two^14) two^5))

  (define (rdfield instr)
    (remainder (quotient instr two^25) two^5))

  (define (imm13field instr)
    (let ((x (remainder instr two^13)))
      (if (not (zero? (quotient x two^12)))
	  (- x two^13)
	  x)))
	
  (define (imm22field instr)
    (let ((x (remainder instr two^22)))
      (if (not (zero? (quotient x two^21)))
	  (- x two^22)
	  x)))

  (define (imm30field instr)
    (let ((x (remainder instr two^30)))
      (if (not (zero? (quotient x two^29)))
	  (- x two^30)
	  x)))

  (define (fpop-field instr)
    (remainder (quotient instr two^5) two^9))

  (set! disassemble-instruction
	(let ((class-table (vector class00 class01 class10 class11)))
	  (lambda (instr addr)
	    ((vector-ref class-table (quotient instr two^30)) addr instr))))

  'disassemble-instruction)


; Instruction printer
;
; It assumes that the first instruction comes from address 0, and prints
; addresses (and relative addresses) based on that assumption.
;
; If the optional symbol native-names is supplied, then SPARC register
; names is used, and millicode calls are not annotated with millicode names.

(define (print-instructions ilist . rest)

  (define port (current-output-port))
  (define larceny-names? #t)

  (define (print-ilist ilist a)
    (if (null? ilist)
	'()
	(begin (display (format-instruction (car ilist) a larceny-names?)
			port)
	       (newline port)
	       (print-ilist (cdr ilist) (+ a 4)))))
  
  (do ((rest rest (cdr rest)))
      ((null? rest))
    (cond ((port? (car rest))
	   (set! port (car rest)))
	  ((eq? (car rest) 'native-names)
	   (set! larceny-names? #f))))
  
  (print-ilist ilist 0))

(define format-instruction)		    ; Defined below

(define *format-instructions-pretty* #t)

; Instruction formatter.

(let ()

  (define use-larceny-registers #t)

  (define sparc-register-table 
    (vector "%g0" "%g1" "%g2" "%g3" "%g4" "%g5" "%g6" "%g7"
	    "%o0" "%o1" "%o2" "%o3" "%o4" "%o5" "%o6" "%o7"
	    "%l0" "%l1" "%l2" "%l3" "%l4" "%l5" "%l6" "%l7"
	    "%i0" "%i1" "%i2" "%i3" "%i4" "%i5" "%i6"  "%i7"))

  (define larceny-register-table
    (make-vector 32 #f))

  (define (larceny-register-name reg . rest)
    (if (null? rest)
	(or (and use-larceny-registers
		 (vector-ref larceny-register-table reg))
	    (vector-ref sparc-register-table reg))
	(vector-set! larceny-register-table reg (car rest))))

  (define millicode-procs '())

  (define (float-register-name reg)
    (string-append "%f" (number->string reg)))
    
  (define op car)
  (define op1 cadr)
  (define op2 caddr)
  (define op3 cadddr)
  (define tabstring (string #\tab))

  (define (heximm n)
    (if (>= n 16)
	(string-append tabstring "! 0x" (number->string n 16))
	""))

  (define (millicode-name offset . rest)
    (if (null? rest)
	(let ((probe (assv offset millicode-procs)))
	  (if probe
	      (cdr probe)
	      "[unknown]"))
	(set! millicode-procs
	      (cons (cons offset (car rest)) millicode-procs))))

  (define (millicode-call offset)
    (string-append tabstring "! " (millicode-name offset)))

  (define (plus/minus n)
    (cond ((< n 0)
	   (string-append " - " (number->string (abs n))))
	  ((and (= n 0) *format-instructions-pretty*) "")
	  (else
	   (string-append " + " (number->string n)))))

  (define (srcreg instr extractor)
    (if (mnemonic:freg? (op instr))
	(float-register-name (extractor instr))
	(larceny-register-name (extractor instr))))
	
  (define (sethi instr)
    (string-append (number->string (* (op1 instr) 1024)) ", "
		   (larceny-register-name (op2 instr))
		   (heximm (* (op1 instr) 1024))))

  (define (rrr instr)
    (string-append (larceny-register-name (op1 instr)) ", "
		   (larceny-register-name (op2 instr)) ", "
		   (larceny-register-name (op3 instr))))

  (define (rir instr)
    (string-append (larceny-register-name (op1 instr)) ", "
		   (number->string (op2 instr)) ", "
		   (larceny-register-name (op3 instr))
		   (heximm (op2 instr))))

  (define (sir instr)
    (string-append (srcreg instr op3) ", [ "
		   (larceny-register-name (op1 instr))
		   (plus/minus (op2 instr)) " ]"))

  (define (srr instr)
    (string-append (srcreg instr op3) ", [ "
		   (larceny-register-name (op1 instr)) "+"
		   (larceny-register-name (op2 instr)) " ]"))
      
  (define (lir instr)
    (string-append "[ " (larceny-register-name (op1 instr))
		   (plus/minus (op2 instr)) " ], "
		   (srcreg instr op3)))

  (define (lrr instr)
    (string-append "[ " (larceny-register-name (op1 instr)) "+"
		   (larceny-register-name (op2 instr)) " ], "
		   (srcreg instr op3)))

  (define (bimm instr addr)
    (string-append "#" (number->string (+ (op1 instr) addr))))

  (define (jmpli instr)
    (string-append (larceny-register-name (op1 instr)) 
		   (plus/minus (op2 instr)) ", "
		   (larceny-register-name (op3 instr))
		   (if (and (= (op1 instr) $r.globals)
			    use-larceny-registers)
		       (millicode-call (op2 instr))
		       (heximm (op2 instr)))))

  (define (jmplr instr)
    (string-append (larceny-register-name (op1 instr)) "+"
		   (larceny-register-name (op2 instr)) ", "
		   (larceny-register-name (op3 instr))))

  (define (call instr addr)
    (string-append "#" (number->string (+ (op1 instr) addr))))

  (define (rd instr)
    (string-append "%y, " (srcreg instr op3)))

  (define (wr instr imm?)
    (if imm?
	(string-append (larceny-register-name (op1 instr)) ", "
		       (number->string (op2 instr)) ", %y"
		       (larceny-register-name (op3 instr)))
	(string-append (larceny-register-name (op1 instr)) ", "
		       (larceny-register-name (op2 instr)) ", %y")))

  (define (fpop instr op2-used? op3-used?)
    (string-append (float-register-name (op1 instr)) ", "
		   (cond ((and op2-used? op3-used?)
			  (string-append
			   (float-register-name (op2 instr)) ", "
			   (float-register-name (op3 instr))))
			 (op2-used?
			  (float-register-name (op2 instr)))
			 (else
			  (float-register-name (op3 instr))))))

  ;; If we want to handle instruction aliases (clr, mov, etc) then
  ;; the structure of this procedure must change, because as it is,
  ;; the printing of the name is independent of the operand values.

  (define (format-instr i a larceny-names?)
    (set! use-larceny-registers larceny-names?)
    (let ((m (car i)))
      (string-append (number->string a)
		     tabstring
		     (symbol->string (mnemonic:name m))
		     (if (mnemonic:annul? m) ",a" "")
		     tabstring
		     (cond ((mnemonic:store? m) 
			    (if (mnemonic:immediate? m) (sir i) (srr i)))
			   ((mnemonic:load? m)
			    (if (mnemonic:immediate? m) (lir i) (lrr i)))
			   ((mnemonic:fpop? m)
			    (fpop i (mnemonic:op2? m) (mnemonic:op3? m)))
			   ((mnemonic:branch? m) (bimm i a))
			   ((mnemonic=? m 'sethi) (sethi i))
			   ((mnemonic=? m 'nop) "")
			   ((mnemonic=? m 'jmpl)
			    (if (mnemonic:immediate? m) (jmpli i) (jmplr i)))
			   ((mnemonic=? m 'call) (call i a))
			   ((mnemonic=? m 'rd) (rd i))
			   ((mnemonic=? m 'wr) (wr i (mnemonic:immediate? m)))
			   ((mnemonic:immediate? m) (rir i))
			   (else (rrr i))))))

  (larceny-register-name $r.tmp0 "%tmp0")
  (larceny-register-name $r.result "%result")
  (larceny-register-name $r.argreg2 "%argreg2")
  (larceny-register-name $r.argreg3 "%argreg3")
  (larceny-register-name $r.tmp1 "%tmp1")
  (larceny-register-name $r.tmp2 "%tmp2")
  (larceny-register-name $r.reg0 "%r0")
  (larceny-register-name $r.reg1 "%r1")
  (larceny-register-name $r.reg2 "%r2")
  (larceny-register-name $r.reg3 "%r3")
  (larceny-register-name $r.reg4 "%r4")
  (larceny-register-name $r.reg5 "%r5")
  (larceny-register-name $r.reg6 "%r6")
  (larceny-register-name $r.reg7 "%r7")
  (larceny-register-name $r.e-top "%etop")
  (larceny-register-name $r.e-limit "%elim")
  (larceny-register-name $r.timer "%timer")
  (larceny-register-name $r.millicode "%millicode")
  (larceny-register-name $r.globals "%globals")
  (larceny-register-name $r.stkp "%stkp")       ; note: after elim

  (millicode-name $m.alloc "alloc")
  (millicode-name $m.alloci "alloci")
  (millicode-name $m.gc "gc")
  (millicode-name $m.addtrans "addtrans")
  (millicode-name $m.stkoflow "stkoflow")
  (millicode-name $m.stkuflow "stkuflow")
  (millicode-name $m.creg "creg")
  (millicode-name $m.creg-set! "creg-set!")
  (millicode-name $m.add "+")
  (millicode-name $m.subtract "- (binary)")
  (millicode-name $m.multiply "*")
  (millicode-name $m.quotient "quotient")
  (millicode-name $m.remainder "remainder")
  (millicode-name $m.divide "/")
  (millicode-name $m.modulo "modulo")
  (millicode-name $m.negate "- (unary)")
  (millicode-name $m.numeq "=")
  (millicode-name $m.numlt "<")
  (millicode-name $m.numle "<=")
  (millicode-name $m.numgt ">")
  (millicode-name $m.numge ">=")
  (millicode-name $m.zerop "zero?")
  (millicode-name $m.complexp "complex?")
  (millicode-name $m.realp "real?")
  (millicode-name $m.rationalp "rational?")
  (millicode-name $m.integerp "integer?")
  (millicode-name $m.exactp "exact?")
  (millicode-name $m.inexactp "inexact?")
  (millicode-name $m.exact->inexact "exact->inexact")
  (millicode-name $m.inexact->exact "inexact->exact")
  (millicode-name $m.make-rectangular "make-rectangular")
  (millicode-name $m.real-part "real-part")
  (millicode-name $m.imag-part "imag-part")
  (millicode-name $m.sqrt "sqrt")
  (millicode-name $m.round "round")
  (millicode-name $m.truncate "truncate")
  (millicode-name $m.apply "apply")
  (millicode-name $m.varargs "varargs")
  (millicode-name $m.typetag "typetag")
  (millicode-name $m.typetag-set "typetag-set")
  (millicode-name $m.break "break")
  (millicode-name $m.eqv "eqv?")
  (millicode-name $m.partial-list->vector "partial-list->vector")
  (millicode-name $m.timer-exception "timer-exception")
  (millicode-name $m.exception "exception")
  (millicode-name $m.singlestep "singlestep")
  (millicode-name $m.syscall "syscall")
  (millicode-name $m.bvlcmp "bvlcmp")
  (millicode-name $m.enable-interrupts "enable-interrupts")
  (millicode-name $m.disable-interrupts "disable-interrupts")
  (millicode-name $m.alloc-bv "alloc-bv")
  (millicode-name $m.global-ex "global-exception")
  (millicode-name $m.invoke-ex "invoke-exception")
  (millicode-name $m.global-invoke-ex "global-invoke-exception")
  (millicode-name $m.argc-ex "argc-exception")

  (set! format-instruction format-instr)
  'format-instruction)


; eof


; ----------------------------------------------------------------------

(define (twobit-benchmark type . rest)
  (let ((k (if (null? rest) 1 (car rest))))
    (run-benchmark 
     "twobit"
     k
     (lambda () 
       (case type
         ((long) 
          (compiler-switches 'fast-safe)
          (benchmark-block-mode #f)
          (compile-file "benchmarks/twobit-input-long.sch"))
         ((short) 
          (compiler-switches 'fast-safe)
          (benchmark-block-mode #t)
          (compile-file "benchmarks/twobit-input-short.sch"))
         (else
          (error "Benchmark type must be `long' or `short': " type))))
     (lambda (result)
       #t))))

; eof