--- /dev/null
+; 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 signalled, 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
+\f; 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
+\f; 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
+\f; 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))))
+
+\f; 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))
+
+\f; 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 nonnegative 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 nonnegative 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 nonnegative 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 nonnegative 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 nonnegative 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 nonnegative 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 nonnegative 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 signalled. 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 signalled.
+;
+; If RS2/IMM is not #f, then it is a register or immediate that is moved
+; to ARGREG2 before the exception is signalled; 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 nonnegative 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.
+
+\f; 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*))
+
+\f; 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)
+
+
+\f; 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
HCoop / bpt / guile.git / blobdiff