1 ; Complete source for Twobit and Sparc assembler in one file.
2 ; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
4 ; See 'twobit-benchmark', at end.
6 ; Copyright 1998 Lars T Hansen.
8 ; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
10 ; Completely fundamental pathname manipulation.
12 ; This takes zero or more directory components and a file name and
13 ; constructs a filename relative to the current directory.
15 (define (make-relative-filename . components)
21 (cons "/" (construct (cdr l))))))
23 (if (null? (cdr components))
25 (apply string-append (construct components))))
27 ; This takes one or more directory components and constructs a
28 ; directory name with proper termination (a crock -- we can finess
31 (define (pathname-append . components)
34 (cond ((null? (cdr l))
36 ((string=? (car l) "")
38 ((char=? #\/ (string-ref (car l) (- (string-length (car l)) 1)))
39 (cons (car l) (construct (cdr l))))
42 (cons "/" (construct (cdr l)))))))
44 (let ((n (if (null? (cdr components))
46 (apply string-append (construct components)))))
47 (if (not (char=? #\/ (string-ref n (- (string-length n) 1))))
52 ; Copyright 1998 Lars T Hansen.
54 ; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
56 ; Nbuild parameters for SPARC Larceny.
58 (define (make-nbuild-parameter dir source? verbose? hostdir hostname)
60 `((compiler . ,(pathname-append dir "Compiler"))
61 (util . ,(pathname-append dir "Util"))
62 (build . ,(pathname-append dir "Rts" "Build"))
63 (source . ,(pathname-append dir "Lib"))
64 (common-source . ,(pathname-append dir "Lib" "Common"))
65 (repl-source . ,(pathname-append dir "Repl"))
66 (interp-source . ,(pathname-append dir "Eval"))
67 (machine-source . ,(pathname-append dir "Lib" "Sparc"))
68 (common-asm . ,(pathname-append dir "Asm" "Common"))
69 (sparc-asm . ,(pathname-append dir "Asm" "Sparc"))
70 (target-machine . SPARC)
73 (always-source? . ,source?)
74 (verbose-load? . ,verbose?)
75 (compatibility . ,(pathname-append dir "Compat" hostdir))
76 (host-system . ,hostname)
79 (let ((probe (assq key parameters)))
84 (define nbuild-parameter
85 (make-nbuild-parameter "" #f #f "Larceny" "Larceny"))
88 ; Copyright 1998 Lars T Hansen.
90 ; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
92 ; Useful list functions.
95 ; * Reduce, reduce-right, fold-right, fold-left are compatible with MIT Scheme.
96 ; * Make-list is compatible with MIT Scheme and Chez Scheme.
97 ; * These are not (yet) compatible with Shivers's proposed list functions.
98 ; * remq, remv, remove, remq!, remv!, remov!, every?, and some? are in the
101 ; Destructively remove all associations whose key matches `key' from `alist'.
103 (define (aremq! key alist)
104 (cond ((null? alist) alist)
105 ((eq? key (caar alist))
106 (aremq! key (cdr alist)))
108 (set-cdr! alist (aremq! key (cdr alist)))
111 (define (aremv! key alist)
112 (cond ((null? alist) alist)
113 ((eqv? key (caar alist))
114 (aremv! key (cdr alist)))
116 (set-cdr! alist (aremv! key (cdr alist)))
119 (define (aremove! key alist)
120 (cond ((null? alist) alist)
121 ((equal? key (caar alist))
122 (aremove! key (cdr alist)))
124 (set-cdr! alist (aremove! key (cdr alist)))
127 ; Return a list of elements of `list' selected by the predicate.
129 (define (filter select? list)
130 (cond ((null? list) list)
131 ((select? (car list))
132 (cons (car list) (filter select? (cdr list))))
134 (filter select? (cdr list)))))
136 ; Return the first element of `list' selected by the predicate.
138 (define (find selected? list)
139 (cond ((null? list) #f)
140 ((selected? (car list)) (car list))
141 (else (find selected? (cdr list)))))
143 ; Return a list with all duplicates (according to predicate) removed.
145 (define (remove-duplicates list same?)
147 (define (member? x list)
148 (cond ((null? list) #f)
149 ((same? x (car list)) #t)
150 (else (member? x (cdr list)))))
152 (cond ((null? list) list)
153 ((member? (car list) (cdr list))
154 (remove-duplicates (cdr list) same?))
156 (cons (car list) (remove-duplicates (cdr list) same?)))))
158 ; Return the least element of `list' according to some total order.
160 (define (least less? list)
161 (reduce (lambda (a b) (if (less? a b) a b)) #f list))
163 ; Return the greatest element of `list' according to some total order.
165 (define (greatest greater? list)
166 (reduce (lambda (a b) (if (greater? a b) a b)) #f list))
168 ; (mappend p l) = (apply append (map p l))
170 (define (mappend proc l)
171 (apply append (map proc l)))
173 ; (make-list n) => (a1 ... an) for some ai
174 ; (make-list n x) => (a1 ... an) where ai = x
176 (define (make-list nelem . rest)
177 (let ((val (if (null? rest) #f (car rest))))
181 (loop (- n 1) (cons val l))))
184 ; (reduce p x ()) => x
185 ; (reduce p x (a)) => a
186 ; (reduce p x (a b ...)) => (p (p a b) ...))
188 (define (reduce proc initial l)
193 (loop (proc val (car l)) (cdr l))))
195 (cond ((null? l) initial)
196 ((null? (cdr l)) (car l))
197 (else (loop (car l) (cdr l)))))
199 ; (reduce-right p x ()) => x
200 ; (reduce-right p x (a)) => a
201 ; (reduce-right p x (a b ...)) => (p a (p b ...))
203 (define (reduce-right proc initial l)
208 (proc (car l) (loop (cdr l)))))
210 (cond ((null? l) initial)
211 ((null? (cdr l)) (car l))
214 ; (fold-left p x (a b ...)) => (p (p (p x a) b) ...)
216 (define (fold-left proc initial l)
219 (fold-left proc (proc initial (car l)) (cdr l))))
221 ; (fold-right p x (a b ...)) => (p a (p b (p ... x)))
223 (define (fold-right proc initial l)
226 (proc (car l) (fold-right proc initial (cdr l)))))
228 ; (iota n) => (0 1 2 ... n-1)
231 (let loop ((n (- n 1)) (r '()))
232 (let ((r (cons n r)))
237 ; (list-head (a1 ... an) m) => (a1 ... am) for m <= n
239 (define (list-head l n)
242 (cons (car l) (list-head (cdr l) (- n 1)))))
246 ; Copyright 1998 Lars T Hansen.
248 ; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
250 ; Larceny -- compatibility library for Twobit running under Larceny.
252 (define ($$trace x) #t)
254 (define host-system 'larceny)
258 (define (.check! flag exn . args)
260 (apply error "Runtime check exception: " exn args)))
262 ; The compatibility library loads Auxlib if compat:initialize is called
263 ; without arguments. Compat:load will load fasl files when appropriate.
265 (define (compat:initialize . rest)
267 (let ((dir (nbuild-parameter 'compatibility)))
268 (compat:load (string-append dir "compat2.sch"))
269 (compat:load (string-append dir "../../Auxlib/list.sch"))
270 (compat:load (string-append dir "../../Auxlib/pp.sch")))))
272 (define (with-optimization level thunk)
275 ; Calls thunk1, and if thunk1 causes an error to be signalled, calls thunk2.
277 (define (call-with-error-control thunk1 thunk2)
278 (let ((eh (error-handler)))
279 (error-handler (lambda args
286 (define (larc-new-extension fn ext)
287 (let* ((l (string-length fn))
288 (x (let loop ((i (- l 1)))
290 ((char=? (string-ref fn i) #\.) (+ i 1))
291 (else (loop (- i 1)))))))
293 (string-append fn "." ext)
294 (string-append (substring fn 0 x) ext))))
296 (define (compat:load filename)
298 (if (nbuild-parameter 'verbose-load?)
299 (format #t "~a~%" fn))
301 (if (nbuild-parameter 'always-source?)
303 (let ((fn (larc-new-extension filename "fasl")))
304 (if (and (file-exists? fn)
305 (compat:file-newer? fn filename))
307 (loadit filename)))))
309 (define (compat:file-newer? a b)
310 (let* ((ta (file-modification-time a))
311 (tb (file-modification-time b))
312 (limit (vector-length ta)))
316 ((= (vector-ref ta i) (vector-ref tb i))
319 (> (vector-ref ta i) (vector-ref tb i)))))))
322 ; Copyright 1998 Lars T Hansen.
324 ; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
326 ; Larceny -- second part of compatibility code
327 ; This file ought to be compiled, but doesn't have to be.
331 (define host-system 'larceny) ; Don't remove this!
333 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
335 ; A well-defined sorting procedure.
337 (define compat:sort (lambda (list less?) (sort list less?)))
340 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
342 ; Well-defined character codes.
343 ; Returns the UCS-2 code for a character.
345 (define compat:char->integer char->integer)
347 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
351 (define (write-lop item port)
352 (lowlevel-write item port)
356 (define write-fasl-datum lowlevel-write)
358 ; The power of self-hosting ;-)
360 (define (misc->bytevector x)
361 (let ((bv (bytevector-like-copy x)))
362 (typetag-set! bv $tag.bytevector-typetag)
365 (define string->bytevector misc->bytevector)
367 (define bignum->bytevector misc->bytevector)
369 (define (flonum->bytevector x)
370 (clear-first-word (misc->bytevector x)))
372 (define (compnum->bytevector x)
373 (clear-first-word (misc->bytevector x)))
375 ; Clears garbage word of compnum/flonum; makes regression testing much
378 (define (clear-first-word bv)
379 (bytevector-like-set! bv 0 0)
380 (bytevector-like-set! bv 1 0)
381 (bytevector-like-set! bv 2 0)
382 (bytevector-like-set! bv 3 0)
385 (define (list->bytevector l)
386 (let ((b (make-bytevector (length l))))
390 (bytevector-set! b i (car l)))))
392 (define bytevector-word-ref
393 (let ((two^8 (expt 2 8))
395 (two^24 (expt 2 24)))
397 (+ (* (bytevector-ref bv i) two^24)
398 (* (bytevector-ref bv (+ i 1)) two^16)
399 (* (bytevector-ref bv (+ i 2)) two^8)
400 (bytevector-ref bv (+ i 3))))))
402 (define (twobit-format fmt . rest)
403 (let ((out (open-output-string)))
404 (apply format out fmt rest)
405 (get-output-string out)))
407 ; This needs to be a random number in both a weaker and stronger sense
408 ; than `random': it doesn't need to be a truly random number, so a sequence
409 ; of calls can return a non-random sequence, but if two processes generate
410 ; two sequences, then those sequences should not be the same.
414 (define (an-arbitrary-number)
415 (system "echo \\\"`date`\\\" > a-random-number")
416 (let ((x (string-hash (call-with-input-file "a-random-number" read))))
417 (delete-file "a-random-number")
420 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
424 (define cerror error)
427 ; Copyright 1991 Wiliam Clinger.
429 ; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
431 ; Sets represented as lists.
435 (define (empty-set) '())
437 (define (empty-set? x) (null? x))
442 ((member (car x) y) (loop (cdr x) y))
443 (else (loop (cdr x) (cons (car x) y)))))
446 (define (set-equal? x y)
447 (and (subset? x y) (subset? y x)))
449 (define (subset? x y)
450 (every? (lambda (x) (member x y))
453 ; To get around MacScheme's limit on the number of arguments.
463 (else (union2 (cdr x) (cons (car x) y)))))))
467 (do ((sets sets (cdr sets))
468 (result '() (union2 (car sets) result)))
473 (cond ((null? args) '())
474 ((null? (cdr args)) (car args))
475 ((null? (cddr args)) (union2 (car args) (cadr args)))
476 (else (union2 (union2 (car args)
478 (apply union (cddr args))))))))
481 (letrec ((intersection2
483 (cond ((null? x) '())
485 (cons (car x) (intersection2 (cdr x) y)))
486 (else (intersection2 (cdr x) y))))))
488 (cond ((null? args) '())
489 ((null? (cdr args)) (car args))
490 ((null? (cddr args)) (intersection2 (car args) (cadr args)))
491 (else (intersection2 (intersection2 (car args)
493 (apply intersection (cddr args))))))))
495 (define (difference x y)
496 (cond ((null? x) '())
498 (difference (cdr x) y))
499 (else (cons (car x) (difference (cdr x) y)))))
500 ; Reasonably portable hashing on EQ?, EQV?, EQUAL?.
501 ; Requires bignums, SYMBOL-HASH.
503 ; Given any Scheme object, returns a non-negative exact integer
506 (define object-hash (lambda (x) 0)) ; hash on EQ?, EQV?
507 (define equal-hash (lambda (x) 0)) ; hash on EQUAL?
512 (adj:negative 8000000)
515 (adj:complex 7700000)
517 (adj:compnum 6900000)
529 (define (combine hash adjustment)
530 (modulo (+ hash hash hash adjustment) 16777216))
532 (define (hash-on-equal x budget)
537 (let ((budget (quotient budget 2)))
538 (combine (hash-on-equal (car x) budget)
539 (hash-on-equal (cdr x) budget))))
541 (let ((n (vector-length x))
542 (budget (quotient budget 4)))
545 (combine (hash-on-equal (vector-ref x 0) budget)
546 (hash-on-equal (vector-ref x (- n 1)) budget))
547 (hash-on-equal (vector-ref x (quotient n 2))
562 (combine (object-hash (- x)) adj:negative))
564 (combine x adj:fixnum))
566 (combine (modulo x n) adj:large))))
568 (combine (combine (object-hash (numerator x))
570 (object-hash (denominator x))))
574 (combine (combine (object-hash (real-part x))
576 (object-hash (imag-part x))))
580 ; We can't really do anything with inexact numbers
581 ; unless infinities and NaNs behave reasonably.
585 (combine (object-hash
586 (inexact->exact (numerator x)))
588 (object-hash (inexact->exact (denominator x)))))
592 (combine (combine (object-hash (real-part x))
594 (object-hash (imag-part x))))
597 (combine (char->integer x) adj:char))
599 (combine (string-length x) adj:string))
601 (combine (vector-length x) adj:vector))
603 (combine 1 adj:misc))
605 (combine 2 adj:misc))
607 (combine 3 adj:misc))
621 (hash-on-equal x budget0)))); Hash tables.
622 ; Requires CALL-WITHOUT-INTERRUPTS.
623 ; This code should be thread-safe provided VECTOR-REF is atomic.
625 ; (make-hashtable <hash-function> <bucket-searcher> <size>)
627 ; Returns a newly allocated mutable hash table
628 ; using <hash-function> as the hash function
629 ; and <bucket-searcher>, e.g. ASSQ, ASSV, ASSOC, to search a bucket
630 ; with <size> buckets at first, expanding the number of buckets as needed.
631 ; The <hash-function> must accept a key and return a non-negative exact
634 ; (make-hashtable <hash-function> <bucket-searcher>)
636 ; Equivalent to (make-hashtable <hash-function> <bucket-searcher> n)
637 ; for some value of n chosen by the implementation.
639 ; (make-hashtable <hash-function>)
641 ; Equivalent to (make-hashtable <hash-function> assv).
645 ; Equivalent to (make-hashtable object-hash assv).
647 ; (hashtable-contains? <hashtable> <key>)
649 ; Returns true iff the <hashtable> contains an entry for <key>.
651 ; (hashtable-fetch <hashtable> <key> <flag>)
653 ; Returns the value associated with <key> in the <hashtable> if the
654 ; <hashtable> contains <key>; otherwise returns <flag>.
656 ; (hashtable-get <hashtable> <key>)
658 ; Equivalent to (hashtable-fetch <hashtable> <key> #f)
660 ; (hashtable-put! <hashtable> <key> <value>)
662 ; Changes the <hashtable> to associate <key> with <value>, replacing
663 ; any existing association for <key>.
665 ; (hashtable-remove! <hashtable> <key>)
667 ; Removes any association for <key> within the <hashtable>.
669 ; (hashtable-clear! <hashtable>)
671 ; Removes all associations from the <hashtable>.
673 ; (hashtable-size <hashtable>)
675 ; Returns the number of keys contained within the <hashtable>.
677 ; (hashtable-for-each <procedure> <hashtable>)
679 ; The <procedure> must accept two arguments, a key and the value
680 ; associated with that key. Calls the <procedure> once for each
681 ; key-value association. The order of these calls is indeterminate.
683 ; (hashtable-map <procedure> <hashtable>)
685 ; The <procedure> must accept two arguments, a key and the value
686 ; associated with that key. Calls the <procedure> once for each
687 ; key-value association, and returns a list of the results. The
688 ; order of the calls is indeterminate.
690 ; (hashtable-copy <hashtable>)
692 ; Returns a copy of the <hashtable>.
694 ; These global variables are assigned new values later.
696 (define make-hashtable (lambda args '*))
697 (define hashtable-contains? (lambda (ht key) #f))
698 (define hashtable-fetch (lambda (ht key flag) flag))
699 (define hashtable-get (lambda (ht key) (hashtable-fetch ht key #f)))
700 (define hashtable-put! (lambda (ht key val) '*))
701 (define hashtable-remove! (lambda (ht key) '*))
702 (define hashtable-clear! (lambda (ht) '*))
703 (define hashtable-size (lambda (ht) 0))
704 (define hashtable-for-each (lambda (ht proc) '*))
705 (define hashtable-map (lambda (ht proc) '()))
706 (define hashtable-copy (lambda (ht) ht))
709 ; A hashtable is represented as a vector of the form
711 ; #(("HASHTABLE") <count> <hasher> <searcher> <buckets>)
713 ; where <count> is the number of associations within the hashtable,
714 ; <hasher> is the hash function, <searcher> is the bucket searcher,
715 ; and <buckets> is a vector of buckets.
717 ; The <hasher> and <searcher> fields are constant, but
718 ; the <count> and <buckets> fields are mutable.
720 ; For thread-safe operation, the mutators must modify both
721 ; as an atomic operation. Other operations do not require
722 ; critical sections provided VECTOR-REF is an atomic operation
723 ; and the operation does not modify the hashtable, does not
724 ; reference the <count> field, and fetches the <buckets>
725 ; field exactly once.
727 (let ((doc (list "HASHTABLE"))
728 (count (lambda (ht) (vector-ref ht 1)))
729 (count! (lambda (ht n) (vector-set! ht 1 n)))
730 (hasher (lambda (ht) (vector-ref ht 2)))
731 (searcher (lambda (ht) (vector-ref ht 3)))
732 (buckets (lambda (ht) (vector-ref ht 4)))
733 (buckets! (lambda (ht v) (vector-set! ht 4 v)))
735 (let ((hashtable? (lambda (ht)
737 (= 5 (vector-length ht))
738 (eq? doc (vector-ref ht 0)))))
739 (hashtable-error (lambda (x)
740 (display "ERROR: Bad hash table: ")
745 ; Internal operations.
747 (define (make-ht hashfun searcher size)
748 (vector doc 0 hashfun searcher (make-vector size '())))
750 ; Substitute x for the first occurrence of y within the list z.
751 ; y is known to occur within z.
753 (define (substitute1 x y z)
754 (cond ((eq? y (car z))
758 (substitute1 x y (cdr z))))))
760 ; Remove the first occurrence of x from y.
761 ; x is known to occur within y.
764 (cond ((eq? x (car y))
768 (remq1 x (cdr y))))))
771 (call-without-interrupts
773 (let ((ht (make-ht (hasher ht0)
775 (+ 1 (* 2 (count ht0))))))
776 (ht-for-each (lambda (key val)
779 (buckets! ht0 (buckets ht))))))
781 ; Returns the contents of the hashtable as a vector of pairs.
783 (define (contents ht)
784 (let* ((v (buckets ht))
785 (n (vector-length v))
786 (z (make-vector (count ht) '())))
787 (define (loop i bucket j)
790 (if (= j (vector-length z))
792 (begin (display "BUG in hashtable")
798 (let ((entry (car bucket)))
799 (vector-set! z j (cons (car entry) (cdr entry)))
805 (define (contains? ht key)
807 (let* ((v (buckets ht))
808 (n (vector-length v))
809 (h (modulo ((hasher ht) key) n))
810 (b (vector-ref v h)))
811 (if ((searcher ht) key b)
814 (hashtable-error ht)))
816 (define (fetch ht key flag)
818 (let* ((v (buckets ht))
819 (n (vector-length v))
820 (h (modulo ((hasher ht) key) n))
822 (probe ((searcher ht) key b)))
826 (hashtable-error ht)))
828 (define (put! ht key val)
830 (call-without-interrupts
832 (let* ((v (buckets ht))
833 (n (vector-length v))
834 (h (modulo ((hasher ht) key) n))
836 (probe ((searcher ht) key b)))
838 ; Using SET-CDR! on the probe would make it necessary
839 ; to synchronize the CONTENTS routine.
840 (vector-set! v h (substitute1 (cons key val) probe b))
841 (begin (count! ht (+ (count ht) 1))
842 (vector-set! v h (cons (cons key val) b))
846 (hashtable-error ht)))
848 (define (remove! ht key)
850 (call-without-interrupts
852 (let* ((v (buckets ht))
853 (n (vector-length v))
854 (h (modulo ((hasher ht) key) n))
856 (probe ((searcher ht) key b)))
858 (begin (count! ht (- (count ht) 1))
859 (vector-set! v h (remq1 probe b))
860 (if (< (* 2 (+ defaultn (count ht))) n)
863 (hashtable-error ht)))
867 (call-without-interrupts
870 (buckets! ht (make-vector defaultn '()))
872 (hashtable-error ht)))
877 (hashtable-error ht)))
879 ; This code must be written so that the procedure can modify the
880 ; hashtable without breaking any invariants.
882 (define (ht-for-each f ht)
884 (let* ((v (contents ht))
885 (n (vector-length v)))
888 (let ((x (vector-ref v j)))
889 (f (car x) (cdr x)))))
890 (hashtable-error ht)))
892 (define (ht-map f ht)
894 (let* ((v (contents ht))
895 (n (vector-length v)))
897 (results '() (let ((x (vector-ref v j)))
898 (cons (f (car x) (cdr x))
902 (hashtable-error ht)))
906 (let* ((newtable (make-hashtable (hasher ht) (searcher ht) 0))
908 (n (vector-length v))
909 (newvector (make-vector n '())))
910 (count! newtable (count ht))
911 (buckets! newtable newvector)
914 (vector-set! newvector i (append (vector-ref v i) '())))
916 (hashtable-error ht)))
918 ; External entry points.
922 (let* ((hashfun (if (null? args) object-hash (car args)))
923 (searcher (if (or (null? args) (null? (cdr args)))
926 (size (if (or (null? args) (null? (cdr args)) (null? (cddr args)))
929 (make-ht hashfun searcher size))))
931 (set! hashtable-contains? (lambda (ht key) (contains? ht key)))
932 (set! hashtable-fetch (lambda (ht key flag) (fetch ht key flag)))
933 (set! hashtable-get (lambda (ht key) (fetch ht key #f)))
934 (set! hashtable-put! (lambda (ht key val) (put! ht key val)))
935 (set! hashtable-remove! (lambda (ht key) (remove! ht key)))
936 (set! hashtable-clear! (lambda (ht) (clear! ht)))
937 (set! hashtable-size (lambda (ht) (size ht)))
938 (set! hashtable-for-each (lambda (ht proc) (ht-for-each ht proc)))
939 (set! hashtable-map (lambda (ht proc) (ht-map ht proc)))
940 (set! hashtable-copy (lambda (ht) (ht-copy ht)))
942 ; Hash trees: a functional data structure analogous to hash tables.
944 ; (make-hashtree <hash-function> <bucket-searcher>)
946 ; Returns a newly allocated mutable hash table
947 ; using <hash-function> as the hash function
948 ; and <bucket-searcher>, e.g. ASSQ, ASSV, ASSOC, to search a bucket.
949 ; The <hash-function> must accept a key and return a non-negative exact
952 ; (make-hashtree <hash-function>)
954 ; Equivalent to (make-hashtree <hash-function> assv).
958 ; Equivalent to (make-hashtree object-hash assv).
960 ; (hashtree-contains? <hashtree> <key>)
962 ; Returns true iff the <hashtree> contains an entry for <key>.
964 ; (hashtree-fetch <hashtree> <key> <flag>)
966 ; Returns the value associated with <key> in the <hashtree> if the
967 ; <hashtree> contains <key>; otherwise returns <flag>.
969 ; (hashtree-get <hashtree> <key>)
971 ; Equivalent to (hashtree-fetch <hashtree> <key> #f)
973 ; (hashtree-put <hashtree> <key> <value>)
975 ; Returns a new hashtree that is like <hashtree> except that
976 ; <key> is associated with <value>.
978 ; (hashtree-remove <hashtree> <key>)
980 ; Returns a new hashtree that is like <hashtree> except that
981 ; <key> is not associated with any value.
983 ; (hashtree-size <hashtree>)
985 ; Returns the number of keys contained within the <hashtree>.
987 ; (hashtree-for-each <procedure> <hashtree>)
989 ; The <procedure> must accept two arguments, a key and the value
990 ; associated with that key. Calls the <procedure> once for each
991 ; key-value association. The order of these calls is indeterminate.
993 ; (hashtree-map <procedure> <hashtree>)
995 ; The <procedure> must accept two arguments, a key and the value
996 ; associated with that key. Calls the <procedure> once for each
997 ; key-value association, and returns a list of the results. The
998 ; order of the calls is indeterminate.
1000 ; These global variables are assigned new values later.
1002 (define make-hashtree (lambda args '*))
1003 (define hashtree-contains? (lambda (ht key) #f))
1004 (define hashtree-fetch (lambda (ht key flag) flag))
1005 (define hashtree-get (lambda (ht key) (hashtree-fetch ht key #f)))
1006 (define hashtree-put (lambda (ht key val) '*))
1007 (define hashtree-remove (lambda (ht key) '*))
1008 (define hashtree-size (lambda (ht) 0))
1009 (define hashtree-for-each (lambda (ht proc) '*))
1010 (define hashtree-map (lambda (ht proc) '()))
1013 ; A hashtree is represented as a vector of the form
1015 ; #(("hashtree") <count> <hasher> <searcher> <buckets>)
1017 ; where <count> is the number of associations within the hashtree,
1018 ; <hasher> is the hash function, <searcher> is the bucket searcher,
1019 ; and <buckets> is generated by the following grammar:
1022 ; | (<fixnum> <associations> <buckets> <buckets>)
1023 ; <alist> ::= (<associations>)
1024 ; <associations> ::=
1025 ; | <association> <associations>
1026 ; <association> ::= (<key> . <value>)
1028 ; If <buckets> is of the form (n alist buckets1 buckets2),
1029 ; then n is the hash code of all keys in alist, all keys in buckets1
1030 ; have a hash code less than n, and all keys in buckets2 have a hash
1031 ; code greater than n.
1033 (let ((doc (list "hashtree"))
1034 (count (lambda (ht) (vector-ref ht 1)))
1035 (hasher (lambda (ht) (vector-ref ht 2)))
1036 (searcher (lambda (ht) (vector-ref ht 3)))
1037 (buckets (lambda (ht) (vector-ref ht 4)))
1039 (make-empty-buckets (lambda () '()))
1042 (lambda (h alist buckets1 buckets2)
1043 (list h alist buckets1 buckets2)))
1045 (buckets-empty? (lambda (buckets) (null? buckets)))
1047 (buckets-n (lambda (buckets) (car buckets)))
1048 (buckets-alist (lambda (buckets) (cadr buckets)))
1049 (buckets-left (lambda (buckets) (caddr buckets)))
1050 (buckets-right (lambda (buckets) (cadddr buckets))))
1052 (let ((hashtree? (lambda (ht)
1054 (= 5 (vector-length ht))
1055 (eq? doc (vector-ref ht 0)))))
1056 (hashtree-error (lambda (x)
1057 (display "ERROR: Bad hash tree: ")
1062 ; Internal operations.
1064 (define (make-ht count hashfun searcher buckets)
1065 (vector doc count hashfun searcher buckets))
1067 ; Substitute x for the first occurrence of y within the list z.
1068 ; y is known to occur within z.
1070 (define (substitute1 x y z)
1071 (cond ((eq? y (car z))
1075 (substitute1 x y (cdr z))))))
1077 ; Remove the first occurrence of x from y.
1078 ; x is known to occur within y.
1081 (cond ((eq? x (car y))
1085 (remq1 x (cdr y))))))
1087 ; Returns the contents of the hashtree as a list of pairs.
1089 (define (contents ht)
1090 (let* ((t (buckets ht)))
1092 (define (contents t alist)
1093 (if (buckets-empty? t)
1095 (contents (buckets-left t)
1096 (contents (buckets-right t)
1097 (append-reverse (buckets-alist t)
1100 (define (append-reverse x y)
1103 (append-reverse (cdr x)
1106 ; Creating a new hashtree from a list that is almost sorted
1107 ; in hash code order would create an extremely unbalanced
1108 ; hashtree, so this routine randomizes the order a bit.
1110 (define (randomize1 alist alist1 alist2 alist3)
1112 (randomize-combine alist1 alist2 alist3)
1113 (randomize2 (cdr alist)
1114 (cons (car alist) alist1)
1118 (define (randomize2 alist alist1 alist2 alist3)
1120 (randomize-combine alist1 alist2 alist3)
1121 (randomize3 (cdr alist)
1123 (cons (car alist) alist2)
1126 (define (randomize3 alist alist1 alist2 alist3)
1128 (randomize-combine alist1 alist2 alist3)
1129 (randomize1 (cdr alist)
1132 (cons (car alist) alist3))))
1134 (define (randomize-combine alist1 alist2 alist3)
1135 (cond ((null? alist2)
1138 (append-reverse alist2 alist1))
1141 (randomize1 alist3 '() '() '())
1143 (randomize1 alist1 '() '() '())
1144 (randomize1 alist2 '() '() '()))))))
1146 (randomize1 (contents t '()) '() '() '())))
1148 (define (contains? ht key)
1150 (let* ((t (buckets ht))
1151 (h ((hasher ht) key)))
1152 (if ((searcher ht) key (find-bucket t h))
1155 (hashtree-error ht)))
1157 (define (fetch ht key flag)
1159 (let* ((t (buckets ht))
1160 (h ((hasher ht) key))
1161 (probe ((searcher ht) key (find-bucket t h))))
1165 (hashtree-error ht)))
1167 ; Given a <buckets> t and a hash code h, returns the alist for h.
1169 (define (find-bucket t h)
1170 (if (buckets-empty? t)
1172 (let ((n (buckets-n t)))
1174 (find-bucket (buckets-left t) h))
1176 (find-bucket (buckets-right t) h))
1178 (buckets-alist t))))))
1180 (define (put ht key val)
1182 (let ((t (buckets ht))
1183 (h ((hasher ht) key))
1184 (association (cons key val))
1187 (if (buckets-empty? t)
1188 (begin (set! c (+ c 1))
1189 (make-buckets h (list association) t t))
1190 (let ((n (buckets-n t))
1191 (alist (buckets-alist t))
1192 (left (buckets-left t))
1193 (right (buckets-right t)))
1197 (put (buckets-left t) h)
1203 (put (buckets-right t) h)))
1205 (let ((probe ((searcher ht) key alist)))
1208 (substitute1 association
1216 (cons association alist)
1219 (let ((buckets (put t h)))
1220 (make-ht c (hasher ht) (searcher ht) buckets)))
1221 (hashtree-error ht)))
1223 (define (remove ht key)
1225 (let ((t (buckets ht))
1226 (h ((hasher ht) key))
1228 (define (remove t h)
1229 (if (buckets-empty? t)
1231 (let ((n (buckets-n t))
1232 (alist (buckets-alist t))
1233 (left (buckets-left t))
1234 (right (buckets-right t)))
1246 (let ((probe ((searcher ht) key alist)))
1248 (begin (set! c (- c 1))
1254 (let ((buckets (remove t h)))
1255 (make-ht c (hasher ht) (searcher ht) buckets)))
1256 (hashtree-error ht)))
1261 (hashtree-error ht)))
1263 (define (ht-for-each f ht)
1265 (for-each (lambda (association)
1266 (f (car association)
1269 (hashtree-error ht)))
1271 (define (ht-map f ht)
1273 (map (lambda (association)
1274 (f (car association)
1277 (hashtree-error ht)))
1279 ; External entry points.
1283 (let* ((hashfun (if (null? args) object-hash (car args)))
1284 (searcher (if (or (null? args) (null? (cdr args)))
1287 (make-ht 0 hashfun searcher (make-empty-buckets)))))
1289 (set! hashtree-contains? (lambda (ht key) (contains? ht key)))
1290 (set! hashtree-fetch (lambda (ht key flag) (fetch ht key flag)))
1291 (set! hashtree-get (lambda (ht key) (fetch ht key #f)))
1292 (set! hashtree-put (lambda (ht key val) (put ht key val)))
1293 (set! hashtree-remove (lambda (ht key) (remove ht key)))
1294 (set! hashtree-size (lambda (ht) (size ht)))
1295 (set! hashtree-for-each (lambda (ht proc) (ht-for-each ht proc)))
1296 (set! hashtree-map (lambda (ht proc) (ht-map ht proc)))
1298 ; Copyright 1994 William Clinger
1300 ; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
1304 ; Compiler switches needed by Twobit.
1306 (define make-twobit-flag)
1307 (define display-twobit-flag)
1309 (define make-twobit-flag
1312 (define (twobit-warning)
1313 (display "Error: incorrect arguments to ")
1318 (define (display-flag state)
1319 (display (if state " + " " - "))
1322 (display (if state "on" "off"))
1327 (cond ((null? args) state)
1328 ((and (null? (cdr args))
1329 (boolean? (car args)))
1330 (set! state (car args))
1332 ((and (null? (cdr args))
1333 (eq? (car args) 'display))
1334 (display-flag state))
1335 (else (twobit-warning)))))))
1337 (define (display-twobit-flag flag)
1340 ; Debugging and convenience.
1342 (define issue-warnings
1343 (make-twobit-flag 'issue-warnings))
1345 (define include-source-code
1346 (make-twobit-flag 'include-source-code))
1348 (define include-variable-names
1349 (make-twobit-flag 'include-variable-names))
1351 (define include-procedure-names
1352 (make-twobit-flag 'include-procedure-names))
1355 ; This switch isn't fully implemented yet. If it is true, then
1356 ; Twobit will generate flat closures and will go to some trouble
1357 ; to zero stale registers and stack slots.
1358 ; Don't turn this switch off unless space is more important than speed.
1360 (define avoid-space-leaks
1361 (make-twobit-flag 'avoid-space-leaks))
1363 ; Major optimizations.
1365 (define integrate-usual-procedures
1366 (make-twobit-flag 'integrate-usual-procedures))
1368 (define control-optimization
1369 (make-twobit-flag 'control-optimization))
1371 (define parallel-assignment-optimization
1372 (make-twobit-flag 'parallel-assignment-optimization))
1374 (define lambda-optimization
1375 (make-twobit-flag 'lambda-optimization))
1377 (define benchmark-mode
1378 (make-twobit-flag 'benchmark-mode))
1380 (define benchmark-block-mode
1381 (make-twobit-flag 'benchmark-block-mode))
1383 (define global-optimization
1384 (make-twobit-flag 'global-optimization))
1386 (define interprocedural-inlining
1387 (make-twobit-flag 'interprocedural-inlining))
1389 (define interprocedural-constant-propagation
1390 (make-twobit-flag 'interprocedural-constant-propagation))
1392 (define common-subexpression-elimination
1393 (make-twobit-flag 'common-subexpression-elimination))
1395 (define representation-inference
1396 (make-twobit-flag 'representation-inference))
1398 (define local-optimization
1399 (make-twobit-flag 'local-optimization))
1401 ; For backwards compatibility, until I can change the code.
1403 (define (ignore-space-leaks . args)
1405 (not (avoid-space-leaks))
1406 (avoid-space-leaks (not (car args)))))
1408 (define lambda-optimizations lambda-optimization)
1409 (define local-optimizations local-optimization)
1411 (define (set-compiler-flags! how)
1414 (set-compiler-flags! 'standard)
1415 (avoid-space-leaks #t)
1416 (integrate-usual-procedures #f)
1417 (control-optimization #f)
1418 (parallel-assignment-optimization #f)
1419 (lambda-optimization #f)
1421 (benchmark-block-mode #f)
1422 (global-optimization #f)
1423 (interprocedural-inlining #f)
1424 (interprocedural-constant-propagation #f)
1425 (common-subexpression-elimination #f)
1426 (representation-inference #f)
1427 (local-optimization #f))
1430 (include-source-code #f)
1431 (include-procedure-names #t)
1432 (include-variable-names #t)
1433 (avoid-space-leaks #f)
1434 (runtime-safety-checking #t)
1435 (integrate-usual-procedures #f)
1436 (control-optimization #t)
1437 (parallel-assignment-optimization #t)
1438 (lambda-optimization #t)
1440 (benchmark-block-mode #f)
1441 (global-optimization #t)
1442 (interprocedural-inlining #t)
1443 (interprocedural-constant-propagation #t)
1444 (common-subexpression-elimination #t)
1445 (representation-inference #t)
1446 (local-optimization #t))
1448 (let ((bbmode (benchmark-block-mode)))
1449 (set-compiler-flags! 'standard)
1450 (integrate-usual-procedures #t)
1452 (benchmark-block-mode bbmode)))
1454 (set-compiler-flags! 'fast-safe)
1455 (runtime-safety-checking #f))
1457 (error "set-compiler-flags!: unknown mode " how))))
1459 (define (display-twobit-flags which)
1462 (display-twobit-flag issue-warnings)
1463 (display-twobit-flag include-procedure-names)
1464 (display-twobit-flag include-variable-names)
1465 (display-twobit-flag include-source-code))
1467 (display-twobit-flag avoid-space-leaks))
1469 (display-twobit-flag integrate-usual-procedures)
1470 (display-twobit-flag control-optimization)
1471 (display-twobit-flag parallel-assignment-optimization)
1472 (display-twobit-flag lambda-optimization)
1473 (display-twobit-flag benchmark-mode)
1474 (display-twobit-flag benchmark-block-mode)
1475 (display-twobit-flag global-optimization)
1476 (if (global-optimization)
1477 (begin (display " ")
1478 (display-twobit-flag interprocedural-inlining)
1480 (display-twobit-flag interprocedural-constant-propagation)
1482 (display-twobit-flag common-subexpression-elimination)
1484 (display-twobit-flag representation-inference)))
1485 (display-twobit-flag local-optimization))
1487 ; The switch might mean something to the assembler, but not to Twobit
1491 ; Copyright 1991 William Clinger
1493 ; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
1495 ; 14 April 1999 / wdc
1497 ($$trace "pass1.aux")
1499 ;***************************************************************
1501 ; Each definition in this section should be overridden by an assignment
1502 ; in a target-specific file.
1504 ; If a lambda expression has more than @maxargs-with-rest-arg@ required
1505 ; arguments followed by a rest argument, then the macro expander will
1506 ; rewrite the lambda expression as a lambda expression with only one
1507 ; argument (a rest argument) whose body is a LET that binds the arguments
1508 ; of the original lambda expression.
1510 (define @maxargs-with-rest-arg@
1513 (define (prim-entry name) #f) ; no integrable procedures
1514 (define (prim-arity name) 0) ; all of which take 0 arguments
1515 (define (prim-opcodename name) name) ; and go by their source names
1517 ; End of definitions to be overridden by target-specific assignments.
1519 ;***************************************************************
1521 ; Miscellaneous routines.
1523 (define (m-warn msg . more)
1524 (if (issue-warnings)
1526 (display "WARNING from macro expander:")
1530 (for-each (lambda (x) (write x) (newline))
1533 (define (m-error msg . more)
1534 (display "ERROR detected during macro expansion:")
1538 (for-each (lambda (x) (write x) (newline))
1540 (m-quit (make-constant #f)))
1542 (define (m-bug msg . more)
1543 (display "BUG in macro expander: ")
1547 (for-each (lambda (x) (write x) (newline))
1549 (m-quit (make-constant #f)))
1551 ; Given a <formals>, returns a list of bound variables.
1554 (define (make-null-terminated x)
1555 (cond ((null? x) '())
1557 (cons (car x) (make-null-terminated (cdr x))))
1560 ; Returns the length of the given list, or -1 if the argument
1561 ; is not a list. Does not check for circular lists.
1563 (define (safe-length x)
1566 ((pair? x) (loop (cdr x) (+ n 1)))
1570 ; Given a unary predicate and a list, returns a list of those
1571 ; elements for which the predicate is true.
1573 (define (filter1 p x)
1574 (cond ((null? x) '())
1575 ((p (car x)) (cons (car x) (filter1 p (cdr x))))
1576 (else (filter1 p (cdr x)))))
1578 ; Given a unary predicate and a list, returns #t if the
1579 ; predicate is true of every element of the list.
1581 (define (every1? p x)
1582 (cond ((null? x) #t)
1583 ((p (car x)) (every1? p (cdr x)))
1586 ; Binary union of two sets represented as lists, using equal?.
1588 (define (union2 x y)
1592 (else (union2 (cdr x) (cons (car x) y)))))
1594 ; Given an association list, copies the association pairs.
1596 (define (copy-alist alist)
1597 (map (lambda (x) (cons (car x) (cdr x)))
1600 ; Removes a value from a list. May destroy the list.
1604 (letrec ((loop (lambda (x y prev)
1605 (cond ((null? y) #t)
1607 (set-cdr! prev (cdr y))
1608 (loop x (cdr prev) prev))
1610 (loop x (cdr y) y))))))
1612 (cond ((null? y) '())
1619 ; Procedure-specific source code transformations.
1620 ; The transformer is passed a source code expression and a predicate
1621 ; and returns one of:
1623 ; the original source code expression
1624 ; a new source code expression to use in place of the original
1625 ; #f to indicate that the procedure is being called
1626 ; with an incorrect number of arguments or
1627 ; with an incorrect operand
1629 ; The original source code expression is guaranteed to be a list whose
1630 ; car is the name associated with the transformer.
1631 ; The predicate takes an identifier (a symbol) and returns true iff
1632 ; that identifier is bound to something other than its global binding.
1634 ; Since the procedures and their transformations are target-specific,
1635 ; they are defined in another file, in the Target subdirectory.
1638 ; I think this is now used in only one place, in simplify-if.
1640 (define (integrable? name)
1641 (and (integrate-usual-procedures)
1644 ; MAKE-READABLE strips the referencing information
1645 ; and replaces (begin I) by I.
1646 ; If the optional argument is true, then it also reconstructs LET.
1648 (define (make-readable exp . rest)
1649 (let ((fancy? (and (not (null? rest))
1651 (define (make-readable exp)
1653 ((quote) (make-readable-quote exp))
1654 ((lambda) `(lambda ,(lambda.args exp)
1655 ,@(map (lambda (def)
1656 `(define ,(def.lhs def)
1657 ,(make-readable (def.rhs def))))
1659 ,(make-readable (lambda.body exp))))
1660 ((set!) `(set! ,(assignment.lhs exp)
1661 ,(make-readable (assignment.rhs exp))))
1662 ((if) `(if ,(make-readable (if.test exp))
1663 ,(make-readable (if.then exp))
1664 ,(make-readable (if.else exp))))
1665 ((begin) (if (variable? exp)
1667 `(begin ,@(map make-readable (begin.exprs exp)))))
1668 (else (make-readable-call exp))))
1669 (define (make-readable-quote exp)
1670 (let ((x (constant.value exp)))
1678 (define (make-readable-call exp)
1679 (let ((proc (call.proc exp)))
1682 (list? (lambda.args proc)))
1683 ;(make-readable-let* exp '() '() '())
1684 (make-readable-let exp)
1685 `(,(make-readable (call.proc exp))
1686 ,@(map make-readable (call.args exp))))))
1687 (define (make-readable-let exp)
1688 (let* ((L (call.proc exp))
1689 (formals (lambda.args L))
1690 (args (map make-readable (call.args exp)))
1691 (body (make-readable (lambda.body L))))
1692 (if (and (null? (lambda.defs L))
1695 (or (and (eq? (car body) 'let)
1696 (= (length (cadr body)) 1))
1697 (eq? (car body) 'let*)))
1698 `(let* ((,(car formals) ,(car args))
1704 ,@(map (lambda (def)
1705 `(define ,(def.lhs def)
1706 ,(make-readable (def.rhs def))))
1709 (define (make-readable-let* exp vars inits defs)
1710 (if (and (null? defs)
1712 (lambda? (call.proc exp))
1713 (= 1 (length (lambda.args (call.proc exp)))))
1714 (let ((proc (call.proc exp))
1715 (arg (car (call.args exp))))
1716 (if (and (call? arg)
1717 (lambda? (call.proc arg))
1718 (= 1 (length (lambda.args (call.proc arg))))
1719 (null? (lambda.defs (call.proc arg))))
1721 (make-call proc (list (lambda.body (call.proc arg))))
1722 (cons (car (lambda.args (call.proc arg))) vars)
1723 (cons (make-readable (car (call.args arg))) inits)
1725 (make-readable-let* (lambda.body proc)
1726 (cons (car (lambda.args proc)) vars)
1727 (cons (make-readable (car (call.args exp)))
1730 `(define ,(def.lhs def)
1731 ,(make-readable (def.rhs def))))
1732 (reverse (lambda.defs proc))))))
1733 (cond ((or (not (null? vars))
1739 ,(make-readable exp)))
1741 (lambda? (call.proc exp)))
1742 (let ((proc (call.proc exp)))
1745 (map make-readable (call.args exp)))
1746 ,@(map (lambda (def)
1747 `(define ,(def.lhs def)
1748 ,(make-readable (def.rhs def))))
1750 ,(make-readable (lambda.body proc)))))
1752 (make-readable exp)))))
1753 (make-readable exp)))
1757 ; MAKE-UNREADABLE does the reverse.
1758 ; It assumes there are no internal definitions.
1760 (define (make-unreadable exp)
1761 (cond ((symbol? exp) (list 'begin exp))
1765 ((lambda) (list 'lambda
1768 (list '() '() '() '())
1769 (make-unreadable (cons 'begin (cddr exp)))))
1770 ((set!) (list 'set! (cadr exp) (make-unreadable (caddr exp))))
1772 (make-unreadable (cadr exp))
1773 (make-unreadable (caddr exp))
1774 (if (= (length exp) 3)
1776 (make-unreadable (cadddr exp)))))
1777 ((begin) (if (= (length exp) 2)
1778 (make-unreadable (cadr exp))
1779 (cons 'begin (map make-unreadable (cdr exp)))))
1780 (else (map make-unreadable exp))))
1781 (else (list 'quote exp))))
1782 ; Copyright 1991 William D Clinger.
1784 ; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
1788 ; Procedures for fetching and clobbering parts of expressions.
1790 ($$trace "pass2.aux")
1792 (define (constant? exp) (eq? (car exp) 'quote))
1793 (define (variable? exp)
1794 (and (eq? (car exp) 'begin)
1795 (null? (cddr exp))))
1796 (define (lambda? exp) (eq? (car exp) 'lambda))
1797 (define (call? exp) (pair? (car exp)))
1798 (define (assignment? exp) (eq? (car exp) 'set!))
1799 (define (conditional? exp) (eq? (car exp) 'if))
1800 (define (begin? exp)
1801 (and (eq? (car exp) 'begin)
1802 (not (null? (cddr exp)))))
1804 (define (make-constant value) (list 'quote value))
1805 (define (make-variable name) (list 'begin name))
1806 (define (make-lambda formals defs R F G decls doc body)
1810 (list 'quote (list R F G decls doc))
1812 (define (make-call proc args) (cons proc (append args '())))
1813 (define (make-assignment lhs rhs) (list 'set! lhs rhs))
1814 (define (make-conditional e0 e1 e2) (list 'if e0 e1 e2))
1815 (define (make-begin exprs)
1816 (if (null? (cdr exprs))
1818 (cons 'begin (append exprs '()))))
1819 (define (make-definition lhs rhs) (list 'define lhs rhs))
1821 (define (constant.value exp) (cadr exp))
1822 (define (variable.name exp) (cadr exp))
1823 (define (lambda.args exp) (cadr exp))
1824 (define (lambda.defs exp) (cdr (caddr exp)))
1825 (define (lambda.R exp) (car (cadr (cadddr exp))))
1826 (define (lambda.F exp) (cadr (cadr (cadddr exp))))
1827 (define (lambda.G exp) (caddr (cadr (cadddr exp))))
1828 (define (lambda.decls exp) (cadddr (cadr (cadddr exp))))
1829 (define (lambda.doc exp) (car (cddddr (cadr (cadddr exp)))))
1830 (define (lambda.body exp) (car (cddddr exp)))
1831 (define (call.proc exp) (car exp))
1832 (define (call.args exp) (cdr exp))
1833 (define (assignment.lhs exp) (cadr exp))
1834 (define (assignment.rhs exp) (caddr exp))
1835 (define (if.test exp) (cadr exp))
1836 (define (if.then exp) (caddr exp))
1837 (define (if.else exp) (cadddr exp))
1838 (define (begin.exprs exp) (cdr exp))
1839 (define (def.lhs exp) (cadr exp))
1840 (define (def.rhs exp) (caddr exp))
1842 (define (variable-set! exp newexp)
1843 (set-car! exp (car newexp))
1844 (set-cdr! exp (append (cdr newexp) '())))
1845 (define (lambda.args-set! exp args) (set-car! (cdr exp) args))
1846 (define (lambda.defs-set! exp defs) (set-cdr! (caddr exp) defs))
1847 (define (lambda.R-set! exp R) (set-car! (cadr (cadddr exp)) R))
1848 (define (lambda.F-set! exp F) (set-car! (cdr (cadr (cadddr exp))) F))
1849 (define (lambda.G-set! exp G) (set-car! (cddr (cadr (cadddr exp))) G))
1850 (define (lambda.decls-set! exp decls) (set-car! (cdddr (cadr (cadddr exp))) decls))
1851 (define (lambda.doc-set! exp doc) (set-car! (cddddr (cadr (cadddr exp))) doc))
1852 (define (lambda.body-set! exp exp0) (set-car! (cddddr exp) exp0))
1853 (define (call.proc-set! exp exp0) (set-car! exp exp0))
1854 (define (call.args-set! exp exprs) (set-cdr! exp exprs))
1855 (define (assignment.rhs-set! exp exp0) (set-car! (cddr exp) exp0))
1856 (define (if.test-set! exp exp0) (set-car! (cdr exp) exp0))
1857 (define (if.then-set! exp exp0) (set-car! (cddr exp) exp0))
1858 (define (if.else-set! exp exp0) (set-car! (cdddr exp) exp0))
1859 (define (begin.exprs-set! exp exprs) (set-cdr! exp exprs))
1861 (define expression-set! variable-set!) ; used only by pass 3
1863 ; FIXME: This duplicates information in Lib/procinfo.sch.
1865 (define (make-doc name arity formals source-code filename filepos)
1866 (vector name source-code arity filename filepos formals))
1867 (define (doc.name d) (vector-ref d 0))
1868 (define (doc.code d) (vector-ref d 1))
1869 (define (doc.arity d) (vector-ref d 2))
1870 (define (doc.file d) (vector-ref d 3))
1871 (define (doc.filepos d) (vector-ref d 4))
1872 (define (doc.formals d) (vector-ref d 5))
1873 (define (doc.name-set! d x) (if d (vector-set! d 0 x)))
1874 (define (doc.code-set! d x) (if d (vector-set! d 1 x)))
1875 (define (doc.arity-set! d x) (if d (vector-set! d 2 x)))
1876 (define (doc.file-set! d x) (if d (vector-set! d 3 x)))
1877 (define (doc.filepos-set! d x) (if d (vector-set! d 4 x)))
1878 (define (doc.formals-set! d x) (if d (vector-set! d 5 x)))
1879 (define (doc-copy d) (list->vector (vector->list d)))
1881 (define (ignored? name) (eq? name name:IGNORED))
1883 ; Fairly harmless bug: rest arguments aren't getting flagged.
1885 (define (flag-as-ignored name L)
1886 (define (loop name formals)
1887 (cond ((null? formals)
1888 ;(pass2-error p2error:violation-of-invariant name formals)
1890 ((symbol? formals) #t)
1891 ((eq? name (car formals))
1892 (set-car! formals name:IGNORED)
1893 (if (not (local? (lambda.R L) name:IGNORED))
1895 (cons (make-R-entry name:IGNORED '() '() '())
1897 (else (loop name (cdr formals)))))
1898 (loop name (lambda.args L)))
1900 (define (make-null-terminated formals)
1901 (cond ((null? formals) '())
1902 ((symbol? formals) (list formals))
1903 (else (cons (car formals)
1904 (make-null-terminated (cdr formals))))))
1906 (define (list-head x n)
1907 (cond ((zero? n) '())
1908 (else (cons (car x) (list-head (cdr x) (- n 1))))))
1911 (cond ((null? y) '())
1912 ((eq? x (car y)) (remq x (cdr y)))
1913 (else (cons (car y) (remq x (cdr y))))))
1915 (define (make-call-to-LIST args)
1916 (cond ((null? args) (make-constant '()))
1918 (make-call (make-variable name:CONS)
1919 (list (car args) (make-constant '()))))
1920 (else (make-call (make-variable name:LIST) args))))
1922 (define (pass2-error i . etc)
1923 (apply cerror (cons (vector-ref pass2-error-messages i) etc)))
1925 (define pass2-error-messages
1926 '#("System error: violation of an invariant in pass 2"
1927 "Wrong number of arguments to known procedure"))
1929 (define p2error:violation-of-invariant 0)
1930 (define p2error:wna 1)
1932 ; Procedures for fetching referencing information from R-tables.
1934 (define (make-R-entry name refs assigns calls)
1935 (list name refs assigns calls))
1937 (define (R-entry.name x) (car x))
1938 (define (R-entry.references x) (cadr x))
1939 (define (R-entry.assignments x) (caddr x))
1940 (define (R-entry.calls x) (cadddr x))
1942 (define (R-entry.references-set! x refs) (set-car! (cdr x) refs))
1943 (define (R-entry.assignments-set! x assignments) (set-car! (cddr x) assignments))
1944 (define (R-entry.calls-set! x calls) (set-car! (cdddr x) calls))
1946 (define (local? R I)
1949 (define (R-entry R I)
1952 (define (R-lookup R I)
1954 (pass2-error p2error:violation-of-invariant R I)))
1956 (define (references R I)
1957 (cadr (R-lookup R I)))
1959 (define (assignments R I)
1960 (caddr (R-lookup R I)))
1963 (cadddr (R-lookup R I)))
1965 (define (references-set! R I X)
1966 (set-car! (cdr (R-lookup R I)) X))
1968 (define (assignments-set! R I X)
1969 (set-car! (cddr (R-lookup R I)) X))
1971 (define (calls-set! R I X)
1972 (set-car! (cdddr (R-lookup R I)) X))
1974 ; A notepad is a vector of the form #(L0 (L1 ...) (L2 ...) (I ...)),
1975 ; where the components are:
1976 ; element 0: a parent lambda expression (or #f if there is no enclosing
1977 ; parent, or we want to pretend that there isn't).
1978 ; element 1: a list of lambda expressions that the parent lambda
1979 ; expression encloses immediately.
1980 ; element 2: a subset of that list that does not escape.
1981 ; element 3: a list of free variables.
1983 (define (make-notepad L)
1984 (vector L '() '() '()))
1986 (define (notepad.parent np) (vector-ref np 0))
1987 (define (notepad.lambdas np) (vector-ref np 1))
1988 (define (notepad.nonescaping np) (vector-ref np 2))
1989 (define (notepad.vars np) (vector-ref np 3))
1991 (define (notepad.lambdas-set! np x) (vector-set! np 1 x))
1992 (define (notepad.nonescaping-set! np x) (vector-set! np 2 x))
1993 (define (notepad.vars-set! np x) (vector-set! np 3 x))
1995 (define (notepad-lambda-add! np L)
1996 (notepad.lambdas-set! np (cons L (notepad.lambdas np))))
1998 (define (notepad-nonescaping-add! np L)
1999 (notepad.nonescaping-set! np (cons L (notepad.nonescaping np))))
2001 (define (notepad-var-add! np I)
2002 (let ((vars (notepad.vars np)))
2003 (if (not (memq I vars))
2004 (notepad.vars-set! np (cons I vars)))))
2006 ; Given a notepad, returns the list of variables that are closed
2007 ; over by some nested lambda expression that escapes.
2009 (define (notepad-captured-variables np)
2010 (let ((nonescaping (notepad.nonescaping np)))
2013 (if (memq L nonescaping)
2016 (notepad.lambdas np)))))
2018 ; Given a notepad, returns a list of free variables computed
2019 ; as the union of the immediate free variables with the free
2020 ; variables of nested lambda expressions.
2022 (define (notepad-free-variables np)
2023 (do ((lambdas (notepad.lambdas np) (cdr lambdas))
2024 (fv (notepad.vars np)
2025 (let ((L (car lambdas)))
2026 (union (difference (lambda.F L)
2027 (make-null-terminated (lambda.args L)))
2029 ((null? lambdas) fv)))
2030 ; Copyright 1992 William Clinger
2032 ; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
2035 \f; Implementation-dependent parameters and preferences that determine
2036 ; how identifiers are represented in the output of the macro expander.
2038 ; The basic problem is that there are no reserved words, so the
2039 ; syntactic keywords of core Scheme that are used to express the
2040 ; output need to be represented by data that cannot appear in the
2041 ; input. This file defines those data.
2045 ; FIXME: The following definitions are currently ignored.
2047 ; The following definitions assume that identifiers of mixed case
2048 ; cannot appear in the input.
2050 (define begin1 (string->symbol "Begin"))
2051 (define define1 (string->symbol "Define"))
2052 (define quote1 (string->symbol "Quote"))
2053 (define lambda1 (string->symbol "Lambda"))
2054 (define if1 (string->symbol "If"))
2055 (define set!1 (string->symbol "Set!"))
2057 ; The following defines an implementation-dependent expression
2058 ; that evaluates to an undefined (not unspecified!) value, for
2059 ; use in expanding the (define x) syntax.
2061 (define undefined1 (list (string->symbol "Undefined")))
2065 ; A variable is renamed by suffixing a vertical bar followed by a unique
2066 ; integer. In IEEE and R4RS Scheme, a vertical bar cannot appear as part
2067 ; of an identifier, but presumably this is enforced by the reader and not
2068 ; by the compiler. Any other character that cannot appear as part of an
2069 ; identifier may be used instead of the vertical bar.
2071 (define renaming-prefix-character #\.)
2072 (define renaming-suffix-character #\|)
2074 (define renaming-prefix (string renaming-prefix-character))
2075 (define renaming-suffix (string renaming-suffix-character))
2077 ; Patches for Twobit. Here temporarily.
2079 (define (make-toplevel-definition id exp)
2081 (doc.name-set! (lambda.doc exp) id))
2083 (list (make-assignment id exp)
2084 (make-constant id))))
2086 (define (make-undefined)
2087 (make-call (make-variable 'undefined) '()))
2089 (define (make-unspecified)
2090 (make-call (make-variable 'unspecified) '()))
2091 ; Copyright 1992 William Clinger
2093 ; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
2096 \f; Syntactic environments.
2098 ; A syntactic environment maps identifiers to denotations,
2099 ; where a denotation is one of
2101 ; (special <special>)
2102 ; (macro <rules> <env>)
2103 ; (inline <rules> <env>)
2104 ; (identifier <id> <references> <assignments> <calls>)
2106 ; and where <special> is one of
2119 ; and where <rules> is a compiled <transformer spec> (see R4RS),
2120 ; <env> is a syntactic environment, and <id> is an identifier.
2122 ; An inline denotation is like a macro denotation, except that it
2123 ; is not an error when none of the rules match the use. Inline
2124 ; denotations are created by DEFINE-INLINE.
2125 ; The standard syntactic environment should not include any
2126 ; identifier denotations; space leaks will result if it does.
2128 ($$trace "syntaxenv")
2130 (define standard-syntactic-environment
2131 `((quote . (special quote))
2132 (lambda . (special lambda))
2134 (set! . (special set!))
2135 (begin . (special begin))
2136 (define . (special define))
2137 (define-inline . (special define-inline))
2138 (define-syntax . (special define-syntax))
2139 (let-syntax . (special let-syntax))
2140 (letrec-syntax . (special letrec-syntax))
2141 (syntax-rules . (special syntax-rules))
2144 ; Unforgeable synonyms for lambda and set!, used to expand definitions.
2146 (define lambda0 (string->symbol " lambda "))
2147 (define set!0 (string->symbol " set! "))
2149 (define (syntactic-copy env)
2152 (define (make-basic-syntactic-environment)
2154 (cdr (assq 'lambda standard-syntactic-environment)))
2156 (cdr (assq 'set! standard-syntactic-environment)))
2157 (syntactic-copy standard-syntactic-environment))))
2159 ; The global-syntactic-environment will always be a nonempty
2160 ; association list since there is no way to remove the entry
2161 ; for lambda0. That entry is used as a header by destructive
2164 (define global-syntactic-environment
2165 (make-basic-syntactic-environment))
2167 (define (global-syntactic-environment-set! env)
2168 (set-cdr! global-syntactic-environment env)
2171 (define (syntactic-bind-globally! id denotation)
2172 (if (and (identifier-denotation? denotation)
2173 (eq? id (identifier-name denotation)))
2174 (letrec ((remove-bindings-for-id
2176 (cond ((null? bindings) '())
2177 ((eq? (caar bindings) id)
2178 (remove-bindings-for-id (cdr bindings)))
2179 (else (cons (car bindings)
2180 (remove-bindings-for-id (cdr bindings))))))))
2181 (global-syntactic-environment-set!
2182 (remove-bindings-for-id (cdr global-syntactic-environment))))
2183 (let ((x (assq id global-syntactic-environment)))
2185 (begin (set-cdr! x denotation) #t)
2186 (global-syntactic-environment-set!
2187 (cons (cons id denotation)
2188 (cdr global-syntactic-environment)))))))
2190 (define (syntactic-divert env1 env2)
2193 (define (syntactic-extend env ids denotations)
2194 (syntactic-divert env (map cons ids denotations)))
2196 (define (syntactic-lookup env id)
2197 (let ((entry (assq id env)))
2200 (make-identifier-denotation id))))
2202 (define (syntactic-assign! env id denotation)
2203 (let ((entry (assq id env)))
2205 (set-cdr! entry denotation)
2206 (m-bug "Bug detected in syntactic-assign!" env id denotation))))
2210 (define denotation-class car)
2212 (define (special-denotation? denotation)
2213 (eq? (denotation-class denotation) 'special))
2215 (define (macro-denotation? denotation)
2216 (eq? (denotation-class denotation) 'macro))
2218 (define (inline-denotation? denotation)
2219 (eq? (denotation-class denotation) 'inline))
2221 (define (identifier-denotation? denotation)
2222 (eq? (denotation-class denotation) 'identifier))
2224 (define (make-macro-denotation rules env)
2225 (list 'macro rules env))
2227 (define (make-inline-denotation id rules env)
2228 (list 'inline rules env id))
2230 (define (make-identifier-denotation id)
2231 (list 'identifier id '() '() '()))
2233 (define macro-rules cadr)
2234 (define macro-env caddr)
2236 (define inline-rules macro-rules)
2237 (define inline-env macro-env)
2238 (define inline-name cadddr)
2240 (define identifier-name cadr)
2241 (define identifier-R-entry cdr)
2243 (define (same-denotation? d1 d2)
2245 (and (identifier-denotation? d1)
2246 (identifier-denotation? d2)
2247 (eq? (identifier-name d1)
2248 (identifier-name d2)))))
2250 (define denotation-of-quote
2251 (syntactic-lookup standard-syntactic-environment 'quote))
2253 (define denotation-of-lambda
2254 (syntactic-lookup standard-syntactic-environment 'lambda))
2256 (define denotation-of-if
2257 (syntactic-lookup standard-syntactic-environment 'if))
2259 (define denotation-of-set!
2260 (syntactic-lookup standard-syntactic-environment 'set!))
2262 (define denotation-of-begin
2263 (syntactic-lookup standard-syntactic-environment 'begin))
2265 (define denotation-of-define
2266 (syntactic-lookup standard-syntactic-environment 'define))
2268 (define denotation-of-define-inline
2269 (syntactic-lookup standard-syntactic-environment 'define-inline))
2271 (define denotation-of-define-syntax
2272 (syntactic-lookup standard-syntactic-environment 'define-syntax))
2274 (define denotation-of-let-syntax
2275 (syntactic-lookup standard-syntactic-environment 'let-syntax))
2277 (define denotation-of-letrec-syntax
2278 (syntactic-lookup standard-syntactic-environment 'letrec-syntax))
2280 (define denotation-of-syntax-rules
2281 (syntactic-lookup standard-syntactic-environment 'syntax-rules))
2283 (define denotation-of-...
2284 (syntactic-lookup standard-syntactic-environment '...))
2286 (define denotation-of-transformer
2287 (syntactic-lookup standard-syntactic-environment 'transformer))
2289 ; Given a syntactic environment env to be extended, an alist returned
2290 ; by rename-vars, and a syntactic environment env2, extends env by
2291 ; binding the fresh identifiers to the denotations of the original
2292 ; identifiers in env2.
2294 (define (syntactic-alias env alist env2)
2297 (map (lambda (name-pair)
2298 (let ((old-name (car name-pair))
2299 (new-name (cdr name-pair)))
2301 (syntactic-lookup env2 old-name))))
2304 ; Given a syntactic environment and an alist returned by rename-vars,
2305 ; extends the environment by binding the old identifiers to the fresh
2307 ; For Twobit, it also binds the fresh identifiers to their denotations.
2308 ; This is ok so long as the fresh identifiers are not legal Scheme
2311 (define (syntactic-rename env alist)
2314 (let* ((old (caar alist))
2316 (denotation (make-identifier-denotation new)))
2318 (cons (cons old denotation)
2319 (cons (cons new denotation)
2323 ; Renaming of variables.
2325 (define renaming-counter 0)
2327 (define (make-rename-procedure)
2328 (set! renaming-counter (+ renaming-counter 1))
2329 (let ((suffix (string-append renaming-suffix (number->string renaming-counter))))
2332 (let ((s (symbol->string sym)))
2333 (if (and (positive? (string-length s))
2334 (char=? (string-ref s 0) renaming-prefix-character))
2335 (string->symbol (string-append s suffix))
2336 (string->symbol (string-append renaming-prefix s suffix))))
2337 (m-warn "Illegal use of rename procedure" 'ok:FIXME sym)))))
2339 ; Given a datum, strips the suffixes from any symbols that appear within
2340 ; the datum, trying not to copy any more of the datum than necessary.
2343 (define (original-symbol x)
2344 (define (loop sym s i n)
2346 ((char=? (string-ref s i)
2347 renaming-suffix-character)
2348 (string->symbol (substring s 1 i)))
2350 (loop sym s (+ i 1) n))))
2351 (let ((s (symbol->string x)))
2352 (if (and (positive? (string-length s))
2353 (char=? (string-ref s 0) renaming-prefix-character))
2354 (loop x s 0 (string-length s))
2357 (original-symbol x))
2359 (let ((a (m-strip (car x)))
2360 (b (m-strip (cdr x))))
2361 (if (and (eq? a (car x))
2366 (let* ((v (vector->list x))
2367 (v2 (map m-strip v)))
2370 (list->vector v2))))
2373 ; Given a list of identifiers, or a formal parameter "list",
2374 ; returns an alist that associates each identifier with a fresh identifier.
2376 (define (rename-vars original-vars)
2377 (let ((rename (make-rename-procedure)))
2378 (define (loop vars newvars)
2379 (cond ((null? vars) (reverse newvars))
2381 (let ((var (car vars)))
2384 (cons (cons var (rename var))
2386 (m-error "Illegal variable" var))))
2388 (loop (list vars) newvars))
2389 (else (m-error "Malformed parameter list" original-vars))))
2390 (loop original-vars '())))
2392 ; Given a <formals> and an alist returned by rename-vars that contains
2393 ; a new name for each formal identifier in <formals>, renames the
2394 ; formal identifiers.
2396 (define (rename-formals formals alist)
2397 (cond ((null? formals) '())
2399 (cons (cdr (assq (car formals) alist))
2400 (rename-formals (cdr formals) alist)))
2401 (else (cdr (assq formals alist)))))
2402 ; Copyright 1992 William Clinger
2404 ; Permission to copy this software, in whole or in part, to use this
2405 ; software for any lawful purpose, and to redistribute this software
2406 ; is granted subject to the restriction that all copies made of this
2407 ; software must include this copyright notice in full.
2409 ; I also request that you send me a copy of any improvements that you
2410 ; make to this software so that they may be incorporated within it to
2411 ; the benefit of the Scheme community.
2414 \f; Compiler for a <transformer spec>.
2418 ; The Revised^4 Report on the Algorithmic Language Scheme.
2419 ; Clinger and Rees [editors]. To appear in Lisp Pointers.
2420 ; Also available as a technical report from U of Oregon,
2421 ; MIT AI Lab, and Cornell.
2423 ; Macros That Work. Clinger and Rees. POPL '91.
2425 ; The input is a <transformer spec> and a syntactic environment.
2426 ; Syntactic environments are described in another file.
2428 ; The supported syntax differs from the R4RS in that vectors are
2429 ; allowed as patterns and as templates and are not allowed as
2430 ; pattern or template data.
2432 ; <transformer spec> --> (syntax-rules <literals> <rules>)
2433 ; <rules> --> () | (<rule> . <rules>)
2434 ; <rule> --> (<pattern> <template>)
2435 ; <pattern> --> <pattern_var> ; a <symbol> not in <literals>
2436 ; | <symbol> ; a <symbol> in <literals>
2438 ; | (<pattern> . <pattern>)
2439 ; | (<ellipsis_pattern>)
2440 ; | #(<pattern>*) ; extends R4RS
2441 ; | #(<pattern>* <ellipsis_pattern>) ; extends R4RS
2443 ; <template> --> <pattern_var>
2446 ; | (<template2> . <template2>)
2447 ; | #(<template>*) ; extends R4RS
2449 ; <template2> --> <template> | <ellipsis_template>
2450 ; <pattern_datum> --> <string> ; no <vector>
2454 ; <ellipsis_pattern> --> <pattern> ...
2455 ; <ellipsis_template> --> <template> ...
2456 ; <pattern_var> --> <symbol> ; not in <literals>
2457 ; <literals> --> () | (<symbol> . <literals>)
2461 ; scope of an ellipsis
2463 ; Within a pattern or template, the scope of an ellipsis
2464 ; (...) is the pattern or template that appears to its left.
2466 ; rank of a pattern variable
2468 ; The rank of a pattern variable is the number of ellipses
2469 ; within whose scope it appears in the pattern.
2471 ; rank of a subtemplate
2473 ; The rank of a subtemplate is the number of ellipses within
2474 ; whose scope it appears in the template.
2476 ; template rank of an occurrence of a pattern variable
2478 ; The template rank of an occurrence of a pattern variable
2479 ; within a template is the rank of that occurrence, viewed
2482 ; variables bound by a pattern
2484 ; The variables bound by a pattern are the pattern variables
2485 ; that appear within it.
2487 ; referenced variables of a subtemplate
2489 ; The referenced variables of a subtemplate are the pattern
2490 ; variables that appear within it.
2492 ; variables opened by an ellipsis template
2494 ; The variables opened by an ellipsis template are the
2495 ; referenced pattern variables whose rank is greater than
2496 ; the rank of the ellipsis template.
2501 ; No pattern variable appears more than once within a pattern.
2503 ; For every occurrence of a pattern variable within a template,
2504 ; the template rank of the occurrence must be greater than or
2505 ; equal to the pattern variable's rank.
2507 ; Every ellipsis template must open at least one variable.
2509 ; For every ellipsis template, the variables opened by an
2510 ; ellipsis template must all be bound to sequences of the
2514 ; The compiled form of a <rule> is
2516 ; <rule> --> (<pattern> <template> <inserted>)
2517 ; <pattern> --> <pattern_var>
2520 ; | (<pattern> . <pattern>)
2521 ; | <ellipsis_pattern>
2524 ; <template> --> <pattern_var>
2527 ; | (<template2> . <template2>)
2530 ; <template2> --> <template> | <ellipsis_template>
2531 ; <pattern_datum> --> <string>
2535 ; <pattern_var> --> #(<V> <symbol> <rank>)
2536 ; <ellipsis_pattern> --> #(<E> <pattern> <pattern_vars>)
2537 ; <ellipsis_template> --> #(<E> <template> <pattern_vars>)
2538 ; <inserted> --> () | (<symbol> . <inserted>)
2539 ; <pattern_vars> --> () | (<pattern_var> . <pattern_vars>)
2540 ; <rank> --> <exact non-negative integer>
2542 ; where <V> and <E> are unforgeable values.
2543 ; The pattern variables associated with an ellipsis pattern
2544 ; are the variables bound by the pattern, and the pattern
2545 ; variables associated with an ellipsis template are the
2546 ; variables opened by the ellipsis template.
2549 ; What's wrong with the above?
2550 ; If the template contains a big chunk that contains no pattern variables
2551 ; or inserted identifiers, then the big chunk will be copied unnecessarily.
2552 ; That shouldn't matter very often.
2554 ($$trace "syntaxrules")
2556 (define pattern-variable-flag (list 'v))
2557 (define ellipsis-pattern-flag (list 'e))
2558 (define ellipsis-template-flag ellipsis-pattern-flag)
2560 (define (make-patternvar v rank)
2561 (vector pattern-variable-flag v rank))
2562 (define (make-ellipsis-pattern P vars)
2563 (vector ellipsis-pattern-flag P vars))
2564 (define (make-ellipsis-template T vars)
2565 (vector ellipsis-template-flag T vars))
2567 (define (patternvar? x)
2569 (= (vector-length x) 3)
2570 (eq? (vector-ref x 0) pattern-variable-flag)))
2572 (define (ellipsis-pattern? x)
2574 (= (vector-length x) 3)
2575 (eq? (vector-ref x 0) ellipsis-pattern-flag)))
2577 (define (ellipsis-template? x)
2579 (= (vector-length x) 3)
2580 (eq? (vector-ref x 0) ellipsis-template-flag)))
2582 (define (patternvar-name V) (vector-ref V 1))
2583 (define (patternvar-rank V) (vector-ref V 2))
2584 (define (ellipsis-pattern P) (vector-ref P 1))
2585 (define (ellipsis-pattern-vars P) (vector-ref P 2))
2586 (define (ellipsis-template T) (vector-ref T 1))
2587 (define (ellipsis-template-vars T) (vector-ref T 2))
2589 (define (pattern-variable v vars)
2590 (cond ((null? vars) #f)
2591 ((eq? v (patternvar-name (car vars)))
2593 (else (pattern-variable v (cdr vars)))))
2595 ; Given a <transformer spec> and a syntactic environment,
2596 ; returns a macro denotation.
2598 ; A macro denotation is of the form
2600 ; (macro (<rule> ...) env)
2602 ; where each <rule> has been compiled as described above.
2604 (define (m-compile-transformer-spec spec env)
2605 (if (and (> (safe-length spec) 1)
2606 (eq? (syntactic-lookup env (car spec))
2607 denotation-of-syntax-rules))
2608 (let ((literals (cadr spec))
2609 (rules (cddr spec)))
2610 (if (or (not (list? literals))
2611 (not (every1? (lambda (rule)
2612 (and (= (safe-length rule) 2)
2613 (pair? (car rule))))
2615 (m-error "Malformed syntax-rules" spec))
2618 (m-compile-rule rule literals env))
2621 (m-error "Malformed syntax-rules" spec)))
2623 (define (m-compile-rule rule literals env)
2624 (m-compile-pattern (cdr (car rule))
2627 (lambda (compiled-rule patternvars)
2629 ; should check uniqueness of pattern variables here
2636 (define (m-compile-pattern P literals env k)
2637 (define (loop P vars rank k)
2639 (if (memq P literals)
2641 (let ((var (make-patternvar P rank)))
2642 (k var (cons var vars)))))
2643 ((null? P) (k '() vars))
2645 (if (and (pair? (cdr P))
2647 (same-denotation? (syntactic-lookup env (cadr P))
2649 (if (null? (cddr P))
2654 (k (make-ellipsis-pattern P vars1)
2655 (union2 vars1 vars))))
2656 (m-error "Malformed pattern" P))
2665 (k (cons P1 P2) vars)))))))
2667 (loop (vector->list P)
2671 (k (vector P) vars))))
2675 (define (m-compile-template T vars env)
2677 (define (loop T inserted referenced rank escaped? k)
2679 (let ((x (pattern-variable T vars)))
2681 (if (>= rank (patternvar-rank x))
2682 (k x inserted (cons x referenced))
2684 "Too few ellipses follow pattern variable in template"
2685 (patternvar-name x)))
2686 (k T (cons T inserted) referenced))))
2687 ((null? T) (k '() inserted referenced))
2689 (cond ((and (not escaped?)
2691 (same-denotation? (syntactic-lookup env (car T))
2695 (loop (cadr T) inserted referenced rank #t k))
2696 ((and (not escaped?)
2699 (same-denotation? (syntactic-lookup env (cadr T))
2701 (loop1 T inserted referenced rank escaped? k))
2708 (lambda (T1 inserted referenced)
2714 (lambda (T2 inserted referenced)
2715 (k (cons T1 T2) inserted referenced))))))))
2717 (loop (vector->list T)
2722 (lambda (T inserted referenced)
2723 (k (vector T) inserted referenced))))
2724 (else (k T inserted referenced))))
2726 (define (loop1 T inserted referenced rank escaped? k)
2732 (lambda (T1 inserted referenced1)
2735 (append referenced1 referenced)
2738 (lambda (T2 inserted referenced)
2739 (k (cons (make-ellipsis-template
2741 (filter1 (lambda (var)
2742 (> (patternvar-rank var)
2754 (lambda (T inserted referenced)
2755 (list T inserted))))
2757 ; The pattern matcher.
2759 ; Given an input, a pattern, and two syntactic environments,
2760 ; returns a pattern variable environment (represented as an alist)
2761 ; if the input matches the pattern, otherwise returns #f.
2763 (define empty-pattern-variable-environment
2764 (list (make-patternvar (string->symbol "") 0)))
2766 (define (m-match F P env-def env-use)
2768 (define (match F P answer rank)
2770 (and (null? F) answer))
2773 (let ((answer (match (car F) (car P) answer rank)))
2774 (and answer (match (cdr F) (cdr P) answer rank)))))
2777 (same-denotation? (syntactic-lookup env-def P)
2778 (syntactic-lookup env-use F))
2781 (cons (cons P F) answer))
2782 ((ellipsis-pattern? P)
2783 (match1 F P answer (+ rank 1)))
2786 (match (vector->list F) (vector-ref P 0) answer rank)))
2787 (else (and (equal? F P) answer))))
2789 (define (match1 F P answer rank)
2790 (cond ((not (list? F)) #f)
2792 (append (map (lambda (var) (cons var '()))
2793 (ellipsis-pattern-vars P))
2796 (let* ((P1 (ellipsis-pattern P))
2797 (answers (map (lambda (F) (match F P1 answer rank))
2799 (if (every1? (lambda (answer) answer) answers)
2800 (append (map (lambda (var)
2802 (map (lambda (answer)
2803 (cdr (assq var answer)))
2805 (ellipsis-pattern-vars P))
2809 (match F P empty-pattern-variable-environment 0))
2811 (define (m-rewrite T alist)
2813 (define (rewrite T alist rank)
2814 (cond ((null? T) '())
2816 ((if (ellipsis-pattern? (car T))
2819 (rewrite (car T) alist rank)
2820 (rewrite (cdr T) alist rank)))
2821 ((symbol? T) (cdr (assq T alist)))
2822 ((patternvar? T) (cdr (assq T alist)))
2823 ((ellipsis-template? T)
2824 (rewrite1 T alist (+ rank 1)))
2826 (list->vector (rewrite (vector-ref T 0) alist rank)))
2829 (define (rewrite1 T alist rank)
2830 (let* ((T1 (ellipsis-template T))
2831 (vars (ellipsis-template-vars T))
2832 (rows (map (lambda (var) (cdr (assq var alist)))
2834 (map (lambda (alist) (rewrite T1 alist rank))
2835 (make-columns vars rows alist))))
2837 (define (make-columns vars rows alist)
2839 (if (null? (car rows))
2841 (cons (append (map (lambda (var row)
2842 (cons var (car row)))
2846 (loop (map cdr rows)))))
2847 (if (or (null? (cdr rows))
2848 (apply = (map length rows)))
2850 (m-error "Use of macro is not consistent with definition"
2854 (rewrite T alist 0))
2856 ; Given a use of a macro, the syntactic environment of the use,
2857 ; a continuation that expects a transcribed expression and
2858 ; a new environment in which to continue expansion, and a boolean
2859 ; that is true if this transcription is for an inline procedure,
2860 ; does the right thing.
2862 (define (m-transcribe0 exp env-use k inline?)
2863 (let* ((m (syntactic-lookup env-use (car exp)))
2864 (rules (macro-rules m))
2865 (env-def (macro-env m))
2867 (define (loop rules)
2871 (m-error "Use of macro does not match definition" exp))
2872 (let* ((rule (car rules))
2873 (pattern (car rule))
2874 (alist (m-match F pattern env-def env-use)))
2876 (let* ((template (cadr rule))
2877 (inserted (caddr rule))
2878 (alist2 (rename-vars inserted))
2879 (newexp (m-rewrite template (append alist2 alist))))
2881 (syntactic-alias env-use alist2 env-def)))
2882 (loop (cdr rules))))))
2883 (if (procedure? rules)
2884 (m-transcribe-low-level exp env-use k rules env-def)
2887 (define (m-transcribe exp env-use k)
2888 (m-transcribe0 exp env-use k #f))
2890 (define (m-transcribe-inline exp env-use k)
2891 (m-transcribe0 exp env-use k #t))
2893 ; Copyright 1998 William Clinger
2895 ; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
2897 ; Low-level macro facility based on explicit renaming. See
2898 ; William D Clinger. Hygienic macros through explicit renaming.
2899 ; In Lisp Pointers IV(4), 25-28, December 1991.
2901 ($$trace "lowlevel")
2903 (define (m-transcribe-low-level exp env-use k transformer env-def)
2904 (let ((rename0 (make-rename-procedure))
2907 (define (lookup sym)
2908 (let loop ((alist renamed))
2909 (cond ((null? alist)
2910 (syntactic-lookup env-use sym))
2911 ((eq? sym (cdr (car alist)))
2912 (syntactic-lookup env-def (car (car alist))))
2914 (loop (cdr alist))))))
2918 (let ((probe (assq sym renamed)))
2921 (let ((sym2 (rename0 sym)))
2922 (set! renamed (cons (cons sym sym2) renamed))
2924 (m-error "Illegal use of a rename procedure" sym))))
2927 (same-denotation? (lookup sym1) (lookup sym2)))))
2928 (let ((exp2 (transformer exp rename compare)))
2931 (syntactic-alias env-use renamed env-def))))))
2933 (define identifier? symbol?)
2935 (define (identifier->symbol id)
2937 ; Copyright 1992 William Clinger
2939 ; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
2945 ; This procedure sets the default scope of global macro definitions.
2947 (define define-syntax-scope
2948 (let ((flag 'letrec))
2950 (cond ((null? args) flag)
2951 ((not (null? (cdr args)))
2953 "Too many arguments passed to define-syntax-scope"
2955 ((memq (car args) '(letrec letrec* let*))
2956 (set! flag (car args)))
2957 (else (m-warn "Unrecognized argument to define-syntax-scope"
2960 ; The main entry point.
2961 ; The outermost lambda allows known procedures to be lifted outside
2962 ; all local variables.
2964 (define (macro-expand def-or-exp)
2965 (call-with-current-continuation
2968 (set! renaming-counter 0)
2970 (make-lambda '() ; formals
2977 (desugar-definitions def-or-exp
2978 global-syntactic-environment
2979 make-toplevel-definition))
2982 (define (desugar-definitions exp env make-toplevel-definition)
2986 (lambda (exp rest first env)
2987 (cond ((and (pair? exp)
2989 (eq? (syntactic-lookup env (car exp))
2990 denotation-of-begin)
2992 (define-loop (cadr exp) (append (cddr exp) rest) first env))
2995 (eq? (syntactic-lookup env (car exp))
2996 denotation-of-define))
2997 (let ((exp (desugar-define exp env)))
2998 (cond ((and (null? first) (null? rest))
3001 (make-begin (reverse (cons exp first))))
3002 (else (define-loop (car rest)
3008 (or (eq? (syntactic-lookup env (car exp))
3009 denotation-of-define-syntax)
3010 (eq? (syntactic-lookup env (car exp))
3011 denotation-of-define-inline))
3013 (define-syntax-loop exp rest env))
3016 (macro-denotation? (syntactic-lookup env (car exp))))
3020 (define-loop exp rest first env))))
3021 ((and (null? first) (null? rest))
3024 (make-begin (reverse (cons (m-expand exp env) first))))
3026 (append (reverse first)
3027 (map (lambda (exp) (m-expand exp env))
3028 (cons exp rest))))))))
3031 (lambda (exp rest env)
3032 (cond ((and (pair? exp)
3034 (eq? (syntactic-lookup env (car exp))
3035 denotation-of-begin)
3037 (define-syntax-loop (cadr exp) (append (cddr exp) rest) env))
3040 (eq? (syntactic-lookup env (car exp))
3041 denotation-of-define-syntax))
3042 (if (pair? (cdr exp))
3043 (redefinition (cadr exp)))
3045 (m-define-syntax exp env)
3046 (begin (m-define-syntax exp env)
3047 (define-syntax-loop (car rest) (cdr rest) env))))
3050 (eq? (syntactic-lookup env (car exp))
3051 denotation-of-define-inline))
3052 (if (pair? (cdr exp))
3053 (redefinition (cadr exp)))
3055 (m-define-inline exp env)
3056 (begin (m-define-inline exp env)
3057 (define-syntax-loop (car rest) (cdr rest) env))))
3060 (macro-denotation? (syntactic-lookup env (car exp))))
3064 (define-syntax-loop exp rest env))))
3067 (eq? (syntactic-lookup env (car exp))
3068 denotation-of-define))
3069 (define-loop exp rest '() env))
3073 (map (lambda (exp) (m-expand exp env))
3074 (cons exp rest)))))))
3079 ((null? (cdr exp)) (m-error "Malformed definition" exp))
3080 ; (define foo) syntax is transformed into (define foo (undefined)).
3082 (let ((id (cadr exp)))
3083 (if (or (null? pass1-block-inlines)
3084 (not (memq id pass1-block-inlines)))
3087 (syntactic-bind-globally! id (make-identifier-denotation id))))
3088 (make-toplevel-definition id (make-undefined))))
3091 (let* ((def (car exp))
3092 (pattern (cadr exp))
3094 (args (cdr pattern))
3096 (if (and (symbol? (car (cadr exp)))
3102 (,set!0 ,f (,lambda0 ,args ,@body))
3105 `(,def ,f (,lambda0 ,args ,@body))))
3107 ((> (length exp) 3) (m-error "Malformed definition" exp))
3108 (else (let ((id (cadr exp)))
3109 (if (or (null? pass1-block-inlines)
3110 (not (memq id pass1-block-inlines)))
3113 (syntactic-bind-globally! id (make-identifier-denotation id))))
3114 (make-toplevel-definition id (m-expand (caddr exp) env)))))))
3119 (if (not (identifier-denotation?
3120 (syntactic-lookup global-syntactic-environment id)))
3121 (if (issue-warnings)
3122 (m-warn "Redefining " id)))
3123 (m-error "Malformed variable or keyword" id)))))
3127 (define-loop exp '() '() env)))
3129 ; Given an expression and a syntactic environment,
3130 ; returns an expression in core Scheme.
3132 (define (m-expand exp env)
3133 (cond ((not (pair? exp))
3135 ((not (symbol? (car exp)))
3136 (m-application exp env))
3138 (let ((keyword (syntactic-lookup env (car exp))))
3139 (case (denotation-class keyword)
3142 ((eq? keyword denotation-of-quote) (m-quote exp))
3143 ((eq? keyword denotation-of-lambda) (m-lambda exp env))
3144 ((eq? keyword denotation-of-if) (m-if exp env))
3145 ((eq? keyword denotation-of-set!) (m-set exp env))
3146 ((eq? keyword denotation-of-begin) (m-begin exp env))
3147 ((eq? keyword denotation-of-let-syntax)
3148 (m-let-syntax exp env))
3149 ((eq? keyword denotation-of-letrec-syntax)
3150 (m-letrec-syntax exp env))
3151 ((or (eq? keyword denotation-of-define)
3152 (eq? keyword denotation-of-define-syntax)
3153 (eq? keyword denotation-of-define-inline))
3154 (m-error "Definition out of context" exp))
3155 (else (m-bug "Bug detected in m-expand" exp env))))
3156 ((macro) (m-macro exp env))
3157 ((inline) (m-inline exp env))
3158 ((identifier) (m-application exp env))
3159 (else (m-bug "Bug detected in m-expand" exp env)))))))
3161 (define (m-atom exp env)
3162 (cond ((not (symbol? exp))
3163 ; Here exp ought to be a boolean, number, character, or string.
3164 ; I'll warn about other things but treat them as if quoted.
3166 ; I'm turning off some of the warnings because notably procedures
3167 ; and #!unspecified can occur in loaded files and it's a major
3168 ; pain if a warning is printed for each. --lars
3169 (if (and (not (boolean? exp))
3173 (not (procedure? exp))
3174 (not (eq? exp (unspecified))))
3175 (m-warn "Malformed constant -- should be quoted" exp))
3176 (make-constant exp))
3177 (else (let ((denotation (syntactic-lookup env exp)))
3178 (case (denotation-class denotation)
3180 (m-warn "Syntactic keyword used as a variable" exp)
3181 ; Syntactic keywords used as variables are treated as #t.
3184 (make-variable (inline-name denotation)))
3186 (let ((var (make-variable (identifier-name denotation)))
3187 (R-entry (identifier-R-entry denotation)))
3188 (R-entry.references-set!
3190 (cons var (R-entry.references R-entry)))
3192 (else (m-bug "Bug detected by m-atom" exp env)))))))
3194 (define (m-quote exp)
3195 (if (and (pair? (cdr exp))
3197 (make-constant (m-strip (cadr exp)))
3198 (m-error "Malformed quoted constant" exp)))
3200 (define (m-lambda exp env)
3201 (if (> (safe-length exp) 2)
3203 (let* ((formals (cadr exp))
3204 (alist (rename-vars formals))
3205 (env (syntactic-rename env alist))
3208 (do ((alist alist (cdr alist)))
3210 (if (assq (caar alist) (cdr alist))
3211 (m-error "Malformed parameter list" formals)))
3213 ; To simplify the run-time system, there's a limit on how many
3214 ; fixed arguments can be followed by a rest argument.
3215 ; That limit is removed here.
3216 ; Bug: documentation slot isn't right when this happens.
3217 ; Bug: this generates extremely inefficient code.
3219 (if (and (not (list? formals))
3220 (> (length alist) @maxargs-with-rest-arg@))
3221 (let ((TEMP (car (rename-vars '(temp)))))
3224 ((,lambda0 ,(map car alist)
3226 ,@(do ((actuals '() (cons (list name:CAR path)
3228 (path TEMP (list name:CDR path))
3229 (formals formals (cdr formals)))
3231 (append (reverse actuals) (list path))))))
3233 (make-lambda (rename-formals formals alist)
3234 '() ; no definitions yet
3235 (map (lambda (entry)
3236 (cdr (syntactic-lookup env (cdr entry))))
3244 (exact->inexact (- (length alist) 1)))
3245 (if (include-variable-names)
3248 (if (include-source-code)
3252 source-file-position)
3253 (m-body body env))))
3255 (m-error "Malformed lambda expression" exp)))
3257 (define (m-body body env)
3258 (define (loop body env defs)
3260 (m-error "Empty body"))
3261 (let ((exp (car body)))
3262 (if (and (pair? exp)
3263 (symbol? (car exp)))
3264 (let ((denotation (syntactic-lookup env (car exp))))
3265 (case (denotation-class denotation)
3267 (cond ((eq? denotation denotation-of-begin)
3268 (loop (append (cdr exp) (cdr body)) env defs))
3269 ((eq? denotation denotation-of-define)
3270 (loop (cdr body) env (cons exp defs)))
3271 (else (finalize-body body env defs))))
3276 (loop (cons exp (cdr body))
3279 ((inline identifier)
3280 (finalize-body body env defs))
3281 (else (m-bug "Bug detected in m-body" body env))))
3282 (finalize-body body env defs))))
3283 (loop body env '()))
3285 (define (finalize-body body env defs)
3287 (let ((body (map (lambda (exp) (m-expand exp env))
3289 (if (null? (cdr body))
3293 (define (sort-defs defs)
3296 (let ((rhs (cadr def)))
3297 (if (not (pair? rhs))
3300 (syntactic-lookup env (car rhs))))
3301 (cond ((eq? denotation
3302 denotation-of-lambda)
3303 (cons 'procedure def))
3305 denotation-of-quote)
3306 (cons 'trivial def))
3308 (cons 'miscellaneous def)))))))
3310 (sorted (twobit-sort (lambda (x y)
3311 (or (eq? (car x) 'procedure)
3312 (eq? (car y) 'miscellaneous)))
3315 (define (desugar-definition def)
3316 (if (> (safe-length def) 2)
3317 (cond ((pair? (cadr def))
3324 ((and (= (length def) 3)
3325 (symbol? (cadr def)))
3327 (else (m-error "Malformed definition" def)))
3328 (m-error "Malformed definition" def)))
3329 (define (expand-letrec bindings body)
3332 `(,lambda0 ,(map car bindings)
3333 ,@(map (lambda (binding)
3334 `(,set!0 ,(car binding)
3339 (map (lambda (binding) (make-unspecified)) bindings)))
3340 (expand-letrec (sort-defs (map desugar-definition
3344 (define (m-if exp env)
3345 (let ((n (safe-length exp)))
3346 (if (or (= n 3) (= n 4))
3347 (make-conditional (m-expand (cadr exp) env)
3348 (m-expand (caddr exp) env)
3351 (m-expand (cadddr exp) env)))
3352 (m-error "Malformed if expression" exp))))
3354 (define (m-set exp env)
3355 (if (= (safe-length exp) 3)
3356 (let ((lhs (m-expand (cadr exp) env))
3357 (rhs (m-expand (caddr exp) env)))
3359 (let* ((x (variable.name lhs))
3360 (assignment (make-assignment x rhs))
3361 (denotation (syntactic-lookup env x)))
3362 (if (identifier-denotation? denotation)
3363 (let ((R-entry (identifier-R-entry denotation)))
3364 (R-entry.references-set!
3366 (remq lhs (R-entry.references R-entry)))
3367 (R-entry.assignments-set!
3369 (cons assignment (R-entry.assignments R-entry)))))
3370 (if (and (lambda? rhs)
3371 (include-procedure-names))
3372 (let ((doc (lambda.doc rhs)))
3373 (doc.name-set! doc x)))
3374 (if pass1-block-compiling?
3375 (set! pass1-block-assignments
3376 (cons x pass1-block-assignments)))
3378 (m-error "Malformed assignment" exp)))
3379 (m-error "Malformed assignment" exp)))
3381 (define (m-begin exp env)
3382 (cond ((> (safe-length exp) 1)
3383 (make-begin (map (lambda (exp) (m-expand exp env)) (cdr exp))))
3384 ((= (safe-length exp) 1)
3385 (m-warn "Non-standard begin expression" exp)
3388 (m-error "Malformed begin expression" exp))))
3390 (define (m-application exp env)
3391 (if (> (safe-length exp) 0)
3392 (let* ((proc (m-expand (car exp) env))
3393 (args (map (lambda (exp) (m-expand exp env))
3395 (call (make-call proc args)))
3396 (if (variable? proc)
3397 (let* ((procname (variable.name proc))
3399 (and (not (null? args))
3400 (constant? (car args))
3401 (integrate-usual-procedures)
3402 (every1? constant? args)
3403 (let ((entry (constant-folding-entry procname)))
3406 (constant-folding-predicates entry)))
3407 (and (= (length args)
3408 (length predicates))
3409 (let loop ((args args)
3410 (predicates predicates))
3411 (cond ((null? args) entry)
3413 (constant.value (car args)))
3418 (make-constant (apply (constant-folding-folder entry)
3419 (map constant.value args)))
3420 (let ((denotation (syntactic-lookup env procname)))
3421 (if (identifier-denotation? denotation)
3422 (let ((R-entry (identifier-R-entry denotation)))
3425 (cons call (R-entry.calls R-entry)))))
3428 (m-error "Malformed application" exp)))
3430 ; The environment argument should always be global here.
3432 (define (m-define-inline exp env)
3433 (cond ((and (= (safe-length exp) 3)
3434 (symbol? (cadr exp)))
3435 (let ((name (cadr exp)))
3436 (m-define-syntax1 name
3439 (define-syntax-scope))
3441 (syntactic-lookup global-syntactic-environment name)))
3442 (syntactic-bind-globally!
3444 (make-inline-denotation name
3445 (macro-rules denotation)
3446 (macro-env denotation))))
3447 (make-constant name)))
3449 (m-error "Malformed define-inline" exp))))
3451 ; The environment argument should always be global here.
3453 (define (m-define-syntax exp env)
3454 (cond ((and (= (safe-length exp) 3)
3455 (symbol? (cadr exp)))
3456 (m-define-syntax1 (cadr exp)
3459 (define-syntax-scope)))
3460 ((and (= (safe-length exp) 4)
3461 (symbol? (cadr exp))
3462 ; FIXME: should use denotations here
3463 (memq (caddr exp) '(letrec letrec* let*)))
3464 (m-define-syntax1 (cadr exp)
3468 (else (m-error "Malformed define-syntax" exp))))
3470 (define (m-define-syntax1 keyword spec env scope)
3471 (if (and (pair? spec)
3472 (symbol? (car spec)))
3473 (let* ((transformer-keyword (car spec))
3474 (denotation (syntactic-lookup env transformer-keyword)))
3475 (cond ((eq? denotation denotation-of-syntax-rules)
3477 ((letrec) (m-define-syntax-letrec keyword spec env))
3478 ((letrec*) (m-define-syntax-letrec* keyword spec env))
3479 ((let*) (m-define-syntax-let* keyword spec env))
3480 (else (m-bug "Weird scope" scope))))
3481 ((same-denotation? denotation denotation-of-transformer)
3482 ; FIXME: no error checking here
3483 (syntactic-bind-globally!
3485 (make-macro-denotation (eval (cadr spec)) env)))
3487 (m-error "Malformed syntax transformer" spec))))
3488 (m-error "Malformed syntax transformer" spec))
3489 (make-constant keyword))
3491 (define (m-define-syntax-letrec keyword spec env)
3492 (syntactic-bind-globally!
3494 (m-compile-transformer-spec spec env)))
3496 (define (m-define-syntax-letrec* keyword spec env)
3497 (let* ((env (syntactic-extend (syntactic-copy env)
3499 '((fake denotation))))
3500 (transformer (m-compile-transformer-spec spec env)))
3501 (syntactic-assign! env keyword transformer)
3502 (syntactic-bind-globally! keyword transformer)))
3504 (define (m-define-syntax-let* keyword spec env)
3505 (syntactic-bind-globally!
3507 (m-compile-transformer-spec spec (syntactic-copy env))))
3509 (define (m-let-syntax exp env)
3510 (if (and (> (safe-length exp) 2)
3511 (every1? (lambda (binding)
3512 (and (pair? binding)
3513 (symbol? (car binding))
3514 (pair? (cdr binding))
3515 (null? (cddr binding))))
3518 (syntactic-extend env
3519 (map car (cadr exp))
3521 (m-compile-transformer-spec
3524 (map cadr (cadr exp)))))
3525 (m-error "Malformed let-syntax" exp)))
3527 (define (m-letrec-syntax exp env)
3528 (if (and (> (safe-length exp) 2)
3529 (every1? (lambda (binding)
3530 (and (pair? binding)
3531 (symbol? (car binding))
3532 (pair? (cdr binding))
3533 (null? (cddr binding))))
3535 (let ((env (syntactic-extend env
3536 (map car (cadr exp))
3540 (for-each (lambda (id spec)
3544 (m-compile-transformer-spec spec env)))
3545 (map car (cadr exp))
3546 (map cadr (cadr exp)))
3547 (m-body (cddr exp) env))
3548 (m-error "Malformed let-syntax" exp)))
3550 (define (m-macro exp env)
3554 (m-expand exp env))))
3556 (define (m-inline exp env)
3557 (if (integrate-usual-procedures)
3558 (m-transcribe-inline exp
3560 (lambda (newexp env)
3561 (if (eq? exp newexp)
3562 (m-application exp env)
3563 (m-expand newexp env))))
3564 (m-application exp env)))
3566 (define m-quit ; assigned by macro-expand
3570 ; Clean up alist hacking et cetera.
3572 ; Integrable procedures.
3573 ; New semantics for body of LET-SYNTAX and LETREC-SYNTAX.
3574 ; Copyright 1992 William Clinger
3576 ; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
3582 ; The usual macros, adapted from Jonathan's Version 2 implementation.
3583 ; DEFINE is handled primitively, since top-level DEFINE has a side
3584 ; effect on the global syntactic environment, and internal definitions
3585 ; have to be handled specially anyway.
3587 ; Some extensions are noted, as are some optimizations.
3589 ; The LETREC* scope rule is used here to protect these macros against
3590 ; redefinition of LAMBDA etc. The scope rule is changed to LETREC at
3591 ; the end of this file.
3593 (define-syntax-scope 'letrec*)
3595 (for-each (lambda (form)
3596 (macro-expand form))
3599 ; Named LET is defined later, after LETREC has been defined.
3603 ((let ((?name ?val) ...) ?body ?body1 ...)
3604 ((lambda (?name ...) ?body ?body1 ...) ?val ...))))
3608 ((let* () ?body ?body1 ...)
3609 (let () ?body ?body1 ...))
3610 ((let* ((?name1 ?val1) (?name ?val) ...) ?body ?body1 ...)
3611 (let ((?name1 ?val1)) (let* ((?name ?val) ...) ?body ?body1 ...)))))
3613 ; Internal definitions have to be handled specially anyway,
3614 ; so we might as well rely on them here.
3616 (define-syntax letrec
3617 (syntax-rules (lambda quote)
3618 ((letrec ((?name ?val) ...) ?body ?body2 ...)
3620 (define ?name ?val) ...
3621 ?body ?body2 ...)))))
3623 ; This definition of named LET extends the prior definition of LET.
3624 ; The first rule is non-circular, thanks to the LET* scope that is
3625 ; specified for this use of DEFINE-SYNTAX.
3627 (define-syntax let let*
3629 ((let (?bindings ...) . ?body)
3630 (let (?bindings ...) . ?body))
3631 ((let ?tag ((?name ?val) ...) ?body ?body1 ...)
3632 (let ((?name ?val) ...)
3633 (letrec ((?tag (lambda (?name ...) ?body ?body1 ...)))
3634 (?tag ?name ...))))))
3640 ((and ?e1 ?e2 ?e3 ...)
3641 (if ?e1 (and ?e2 ?e3 ...) #f))))
3647 ((or ?e1 ?e2 ?e3 ...)
3649 (if temp temp (or ?e2 ?e3 ...))))))
3652 (syntax-rules (else =>)
3653 ((cond (else ?result ?result2 ...))
3654 (begin ?result ?result2 ...))
3656 ((cond (?test => ?result))
3658 (if temp (?result temp))))
3660 ((cond (?test)) ?test)
3662 ((cond (?test ?result ?result2 ...))
3663 (if ?test (begin ?result ?result2 ...)))
3665 ((cond (?test => ?result) ?clause ?clause2 ...)
3667 (if temp (?result temp) (cond ?clause ?clause2 ...))))
3669 ((cond (?test) ?clause ?clause2 ...)
3670 (or ?test (cond ?clause ?clause2 ...)))
3672 ((cond (?test ?result ?result2 ...)
3673 ?clause ?clause2 ...)
3675 (begin ?result ?result2 ...)
3676 (cond ?clause ?clause2 ...)))))
3678 ; The R4RS says a <step> may be omitted.
3679 ; That's a good excuse for a macro-defining macro that uses LETREC-SYNTAX
3680 ; and the ... escape.
3684 ((do (?bindings0 ...) (?test) ?body0 ...)
3685 (do (?bindings0 ...) (?test (if #f #f)) ?body0 ...))
3686 ((do (?bindings0 ...) ?clause0 ?body0 ...)
3689 (... (syntax-rules ()
3690 ((do-aux () ((?name ?init ?step) ...) ?clause ?body ...)
3691 (letrec ((loop (lambda (?name ...)
3694 (begin #t ?body ...)
3695 (loop ?step ...))))))
3697 ((do-aux ((?name ?init ?step) ?todo ...)
3702 (?bindings ... (?name ?init ?step))
3705 ((do-aux ((?name ?init) ?todo ...)
3710 (?bindings ... (?name ?init ?name))
3713 (do-aux (?bindings0 ...) () ?clause0 ?body0 ...)))))
3715 (define-syntax delay
3717 ((delay ?e) (.make-promise (lambda () ?e)))))
3719 ; Another use of LETREC-SYNTAX and the escape extension.
3722 (syntax-rules (else)
3723 ((case ?e1 (else ?body ?body2 ...))
3724 (begin ?e1 ?body ?body2 ...))
3725 ((case ?e1 (?z ?body ?body2 ...))
3726 (if (memv ?e1 '?z) (begin ?body ?body2 ...)))
3727 ((case ?e1 ?clause1 ?clause2 ?clause3 ...)
3730 (... (syntax-rules (else)
3731 ((case-aux ?temp (else ?body ?body2 ...))
3732 (begin ?body ?body2 ...))
3733 ((case-aux ?temp ((?z ...) ?body ?body2 ...))
3734 (if (memv ?temp '(?z ...)) (begin ?body ?body2 ...)))
3735 ((case-aux ?temp ((?z ...) ?body ?body2 ...) ?c1 ?c2 ...)
3736 (if (memv ?temp '(?z ...))
3737 (begin ?body ?body2 ...)
3738 (case-aux ?temp ?c1 ?c2 ...)))
3739 ; a popular extension
3740 ((case-aux ?temp (?z ?body ...) ?c1 ...)
3741 (case-aux ?temp ((?z) ?body ...) ?c1 ...))))))
3743 (case-aux temp ?clause1 ?clause2 ?clause3 ...))))))
3745 ; A complete implementation of quasiquote, obtained by translating
3746 ; Jonathan Rees's implementation that was posted to RRRS-AUTHORS
3747 ; on 22 December 1986.
3748 ; Unfortunately, the use of LETREC scope means that it is vulnerable
3749 ; to top-level redefinitions of QUOTE etc. That could be fixed, but
3750 ; it has hair enough already.
3754 (define-syntax .finalize-quasiquote letrec
3755 (syntax-rules (quote unquote unquote-splicing)
3756 ((.finalize-quasiquote quote ?arg ?return)
3757 (.interpret-continuation ?return (quote ?arg)))
3758 ((.finalize-quasiquote unquote ?arg ?return)
3759 (.interpret-continuation ?return ?arg))
3760 ((.finalize-quasiquote unquote-splicing ?arg ?return)
3761 (syntax-error ",@ in illegal context" ?arg))
3762 ((.finalize-quasiquote ?mode ?arg ?return)
3763 (.interpret-continuation ?return (?mode . ?arg)))))
3765 ; The first two "arguments" to .descend-quasiquote and to
3766 ; .descend-quasiquote-pair are always identical.
3768 (define-syntax .descend-quasiquote letrec
3769 (syntax-rules (quasiquote unquote unquote-splicing)
3770 ((.descend-quasiquote `?y ?x ?level ?return)
3771 (.descend-quasiquote-pair ?x ?x (?level) ?return))
3772 ((.descend-quasiquote ,?y ?x () ?return)
3773 (.interpret-continuation ?return unquote ?y))
3774 ((.descend-quasiquote ,?y ?x (?level) ?return)
3775 (.descend-quasiquote-pair ?x ?x ?level ?return))
3776 ((.descend-quasiquote ,@?y ?x () ?return)
3777 (.interpret-continuation ?return unquote-splicing ?y))
3778 ((.descend-quasiquote ,@?y ?x (?level) ?return)
3779 (.descend-quasiquote-pair ?x ?x ?level ?return))
3780 ((.descend-quasiquote (?y . ?z) ?x ?level ?return)
3781 (.descend-quasiquote-pair ?x ?x ?level ?return))
3782 ((.descend-quasiquote #(?y ...) ?x ?level ?return)
3783 (.descend-quasiquote-vector ?x ?x ?level ?return))
3784 ((.descend-quasiquote ?y ?x ?level ?return)
3785 (.interpret-continuation ?return quote ?x))))
3787 (define-syntax .descend-quasiquote-pair letrec
3788 (syntax-rules (quote unquote unquote-splicing)
3789 ((.descend-quasiquote-pair (?carx . ?cdrx) ?x ?level ?return)
3790 (.descend-quasiquote ?carx ?carx ?level (1 ?cdrx ?x ?level ?return)))))
3792 (define-syntax .descend-quasiquote-vector letrec
3793 (syntax-rules (quote)
3794 ((.descend-quasiquote-vector #(?y ...) ?x ?level ?return)
3795 (.descend-quasiquote (?y ...) (?y ...) ?level (6 ?x ?return)))))
3797 ; Representations for continuations used here.
3798 ; Continuation types 0, 1, 2, and 6 take a mode and an expression.
3799 ; Continuation types -1, 3, 4, 5, and 7 take just an expression.
3802 ; means no continuation
3804 ; means to call .finalize-quasiquote with no further continuation
3805 ; (1 ?cdrx ?x ?level ?return)
3806 ; means a return from the call to .descend-quasiquote from
3807 ; .descend-quasiquote-pair
3808 ; (2 ?car-mode ?car-arg ?x ?return)
3809 ; means a return from the second call to .descend-quasiquote in
3810 ; in Jonathan's code for .descend-quasiquote-pair
3811 ; (3 ?car-arg ?return)
3812 ; means take the result and return an append of ?car-arg with it
3813 ; (4 ?cdr-mode ?cdr-arg ?return)
3814 ; means take the result and call .finalize-quasiquote on ?cdr-mode
3815 ; and ?cdr-arg with a continuation of type 5
3816 ; (5 ?car-result ?return)
3817 ; means take the result and return a cons of ?car-result onto it
3819 ; means a return from the call to .descend-quasiquote from
3820 ; .descend-quasiquote-vector
3822 ; means take the result and return a call of list->vector on it
3824 (define-syntax .interpret-continuation letrec
3825 (syntax-rules (quote unquote unquote-splicing)
3826 ((.interpret-continuation (-1) ?e) ?e)
3827 ((.interpret-continuation (0) ?mode ?arg)
3828 (.finalize-quasiquote ?mode ?arg (-1)))
3829 ((.interpret-continuation (1 ?cdrx ?x ?level ?return) ?car-mode ?car-arg)
3830 (.descend-quasiquote ?cdrx
3833 (2 ?car-mode ?car-arg ?x ?return)))
3834 ((.interpret-continuation (2 quote ?car-arg ?x ?return) quote ?cdr-arg)
3835 (.interpret-continuation ?return quote ?x))
3836 ((.interpret-continuation (2 unquote-splicing ?car-arg ?x ?return) quote ())
3837 (.interpret-continuation ?return unquote ?car-arg))
3838 ((.interpret-continuation (2 unquote-splicing ?car-arg ?x ?return)
3840 (.finalize-quasiquote ?cdr-mode ?cdr-arg (3 ?car-arg ?return)))
3841 ((.interpret-continuation (2 ?car-mode ?car-arg ?x ?return)
3843 (.finalize-quasiquote ?car-mode ?car-arg (4 ?cdr-mode ?cdr-arg ?return)))
3845 ((.interpret-continuation (3 ?car-arg ?return) ?e)
3846 (.interpret-continuation ?return append (?car-arg ?e)))
3847 ((.interpret-continuation (4 ?cdr-mode ?cdr-arg ?return) ?e1)
3848 (.finalize-quasiquote ?cdr-mode ?cdr-arg (5 ?e1 ?return)))
3849 ((.interpret-continuation (5 ?e1 ?return) ?e2)
3850 (.interpret-continuation ?return .cons (?e1 ?e2)))
3851 ((.interpret-continuation (6 ?x ?return) quote ?arg)
3852 (.interpret-continuation ?return quote ?x))
3853 ((.interpret-continuation (6 ?x ?return) ?mode ?arg)
3854 (.finalize-quasiquote ?mode ?arg (7 ?return)))
3855 ((.interpret-continuation (7 ?return) ?e)
3856 (.interpret-continuation ?return .list->vector (?e)))))
3858 (define-syntax quasiquote letrec
3861 (.descend-quasiquote ?x ?x () (0)))))
3864 (define-syntax let*-syntax
3866 ((let*-syntax () ?body)
3867 (let-syntax () ?body))
3868 ((let*-syntax ((?name1 ?val1) (?name ?val) ...) ?body)
3869 (let-syntax ((?name1 ?val1)) (let*-syntax ((?name ?val) ...) ?body)))))
3874 (define-syntax-scope 'letrec)
3876 (define standard-syntactic-environment
3877 (syntactic-copy global-syntactic-environment))
3879 (define (make-standard-syntactic-environment)
3880 (syntactic-copy standard-syntactic-environment))
3881 ; Copyright 1998 William Clinger.
3883 ; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
3887 ; Given an expression in the subset of Scheme used as an intermediate language
3888 ; by Twobit, returns a newly allocated copy of the expression in which the
3889 ; local variables have been renamed and the referencing information has been
3892 (define (copy-exp exp)
3894 (define special-names (cons name:IGNORED argument-registers))
3896 (define original-names (make-hashtable symbol-hash assq))
3898 (define renaming-counter 0)
3900 (define (rename-vars vars)
3901 (let ((rename (make-rename-procedure)))
3903 (cond ((memq var special-names)
3905 ((hashtable-get original-names var)
3908 (hashtable-put! original-names var #t)
3912 (define (rename-formals formals newnames)
3913 (cond ((null? formals) '())
3914 ((symbol? formals) (car newnames))
3915 ((memq (car formals) special-names)
3917 (rename-formals (cdr formals)
3919 (else (cons (car newnames)
3920 (rename-formals (cdr formals)
3923 ; Environments that map symbols to arbitrary information.
3924 ; This data type is mutable, and uses the shallow binding technique.
3926 (define (make-env) (make-hashtable symbol-hash assq))
3928 (define (env-bind! env sym info)
3929 (let ((stack (hashtable-get env sym)))
3930 (hashtable-put! env sym (cons info stack))))
3932 (define (env-unbind! env sym)
3933 (let ((stack (hashtable-get env sym)))
3934 (hashtable-put! env sym (cdr stack))))
3936 (define (env-lookup env sym default)
3937 (let ((stack (hashtable-get env sym)))
3942 (define (env-bind-multiple! env symbols infos)
3943 (for-each (lambda (sym info) (env-bind! env sym info))
3947 (define (env-unbind-multiple! env symbols)
3948 (for-each (lambda (sym) (env-unbind! env sym))
3953 (define (lexical-lookup R-table name)
3954 (assq name R-table))
3956 (define (copy exp env notepad R-table)
3957 (cond ((constant? exp) exp)
3959 (let* ((bvl (make-null-terminated (lambda.args exp)))
3960 (newnames (rename-vars bvl))
3961 (procnames (map def.lhs (lambda.defs exp)))
3962 (newprocnames (rename-vars procnames))
3963 (refinfo (map (lambda (var)
3964 (make-R-entry var '() '() '()))
3965 (append newnames newprocnames)))
3968 (rename-formals (lambda.args exp) newnames)
3975 (lambda.body exp))))
3976 (env-bind-multiple! env procnames newprocnames)
3977 (env-bind-multiple! env bvl newnames)
3978 (for-each (lambda (entry)
3979 (env-bind! R-table (R-entry.name entry) entry))
3981 (notepad-lambda-add! notepad newexp)
3982 (let ((newnotepad (make-notepad notepad)))
3983 (for-each (lambda (name rhs)
3986 (cons (make-definition
3988 (copy rhs env newnotepad R-table))
3989 (lambda.defs newexp))))
3990 (reverse newprocnames)
3992 (reverse (lambda.defs exp))))
3995 (copy (lambda.body exp) env newnotepad R-table))
3996 (lambda.F-set! newexp (notepad-free-variables newnotepad))
3997 (lambda.G-set! newexp (notepad-captured-variables newnotepad)))
3998 (env-unbind-multiple! env procnames)
3999 (env-unbind-multiple! env bvl)
4000 (for-each (lambda (entry)
4001 (env-unbind! R-table (R-entry.name entry)))
4005 (let* ((oldname (assignment.lhs exp))
4006 (name (env-lookup env oldname oldname))
4007 (varinfo (env-lookup R-table name #f))
4009 (make-assignment name
4010 (copy (assignment.rhs exp) env notepad R-table))))
4011 (notepad-var-add! notepad name)
4013 (R-entry.assignments-set!
4015 (cons newexp (R-entry.assignments varinfo))))
4018 (make-conditional (copy (if.test exp) env notepad R-table)
4019 (copy (if.then exp) env notepad R-table)
4020 (copy (if.else exp) env notepad R-table)))
4022 (make-begin (map (lambda (exp) (copy exp env notepad R-table))
4023 (begin.exprs exp))))
4025 (let* ((oldname (variable.name exp))
4026 (name (env-lookup env oldname oldname))
4027 (varinfo (env-lookup R-table name #f))
4028 (newexp (make-variable name)))
4029 (notepad-var-add! notepad name)
4031 (R-entry.references-set!
4033 (cons newexp (R-entry.references varinfo))))
4036 (let ((newexp (make-call (copy (call.proc exp) env notepad R-table)
4038 (copy exp env notepad R-table))
4040 (if (variable? (call.proc newexp))
4049 (cons newexp (R-entry.calls varinfo))))))
4050 (if (lambda? (call.proc newexp))
4051 (notepad-nonescaping-add! notepad (call.proc newexp)))
4055 (copy exp (make-env) (make-notepad #f) (make-env)))
4058 ; Given an expression, traverses the expression to confirm
4059 ; that the referencing invariants are correct.
4061 (define (check-referencing-invariants exp . flags)
4063 (let ((check-free-variables? (memq 'free flags))
4064 (check-referencing? (memq 'reference flags))
4065 (first-violation? #t))
4067 ; env is the list of enclosing lambda expressions,
4068 ; beginning with the innermost.
4070 (define (check exp env)
4071 (cond ((constant? exp) (return exp #t))
4073 (let ((env (cons exp env)))
4075 (and (every? (lambda (exp)
4077 (map def.rhs (lambda.defs exp)))
4078 (check (lambda.body exp) env)
4079 (if (and check-free-variables?
4081 (subset? (difference
4083 (make-null-terminated
4085 (lambda.F (car env)))
4087 (if check-referencing?
4088 (let ((env (cons exp env))
4090 (every? (lambda (formal)
4091 (or (ignored? formal)
4092 (R-entry R formal)))
4093 (make-null-terminated
4094 (lambda.args exp))))
4098 (and (if (and check-free-variables?
4100 (memq (variable.name exp)
4101 (lambda.F (car env)))
4103 (if check-referencing?
4104 (let ((Rinfo (lookup env (variable.name exp))))
4106 (memq exp (R-entry.references Rinfo))
4111 (and (check (assignment.rhs exp) env)
4112 (if (and check-free-variables?
4114 (memq (assignment.lhs exp)
4115 (lambda.F (car env)))
4117 (if check-referencing?
4118 (let ((Rinfo (lookup env (assignment.lhs exp))))
4120 (memq exp (R-entry.assignments Rinfo))
4125 (and (check (if.test exp) env)
4126 (check (if.then exp) env)
4127 (check (if.else exp) env))))
4130 (every? (lambda (exp) (check exp env))
4131 (begin.exprs exp))))
4134 (and (check (call.proc exp) env)
4135 (every? (lambda (exp) (check exp env))
4137 (if (and check-referencing?
4138 (variable? (call.proc exp)))
4139 (let ((Rinfo (lookup env
4143 (memq exp (R-entry.calls Rinfo))
4148 (define (return exp flag)
4152 (set! first-violation? #f)
4153 (display "Violation of referencing invariants")
4155 (pretty-print (make-readable exp))
4157 (else (pretty-print (make-readable exp))
4160 (define (lookup env I)
4163 (let ((Rinfo (R-entry (lambda.R (car env)) I)))
4165 (lookup (cdr env) I)))))
4168 (begin (set! check-free-variables? #t)
4169 (set! check-referencing? #t)))
4174 ; Calculating the free variable information for an expression
4175 ; as output by pass 2. This should be faster than computing both
4176 ; the free variables and the referencing information.
4178 (define (compute-free-variables! exp)
4180 (define empty-set (make-set '()))
4182 (define (singleton x) (list x))
4184 (define (union2 x y) (union x y))
4185 (define (union3 x y z) (union x y z))
4187 (define (set->list set) set)
4190 (cond ((constant? exp) empty-set)
4192 (let* ((defs (lambda.defs exp))
4194 (make-null-terminated (lambda.args exp))))
4195 (defined (make-set (map def.lhs defs)))
4199 (free (def.rhs def)))
4201 (Fbody (free (lambda.body exp)))
4202 (F (union2 Fdefs Fbody)))
4203 (lambda.F-set! exp (set->list F))
4204 (lambda.G-set! exp (set->list F))
4205 (difference F (union2 formals defined))))
4207 (union2 (make-set (list (assignment.lhs exp)))
4208 (free (assignment.rhs exp))))
4210 (union3 (free (if.test exp))
4211 (free (if.then exp))
4212 (free (if.else exp))))
4215 (map (lambda (exp) (free exp))
4216 (begin.exprs exp))))
4218 (singleton (variable.name exp)))
4220 (union2 (free (call.proc exp))
4222 (map (lambda (exp) (free exp))
4228 ; As above, but representing sets as hashtrees.
4229 ; This is commented out because it is much slower than the implementation
4230 ; above. Because the set of free variables is represented as a list
4231 ; within a lambda expression, this implementation must convert the
4232 ; representation for every lambda expression, which is quite expensive
4233 ; for A-normal form.
4237 (define (compute-free-variables! exp)
4239 (define empty-set (make-hashtree symbol-hash assq))
4241 (define (singleton x)
4242 (hashtree-put empty-set x #t))
4244 (define (make-set values)
4247 (hashtree-put (make-set (cdr values))
4251 (define (union2 x y)
4252 (hashtree-for-each (lambda (key val)
4253 (set! x (hashtree-put x key #t)))
4257 (define (union3 x y z)
4258 (union2 (union2 x y) z))
4260 (define (apply-union sets)
4267 (apply-union (cdr sets))))))
4269 (define (difference x y)
4270 (hashtree-for-each (lambda (key val)
4271 (set! x (hashtree-remove x key)))
4275 (define (set->list set)
4276 (hashtree-map (lambda (sym val) sym) set))
4279 (cond ((constant? exp) empty-set)
4281 (let* ((defs (lambda.defs exp))
4283 (make-null-terminated (lambda.args exp))))
4284 (defined (make-set (map def.lhs defs)))
4288 (free (def.rhs def)))
4290 (Fbody (free (lambda.body exp)))
4291 (F (union2 Fdefs Fbody)))
4292 (lambda.F-set! exp (set->list F))
4293 (lambda.G-set! exp (set->list F))
4294 (difference F (union2 formals defined))))
4296 (union2 (make-set (list (assignment.lhs exp)))
4297 (free (assignment.rhs exp))))
4299 (union3 (free (if.test exp))
4300 (free (if.then exp))
4301 (free (if.else exp))))
4304 (map (lambda (exp) (free exp))
4305 (begin.exprs exp))))
4307 (singleton (variable.name exp)))
4309 (union2 (free (call.proc exp))
4311 (map (lambda (exp) (free exp))
4315 (hashtree-map (lambda (sym val) sym)
4317 #t); Copyright 1991 William Clinger
4319 ; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
4323 ; First pass of the Twobit compiler:
4324 ; macro expansion, syntax checking, alpha conversion,
4325 ; preliminary annotation.
4327 ; The input to this pass is a Scheme definition or expression.
4328 ; The output is an expression in the subset of Scheme described
4329 ; by the following grammar, where the output satisfies certain
4330 ; additional invariants described below.
4332 ; "X ..." means zero or more occurrences of X.
4334 ; L --> (lambda (I_1 ...)
4336 ; (quote (R F G <decls> <doc>)
4338 ; | (lambda (I_1 ... . I_rest)
4340 ; (quote (R F <decls> <doc>))
4342 ; D --> (define I L)
4343 ; E --> (quote K) ; constants
4344 ; | (begin I) ; variable references
4345 ; | L ; lambda expressions
4346 ; | (E0 E1 ...) ; calls
4347 ; | (set! I E) ; assignments
4348 ; | (if E0 E1 E2) ; conditionals
4349 ; | (begin E0 E1 E2 ...) ; sequential expressions
4350 ; I --> <identifier>
4352 ; R --> ((I <references> <assignments> <calls>) ...)
4356 ; Invariants that hold for the output:
4357 ; * There are no internal definitions.
4358 ; * No identifier containing an upper case letter is bound anywhere.
4359 ; (Change the "name:..." variables if upper case is preferred.)
4360 ; * No identifier is bound in more than one place.
4361 ; * Each R contains one entry for every identifier bound in the
4362 ; formal argument list and the internal definition list that
4363 ; precede it. Each entry contains a list of pointers to all
4364 ; references to the identifier, a list of pointers to all
4365 ; assignments to the identifier, and a list of pointers to all
4366 ; calls to the identifier.
4367 ; * Except for constants, the expression does not share structure
4368 ; with the original input or itself, except that the references
4369 ; and assignments in R are guaranteed to share structure with
4370 ; the expression. Thus the expression may be side effected, and
4371 ; side effects to references or assignments obtained through R
4372 ; are guaranteed to change the references or assignments pointed
4374 ; * F and G are garbage.
4378 (define source-file-name #f)
4379 (define source-file-position #f)
4381 (define pass1-block-compiling? #f)
4382 (define pass1-block-assignments '())
4383 (define pass1-block-inlines '())
4385 (define (pass1 def-or-exp . rest)
4386 (set! source-file-name #f)
4387 (set! source-file-position #f)
4388 (set! pass1-block-compiling? #f)
4389 (set! pass1-block-assignments '())
4390 (set! pass1-block-inlines '())
4391 (if (not (null? rest))
4392 (begin (set! source-file-name (car rest))
4393 (if (not (null? (cdr rest)))
4394 (set! source-file-position (cadr rest)))))
4395 (set! renaming-counter 0)
4396 (macro-expand def-or-exp))
4398 ; Compiles a whole sequence of top-level forms on the assumption
4399 ; that no variable that is defined by a form in the sequence is
4400 ; ever defined or assigned outside of the sequence.
4402 ; This is a crock in three parts:
4404 ; 1. Macro-expand each form and record assignments.
4405 ; 2. Find the top-level variables that are defined but not
4406 ; assigned, give them local names, generate a DEFINE-INLINE
4407 ; for each of the top-level procedures, and macro-expand
4409 ; 3. Wrap the whole mess in an appropriate LET and recompute
4410 ; the referencing information by copying it.
4412 ; Note that macros get expanded twice, and that all DEFINE-SYNTAX
4413 ; macros are considered local to the forms.
4415 ; FIXME: Need to turn off warning messages.
4417 (define (pass1-block forms . rest)
4420 (set! pass1-block-compiling? #t)
4421 (set! pass1-block-assignments '())
4422 (set! pass1-block-inlines '())
4423 (set! renaming-counter 0)
4424 (let ((env0 (syntactic-copy global-syntactic-environment))
4425 (bmode (benchmark-mode))
4426 (wmode (issue-warnings))
4428 (define (make-toplevel-definition id exp)
4429 (cond ((memq id defined)
4430 (set! pass1-block-assignments
4431 (cons id pass1-block-assignments)))
4432 ((or (constant? exp)
4434 (list? (lambda.args exp))))
4435 (set! defined (cons id defined))))
4437 (list (make-assignment id exp)
4438 (make-constant id))))
4441 (for-each (lambda (form)
4442 (desugar-definitions form
4443 global-syntactic-environment
4444 make-toplevel-definition))
4446 (set! global-syntactic-environment env0)
4447 (benchmark-mode bmode)
4448 (issue-warnings wmode)
4449 (part2 (filter (lambda (id)
4450 (not (memq id pass1-block-assignments)))
4451 (reverse defined)))))
4453 (define (part2 defined)
4454 (set! pass1-block-compiling? #f)
4455 (set! pass1-block-assignments '())
4456 (set! pass1-block-inlines '())
4457 (set! renaming-counter 0)
4458 (let* ((rename (make-rename-procedure))
4459 (alist (map (lambda (id)
4460 (cons id (rename id)))
4462 (definitions0 '()) ; for constants
4463 (definitions1 '())) ; for lambda expressions
4464 (define (make-toplevel-definition id exp)
4466 (doc.name-set! (lambda.doc exp) id))
4467 (let ((probe (assq id alist)))
4469 (let ((id1 (cdr probe)))
4470 (cond ((constant? exp)
4472 (cons (make-assignment id exp)
4477 (cons (make-assignment id1 exp)
4481 (make-lambda (lambda.args exp)
4482 '() ; no definitions
4491 (lambda.args exp))))))
4493 (m-error "Inconsistent macro expansion"
4494 (make-readable exp)))))
4495 (make-assignment id exp))))
4496 (let ((env0 (syntactic-copy global-syntactic-environment))
4497 (bmode (benchmark-mode))
4498 (wmode (issue-warnings)))
4500 (for-each (lambda (pair)
4501 (let ((id0 (car pair))
4503 (syntactic-bind-globally!
4505 (make-inline-denotation
4507 (lambda (exp rename compare)
4508 ; Deliberately non-hygienic!
4509 (cons id1 (cdr exp)))
4510 global-syntactic-environment))
4511 (set! pass1-block-inlines
4512 (cons id0 pass1-block-inlines))))
4515 (issue-warnings wmode)
4517 (do ((forms forms (cdr forms))
4519 (cons (desugar-definitions
4521 global-syntactic-environment
4522 make-toplevel-definition)
4525 (reverse newforms)))))
4526 (benchmark-mode bmode)
4527 (set! global-syntactic-environment env0)
4528 (part3 alist definitions0 definitions1 forms)))))
4530 (define (part3 alist definitions0 definitions1 forms)
4531 (set! pass1-block-compiling? #f)
4532 (set! pass1-block-assignments '())
4533 (set! pass1-block-inlines '())
4534 (let* ((constnames0 (map assignment.lhs definitions0))
4535 (constnames1 (map (lambda (id0)
4536 (cdr (assq id0 alist)))
4538 (procnames1 (map assignment.lhs definitions1)))
4543 '() ; no definitions
4552 (cons (make-constant #f)
4555 (make-assignment id (make-variable (cdr (assq id alist)))))
4560 '() ; no definitions
4568 (map assignment.lhs definitions1)
4569 '() ; no definitions
4575 (make-begin (cons (make-constant #f)
4576 (append definitions1 forms))))
4577 (map (lambda (ignored) (make-unspecified))
4579 (map make-variable constnames1))
4581 (map assignment.rhs definitions0)))))
4583 (set! source-file-name #f)
4584 (set! source-file-position #f)
4585 (if (not (null? rest))
4586 (begin (set! source-file-name (car rest))
4587 (if (not (null? (cdr rest)))
4588 (set! source-file-position (cadr rest)))))
4590 ; Copyright 1999 William D Clinger.
4592 ; Permission to copy this software, in whole or in part, to use this
4593 ; software for any lawful noncommercial purpose, and to redistribute
4594 ; this software is granted subject to the restriction that all copies
4595 ; made of this software must include this copyright notice in full.
4597 ; I also request that you send me a copy of any improvements that you
4598 ; make to this software so that they may be incorporated within it to
4599 ; the benefit of the Scheme community.
4603 ; Support for intraprocedural value numbering:
4604 ; set of available expressions
4607 ; The set of available expressions is represented as a
4608 ; mutable abstract data type Available with these operations:
4610 ; make-available-table: -> Available
4611 ; copy-available-table: Available -> Available
4612 ; available-expression: Available x Expr -> (symbol + {#f})
4613 ; available-variable: Available x symbol -> Expr
4614 ; available-extend!: Available x symbol x Expr x Killer ->
4615 ; available-kill!: Available x Killer ->
4617 ; where Expr is of the form
4625 ; and Killer is a fixnum, as defined later in this file.
4627 ; (make-available-table)
4628 ; returns an empty table of available expressions.
4629 ; (copy-available-table available)
4630 ; copies the given table.
4631 ; (available-expression available E)
4632 ; returns the name of E if it is available in the table, else #f.
4633 ; (available-variable available T)
4634 ; returns a constant or variable to use in place of T, else #f.
4635 ; (available-extend! available T E K)
4636 ; adds the binding (T E) to the table, with Killer K.
4637 ; If E is a variable and this binding is never killed, then copy
4638 ; propagation will replace uses of T by uses of E; otherwise
4639 ; commoning will replace uses of E by uses of T, until the
4640 ; binding is killed.
4641 ; (available-kill! available K)
4642 ; removes all bindings whose Killer intersects K.
4644 ; (available-extend! available T E K) is very fast if the previous
4645 ; operation on the table was (available-expression available E).
4650 ; The available expressions are represented as a vector of 2 association
4651 ; lists. The first list is used for common subexpression elimination,
4652 ; and the second is used for copy and constant propagation.
4654 ; Each element of the first list is a binding of
4655 ; a symbol T to an expression E, with killer K,
4656 ; represented by the list (E T K).
4658 ; Each element of the second list is a binding of
4659 ; a symbol T to an expression E, with killer K,
4660 ; represented by the list (T E K).
4661 ; The expression E will be a constant or variable.
4663 (define (make-available-table)
4666 (define (copy-available-table available)
4667 (vector (vector-ref available 0)
4668 (vector-ref available 1)))
4670 (define (available-expression available E)
4671 (let ((binding (assoc E (vector-ref available 0))))
4676 (define (available-variable available T)
4677 (let ((binding (assq T (vector-ref available 1))))
4682 (define (available-extend! available T E K)
4683 (cond ((constant? E)
4684 (vector-set! available
4687 (vector-ref available 1))))
4689 (eq? K available:killer:none))
4690 (vector-set! available
4693 (vector-ref available 1))))
4695 (vector-set! available
4698 (vector-ref available 0))))))
4700 (define (available-kill! available K)
4701 (vector-set! available
4703 (filter (lambda (binding)
4707 (vector-ref available 0)))
4708 (vector-set! available
4710 (filter (lambda (binding)
4714 (vector-ref available 1))))
4716 (define (available-intersect! available0 available1 available2)
4717 (vector-set! available0
4719 (intersection (vector-ref available1 0)
4720 (vector-ref available2 0)))
4721 (vector-set! available0
4723 (intersection (vector-ref available1 1)
4724 (vector-ref available2 1))))
4726 ; The Killer concrete data type, represented as a fixnum.
4728 ; The set of side effects that can kill an available expression
4731 ; assignments to global variables
4734 ; uses of STRING-SET!
4735 ; uses of VECTOR-SET!
4737 ; This list is not complete. If we were trying to perform common
4738 ; subexpression elimination on calls to PEEK-CHAR, for example,
4739 ; then those calls would be killed by reads.
4741 (define available:killer:globals 2)
4742 (define available:killer:car 4)
4743 (define available:killer:cdr 8)
4744 (define available:killer:string 16) ; also bytevectors etc
4745 (define available:killer:vector 32) ; also structures etc
4746 (define available:killer:cell 64)
4747 (define available:killer:io 128)
4748 (define available:killer:none 0) ; none of the above
4749 (define available:killer:all 1022) ; all of the above
4751 (define available:killer:immortal 0) ; never killed
4752 (define available:killer:dead 1023) ; never available
4756 (define (available:killer-combine k1 k2)
4761 ; A simple lambda expression has no internal definitions at its head
4762 ; and no declarations aside from A-normal form.
4764 (define (simple-lambda? L)
4765 (and (null? (lambda.defs L))
4766 (every? (lambda (decl)
4767 (eq? decl A-normal-form-declaration))
4770 ; A real call is a call whose procedure expression is
4771 ; neither a lambda expression nor a primop.
4773 (define (real-call? E)
4775 (let ((proc (call.proc E)))
4776 (and (not (lambda? proc))
4777 (or (not (variable? proc))
4778 (let ((f (variable.name proc)))
4779 (or (not (integrate-usual-procedures))
4780 (not (prim-entry f)))))))))
4782 (define (prim-call E)
4784 (let ((proc (call.proc E)))
4785 (and (variable? proc)
4786 (integrate-usual-procedures)
4787 (prim-entry (variable.name proc))))))
4789 (define (no-side-effects? E)
4793 (and (conditional? E)
4794 (no-side-effects? (if.test E))
4795 (no-side-effects? (if.then E))
4796 (no-side-effects? (if.else E)))
4798 (let ((proc (call.proc E)))
4799 (and (variable? proc)
4800 (integrate-usual-procedures)
4801 (let ((entry (prim-entry (variable.name proc))))
4803 (not (eq? available:killer:dead
4804 (prim-lives-until entry))))))))))
4806 ; Given a local variable, the expression within its scope, and
4807 ; a list of local variables that are known to be used only once,
4808 ; returns #t if the variable is used only once.
4810 ; The purpose of this routine is to recognize temporaries that
4811 ; may once have had two or more uses because of CSE, but now have
4812 ; only one use because of further CSE followed by dead code elimination.
4814 (define (temporary-used-once? T E used-once)
4816 (let ((proc (call.proc E))
4817 (args (call.args E)))
4818 (or (and (lambda? proc)
4819 (not (memq T (lambda.F proc)))
4822 (temporary-used-once? T (car args) used-once)))
4823 (do ((exprs (cons proc (call.args E))
4826 (let ((exp (car exprs)))
4827 (cond ((constant? exp)
4830 (if (eq? T (variable.name exp))
4834 ; Terminate the loop and return #f.
4840 (memq T used-once))))
4842 ; Register bindings.
4844 (define (make-regbinding lhs rhs use)
4847 (define (regbinding.lhs x) (car x))
4848 (define (regbinding.rhs x) (cadr x))
4849 (define (regbinding.use x) (caddr x))
4851 ; Given a list of register bindings, an expression E and its free variables F,
4852 ; returns two values:
4853 ; E with the register bindings wrapped around it
4854 ; the free variables of the wrapped expression
4856 (define (wrap-with-register-bindings regbindings E F)
4857 (if (null? regbindings)
4859 (let* ((regbinding (car regbindings))
4860 (R (regbinding.lhs regbinding))
4861 (x (regbinding.rhs regbinding)))
4862 (wrap-with-register-bindings
4864 (make-call (make-lambda (list R)
4869 (list A-normal-form-declaration)
4872 (list (make-variable x)))
4874 (difference F (list R)))))))
4876 ; Returns two values:
4877 ; the subset of regbindings that have x as their right hand side
4878 ; the rest of regbindings
4880 (define (register-bindings regbindings x)
4881 (define (loop regbindings to-x others)
4882 (cond ((null? regbindings)
4883 (values to-x others))
4884 ((eq? x (regbinding.rhs (car regbindings)))
4885 (loop (cdr regbindings)
4886 (cons (car regbindings) to-x)
4889 (loop (cdr regbindings)
4891 (cons (car regbindings) others)))))
4892 (loop regbindings '() '()))
4894 ; This procedure is called when the compiler can tell that an assertion
4897 (define (declaration-error E)
4898 (if (issue-warnings)
4899 (begin (display "WARNING: Assertion is false: ")
4900 (write (make-readable E #t))
4902 ; Representations, which form a subtype hierarchy.
4904 ; <rep> ::= <fixnum> | (<fixnum> <datum> ...)
4906 ; (<rep> <datum> ...) is a subtype of <rep>, but the non-fixnum
4907 ; representations are otherwise interpreted by arbitrary code.
4910 (define *rep-encodings* '())
4911 (define *rep-decodings* '())
4912 (define *rep-subtypes* '())
4913 (define *rep-joins* (make-bytevector 0))
4914 (define *rep-meets* (make-bytevector 0))
4915 (define *rep-joins-special* '#())
4916 (define *rep-meets-special* '#())
4918 (define (representation-error msg . stuff)
4921 (string-append "Bug in flow analysis: " msg)
4925 (define (symbol->rep sym)
4926 (let ((probe (assq sym *rep-encodings*)))
4929 (let ((rep *nreps*))
4930 (set! *nreps* (+ *nreps* 1))
4932 (representation-error "Too many representation types"))
4933 (set! *rep-encodings*
4934 (cons (cons sym rep)
4936 (set! *rep-decodings*
4937 (cons (cons rep sym)
4941 (define (rep->symbol rep)
4943 (cons (rep->symbol (car rep)) (cdr rep))
4944 (let ((probe (assv rep *rep-decodings*)))
4949 (define (representation-table table)
4958 ; DEFINE-SUBTYPE is how representation types are defined.
4960 (define (define-subtype sym1 sym2)
4961 (let* ((rep2 (symbol->rep sym2))
4962 (rep1 (symbol->rep sym1)))
4963 (set! *rep-subtypes*
4964 (cons (cons rep1 rep2)
4968 ; COMPUTE-TYPE-STRUCTURE! must be called before DEFINE-INTERSECTION.
4970 (define (define-intersection sym1 sym2 sym3)
4971 (let ((rep1 (symbol->rep sym1))
4972 (rep2 (symbol->rep sym2))
4973 (rep3 (symbol->rep sym3)))
4974 (representation-aset! *rep-meets* rep1 rep2 rep3)
4975 (representation-aset! *rep-meets* rep2 rep1 rep3)))
4979 (define (representation-aref bv i j)
4980 (bytevector-ref bv (+ (* *nreps* i) j)))
4982 (define (representation-aset! bv i j x)
4983 (bytevector-set! bv (+ (* *nreps* i) j) x))
4985 (define (compute-unions!)
4987 ; Always define a bottom element.
4989 (for-each (lambda (sym)
4990 (define-subtype 'bottom sym))
4991 (map car *rep-encodings*))
4993 (let* ((debugging? #f)
4996 (matrix (make-bytevector n^2)))
4998 ; This code assumes there will always be a top element.
5000 (define (lub rep1 rep2 subtype?)
5003 (if (and (subtype? rep1 i)
5008 (car (twobit-sort subtype? bounds)))))
5011 (lub i j (lambda (rep1 rep2)
5012 (= 1 (representation-aref matrix rep1 rep2)))))
5014 (define (compute-transitive-closure!)
5015 (let ((changed? #f))
5025 (representation-aref matrix i j)
5026 (representation-aref matrix j k)))))
5029 (let ((x (representation-aref matrix i k)))
5033 (representation-aset! matrix i k 1)))))))))
5035 (begin (set! changed? #f)
5039 (define (compute-joins!)
5040 (let ((default (lambda (x y)
5041 (error "Compiler bug: special meet or join" x y))))
5042 (set! *rep-joins-special* (make-vector n default))
5043 (set! *rep-meets-special* (make-vector n default)))
5044 (set! *rep-joins* (make-bytevector n^2))
5045 (set! *rep-meets* (make-bytevector n^2))
5050 (representation-aset! *rep-joins*
5059 (representation-aset! matrix i j 0))
5060 (representation-aset! matrix i i 1))
5061 (for-each (lambda (subtype)
5062 (let ((rep1 (car subtype))
5063 (rep2 (cdr subtype)))
5064 (representation-aset! matrix rep1 rep2 1)))
5066 (compute-transitive-closure!)
5072 (write-char #\space)
5073 (write (representation-aref matrix i j)))
5076 (set! *rep-subtypes* '())))
5078 ; Intersections are not dual to unions because a conservative analysis
5079 ; must always err on the side of the larger subtype.
5080 ; COMPUTE-UNIONS! must be called before COMPUTE-INTERSECTIONS!.
5082 (define (compute-intersections!)
5086 (let ((k (representation-union i j)))
5095 (representation-aset! *rep-meets*
5100 (define (compute-type-structure!)
5102 (compute-intersections!))
5104 (define (representation-subtype? rep1 rep2)
5105 (equal? rep2 (representation-union rep1 rep2)))
5107 (define (representation-union rep1 rep2)
5110 (representation-aref *rep-joins* rep1 rep2)
5111 (representation-union rep1 (car rep2)))
5113 (representation-union (car rep1) rep2)
5114 (let ((r1 (car rep1))
5117 ((vector-ref *rep-joins-special* r1) rep1 rep2)
5118 (representation-union r1 r2))))))
5120 (define (representation-intersection rep1 rep2)
5123 (representation-aref *rep-meets* rep1 rep2)
5124 (representation-intersection rep1 (car rep2)))
5126 (representation-intersection (car rep1) rep2)
5127 (let ((r1 (car rep1))
5130 ((vector-ref *rep-meets-special* r1) rep1 rep2)
5131 (representation-intersection r1 r2))))))
5135 (define (display-unions-and-intersections)
5136 (let* ((column-width 10)
5137 (columns/row (quotient 80 column-width)))
5139 (define (display-symbol sym)
5140 (let* ((s (symbol->string sym))
5141 (n (string-length s)))
5142 (if (< n column-width)
5144 (display (make-string (- column-width n) #\space)))
5145 (begin (display (substring s 0 (- column-width 1)))
5146 (write-char #\space)))))
5148 ; Display columns i to n.
5150 (define (display-matrix f i n)
5151 (display (make-string column-width #\space))
5154 (display-symbol (rep->symbol i)))
5159 (display-symbol (rep->symbol k))
5162 (display-symbol (rep->symbol (f k i))))
5171 (do ((i 0 (+ i columns/row)))
5173 (display-matrix representation-union
5175 (min *nreps* (+ i columns/row))))
5177 (display "Intersections:")
5181 (do ((i 0 (+ i columns/row)))
5183 (display-matrix representation-intersection
5185 (min *nreps* (+ i columns/row))))))
5187 ; Operations that can be specialized.
5189 ; Format: (<name> (<arg-rep> ...) <specific-name>)
5191 (define (rep-specific? f rs)
5192 (rep-match f rs rep-specific caddr))
5194 ; Operations whose result has some specific representation.
5196 ; Format: (<name> (<arg-rep> ...) (<result-rep>))
5198 (define (rep-result? f rs)
5199 (rep-match f rs rep-result caaddr))
5201 ; Unary predicates that give information about representation.
5203 ; Format: (<name> <rep-if-true> <rep-if-false>)
5205 (define (rep-if-true f rs)
5206 (rep-match f rs rep-informing caddr))
5208 (define (rep-if-false f rs)
5209 (rep-match f rs rep-informing cadddr))
5211 ; Given the name of an integrable primitive,
5212 ; the representations of its arguments,
5213 ; a representation table, and a selector function
5214 ; finds the most type-specific row of the table that matches both
5215 ; the name of the primitive and the representations of its arguments,
5216 ; and returns the result of applying the selector to that row.
5217 ; If no row matches, then REP-MATCH returns #f.
5219 ; FIXME: This should be more efficient, and should prefer the most
5222 (define (rep-match f rs table selector)
5223 (let ((n (length rs)))
5224 (let loop ((entries table))
5225 (cond ((null? entries)
5227 ((eq? f (car (car entries)))
5228 (let ((rs0 (cadr (car entries))))
5229 (if (and (= n (length rs0))
5230 (every? (lambda (r1+r2)
5231 (let ((r1 (car r1+r2))
5233 (representation-subtype? r1 r2)))
5235 (selector (car entries))
5236 (loop (cdr entries)))))
5238 (loop (cdr entries)))))))
5240 ; Abstract interpretation with respect to types and constraints.
5241 ; Returns a representation type.
5243 (define (aeval E types constraints)
5245 (let ((proc (call.proc E)))
5246 (if (variable? proc)
5247 (let* ((op (variable.name proc))
5248 (argtypes (map (lambda (E)
5249 (aeval E types constraints))
5251 (type (rep-result? op argtypes)))
5257 (representation-typeof (variable.name E) types constraints))
5259 (representation-of-value (constant.value E)))
5263 ; If x has representation type t0 in the hash table,
5264 ; and some further constraints
5266 ; x = (op y1 ... yn)
5273 ; typeof (x) = op (typeof (y1), ..., typeof (yn))
5274 ; & t0 & t1 & ... & tk
5276 ; where & means intersection and op is the abstraction of op.
5278 ; Also if T : true and T = E then E may give information about
5279 ; the types of other variables. Similarly for T : false.
5281 (define (representation-typeof name types constraints)
5282 (let ((t0 (hashtable-fetch types name rep:object))
5283 (cs (hashtable-fetch (constraints.table constraints) name '())))
5284 (define (loop type cs)
5289 (E (constraint.rhs c)))
5290 (cond ((constant? E)
5291 (loop (representation-intersection type
5295 (loop (representation-intersection
5296 type (aeval E types constraints))
5304 ; The constraints used by this analysis consist of type constraints
5305 ; together with the available expressions used for commoning.
5307 ; (T E K) T = E until killed by an effect in K
5308 ; (T '<rep> K) T : <rep> until killed by an effect in K
5310 (define (make-constraint T E K)
5313 (define (constraint.lhs c)
5316 (define (constraint.rhs c)
5319 (define (constraint.killer c)
5322 (define (make-type-constraint T type K)
5324 (make-constant type)
5327 ; If the new constraint is of the form T = E until killed by K,
5328 ; then there shouldn't be any prior constraints.
5330 ; Otherwise the new constraint is of the form T : t until killed by K.
5331 ; Suppose the prior constraints are
5332 ; T = E until killed by K
5333 ; T : t1 until killed by K1
5335 ; T : tn until killed by Kn
5337 ; If there exists i such that ti is a subtype of t and Ki a subset of K,
5338 ; then the new constraint adds no new information and should be ignored.
5339 ; Otherwise compute t' = t1 & ... & tn and K' = K1 | ... | Kn, where
5340 ; & indicates intersection and | indicates union.
5341 ; If K = K' then add the new constraint T : t' until killed by K;
5342 ; otherwise add two new constraints:
5343 ; T : t' until killed by K'
5344 ; T : t until killed by K
5346 (define (constraints-add! types constraints new)
5347 (let* ((debugging? #f)
5348 (T (constraint.lhs new))
5349 (E (constraint.rhs new))
5350 (K (constraint.killer new))
5351 (cs (constraints-for-variable constraints T)))
5353 (define (loop type K cs newcs)
5355 (cons (make-type-constraint T type K) newcs)
5356 (let* ((c2 (car cs))
5358 (E2 (constraint.rhs c2))
5359 (K2 (constraint.killer c2)))
5361 (let* ((type2 (constant.value E2))
5362 (type3 (representation-intersection type type2)))
5363 (cond ((eq? type2 type3)
5364 (if (= K2 (logand K K2))
5366 (loop (representation-intersection type type2)
5367 (available:killer-combine K K2)
5370 ((representation-subtype? type type3)
5371 (if (= K (logand K K2))
5372 (loop type K cs newcs)
5373 (loop type K cs (cons c2 newcs))))
5376 (available:killer-combine K K2)
5379 (let* ((op (variable.name (call.proc E2)))
5380 (args (call.args E2))
5381 (argtypes (map (lambda (exp)
5382 (aeval exp types constraints))
5384 (cond ((representation-subtype? type rep:true)
5385 (let ((reps (rep-if-true op argtypes)))
5387 (record-new-reps! args argtypes reps K2))))
5388 ((representation-subtype? type rep:false)
5389 (let ((reps (rep-if-false op argtypes)))
5391 (record-new-reps! args argtypes reps K2)))))
5392 (loop type K cs (cons c2 newcs)))))))
5394 (define (record-new-reps! args argtypes reps K2)
5396 (begin (write (list (map make-readable args)
5397 (map rep->symbol argtypes)
5398 (map rep->symbol reps)))
5400 (for-each (lambda (arg type0 type1)
5401 (if (not (representation-subtype? type0 type1))
5403 (let ((name (variable.name arg)))
5404 ; FIXME: In this context, a variable
5405 ; should always be local so the hashtable
5406 ; operation isn't necessary.
5407 (if (hashtable-get types name)
5411 (make-type-constraint
5414 (available:killer-combine K K2)))
5416 "Compiler bug: unexpected global: "
5418 args argtypes reps))
5421 (constraints-add-killedby! constraints T K))
5423 (let* ((table (constraints.table constraints))
5424 (cs (hashtable-fetch table T '())))
5425 (cond ((constant? E)
5426 ; It's a type constraint.
5427 (let ((type (constant.value E)))
5431 (display (rep->symbol type))
5433 (let ((cs (loop type K cs '())))
5434 (hashtable-put! table T cs)
5440 (display (make-readable E #t))
5442 (if (not (null? cs))
5444 (display "Compiler bug: ")
5446 (display " has unexpectedly nonempty constraints")
5448 (hashtable-put! table T (list (list T E K)))
5451 ; Sets of constraints.
5453 ; The set of constraints is represented as (<hashtable> <killedby>),
5454 ; where <hashtable> is a hashtable mapping variables to lists of
5455 ; constraints as above, and <killedby> is a vector mapping basic killers
5456 ; to lists of variables that need to be examined for constraints that
5457 ; are killed by that basic killer.
5459 (define number-of-basic-killers
5462 ((> k available:killer:dead)
5465 (define (constraints.table constraints) (car constraints))
5466 (define (constraints.killed constraints) (cadr constraints))
5468 (define (make-constraints-table)
5469 (list (make-hashtable symbol-hash assq)
5470 (make-vector number-of-basic-killers '())))
5472 (define (copy-constraints-table constraints)
5473 (list (hashtable-copy (constraints.table constraints))
5474 (list->vector (vector->list (constraints.killed constraints)))))
5476 (define (constraints-for-variable constraints T)
5477 (hashtable-fetch (constraints.table constraints) T '()))
5479 (define (constraints-add-killedby! constraints T K0)
5480 (if (not (zero? K0))
5481 (let ((v (constraints.killed constraints)))
5484 ((= i number-of-basic-killers))
5485 (if (not (zero? (logand k K0)))
5486 (vector-set! v i (cons T (vector-ref v i))))))))
5488 (define (constraints-kill! constraints K)
5490 (let ((table (constraints.table constraints))
5491 (killed (constraints.killed constraints)))
5492 (define (examine! T)
5493 (let ((cs (filter (lambda (c)
5494 (zero? (logand (constraint.killer c) K)))
5495 (hashtable-fetch table T '()))))
5497 (hashtable-remove! table T)
5498 (hashtable-put! table T cs))))
5501 ((= i number-of-basic-killers))
5502 (if (not (zero? (logand j K)))
5503 (begin (for-each examine! (vector-ref killed i))
5504 (vector-set! killed i '())))))))
5506 (define (constraints-intersect! constraints0 constraints1 constraints2)
5507 (let ((table0 (constraints.table constraints0))
5508 (table1 (constraints.table constraints1))
5509 (table2 (constraints.table constraints2)))
5510 (if (eq? table0 table1)
5511 ; FIXME: Which is more efficient: to update the killed vector,
5512 ; or not to update it? Both are safe.
5513 (hashtable-for-each (lambda (T cs)
5514 (if (not (null? cs))
5519 (hashtable-fetch table2 T '())
5522 ; This case shouldn't ever happen, so it can be slow.
5524 (constraints-intersect! constraints0 constraints0 constraints1)
5525 (constraints-intersect! constraints0 constraints0 constraints2)))))
5527 (define (cs-intersect cs1 cs2)
5528 (define (loop cs init rep Krep)
5530 (values init rep Krep)
5533 (E2 (constraint.rhs c))
5534 (K2 (constraint.killer c)))
5535 (cond ((constant? E2)
5538 (representation-intersection rep (constant.value E2))
5539 (available:killer-combine Krep K2)))
5542 (begin (display "Compiler bug in cs-intersect")
5544 (loop cs c rep Krep)))
5546 (error "Compiler bug in cs-intersect"))))))
5549 (loop cs1 #f rep:object available:killer:none))
5550 (lambda (c1 rep1 Krep1)
5553 (loop cs2 #f rep:object available:killer:none))
5554 (lambda (c2 rep2 Krep2)
5555 (let ((c (if (equal? c1 c2) c1 #f))
5556 (rep (representation-union rep1 rep2))
5557 (Krep (available:killer-combine Krep1 Krep2)))
5558 (if (eq? rep rep:object)
5560 (let ((T (constraint.lhs (car cs1))))
5562 (list c (make-type-constraint T rep Krep))
5563 (list (make-type-constraint T rep Krep)))))))))))
5564 ; DO NOT EDIT THIS FILE. Edit the config file and rerun "config".
5566 (define $gc.ephemeral 0)
5567 (define $gc.tenuring 1)
5569 (define $mstat.wallocated-hi 0)
5570 (define $mstat.wallocated-lo 1)
5571 (define $mstat.wcollected-hi 2)
5572 (define $mstat.wcollected-lo 3)
5573 (define $mstat.wcopied-hi 4)
5574 (define $mstat.wcopied-lo 5)
5575 (define $mstat.gctime 6)
5576 (define $mstat.wlive 7)
5577 (define $mstat.gc-last-gen 8)
5578 (define $mstat.gc-last-type 9)
5579 (define $mstat.generations 10)
5580 (define $mstat.g-gc-count 0)
5581 (define $mstat.g-prom-count 1)
5582 (define $mstat.g-gctime 2)
5583 (define $mstat.g-wlive 3)
5584 (define $mstat.g-np-youngp 4)
5585 (define $mstat.g-np-oldp 5)
5586 (define $mstat.g-np-j 6)
5587 (define $mstat.g-np-k 7)
5588 (define $mstat.g-alloc 8)
5589 (define $mstat.g-target 9)
5590 (define $mstat.g-promtime 10)
5591 (define $mstat.remsets 11)
5592 (define $mstat.r-apool 0)
5593 (define $mstat.r-upool 1)
5594 (define $mstat.r-ahash 2)
5595 (define $mstat.r-uhash 3)
5596 (define $mstat.r-hrec-hi 4)
5597 (define $mstat.r-hrec-lo 5)
5598 (define $mstat.r-hrem-hi 6)
5599 (define $mstat.r-hrem-lo 7)
5600 (define $mstat.r-hscan-hi 8)
5601 (define $mstat.r-hscan-lo 9)
5602 (define $mstat.r-wscan-hi 10)
5603 (define $mstat.r-wscan-lo 11)
5604 (define $mstat.r-ssbrec-hi 12)
5605 (define $mstat.r-ssbrec-lo 13)
5606 (define $mstat.r-np-p 14)
5607 (define $mstat.fflushed-hi 12)
5608 (define $mstat.fflushed-lo 13)
5609 (define $mstat.wflushed-hi 14)
5610 (define $mstat.wflushed-lo 15)
5611 (define $mstat.stk-created 16)
5612 (define $mstat.frestored-hi 17)
5613 (define $mstat.frestored-lo 18)
5614 (define $mstat.words-heap 19)
5615 (define $mstat.words-remset 20)
5616 (define $mstat.words-rts 21)
5617 (define $mstat.swb-assign 22)
5618 (define $mstat.swb-lhs-ok 23)
5619 (define $mstat.swb-rhs-const 24)
5620 (define $mstat.swb-not-xgen 25)
5621 (define $mstat.swb-trans 26)
5622 (define $mstat.rtime 27)
5623 (define $mstat.stime 28)
5624 (define $mstat.utime 29)
5625 (define $mstat.minfaults 30)
5626 (define $mstat.majfaults 31)
5627 (define $mstat.np-remsetp 32)
5628 (define $mstat.max-heap 33)
5629 (define $mstat.promtime 34)
5630 (define $mstat.wmoved-hi 35)
5631 (define $mstat.wmoved-lo 36)
5632 (define $mstat.vsize 37)
5636 (define $r.reg10 52)
5637 (define $r.reg11 56)
5638 (define $r.reg12 60)
5639 (define $r.reg13 64)
5640 (define $r.reg14 68)
5641 (define $r.reg15 72)
5642 (define $r.reg16 76)
5643 (define $r.reg17 80)
5644 (define $r.reg18 84)
5645 (define $r.reg19 88)
5646 (define $r.reg20 92)
5647 (define $r.reg21 96)
5648 (define $r.reg22 100)
5649 (define $r.reg23 104)
5650 (define $r.reg24 108)
5651 (define $r.reg25 112)
5652 (define $r.reg26 116)
5653 (define $r.reg27 120)
5654 (define $r.reg28 124)
5655 (define $r.reg29 128)
5656 (define $r.reg30 132)
5657 (define $r.reg31 136)
5658 (define $g.stkbot 180)
5659 (define $g.gccnt 420)
5660 (define $m.alloc 1024)
5661 (define $m.alloci 1032)
5663 (define $m.addtrans 1048)
5664 (define $m.stkoflow 1056)
5665 (define $m.stkuflow 1072)
5666 (define $m.creg 1080)
5667 (define $m.creg-set! 1088)
5668 (define $m.add 1096)
5669 (define $m.subtract 1104)
5670 (define $m.multiply 1112)
5671 (define $m.quotient 1120)
5672 (define $m.remainder 1128)
5673 (define $m.divide 1136)
5674 (define $m.modulo 1144)
5675 (define $m.negate 1152)
5676 (define $m.numeq 1160)
5677 (define $m.numlt 1168)
5678 (define $m.numle 1176)
5679 (define $m.numgt 1184)
5680 (define $m.numge 1192)
5681 (define $m.zerop 1200)
5682 (define $m.complexp 1208)
5683 (define $m.realp 1216)
5684 (define $m.rationalp 1224)
5685 (define $m.integerp 1232)
5686 (define $m.exactp 1240)
5687 (define $m.inexactp 1248)
5688 (define $m.exact->inexact 1256)
5689 (define $m.inexact->exact 1264)
5690 (define $m.make-rectangular 1272)
5691 (define $m.real-part 1280)
5692 (define $m.imag-part 1288)
5693 (define $m.sqrt 1296)
5694 (define $m.round 1304)
5695 (define $m.truncate 1312)
5696 (define $m.apply 1320)
5697 (define $m.varargs 1328)
5698 (define $m.typetag 1336)
5699 (define $m.typetag-set 1344)
5700 (define $m.break 1352)
5701 (define $m.eqv 1360)
5702 (define $m.partial-list->vector 1368)
5703 (define $m.timer-exception 1376)
5704 (define $m.exception 1384)
5705 (define $m.singlestep 1392)
5706 (define $m.syscall 1400)
5707 (define $m.bvlcmp 1408)
5708 (define $m.enable-interrupts 1416)
5709 (define $m.disable-interrupts 1424)
5710 (define $m.alloc-bv 1432)
5711 (define $m.global-ex 1440)
5712 (define $m.invoke-ex 1448)
5713 (define $m.global-invoke-ex 1456)
5714 (define $m.argc-ex 1464)
5715 ; DO NOT EDIT THIS FILE. Edit the config file and rerun "config".
5749 (define $r.result $r.o0)
5750 (define $r.argreg2 $r.o1)
5751 (define $r.argreg3 $r.o2)
5752 (define $r.stkp $r.o3)
5753 (define $r.stklim $r.i0)
5754 (define $r.tmp1 $r.o4)
5755 (define $r.tmp2 $r.o5)
5756 (define $r.tmp0 $r.g1)
5757 (define $r.e-top $r.i0)
5758 (define $r.e-limit $r.o3)
5759 (define $r.timer $r.i4)
5760 (define $r.millicode $r.i7)
5761 (define $r.globals $r.i7)
5762 (define $r.reg0 $r.l0)
5763 (define $r.reg1 $r.l1)
5764 (define $r.reg2 $r.l2)
5765 (define $r.reg3 $r.l3)
5766 (define $r.reg4 $r.l4)
5767 (define $r.reg5 $r.l5)
5768 (define $r.reg6 $r.l6)
5769 (define $r.reg7 $r.l7)
5770 ; DO NOT EDIT THIS FILE. Edit the config file and rerun "config".
5774 (define $ex.setcar 2)
5775 (define $ex.setcdr 3)
5780 (define $ex.lessp 14)
5781 (define $ex.lesseqp 15)
5782 (define $ex.equalp 16)
5783 (define $ex.greatereqp 17)
5784 (define $ex.greaterp 18)
5785 (define $ex.quotient 19)
5786 (define $ex.remainder 20)
5787 (define $ex.modulo 21)
5788 (define $ex.logior 22)
5789 (define $ex.logand 23)
5790 (define $ex.logxor 24)
5791 (define $ex.lognot 25)
5793 (define $ex.rsha 27)
5794 (define $ex.rshl 28)
5797 (define $ex.exactp 31)
5798 (define $ex.inexactp 32)
5799 (define $ex.round 33)
5800 (define $ex.trunc 34)
5801 (define $ex.zerop 35)
5804 (define $ex.realpart 38)
5805 (define $ex.imagpart 39)
5806 (define $ex.vref 40)
5807 (define $ex.vset 41)
5808 (define $ex.vlen 42)
5809 (define $ex.pref 50)
5810 (define $ex.pset 51)
5811 (define $ex.plen 52)
5812 (define $ex.sref 60)
5813 (define $ex.sset 61)
5814 (define $ex.slen 62)
5815 (define $ex.bvref 70)
5816 (define $ex.bvset 71)
5817 (define $ex.bvlen 72)
5818 (define $ex.bvlref 80)
5819 (define $ex.bvlset 81)
5820 (define $ex.bvllen 82)
5821 (define $ex.vlref 90)
5822 (define $ex.vlset 91)
5823 (define $ex.vllen 92)
5824 (define $ex.typetag 100)
5825 (define $ex.typetagset 101)
5826 (define $ex.apply 102)
5827 (define $ex.argc 103)
5828 (define $ex.vargc 104)
5829 (define $ex.nonproc 105)
5830 (define $ex.undef-global 106)
5831 (define $ex.dump 107)
5832 (define $ex.dumpfail 108)
5833 (define $ex.timer 109)
5834 (define $ex.unsupported 110)
5835 (define $ex.int2char 111)
5836 (define $ex.char2int 112)
5837 (define $ex.mkbvl 113)
5838 (define $ex.mkvl 114)
5839 (define $ex.char<? 115)
5840 (define $ex.char<=? 116)
5841 (define $ex.char=? 117)
5842 (define $ex.char>? 118)
5843 (define $ex.char>=? 119)
5844 (define $ex.bvfill 120)
5845 (define $ex.enable-interrupts 121)
5846 (define $ex.keyboard-interrupt 122)
5847 (define $ex.arithmetic-exception 123)
5848 (define $ex.global-invoke 124)
5849 (define $ex.fx+ 140)
5850 (define $ex.fx- 141)
5851 (define $ex.fx-- 142)
5852 (define $ex.fx= 143)
5853 (define $ex.fx< 144)
5854 (define $ex.fx<= 145)
5855 (define $ex.fx> 146)
5856 (define $ex.fx>= 147)
5857 (define $ex.fxpositive? 148)
5858 (define $ex.fxnegative? 149)
5859 (define $ex.fxzero? 150)
5860 (define $ex.fx* 151)
5861 ; DO NOT EDIT THIS FILE. Edit the config file and rerun "config".
5863 (define $tag.tagmask 7)
5864 (define $tag.pair-tag 1)
5865 (define $tag.vector-tag 3)
5866 (define $tag.bytevector-tag 5)
5867 (define $tag.procedure-tag 7)
5868 (define $imm.vector-header 162)
5869 (define $imm.bytevector-header 194)
5870 (define $imm.procedure-header 254)
5871 (define $imm.true 6)
5872 (define $imm.false 2)
5873 (define $imm.null 10)
5874 (define $imm.unspecified 278)
5875 (define $imm.eof 534)
5876 (define $imm.undefined 790)
5877 (define $imm.character 38)
5878 (define $tag.vector-typetag 0)
5879 (define $tag.rectnum-typetag 4)
5880 (define $tag.ratnum-typetag 8)
5881 (define $tag.symbol-typetag 12)
5882 (define $tag.port-typetag 16)
5883 (define $tag.structure-typetag 20)
5884 (define $tag.bytevector-typetag 0)
5885 (define $tag.string-typetag 4)
5886 (define $tag.flonum-typetag 8)
5887 (define $tag.compnum-typetag 12)
5888 (define $tag.bignum-typetag 16)
5889 (define $hdr.port 178)
5890 (define $hdr.struct 182)
5891 (define $p.codevector -3)
5892 (define $p.constvector 1)
5893 (define $p.linkoffset 5)
5895 (define $p.codeoffset -1)
5896 ; Copyright 1991 William Clinger
5898 ; Relatively target-independent information for Twobit's backend.
5900 ; 24 April 1999 / wdc
5902 ; Most of the definitions in this file can be extended or overridden by
5903 ; target-specific definitions.
5906 (lambda (less? list) (compat:sort list less?)))
5908 (define renaming-prefix ".")
5910 ; The prefix used for cells introduced by the compiler.
5912 (define cell-prefix (string-append renaming-prefix "CELL:"))
5914 ; Names of global procedures that cannot be redefined or assigned
5916 ; The expansion of quasiquote uses .cons and .list directly, so these
5917 ; should not be changed willy-nilly.
5918 ; Others may be used directly by a DEFINE-INLINE.
5920 (define name:CHECK! '.check!)
5921 (define name:CONS '.cons)
5922 (define name:LIST '.list)
5923 (define name:MAKE-CELL '.make-cell)
5924 (define name:CELL-REF '.cell-ref)
5925 (define name:CELL-SET! '.cell-set!)
5926 (define name:IGNORED (string->symbol "IGNORED"))
5927 (define name:CAR '.car)
5928 (define name:CDR '.cdr)
5930 ;(begin (eval `(define ,name:CONS cons))
5931 ; (eval `(define ,name:LIST list))
5932 ; (eval `(define ,name:MAKE-CELL list))
5933 ; (eval `(define ,name:CELL-REF car))
5934 ; (eval `(define ,name:CELL-SET! set-car!)))
5936 ; If (INTEGRATE-USUAL-PROCEDURES) is true, then control optimization
5937 ; recognizes calls to these procedures.
5939 (define name:NOT 'not)
5940 (define name:MEMQ 'memq)
5941 (define name:MEMV 'memv)
5943 ; If (INTEGRATE-USUAL-PROCEDURES) is true, then control optimization
5944 ; recognizes calls to these procedures and also creates calls to them.
5946 (define name:EQ? 'eq?)
5947 (define name:EQV? 'eqv?)
5949 ; Control optimization creates calls to these procedures,
5950 ; which do not need to check their arguments.
5952 (define name:FIXNUM? 'fixnum?)
5953 (define name:CHAR? 'char?)
5954 (define name:SYMBOL? 'symbol?)
5955 (define name:FX< '<:fix:fix)
5956 (define name:FX- 'fx-) ; non-checking version
5957 (define name:CHAR->INTEGER 'char->integer) ; non-checking version
5958 (define name:VECTOR-REF 'vector-ref:trusted)
5962 ; Prototype, will probably change in the future.
5964 (define (constant-folding-entry name)
5965 (assq name $usual-constant-folding-procedures$))
5967 (define constant-folding-predicates cadr)
5968 (define constant-folding-folder caddr)
5970 (define $usual-constant-folding-procedures$
5971 (let ((always? (lambda (x) #t))
5972 (charcode? (lambda (n)
5977 (ratnum? (lambda (n)
5981 ; smallint? is defined later.
5982 (smallint? (lambda (n) (smallint? n))))
5984 ; This makes some assumptions about the host system.
5986 (integer->char (,charcode?) ,integer->char)
5987 (char->integer (,char?) ,char->integer)
5988 (zero? (,ratnum?) ,zero?)
5989 (< (,ratnum? ,ratnum?) ,<)
5990 (<= (,ratnum? ,ratnum?) ,<=)
5991 (= (,ratnum? ,ratnum?) ,=)
5992 (>= (,ratnum? ,ratnum?) ,>=)
5993 (> (,ratnum? ,ratnum?) ,>)
5994 (+ (,ratnum? ,ratnum?) ,+)
5995 (- (,ratnum? ,ratnum?) ,-)
5996 (* (,ratnum? ,ratnum?) ,*)
5997 (-- (,ratnum?) ,(lambda (x) (- 0 x)))
5998 (eq? (,always? ,always?) ,eq?)
5999 (eqv? (,always? ,always?) ,eqv?)
6000 (equal? (,always? ,always?) ,equal?)
6001 (memq (,always? ,list?) ,memq)
6002 (memv (,always? ,list?) ,memv)
6003 (member (,always? ,list?) ,member)
6004 (assq (,always? ,list?) ,assq)
6005 (assv (,always? ,list?) ,assv)
6006 (assoc (,always? ,list?) ,assoc)
6007 (length (,list?) ,length)
6008 (fixnum? (,smallint?) ,smallint?)
6009 (=:fix:fix (,smallint? ,smallint?) ,=)
6010 (<:fix:fix (,smallint? ,smallint?) ,<)
6011 (<=:fix:fix (,smallint? ,smallint?) ,<=)
6012 (>:fix:fix (,smallint? ,smallint?) ,>)
6013 (>=:fix:fix (,smallint? ,smallint?) ,>=)
6017 (define (.check! flag exn . args)
6019 (apply error "Runtime check exception: " exn args)))
6022 ; Order matters. If f and g are both inlined, and the definition of g
6023 ; uses f, then f should be defined before g.
6032 (.check! (pair? x) ,$ex.car x)
6039 (.check! (pair? x) ,$ex.cdr x)
6042 (define-inline vector-length
6046 (.check! (vector? v) ,$ex.vlen v)
6047 (vector-length:vec v)))))
6049 (define-inline vector-ref
6054 (.check! (fixnum? i) ,$ex.vref v i)
6055 (.check! (vector? v) ,$ex.vref v i)
6056 (.check! (<:fix:fix i (vector-length:vec v)) ,$ex.vref v i)
6057 (.check! (>=:fix:fix i 0) ,$ex.vref v i)
6058 (vector-ref:trusted v i)))))
6060 (define-inline vector-set!
6062 ((vector-set! v0 i0 x0)
6066 (.check! (fixnum? i) ,$ex.vset v i x)
6067 (.check! (vector? v) ,$ex.vset v i x)
6068 (.check! (<:fix:fix i (vector-length:vec v)) ,$ex.vset v i x)
6069 (.check! (>=:fix:fix i 0) ,$ex.vset v i x)
6070 (vector-set!:trusted v i x)))))
6072 ; This transformation must make sure the entire list is freshly
6073 ; allocated when an argument to LIST returns more than once.
6083 (t2 (list ?e2 ...)))
6086 ; This transformation must make sure the entire list is freshly
6087 ; allocated when an argument to VECTOR returns more than once.
6089 (define-inline vector
6095 ((vector ?e1 ?e2 ...)
6098 (... (syntax-rules ()
6099 ((vector-aux1 () ?n ?exps ?indexes ?temps)
6100 (vector-aux2 ?n ?exps ?indexes ?temps))
6101 ((vector-aux1 (?exp1 ?exp2 ...) ?n ?exps ?indexes ?temps)
6102 (vector-aux1 (?exp2 ...)
6108 (... (syntax-rules ()
6109 ((vector-aux2 ?n (?exp1 ?exp2 ...) (?n1 ?n2 ...) (?t1 ?t2 ...))
6113 (v (make-vector ?n ?t1)))
6114 (vector-set! v ?n2 ?t2)
6117 (vector-aux1 (?e1 ?e2 ...) 0 () () ())))))
6119 (define-inline cadddr
6122 (car (cdr (cdr (cdr ?e)))))))
6124 (define-inline cddddr
6127 (cdr (cdr (cdr (cdr ?e)))))))
6129 (define-inline cdddr
6132 (cdr (cdr (cdr ?e))))))
6134 (define-inline caddr
6137 (car (cdr (cdr ?e))))))
6159 (define-inline make-vector
6162 (make-vector ?n '()))))
6164 (define-inline make-string
6167 (make-string ?n #\space))))
6171 ((= ?e1 ?e2 ?e3 ?e4 ...)
6174 (= t ?e3 ?e4 ...))))))
6178 ((< ?e1 ?e2 ?e3 ?e4 ...)
6181 (< t ?e3 ?e4 ...))))))
6185 ((> ?e1 ?e2 ?e3 ?e4 ...)
6188 (> t ?e3 ?e4 ...))))))
6192 ((<= ?e1 ?e2 ?e3 ?e4 ...)
6195 (<= t ?e3 ?e4 ...))))))
6199 ((>= ?e1 ?e2 ?e3 ?e4 ...)
6202 (>= t ?e3 ?e4 ...))))))
6210 ((+ ?e1 ?e2 ?e3 ?e4 ...)
6211 (+ (+ ?e1 ?e2) ?e3 ?e4 ...))))
6219 ((* ?e1 ?e2 ?e3 ?e4 ...)
6220 (* (* ?e1 ?e2) ?e3 ?e4 ...))))
6226 ((- ?e1 ?e2 ?e3 ?e4 ...)
6227 (- (- ?e1 ?e2) ?e3 ?e4 ...))))
6233 ((/ ?e1 ?e2 ?e3 ?e4 ...)
6234 (/ (/ ?e1 ?e2) ?e3 ?e4 ...))))
6244 (define-inline negative?
6249 (define-inline positive?
6256 (lambda (exp rename compare)
6257 (let ((arg1 (cadr exp))
6259 (define (constant? exp)
6264 (identifier? (car exp))
6265 (compare (car exp) (rename 'quote))
6266 (symbol? (cadr exp)))))
6267 (if (or (constant? arg1)
6269 (cons (rename 'eq?) (cdr exp))
6273 (syntax-rules (quote)
6274 ((memq ?expr '(?datum ...))
6277 (... (syntax-rules (quote)
6278 ((memq0 '?xx '(?d ...))
6279 (let ((t1 '(?d ...)))
6280 (memq1 '?xx t1 (?d ...))))
6281 ((memq0 ?e '(?d ...))
6284 (memq1 t0 t1 (?d ...)))))))
6286 (... (syntax-rules ()
6289 ((memq1 ?t0 ?t1 (?d1 ?d2 ...))
6292 (let ((?t1 (cdr ?t1)))
6293 (memq1 ?t0 ?t1 (?d2 ...)))))))))
6294 (memq0 ?expr '(?datum ...))))))
6298 (lambda (exp rename compare)
6299 (let ((arg1 (cadr exp))
6301 (if (or (boolean? arg1)
6306 (identifier? (car arg1))
6307 (compare (car arg1) (rename 'quote))
6308 (symbol? (cadr arg1)))
6311 (identifier? (car arg2))
6312 (compare (car arg2) (rename 'quote))
6313 (every1? (lambda (x)
6319 (cons (rename 'memq) (cdr exp))
6324 (lambda (exp rename compare)
6325 (let ((arg1 (cadr exp))
6327 (if (or (boolean? arg1)
6331 (identifier? (car arg1))
6332 (compare (car arg1) (rename 'quote))
6333 (symbol? (cadr arg1)))
6336 (identifier? (car arg2))
6337 (compare (car arg2) (rename 'quote))
6338 (every1? (lambda (y)
6345 (cons (rename 'assq) (cdr exp))
6349 (syntax-rules (lambda)
6350 ((map ?proc ?exp1 ?exp2 ...)
6353 (... (syntax-rules (lambda)
6354 ((loop 1 () (?y1 ?y2 ...) ?f ?exprs)
6355 (loop 2 (?y1 ?y2 ...) ?f ?exprs))
6356 ((loop 1 (?a1 ?a2 ...) (?y2 ...) ?f ?exprs)
6357 (loop 1 (?a2 ...) (y1 ?y2 ...) ?f ?exprs))
6359 ((loop 2 ?ys (lambda ?formals ?body) ?exprs)
6360 (loop 3 ?ys (lambda ?formals ?body) ?exprs))
6361 ((loop 2 ?ys (?f1 . ?f2) ?exprs)
6362 (let ((f (?f1 . ?f2)))
6363 (loop 3 ?ys f ?exprs)))
6364 ; ?f must be a constant or variable.
6365 ((loop 2 ?ys ?f ?exprs)
6366 (loop 3 ?ys ?f ?exprs))
6368 ((loop 3 (?y1 ?y2 ...) ?f (?e1 ?e2 ...))
6369 (do ((?y1 ?e1 (cdr ?y1))
6372 (results '() (cons (?f (car ?y1) (car ?y2) ...)
6374 ((or (null? ?y1) (null? ?y2) ...)
6375 (reverse results))))))))
6377 (loop 1 (?exp1 ?exp2 ...) () ?proc (?exp1 ?exp2 ...))))))
6379 (define-inline for-each
6380 (syntax-rules (lambda)
6381 ((for-each ?proc ?exp1 ?exp2 ...)
6384 (... (syntax-rules (lambda)
6385 ((loop 1 () (?y1 ?y2 ...) ?f ?exprs)
6386 (loop 2 (?y1 ?y2 ...) ?f ?exprs))
6387 ((loop 1 (?a1 ?a2 ...) (?y2 ...) ?f ?exprs)
6388 (loop 1 (?a2 ...) (y1 ?y2 ...) ?f ?exprs))
6390 ((loop 2 ?ys (lambda ?formals ?body) ?exprs)
6391 (loop 3 ?ys (lambda ?formals ?body) ?exprs))
6392 ((loop 2 ?ys (?f1 . ?f2) ?exprs)
6393 (let ((f (?f1 . ?f2)))
6394 (loop 3 ?ys f ?exprs)))
6395 ; ?f must be a constant or variable.
6396 ((loop 2 ?ys ?f ?exprs)
6397 (loop 3 ?ys ?f ?exprs))
6399 ((loop 3 (?y1 ?y2 ...) ?f (?e1 ?e2 ...))
6400 (do ((?y1 ?e1 (cdr ?y1))
6403 ((or (null? ?y1) (null? ?y2) ...)
6405 (?f (car ?y1) (car ?y2) ...)))))))
6407 (loop 1 (?exp1 ?exp2 ...) () ?proc (?exp1 ?exp2 ...))))))
6411 (define extended-syntactic-environment
6412 (syntactic-copy global-syntactic-environment))
6414 (define (make-extended-syntactic-environment)
6415 (syntactic-copy extended-syntactic-environment))
6417 ; MacScheme machine assembly instructions.
6419 (define instruction.op car)
6420 (define instruction.arg1 cadr)
6421 (define instruction.arg2 caddr)
6422 (define instruction.arg3 cadddr)
6426 (define *mnemonic-names* '()) ; For readify-lap
6429 (define *last-reserved-mnemonic* 32767) ; For consistency check
6431 (define make-mnemonic
6434 (set! count (+ count 1))
6435 (if (= count *last-reserved-mnemonic*)
6436 (error "Error in make-mnemonic: conflict: " name))
6437 (set! *mnemonic-names* (cons (cons count name) *mnemonic-names*))
6440 (define (reserved-mnemonic name value)
6441 (if (and (> value 0) (< value *last-reserved-mnemonic*))
6442 (set! *last-reserved-mnemonic* value))
6443 (set! *mnemonic-names* (cons (cons value name) *mnemonic-names*))
6447 (define make-mnemonic
6450 (set! count (+ count 1))
6451 (set! *mnemonic-names* (cons (cons count name) *mnemonic-names*))
6454 (define (reserved-mnemonic name ignored)
6455 (make-mnemonic name))
6457 (define $.linearize (reserved-mnemonic '.linearize -1)) ; unused?
6458 (define $.label (reserved-mnemonic '.label 63))
6459 (define $.proc (reserved-mnemonic '.proc 62)) ; proc entry point
6460 (define $.cont (reserved-mnemonic '.cont 61)) ; return point
6461 (define $.align (reserved-mnemonic '.align 60)) ; align code stream
6462 (define $.asm (reserved-mnemonic '.asm 59)) ; in-line native code
6463 (define $.proc-doc ; internal def proc info
6464 (reserved-mnemonic '.proc-doc 58))
6465 (define $.end ; end of code vector
6466 (reserved-mnemonic '.end 57)) ; (asm internal)
6467 (define $.singlestep ; insert singlestep point
6468 (reserved-mnemonic '.singlestep 56)) ; (asm internal)
6469 (define $.entry (reserved-mnemonic '.entry 55)) ; procedure entry point
6472 (define $op1 (make-mnemonic 'op1)) ; op prim
6473 (define $op2 (make-mnemonic 'op2)) ; op2 prim,k
6474 (define $op3 (make-mnemonic 'op3)) ; op3 prim,k1,k2
6475 (define $op2imm (make-mnemonic 'op2imm)) ; op2imm prim,x
6476 (define $const (make-mnemonic 'const)) ; const x
6477 (define $global (make-mnemonic 'global)) ; global x
6478 (define $setglbl (make-mnemonic 'setglbl)) ; setglbl x
6479 (define $lexical (make-mnemonic 'lexical)) ; lexical m,n
6480 (define $setlex (make-mnemonic 'setlex)) ; setlex m,n
6481 (define $stack (make-mnemonic 'stack)) ; stack n
6482 (define $setstk (make-mnemonic 'setstk)) ; setstk n
6483 (define $load (make-mnemonic 'load)) ; load k,n
6484 (define $store (make-mnemonic 'store)) ; store k,n
6485 (define $reg (make-mnemonic 'reg)) ; reg k
6486 (define $setreg (make-mnemonic 'setreg)) ; setreg k
6487 (define $movereg (make-mnemonic 'movereg)) ; movereg k1,k2
6488 (define $lambda (make-mnemonic 'lambda)) ; lambda x,n,doc
6489 (define $lexes (make-mnemonic 'lexes)) ; lexes n,doc
6490 (define $args= (make-mnemonic 'args=)) ; args= k
6491 (define $args>= (make-mnemonic 'args>=)) ; args>= k
6492 (define $invoke (make-mnemonic 'invoke)) ; invoke k
6493 (define $save (make-mnemonic 'save)) ; save L,k
6494 (define $setrtn (make-mnemonic 'setrtn)) ; setrtn L
6495 (define $restore (make-mnemonic 'restore)) ; restore n ; deprecated
6496 (define $pop (make-mnemonic 'pop)) ; pop k
6497 (define $popstk (make-mnemonic 'popstk)) ; popstk ; for students
6498 (define $return (make-mnemonic 'return)) ; return
6499 (define $mvrtn (make-mnemonic 'mvrtn)) ; mvrtn ; NYI
6500 (define $apply (make-mnemonic 'apply)) ; apply
6501 (define $nop (make-mnemonic 'nop)) ; nop
6502 (define $jump (make-mnemonic 'jump)) ; jump m,o
6503 (define $skip (make-mnemonic 'skip)) ; skip L ; forward
6504 (define $branch (make-mnemonic 'branch)) ; branch L
6505 (define $branchf (make-mnemonic 'branchf)) ; branchf L
6506 (define $check (make-mnemonic 'check)) ; check k1,k2,k3,L
6507 (define $trap (make-mnemonic 'trap)) ; trap k1,k2,k3,exn
6509 ; A peephole optimizer may define more instructions in some
6510 ; target-specific file.
6513 ; Copyright 1991 William Clinger
6515 ; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
6517 ; Larceny -- target-specific information for Twobit's SPARC backend.
6519 ; 11 June 1999 / wdc
6521 ; The maximum number of fixed arguments that may be followed by a rest
6522 ; argument. This limitation is removed by the macro expander.
6524 (define @maxargs-with-rest-arg@ 30)
6526 ; The number of MacScheme machine registers.
6527 ; (They do not necessarily correspond to hardware registers.)
6530 (define *lastreg* (- *nregs* 1))
6531 (define *fullregs* (quotient *nregs* 2))
6533 ; The number of argument registers that are represented by hardware
6536 (define *nhwregs* 8)
6538 ; Variable names that indicate register targets.
6541 (do ((alist '() (cons (cons (string->symbol
6542 (string-append ".REG" (number->string r)))
6545 (r (- *nhwregs* 1) (- r 1)))
6549 ; A non-inclusive upper bound for the instruction encodings.
6551 (define *number-of-mnemonics* 72)
6553 ; Integrable procedures and procedure-specific source code transformations.
6554 ; Every integrable procedure that takes a varying number of arguments must
6555 ; supply a transformation procedure to map calls into the fixed arity
6556 ; required by the MacScheme machine instructions.
6558 ; The table of integrable procedures.
6559 ; Each entry is a list of the following items:
6562 ; arity (or -1 for special primops like .check!)
6563 ; procedure name to be used by the disassembler
6564 ; predicate for immediate operands (or #f)
6565 ; primop code in the MacScheme machine (not used by Larceny)
6566 ; the effects that kill this primop's result
6567 ; the effects of this primop that kill available expressions
6569 (define (prim-entry name)
6570 (assq name $usual-integrable-procedures$))
6572 (define prim-arity cadr)
6573 (define prim-opcodename caddr)
6574 (define prim-immediate? cadddr)
6575 (define (prim-primcode entry)
6576 (car (cddddr entry)))
6578 ; This predicate returns #t iff its argument will be represented
6579 ; as a fixnum on the target machine.
6582 (let* ((least (- (expt 2 29)))
6583 (greatest (- (- least) 1)))
6588 (<= least x greatest)))))
6590 (define (sparc-imm? x)
6594 (define (sparc-eq-imm? x)
6600 (define (valid-typetag? x)
6604 (define (fixnum-primitives) #t)
6605 (define (flonum-primitives) #t)
6607 ; The table of primitives has been extended with
6608 ; kill information used for commoning.
6610 (define (prim-lives-until entry)
6613 (define (prim-kills entry)
6616 (define $usual-integrable-procedures$
6617 (let ((:globals available:killer:globals)
6618 (:car available:killer:car)
6619 (:cdr available:killer:cdr)
6620 (:string available:killer:string)
6621 (:vector available:killer:vector)
6622 (:cell available:killer:cell)
6623 (:io available:killer:io)
6624 (:none available:killer:none) ; none of the above
6625 (:all available:killer:all) ; all of the above
6626 (:immortal available:killer:immortal) ; never killed
6627 (:dead available:killer:dead) ; never available
6630 ; external arity internal immediate ignored killed kills
6631 ; name name predicate by what
6635 `((break 0 break #f 3 ,:dead ,:all)
6636 (creg 0 creg #f 7 ,:dead ,:all)
6637 (unspecified 0 unspecified #f -1 ,:dead ,:none)
6638 (undefined 0 undefined #f 8 ,:dead ,:none)
6639 (eof-object 0 eof-object #f -1 ,:dead ,:none)
6640 (enable-interrupts 1 enable-interrupts #f -1 ,:dead ,:all)
6641 (disable-interrupts 0 disable-interrupts #f -1 ,:dead ,:all)
6643 (typetag 1 typetag #f #x11 ,:dead ,:none)
6644 (not 1 not #f #x18 ,:immortal ,:none)
6645 (null? 1 null? #f #x19 ,:immortal ,:none)
6646 (pair? 1 pair? #f #x1a ,:immortal ,:none)
6647 (eof-object? 1 eof-object? #f -1 ,:immortal ,:none)
6648 (port? 1 port? #f -1 ,:dead ,:none)
6649 (structure? 1 structure? #f -1 ,:dead ,:none)
6650 (car 1 car #f #x1b ,:car ,:none)
6651 (,name:CAR 1 car #f #x1b ,:car ,:none)
6652 (cdr 1 cdr #f #x1c ,:cdr ,:none)
6653 (,name:CDR 1 cdr #f #x1c ,:cdr ,:none)
6654 (symbol? 1 symbol? #f #x1f ,:immortal ,:none)
6655 (number? 1 complex? #f #x20 ,:immortal ,:none)
6656 (complex? 1 complex? #f #x20 ,:immortal ,:none)
6657 (real? 1 rational? #f #x21 ,:immortal ,:none)
6658 (rational? 1 rational? #f #x21 ,:immortal ,:none)
6659 (integer? 1 integer? #f #x22 ,:immortal ,:none)
6660 (fixnum? 1 fixnum? #f #x23 ,:immortal ,:none)
6661 (flonum? 1 flonum? #f -1 ,:immortal ,:none)
6662 (compnum? 1 compnum? #f -1 ,:immortal ,:none)
6663 (exact? 1 exact? #f #x24 ,:immortal ,:none)
6664 (inexact? 1 inexact? #f #x25 ,:immortal ,:none)
6665 (exact->inexact 1 exact->inexact #f #x26 ,:immortal ,:none)
6666 (inexact->exact 1 inexact->exact #f #x27 ,:immortal ,:none)
6667 (round 1 round #f #x28 ,:immortal ,:none)
6668 (truncate 1 truncate #f #x29 ,:immortal ,:none)
6669 (zero? 1 zero? #f #x2c ,:immortal ,:none)
6670 (-- 1 -- #f #x2d ,:immortal ,:none)
6671 (lognot 1 lognot #f #x2f ,:immortal ,:none)
6672 (real-part 1 real-part #f #x3e ,:immortal ,:none)
6673 (imag-part 1 imag-part #f #x3f ,:immortal ,:none)
6674 (char? 1 char? #f #x40 ,:immortal ,:none)
6675 (char->integer 1 char->integer #f #x41 ,:immortal ,:none)
6676 (integer->char 1 integer->char #f #x42 ,:immortal ,:none)
6677 (string? 1 string? #f #x50 ,:immortal ,:none)
6678 (string-length 1 string-length #f #x51 ,:immortal ,:none)
6679 (vector? 1 vector? #f #x52 ,:immortal ,:none)
6680 (vector-length 1 vector-length #f #x53 ,:immortal ,:none)
6681 (bytevector? 1 bytevector? #f #x54 ,:immortal ,:none)
6682 (bytevector-length 1 bytevector-length #f #x55 ,:immortal ,:none)
6683 (bytevector-fill! 2 bytevector-fill! #f -1 ,:dead ,:string)
6684 (make-bytevector 1 make-bytevector #f #x56 ,:dead ,:none)
6685 (procedure? 1 procedure? #f #x58 ,:immortal ,:none)
6686 (procedure-length 1 procedure-length #f #x59 ,:dead ,:none)
6687 (make-procedure 1 make-procedure #f #x5a ,:dead ,:none)
6688 (creg-set! 1 creg-set! #f #x71 ,:dead ,:none)
6689 (,name:MAKE-CELL 1 make-cell #f #x7e ,:dead ,:none)
6690 (,name:CELL-REF 1 cell-ref #f #x7f ,:cell ,:none)
6691 (,name:CELL-SET! 2 cell-set! #f #xdf ,:dead ,:cell)
6692 (typetag-set! 2 typetag-set! ,valid-typetag? #xa0 ,:dead ,:all)
6693 (eq? 2 eq? ,sparc-eq-imm? #xa1 ,:immortal ,:none)
6694 (eqv? 2 eqv? #f #xa2 ,:immortal ,:none)
6695 (cons 2 cons #f #xa8 ,:dead ,:none)
6696 (,name:CONS 2 cons #f #xa8 ,:dead ,:none)
6697 (set-car! 2 set-car! #f #xa9 ,:dead ,:car)
6698 (set-cdr! 2 set-cdr! #f #xaa ,:dead ,:cdr)
6699 (+ 2 + ,sparc-imm? #xb0 ,:immortal ,:none)
6700 (- 2 - ,sparc-imm? #xb1 ,:immortal ,:none)
6701 (* 2 * ,sparc-imm? #xb2 ,:immortal ,:none)
6702 (/ 2 / #f #xb3 ,:immortal ,:none)
6703 (quotient 2 quotient #f #xb4 ,:immortal ,:none)
6704 (< 2 < ,sparc-imm? #xb5 ,:immortal ,:none)
6705 (<= 2 <= ,sparc-imm? #xb6 ,:immortal ,:none)
6706 (= 2 = ,sparc-imm? #xb7 ,:immortal ,:none)
6707 (> 2 > ,sparc-imm? #xb8 ,:immortal ,:none)
6708 (>= 2 >= ,sparc-imm? #xb9 ,:immortal ,:none)
6709 (logand 2 logand #f #xc0 ,:immortal ,:none)
6710 (logior 2 logior #f #xc1 ,:immortal ,:none)
6711 (logxor 2 logxor #f #xc2 ,:immortal ,:none)
6712 (lsh 2 lsh #f #xc3 ,:immortal ,:none)
6713 (rsha 2 rsha #f -1 ,:immortal ,:none)
6714 (rshl 2 rshl #f -1 ,:immortal ,:none)
6715 (rot 2 rot #f #xc4 ,:immortal ,:none)
6716 (make-string 2 make-string #f -1 ,:dead ,:none)
6717 (string-ref 2 string-ref ,sparc-imm? #xd1 ,:string ,:none)
6718 (string-set! 3 string-set! ,sparc-imm? -1 ,:dead ,:string)
6719 (make-vector 2 make-vector #f #xd2 ,:dead ,:none)
6720 (vector-ref 2 vector-ref ,sparc-imm? #xd3 ,:vector ,:none)
6721 (bytevector-ref 2 bytevector-ref ,sparc-imm? #xd5 ,:string ,:none)
6722 (procedure-ref 2 procedure-ref #f #xd7 ,:dead ,:none)
6723 (char<? 2 char<? ,char? #xe0 ,:immortal ,:none)
6724 (char<=? 2 char<=? ,char? #xe1 ,:immortal ,:none)
6725 (char=? 2 char=? ,char? #xe2 ,:immortal ,:none)
6726 (char>? 2 char>? ,char? #xe3 ,:immortal ,:none)
6727 (char>=? 2 char>=? ,char? #xe4 ,:immortal ,:none)
6729 (sys$partial-list->vector 2 sys$partial-list->vector #f -1 ,:dead ,:all)
6730 (vector-set! 3 vector-set! #f #xf1 ,:dead ,:vector)
6731 (bytevector-set! 3 bytevector-set! #f #xf2 ,:dead ,:string)
6732 (procedure-set! 3 procedure-set! #f #xf3 ,:dead ,:all)
6733 (bytevector-like? 1 bytevector-like? #f -1 ,:immortal ,:none)
6734 (vector-like? 1 vector-like? #f -1 ,:immortal ,:none)
6735 (bytevector-like-ref 2 bytevector-like-ref #f -1 ,:string ,:none)
6736 (bytevector-like-set! 3 bytevector-like-set! #f -1 ,:dead ,:string)
6737 (sys$bvlcmp 2 sys$bvlcmp #f -1 ,:dead ,:all)
6738 (vector-like-ref 2 vector-like-ref #f -1 ,:vector ,:none)
6739 (vector-like-set! 3 vector-like-set! #f -1 ,:dead ,:vector)
6740 (vector-like-length 1 vector-like-length #f -1 ,:immortal ,:none)
6741 (bytevector-like-length 1 bytevector-like-length #f -1 ,:immortal ,:none)
6742 (remainder 2 remainder #f -1 ,:immortal ,:none)
6743 (sys$read-char 1 sys$read-char #f -1 ,:dead ,:io)
6744 (gc-counter 0 gc-counter #f -1 ,:dead ,:none)
6745 ,@(if (fixnum-primitives)
6746 `((most-positive-fixnum
6747 0 most-positive-fixnum
6748 #f -1 ,:immortal ,:none)
6749 (most-negative-fixnum
6750 0 most-negative-fixnum
6751 #f -1 ,:immortal ,:none)
6752 (fx+ 2 fx+ ,sparc-imm? -1 ,:immortal ,:none)
6753 (fx- 2 fx- ,sparc-imm? -1 ,:immortal ,:none)
6754 (fx-- 1 fx-- #f -1 ,:immortal ,:none)
6755 (fx* 2 fx* #f -1 ,:immortal ,:none)
6756 (fx= 2 fx= ,sparc-imm? -1 ,:immortal ,:none)
6757 (fx< 2 fx< ,sparc-imm? -1 ,:immortal ,:none)
6758 (fx<= 2 fx<= ,sparc-imm? -1 ,:immortal ,:none)
6759 (fx> 2 fx> ,sparc-imm? -1 ,:immortal ,:none)
6760 (fx>= 2 fx>= ,sparc-imm? -1 ,:immortal ,:none)
6761 (fxzero? 1 fxzero? #f -1 ,:immortal ,:none)
6762 (fxpositive? 1 fxpositive? #f -1 ,:immortal ,:none)
6763 (fxnegative? 1 fxnegative? #f -1 ,:immortal ,:none))
6765 ,@(if (flonum-primitives)
6766 `((fl+ 2 + #f -1 ,:immortal ,:none)
6767 (fl- 2 - #f -1 ,:immortal ,:none)
6768 (fl-- 1 -- #f -1 ,:immortal ,:none)
6769 (fl* 2 * #f -1 ,:immortal ,:none)
6770 (fl= 2 = #f -1 ,:immortal ,:none)
6771 (fl< 2 < #f -1 ,:immortal ,:none)
6772 (fl<= 2 <= #f -1 ,:immortal ,:none)
6773 (fl> 2 > #f -1 ,:immortal ,:none)
6774 (fl>= 2 >= #f -1 ,:immortal ,:none))
6777 ; Added for CSE, representation analysis.
6779 (,name:CHECK! -1 check! #f -1 ,:dead ,:none)
6780 (vector-length:vec 1 vector-length:vec #f -1 ,:immortal ,:none)
6781 (vector-ref:trusted 2 vector-ref:trusted ,sparc-imm? -1 ,:vector ,:none)
6782 (vector-set!:trusted 3 vector-set!:trusted #f -1 ,:dead ,:vector)
6783 (car:pair 1 car:pair #f -1 ,:car ,:none)
6784 (cdr:pair 1 cdr:pair #f -1 ,:cdr ,:none)
6785 (=:fix:fix 2 =:fix:fix ,sparc-imm? -1 ,:immortal ,:none)
6786 (<:fix:fix 2 <:fix:fix ,sparc-imm? -1 ,:immortal ,:none)
6787 (<=:fix:fix 2 <=:fix:fix ,sparc-imm? -1 ,:immortal ,:none)
6788 (>=:fix:fix 2 >=:fix:fix ,sparc-imm? -1 ,:immortal ,:none)
6789 (>:fix:fix 2 >:fix:fix ,sparc-imm? -1 ,:immortal ,:none)
6791 ; Not yet implemented.
6793 (+:idx:idx 2 +:idx:idx #f -1 ,:immortal ,:none)
6794 (+:fix:fix 2 +:idx:idx #f -1 ,:immortal ,:none)
6795 (+:exi:exi 2 +:idx:idx #f -1 ,:immortal ,:none)
6796 (+:flo:flo 2 +:idx:idx #f -1 ,:immortal ,:none)
6797 (=:flo:flo 2 =:flo:flo #f -1 ,:immortal ,:none)
6798 (=:obj:flo 2 =:obj:flo #f -1 ,:immortal ,:none)
6799 (=:flo:obj 2 =:flo:obj #f -1 ,:immortal ,:none)
6802 ; Not used by the Sparc assembler; for information only.
6804 (define $immediate-primops$
6805 '((typetag-set! #x80)
6821 (bytevector-ref #x92)
6822 (bytevector-like-ref -1)
6823 (vector-like-ref -1)
6833 ; Operations introduced by peephole optimizer.
6835 (define $reg/op1/branchf ; reg/op1/branchf prim,k1,L
6836 (make-mnemonic 'reg/op1/branchf))
6837 (define $reg/op2/branchf ; reg/op2/branchf prim,k1,k2,L
6838 (make-mnemonic 'reg/op2/branchf))
6839 (define $reg/op2imm/branchf ; reg/op2imm/branchf prim,k1,x,L
6840 (make-mnemonic 'reg/op2imm/branchf))
6841 (define $reg/op1/check ; reg/op1/check prim,k1,k2,k3,k4,exn
6842 (make-mnemonic 'reg/op1/check))
6843 (define $reg/op2/check ; reg/op2/check prim,k1,k2,k3,k4,k5,exn
6844 (make-mnemonic 'reg/op2/check))
6845 (define $reg/op2imm/check ; reg/op2imm/check prim,k1,x,k2,k3,k4,exn
6846 (make-mnemonic 'reg/op2imm/check))
6847 (define $reg/op1/setreg ; reg/op1/setreg prim,k1,kr
6848 (make-mnemonic 'reg/op1/setreg))
6849 (define $reg/op2/setreg ; reg/op2/setreg prim,k1,k2,kr
6850 (make-mnemonic 'reg/op2/setreg))
6851 (define $reg/op2imm/setreg ; reg/op2imm/setreg prim,k1,x,kr
6852 (make-mnemonic 'reg/op2imm/setreg))
6853 (define $reg/branchf ; reg/branchf k, L
6854 (make-mnemonic 'reg/branchf))
6855 (define $reg/return ; reg/return k
6856 (make-mnemonic 'reg/return))
6857 (define $reg/setglbl ; reg/setglbl k,x
6858 (make-mnemonic 'reg/setglbl))
6859 (define $reg/op3 ; reg/op3 prim,k1,k2,k3
6860 (make-mnemonic 'reg/op3))
6861 (define $const/setreg ; const/setreg const,k
6862 (make-mnemonic 'const/setreg))
6863 (define $const/return ; const/return const
6864 (make-mnemonic 'const/return))
6865 (define $global/setreg ; global/setreg x,k
6866 (make-mnemonic 'global/setreg))
6867 (define $setrtn/branch ; setrtn/branch L,doc
6868 (make-mnemonic 'setrtn/branch))
6869 (define $setrtn/invoke ; setrtn/invoke L
6870 (make-mnemonic 'setrtn/invoke))
6871 (define $global/invoke ; global/invoke global,n
6872 (make-mnemonic 'global/invoke))
6876 (define $cons 'cons)
6877 (define $car:pair 'car)
6878 (define $cdr:pair 'cdr)
6881 ; Target-specific representations.
6883 ; A few of these representation types must be specified for every target:
6890 (define-subtype 'true 'object) ; values that count as true
6891 (define-subtype 'eqtype 'object) ; can use EQ? instead of EQV?
6892 (define-subtype 'nonpointer 'eqtype) ; can omit write barrier
6893 (define-subtype 'eqtype1 'eqtype) ; eqtypes excluding #f
6894 (define-subtype 'boolean 'nonpointer)
6895 (define-subtype 'truth 'eqtype1) ; { #t }
6896 (define-subtype 'truth 'boolean)
6897 (define-subtype 'false 'boolean) ; { #f }
6898 (define-subtype 'eqtype1 'true)
6899 (define-subtype 'procedure 'true)
6900 (define-subtype 'vector 'true)
6901 (define-subtype 'bytevector 'true)
6902 (define-subtype 'string 'true)
6903 (define-subtype 'pair 'true)
6904 (define-subtype 'emptylist 'eqtype1)
6905 (define-subtype 'emptylist 'nonpointer)
6906 (define-subtype 'symbol 'eqtype1)
6907 (define-subtype 'char 'eqtype1)
6908 (define-subtype 'char 'nonpointer)
6909 (define-subtype 'number 'true)
6910 (define-subtype 'inexact 'number)
6911 (define-subtype 'flonum 'inexact)
6912 (define-subtype 'integer 'number)
6913 (define-subtype 'exact 'number)
6914 (define-subtype 'exactint 'integer)
6915 (define-subtype 'exactint 'exact)
6916 (define-subtype 'fixnum 'exactint)
6917 (define-subtype '!fixnum 'fixnum) ; 0 <= n
6918 (define-subtype 'fixnum! 'fixnum) ; n <= largest index
6919 (define-subtype 'index '!fixnum)
6920 (define-subtype 'index 'fixnum!)
6921 (define-subtype 'zero 'index)
6922 (define-subtype 'fixnum 'eqtype1)
6923 (define-subtype 'fixnum 'nonpointer)
6925 (compute-type-structure!)
6927 ; If the intersection of rep1 and rep2 is known precisely,
6928 ; but neither is a subtype of the other, then their intersection
6929 ; should be declared explicitly.
6930 ; Otherwise a conservative approximation will be used.
6932 (define-intersection 'true 'eqtype 'eqtype1)
6933 (define-intersection 'true 'boolean 'truth)
6934 (define-intersection 'exact 'integer 'exactint)
6935 (define-intersection '!fixnum 'fixnum! 'index)
6937 ;(display-unions-and-intersections)
6941 (define rep:min_fixnum (- (expt 2 29)))
6942 (define rep:max_fixnum (- (expt 2 29) 1))
6943 (define rep:max_index (- (expt 2 24) 1))
6945 ; The representations we'll recognize for now.
6947 (define rep:object (symbol->rep 'object))
6948 (define rep:true (symbol->rep 'true))
6949 (define rep:truth (symbol->rep 'truth))
6950 (define rep:false (symbol->rep 'false))
6951 (define rep:boolean (symbol->rep 'boolean))
6952 (define rep:pair (symbol->rep 'pair))
6953 (define rep:symbol (symbol->rep 'symbol))
6954 (define rep:number (symbol->rep 'number))
6955 (define rep:zero (symbol->rep 'zero))
6956 (define rep:index (symbol->rep 'index))
6957 (define rep:fixnum (symbol->rep 'fixnum))
6958 (define rep:exactint (symbol->rep 'exactint))
6959 (define rep:flonum (symbol->rep 'flonum))
6960 (define rep:exact (symbol->rep 'exact))
6961 (define rep:inexact (symbol->rep 'inexact))
6962 (define rep:integer (symbol->rep 'integer))
6963 ;(define rep:real (symbol->rep 'real))
6964 (define rep:char (symbol->rep 'char))
6965 (define rep:string (symbol->rep 'string))
6966 (define rep:vector (symbol->rep 'vector))
6967 (define rep:procedure (symbol->rep 'procedure))
6968 (define rep:bottom (symbol->rep 'bottom))
6970 ; Given the value of a quoted constant, return its representation.
6972 (define (representation-of-value x)
6982 (cond ((and (exact? x)
6986 ((<= 0 x rep:max_index)
6998 ; We're not tracking other numbers yet.
7006 ; Everything counts as true except for #f.
7010 ; Tables that express the representation-specific operations,
7011 ; and the information about representations that are implied
7012 ; by certain operations.
7013 ; FIXME: Currently way incomplete, but good enough for testing.
7015 (define rep-specific
7017 (representation-table
7019 ; When the procedure in the first column is called with
7020 ; arguments described in the middle column, then the procedure
7021 ; in the last column can be called instead.
7024 ;(+ (index index) +:idx:idx)
7025 ;(+ (fixnum fixnum) +:fix:fix)
7026 ;(- (index index) -:idx:idx)
7027 ;(- (fixnum fixnum) -:fix:fix)
7029 (= (fixnum fixnum) =:fix:fix)
7030 (< (fixnum fixnum) <:fix:fix)
7031 (<= (fixnum fixnum) <=:fix:fix)
7032 (> (fixnum fixnum) >:fix:fix)
7033 (>= (fixnum fixnum) >=:fix:fix)
7035 ;(+ (flonum flonum) +:flo:flo)
7036 ;(- (flonum flonum) -:flo:flo)
7037 ;(= (flonum flonum) =:flo:flo)
7038 ;(< (flonum flonum) <:flo:flo)
7039 ;(<= (flonum flonum) <=:flo:flo)
7040 ;(> (flonum flonum) >:flo:flo)
7041 ;(>= (flonum flonum) >=:flo:flo)
7043 ;(vector-set!:trusted (vector fixnum nonpointer) vector-set!:trusted:imm)
7048 (representation-table
7050 ; When the procedure in the first column is called with
7051 ; arguments described in the middle column, then the result
7052 ; is described by the last column.
7054 '((fixnum? (fixnum) (truth))
7055 (vector? (vector) (truth))
7056 (<= (zero !fixnum) (truth))
7057 (>= (!fixnum zero) (truth))
7058 (<=:fix:fix (zero !fixnum) (truth))
7059 (>=:fix:fix (!fixnum zero) (truth))
7061 (+ (index index) (!fixnum))
7062 (+ (fixnum fixnum) (exactint))
7063 (- (index index) (fixnum!))
7064 (- (fixnum fixnum) (exactint))
7066 (+ (flonum flonum) (flonum))
7067 (- (flonum flonum) (flonum))
7069 ;(+:idx:idx (index index) (!fixnum))
7070 ;(-:idx:idx (index index) (fixnum!))
7071 ;(+:fix:fix (index index) (exactint))
7072 ;(+:fix:fix (fixnum fixnum) (exactint))
7073 ;(-:idx:idx (index index) (fixnum))
7074 ;(-:fix:fix (fixnum fixnum) (exactint))
7076 (make-vector (object object) (vector))
7077 (vector-length:vec (vector) (index))
7078 (cons (object object) (pair))
7080 ; Is it really all that useful to know that the result
7081 ; of these comparisons is a boolean?
7083 (= (number number) (boolean))
7084 (< (number number) (boolean))
7085 (<= (number number) (boolean))
7086 (> (number number) (boolean))
7087 (>= (number number) (boolean))
7089 (=:fix:fix (fixnum fixnum) (boolean))
7090 (<:fix:fix (fixnum fixnum) (boolean))
7091 (<=:fix:fix (fixnum fixnum) (boolean))
7092 (>:fix:fix (fixnum fixnum) (boolean))
7093 (>=:fix:fix (fixnum fixnum) (boolean))
7096 (define rep-informing
7098 (representation-table
7100 ; When the predicate in the first column is called in the test position
7101 ; of a conditional expression, on arguments described by the second
7102 ; column, then the arguments are described by the third column if the
7103 ; predicate returns true, and by the fourth column if the predicate
7107 (fixnum? (object) (fixnum) (object))
7108 (flonum? (object) (flonum) (object))
7109 (vector? (object) (vector) (object))
7110 (pair? (object) (pair) (object))
7112 (= (exactint index) (index index) (exactint index))
7113 (= (index exactint) (index index) (index exactint))
7114 (= (exactint !fixnum) (!fixnum !fixnum) (exactint !fixnum))
7115 (= (!fixnum exactint) (!fixnum !fixnum) (!fixnum exactint))
7116 (= (exactint fixnum!) (fixnum! fixnum!) (exactint fixnum!))
7117 (= (fixnum! exactint) (fixnum! fixnum!) (fixnum! exactint))
7119 (< (!fixnum fixnum!) (index index) (!fixnum fixnum!))
7120 (< (fixnum fixnum!) (fixnum! fixnum!) (fixnum fixnum!))
7121 (< (!fixnum fixnum) (!fixnum !fixnum) (!fixnum fixnum))
7122 (< (fixnum! !fixnum) (fixnum! !fixnum) (index index))
7124 (<= (!fixnum fixnum!) (index index) (!fixnum fixnum!))
7125 (<= (fixnum! !fixnum) (fixnum! !fixnum) (index index))
7126 (<= (fixnum fixnum!) (fixnum! fixnum!) (fixnum fixnum!))
7127 (<= (!fixnum fixnum) (!fixnum !fixnum) (!fixnum fixnum))
7129 (> (!fixnum fixnum!) (!fixnum fixnum!) (index index))
7130 (> (fixnum! !fixnum) (index index) (fixnum! !fixnum))
7131 (> (fixnum fixnum!) (fixnum fixnum!) (fixnum! fixnum!))
7132 (> (!fixnum fixnum) (!fixnum fixnum) (!fixnum !fixnum))
7134 (>= (!fixnum fixnum!) (!fixnum fixnum!) (index index))
7135 (>= (fixnum! !fixnum) (index index) (fixnum! !fixnum))
7136 (>= (fixnum fixnum!) (fixnum fixnum!) (fixnum! fixnum!))
7137 (>= (!fixnum fixnum) (!fixnum fixnum) (!fixnum !fixnum))
7139 (=:fix:fix (exactint index) (index index) (exactint index))
7140 (=:fix:fix (index exactint) (index index) (index exactint))
7141 (=:fix:fix (exactint !fixnum) (!fixnum !fixnum) (exactint !fixnum))
7142 (=:fix:fix (!fixnum exactint) (!fixnum !fixnum) (!fixnum exactint))
7143 (=:fix:fix (exactint fixnum!) (fixnum! fixnum!) (exactint fixnum!))
7144 (=:fix:fix (fixnum! exactint) (fixnum! fixnum!) (fixnum! exactint))
7146 (<:fix:fix (!fixnum fixnum!) (index index) (!fixnum fixnum!))
7147 (<:fix:fix (fixnum! !fixnum) (fixnum! !fixnum) (index index))
7148 (<:fix:fix (fixnum fixnum!) (fixnum! fixnum!) (fixnum fixnum!))
7149 (<:fix:fix (!fixnum fixnum) (!fixnum !fixnum) (!fixnum fixnum))
7151 (<=:fix:fix (!fixnum fixnum!) (index index) (!fixnum fixnum!))
7152 (<=:fix:fix (fixnum! !fixnum) (fixnum! !fixnum) (index index))
7153 (<=:fix:fix (fixnum fixnum!) (fixnum! fixnum!) (fixnum fixnum!))
7154 (<=:fix:fix (!fixnum fixnum) (!fixnum !fixnum) (!fixnum fixnum))
7156 (>:fix:fix (!fixnum fixnum!) (!fixnum fixnum!) (index index))
7157 (>:fix:fix (fixnum! !fixnum) (index index) (fixnum! !fixnum))
7158 (>:fix:fix (fixnum fixnum!) (fixnum fixnum!) (fixnum! fixnum!))
7159 (>:fix:fix (!fixnum fixnum) (!fixnum fixnum) (!fixnum !fixnum))
7161 (>=:fix:fix (!fixnum fixnum!) (!fixnum fixnum!) (index index))
7162 (>=:fix:fix (fixnum! !fixnum) (index index) (fixnum! !fixnum))
7163 (>=:fix:fix (fixnum fixnum!) (fixnum fixnum!) (fixnum! fixnum!))
7164 (>=:fix:fix (!fixnum fixnum) (!fixnum fixnum) (!fixnum !fixnum))
7166 ; Copyright 1991 William D Clinger.
7168 ; Permission to copy this software, in whole or in part, to use this
7169 ; software for any lawful noncommercial purpose, and to redistribute
7170 ; this software is granted subject to the restriction that all copies
7171 ; made of this software must include this copyright notice in full.
7173 ; I also request that you send me a copy of any improvements that you
7174 ; make to this software so that they may be incorporated within it to
7175 ; the benefit of the Scheme community.
7179 ; Second pass of the Twobit compiler:
7180 ; single assignment analysis, local source transformations,
7181 ; assignment elimination, and lambda lifting.
7182 ; The code for assignment elimination and lambda lifting
7183 ; are in a separate file.
7185 ; This pass operates as a source-to-source transformation on
7186 ; expressions written in the subset of Scheme described by the
7187 ; following grammar, where the input and output expressions
7188 ; satisfy certain additional invariants described below.
7190 ; "X ..." means zero or more occurrences of X.
7192 ; L --> (lambda (I_1 ...)
7194 ; (quote (R F G <decls> <doc>)
7196 ; | (lambda (I_1 ... . I_rest)
7198 ; (quote (R F G <decls> <doc>))
7200 ; D --> (define I L)
7201 ; E --> (quote K) ; constants
7202 ; | (begin I) ; variable references
7203 ; | L ; lambda expressions
7204 ; | (E0 E1 ...) ; calls
7205 ; | (set! I E) ; assignments
7206 ; | (if E0 E1 E2) ; conditionals
7207 ; | (begin E0 E1 E2 ...) ; sequential expressions
7208 ; I --> <identifier>
7210 ; R --> ((I <references> <assignments> <calls>) ...)
7214 ; Invariants that hold for the input only:
7215 ; * There are no internal definitions.
7216 ; * No identifier containing an upper case letter is bound anywhere.
7217 ; (Change the "name:..." variables if upper case is preferred.)
7218 ; * No identifier is bound in more than one place.
7219 ; * Each R contains one entry for every identifier bound in the
7220 ; formal argument list and the internal definition list that
7221 ; precede it. Each entry contains a list of pointers to all
7222 ; references to the identifier, a list of pointers to all
7223 ; assignments to the identifier, and a list of pointers to all
7224 ; calls to the identifier.
7225 ; * Except for constants, the expression does not share structure
7226 ; with the original input or itself, except that the references
7227 ; and assignments in R are guaranteed to share structure with
7228 ; the expression. Thus the expression may be side effected, and
7229 ; side effects to references or assignments obtained through R
7230 ; are guaranteed to change the references or assignments pointed
7233 ; Invariants that hold for the output only:
7234 ; * There are no assignments except to global variables.
7235 ; * If I is declared by an internal definition, then the right hand
7236 ; side of the internal definition is a lambda expression and I
7237 ; is referenced only in the procedure position of a call.
7238 ; * Each R contains one entry for every identifier bound in the
7239 ; formal argument list and the internal definition list that
7240 ; precede it. Each entry contains a list of pointers to all
7241 ; references to the identifier, a list of pointers to all
7242 ; assignments to the identifier, and a list of pointers to all
7243 ; calls to the identifier.
7244 ; * For each lambda expression, the associated F is a list of all
7245 ; the identifiers that occur free in the body of that lambda
7246 ; expression, and possibly a few extra identifiers that were
7247 ; once free but have been removed by optimization.
7248 ; * For each lambda expression, the associated G is a subset of F
7249 ; that contains every identifier that occurs free within some
7250 ; inner lambda expression that escapes, and possibly a few that
7251 ; don't. (Assignment-elimination does not calculate G exactly.)
7252 ; * Variables named IGNORED are neither referenced nor assigned.
7253 ; * Except for constants, the expression does not share structure
7254 ; with the original input or itself, except that the references
7255 ; and assignments in R are guaranteed to share structure with
7256 ; the expression. Thus the expression may be side effected, and
7257 ; side effects to references or assignments obtained through R
7258 ; are guaranteed to change the references or assignments pointed
7262 (simplify exp (make-notepad #f)))
7264 ; Given an expression and a "notepad" data structure that conveys
7265 ; inherited attributes, performs the appropriate optimizations and
7266 ; destructively modifies the notepad to record various attributes
7267 ; that it synthesizes while traversing the expression. In particular,
7268 ; any nested lambda expressions and any variable references will be
7269 ; noted in the notepad.
7271 (define (simplify exp notepad)
7274 ((lambda) (simplify-lambda exp notepad))
7275 ((set!) (simplify-assignment exp notepad))
7276 ((if) (simplify-conditional exp notepad))
7277 ((begin) (if (variable? exp)
7278 (begin (notepad-var-add! notepad (variable.name exp))
7280 (simplify-sequential exp notepad)))
7281 (else (simplify-call exp notepad))))
7283 ; Most optimization occurs here.
7284 ; The right hand sides of internal definitions are simplified,
7286 ; Internal definitions of enclosed lambda expressions may
7287 ; then be lifted to this one.
7288 ; Single assignment analysis creates internal definitions.
7289 ; Single assignment elimination converts single assignments
7290 ; to bindings where possible, and renames arguments whose value
7292 ; Assignment elimination then replaces all remaining assigned
7293 ; variables by heap-allocated cells.
7295 (define (simplify-lambda exp notepad)
7296 (notepad-lambda-add! notepad exp)
7297 (let ((defs (lambda.defs exp))
7298 (body (lambda.body exp))
7299 (newnotepad (make-notepad exp)))
7300 (for-each (lambda (def)
7301 (simplify-lambda (def.rhs def) newnotepad))
7303 (lambda.body-set! exp (simplify body newnotepad))
7304 (lambda.F-set! exp (notepad-free-variables newnotepad))
7305 (lambda.G-set! exp (notepad-captured-variables newnotepad))
7306 (single-assignment-analysis exp newnotepad)
7307 (let ((known-lambdas (notepad.nonescaping newnotepad)))
7308 (for-each (lambda (L)
7309 (if (memq L known-lambdas)
7310 (lambda-lifting L exp)
7311 (lambda-lifting L L)))
7312 (notepad.lambdas newnotepad))))
7313 (single-assignment-elimination exp notepad)
7314 (assignment-elimination exp)
7315 (if (not (notepad.parent notepad))
7316 ; This is an outermost lambda expression.
7317 (lambda-lifting exp exp))
7320 ; SIMPLIFY-ASSIGNMENT performs this transformation:
7322 ; (set! I (begin ... E))
7323 ; -> (begin ... (set! I E))
7325 (define (simplify-assignment exp notepad)
7326 (notepad-var-add! notepad (assignment.lhs exp))
7327 (let ((rhs (simplify (assignment.rhs exp) notepad)))
7329 (let ((exprs (reverse (begin.exprs rhs))))
7330 (assignment.rhs-set! exp (car exprs))
7331 (post-simplify-begin
7332 (make-begin (reverse (cons exp (cdr exprs))))
7334 (else (assignment.rhs-set! exp rhs) exp))))
7336 (define (simplify-sequential exp notepad)
7337 (let ((exprs (map (lambda (exp) (simplify exp notepad))
7338 (begin.exprs exp))))
7339 (begin.exprs-set! exp exprs)
7340 (post-simplify-begin exp notepad)))
7342 ; Given (BEGIN E0 E1 E2 ...) where the E_i are simplified expressions,
7343 ; flattens any nested BEGINs and removes trivial expressions that
7344 ; don't appear in the last position. The second argument is used only
7345 ; if a lambda expression is removed.
7346 ; This procedure is careful to return E instead of (BEGIN E).
7347 ; Fairly harmless bug: a variable reference removed by this procedure
7348 ; may remain on the notepad when it shouldn't.
7350 (define (post-simplify-begin exp notepad)
7351 (let ((unspecified-expression (make-unspecified)))
7352 ; (flatten exprs '()) returns the flattened exprs in reverse order.
7353 (define (flatten exprs flattened)
7354 (cond ((null? exprs) flattened)
7355 ((begin? (car exprs))
7356 (flatten (cdr exprs)
7357 (flatten (begin.exprs (car exprs)) flattened)))
7358 (else (flatten (cdr exprs) (cons (car exprs) flattened)))))
7359 (define (filter exprs filtered)
7362 (let ((exp (car exprs)))
7363 (cond ((constant? exp) (filter (cdr exprs) filtered))
7364 ((variable? exp) (filter (cdr exprs) filtered))
7366 (notepad.lambdas-set!
7368 (remq exp (notepad.lambdas notepad)))
7369 (filter (cdr exprs) filtered))
7370 ((equal? exp unspecified-expression)
7371 (filter (cdr exprs) filtered))
7372 (else (filter (cdr exprs) (cons exp filtered)))))))
7373 (let ((exprs (flatten (begin.exprs exp) '())))
7374 (begin.exprs-set! exp (filter (cdr exprs) (list (car exprs))))
7375 (if (null? (cdr (begin.exprs exp)))
7376 (car (begin.exprs exp))
7379 ; SIMPLIFY-CALL performs this transformation:
7381 ; (... (begin ... E) ...)
7382 ; -> (begin ... (... E ...))
7384 ; It also takes care of LET transformations.
7386 (define (simplify-call exp notepad)
7387 (define (loop args newargs exprs)
7389 (finish newargs exprs))
7390 ((begin? (car args))
7391 (let ((newexprs (reverse (begin.exprs (car args)))))
7393 (cons (car newexprs) newargs)
7394 (append (cdr newexprs) exprs))))
7395 (else (loop (cdr args) (cons (car args) newargs) exprs))))
7396 (define (finish newargs exprs)
7397 (call.args-set! exp (reverse newargs))
7399 (if (lambda? (call.proc exp))
7400 (simplify-let exp notepad)
7403 (simplify (call.proc exp) notepad))
7406 (if (and (call? newexp)
7407 (variable? (call.proc newexp)))
7408 (let* ((procname (variable.name (call.proc newexp)))
7409 (args (call.args newexp))
7411 (and (not (null? args))
7412 (constant? (car args))
7413 (integrate-usual-procedures)
7414 (every? constant? args)
7415 (let ((entry (constant-folding-entry procname)))
7418 (constant-folding-predicates entry)))
7419 (and (= (length args)
7420 (length predicates))
7421 (let loop ((args args)
7422 (predicates predicates))
7423 (cond ((null? args) entry)
7431 (make-constant (apply (constant-folding-folder entry)
7432 (map constant.value args)))
7435 (cond ((and (call? newexp)
7436 (begin? (call.proc newexp)))
7437 (let ((exprs0 (reverse (begin.exprs (call.proc newexp)))))
7438 (call.proc-set! newexp (car exprs0))
7439 (post-simplify-begin
7440 (make-begin (reverse
7442 (append (cdr exprs0) exprs))))
7447 (post-simplify-begin
7448 (make-begin (reverse (cons newexp exprs)))
7450 (call.args-set! exp (map (lambda (arg) (simplify arg notepad))
7452 (loop (call.args exp) '() '()))
7454 ; SIMPLIFY-LET performs these transformations:
7456 ; ((lambda (I_1 ... I_k . I_rest) ---) E1 ... Ek Ek+1 ...)
7457 ; -> ((lambda (I_1 ... I_k I_rest) ---) E1 ... Ek (LIST Ek+1 ...))
7459 ; ((lambda (I1 I2 ...) (begin D ...) (quote ...) E) L ...)
7460 ; -> ((lambda (I2 ...) (begin (define I1 L) D ...) (quote ...) E) ...)
7462 ; provided I1 is not assigned and each reference to I1 is in call position.
7466 ; (quote ((I1 ((begin I1)) () ())))
7474 ; (quote ((I1 ((begin I1)) () ())))
7475 ; (if (begin I1) E2 E3))
7480 ; (Together with SIMPLIFY-CONDITIONAL, this cleans up the output of the OR
7481 ; macro and enables certain control optimizations.)
7483 ; ((lambda (I1 I2 ...)
7485 ; (quote (... (I <references> () <calls>) ...) ...)
7488 ; -> ((lambda (I2 ...)
7490 ; (quote (... ...) ...)
7494 ; where D' ... and E' ... are obtained from D ... and E ...
7495 ; by replacing all references to I1 by K. This transformation
7496 ; applies if K is a constant that can be duplicated without changing
7497 ; its EQV? behavior.
7499 ; ((lambda () (begin) (quote ...) E)) -> E
7501 ; ((lambda (IGNORED I2 ...) ---) E1 E2 ...)
7502 ; -> (begin E1 ((lambda (I2 ...) ---) E2 ...))
7504 ; (Single assignment analysis, performed by the simplifier for lambda
7505 ; expressions, detects unused arguments and replaces them in the argument
7506 ; list by the special identifier IGNORED.)
7508 (define (simplify-let exp notepad)
7509 (define proc (call.proc exp))
7511 ; Loop1 operates before simplification of the lambda body.
7513 (define (loop1 formals actuals processed-formals processed-actuals)
7514 (cond ((null? formals)
7515 (if (not (null? actuals))
7516 (pass2-error p2error:wna exp))
7517 (return1 processed-formals processed-actuals))
7519 (return1 (cons formals processed-formals)
7520 (cons (make-call-to-LIST actuals) processed-actuals)))
7522 (pass2-error p2error:wna exp)
7523 (return1 processed-formals
7525 ((and (lambda? (car actuals))
7526 (let ((Rinfo (R-lookup (lambda.R proc) (car formals))))
7527 (and (null? (R-entry.assignments Rinfo))
7528 (= (length (R-entry.references Rinfo))
7529 (length (R-entry.calls Rinfo))))))
7530 (let ((I (car formals))
7532 (notepad-nonescaping-add! notepad L)
7533 (lambda.defs-set! proc
7534 (cons (make-definition I L)
7535 (lambda.defs proc)))
7536 (standardize-known-calls L
7538 (R-lookup (lambda.R proc) I)))
7539 (lambda.F-set! proc (union (lambda.F proc)
7540 (free-variables L)))
7541 (lambda.G-set! proc (union (lambda.G proc) (lambda.G L))))
7542 (loop1 (cdr formals)
7546 ((and (constant? (car actuals))
7547 (let ((x (constant.value (car actuals))))
7552 (let* ((I (car formals))
7553 (Rinfo (R-lookup (lambda.R proc) I)))
7554 (if (null? (R-entry.assignments Rinfo))
7556 (for-each (lambda (ref)
7557 (variable-set! ref (car actuals)))
7558 (R-entry.references Rinfo))
7559 (lambda.R-set! proc (remq Rinfo (lambda.R proc)))
7560 (lambda.F-set! proc (remq I (lambda.F proc)))
7561 (lambda.G-set! proc (remq I (lambda.G proc)))
7562 (loop1 (cdr formals)
7566 (loop1 (cdr formals)
7568 (cons (car formals) processed-formals)
7569 (cons (car actuals) processed-actuals)))))
7570 (else (if (null? actuals)
7571 (pass2-error p2error:wna exp))
7572 (loop1 (cdr formals)
7574 (cons (car formals) processed-formals)
7575 (cons (car actuals) processed-actuals)))))
7577 (define (return1 rev-formals rev-actuals)
7578 (let ((formals (reverse rev-formals))
7579 (actuals (reverse rev-actuals)))
7580 (lambda.args-set! proc formals)
7581 (if (and (not (null? formals))
7582 (null? (cdr formals))
7583 (let* ((x (car formals))
7585 (refs (references R x)))
7586 (and (= 1 (length refs))
7587 (null? (assignments R x)))))
7588 (let ((x (car formals))
7589 (body (lambda.body proc)))
7590 (cond ((and (variable? body)
7591 (eq? x (variable.name body)))
7592 (simplify (car actuals) notepad))
7593 ((and (conditional? body)
7594 (let ((B0 (if.test body)))
7596 (eq? x (variable.name B0))))
7597 (if.test-set! body (car actuals))
7598 (simplify body notepad))
7600 (return1-finish formals actuals))))
7601 (return1-finish formals actuals))))
7603 (define (return1-finish formals actuals)
7604 (simplify-lambda proc notepad)
7605 (loop2 formals actuals '() '() '()))
7607 ; Loop2 operates after simplification of the lambda body.
7609 (define (loop2 formals actuals processed-formals processed-actuals for-effect)
7610 (cond ((null? formals)
7611 (return2 processed-formals processed-actuals for-effect))
7612 ((ignored? (car formals))
7613 (loop2 (cdr formals)
7617 (cons (car actuals) for-effect)))
7618 (else (loop2 (cdr formals)
7620 (cons (car formals) processed-formals)
7621 (cons (car actuals) processed-actuals)
7624 (define (return2 rev-formals rev-actuals rev-for-effect)
7625 (let ((formals (reverse rev-formals))
7626 (actuals (reverse rev-actuals))
7627 (for-effect (reverse rev-for-effect)))
7628 (lambda.args-set! proc formals)
7629 (call.args-set! exp actuals)
7630 (let ((exp (if (and (null? actuals)
7631 (or (null? (lambda.defs proc))
7632 (and (notepad.parent notepad)
7634 (notepad.parent notepad)
7635 (map (lambda (def) '())
7636 (lambda.defs proc))))))
7637 (begin (for-each (lambda (I)
7638 (notepad-var-add! notepad I))
7640 (if (not (null? (lambda.defs proc)))
7641 (let ((parent (notepad.parent notepad))
7642 (defs (lambda.defs proc))
7643 (R (lambda.R proc)))
7646 (append defs (lambda.defs parent)))
7647 (lambda.defs-set! proc '())
7650 (append (map (lambda (def)
7651 (R-lookup R (def.lhs def)))
7653 (lambda.R parent)))))
7656 (if (null? for-effect)
7658 (post-simplify-begin (make-begin (append for-effect (list exp)))
7661 (notepad-nonescaping-add! notepad proc)
7662 (loop1 (lambda.args proc) (call.args exp) '() '()))
7664 ; Single assignment analysis performs the transformation
7666 ; (lambda (... I ...)
7668 ; (quote (... (I <references> ((set! I L)) <calls>) ...) ...)
7669 ; (begin (set! I L) E1 ...))
7670 ; -> (lambda (... IGNORED ...)
7671 ; (begin (define I L) D ...)
7672 ; (quote (... (I <references> () <calls>) ...) ...)
7675 ; For best results, pass 1 should sort internal definitions and LETRECs so
7676 ; that procedure definitions/bindings come first.
7678 ; This procedure operates by side effect.
7680 (define (single-assignment-analysis L notepad)
7681 (let ((formals (lambda.args L))
7682 (defs (lambda.defs L))
7684 (body (lambda.body L)))
7685 (define (finish! exprs escapees)
7686 (begin.exprs-set! body
7687 (append (reverse escapees)
7689 (lambda.body-set! L (post-simplify-begin body '())))
7691 (let loop ((exprs (begin.exprs body))
7693 (let ((first (car exprs)))
7694 (if (and (assignment? first)
7695 (not (null? (cdr exprs))))
7696 (let ((I (assignment.lhs first))
7697 (rhs (assignment.rhs first)))
7698 (if (and (lambda? rhs)
7700 (= 1 (length (assignments R I))))
7701 (if (= (length (calls R I))
7702 (length (references R I)))
7703 (begin (notepad-nonescaping-add! notepad rhs)
7704 (flag-as-ignored I L)
7706 (cons (make-definition I rhs)
7708 (assignments-set! R I '())
7709 (standardize-known-calls
7711 (R-entry.calls (R-lookup R I)))
7712 (loop (cdr exprs) escapees))
7714 (cons (car exprs) escapees)))
7715 (finish! exprs escapees)))
7716 (finish! exprs escapees)))))))
7718 (define (standardize-known-calls L calls)
7719 (let ((formals (lambda.args L)))
7720 (cond ((not (list? formals))
7721 (let* ((newformals (make-null-terminated formals))
7722 (n (- (length newformals) 1)))
7723 (lambda.args-set! L newformals)
7724 (for-each (lambda (call)
7725 (if (>= (length (call.args call)) n)
7728 (append (list-head (call.args call) n)
7731 (list-tail (call.args call) n)))))
7732 (pass2-error p2error:wna call)))
7734 (else (let ((n (length formals)))
7735 (for-each (lambda (call)
7736 (if (not (= (length (call.args call)) n))
7737 (pass2-error p2error:wna call)))
7739 ; Copyright 1991 William D Clinger.
7741 ; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
7745 ; Second pass of the Twobit compiler, part 2:
7746 ; single assignment elimination, assignment elimination,
7747 ; and lambda lifting.
7749 ; See part 1 for further documentation.
7751 ; Single assignment elimination performs the transformation
7753 ; (lambda (... I1 ... In ...)
7755 ; (begin (set! I1 E1)
7759 ; -> (lambda (... IGNORED ... IGNORED ...)
7760 ; (let* ((I1 E1) ... (In En))
7764 ; provided for each k:
7766 ; 1. Ik does not occur in E1, ..., Ek.
7767 ; 2. Either E1 through Ek contain no procedure calls
7768 ; or Ik is not referenced by an escaping lambda expression.
7769 ; 3. Ik is assigned only once.
7771 ; I doubt whether the third condition is really necessary, but
7772 ; dropping it would involve a more complex calculation of the
7773 ; revised referencing information.
7775 ; A more precise description of the transformation:
7777 ; (lambda (... I1 ... In ...)
7778 ; (begin (define F1 L1) ...)
7779 ; (quote (... (I1 <references> ((set! I1 E1)) <calls>) ...
7780 ; (In <references> ((set! In En)) <calls>)
7781 ; (F1 <references> () <calls>) ...) ...)
7782 ; (begin (set! I1 E1) ... (set! In En) E ...))
7783 ; -> (lambda (... IGNORED ... IGNORED ...)
7788 ; (quote ((I1 <references> () <calls>)) ...)
7791 ; (begin (define F1 L1) ...)
7792 ; (quote (... (In <references> () <calls>)
7793 ; (F1 <references> () <calls>) ...) ...)
7799 ; For best results, pass 1 should sort internal definitions and LETRECs
7800 ; so that procedure definitions/bindings come first, followed by
7801 ; definitions/bindings whose right hand side contains no calls,
7802 ; followed by definitions/bindings of variables that do not escape,
7803 ; followed by all other definitions/bindings.
7805 ; Pass 1 can't tell which variables escape, however. Pass 2 can't tell
7806 ; which variables escape either until all enclosed lambda expressions
7807 ; have been simplified and the first transformation above has been
7808 ; performed. That is why single assignment analysis precedes single
7809 ; assignment elimination. As implemented here, an assignment that does
7810 ; not satisfy the conditions above will prevent the transformation from
7811 ; being applied to any subsequent assignments.
7813 ; This procedure operates by side effect.
7815 (define (single-assignment-elimination L notepad)
7817 (if (begin? (lambda.body L))
7819 (let* ((formals (make-null-terminated (lambda.args L)))
7820 (defined (map def.lhs (lambda.defs L)))
7821 (escaping (intersection formals
7822 (notepad-captured-variables notepad)))
7826 ; exprs that remain in the body;
7827 ; assigns that will be replaced by let* variables;
7828 ; call-has-occurred?, a boolean;
7829 ; free variables of the assigns;
7830 ; Performs the transformation described above.
7832 (define (loop exprs assigns call-has-occurred? free)
7833 (cond ((null? (cdr exprs))
7834 (return exprs assigns))
7835 ((assignment? (car exprs))
7836 (let ((I1 (assignment.lhs (car exprs)))
7837 (E1 (assignment.rhs (car exprs))))
7838 (if (and (memq I1 formals)
7839 (= (length (assignments R I1)) 1)
7840 (not (and call-has-occurred?
7841 (memq I1 escaping))))
7842 (let* ((free-in-E1 (free-variables E1))
7843 (newfree (union free-in-E1 free)))
7844 (if (or (memq I1 newfree)
7847 (intersection free-in-E1 defined))))
7848 (return exprs assigns)
7850 (cons (car exprs) assigns)
7851 (or call-has-occurred?
7852 (might-return-twice? E1))
7854 (return exprs assigns))))
7855 (else (return exprs assigns))))
7857 (define (return exprs assigns)
7858 (if (not (null? assigns))
7859 (let ((I (assignment.lhs (car assigns)))
7860 (E (assignment.rhs (car assigns)))
7861 (defs (lambda.defs L))
7864 (flag-as-ignored I L)
7865 (assignments-set! R I '())
7866 (let ((L2 (make-lambda (list I)
7870 (R-entry R (def.lhs def)))
7876 (make-begin exprs))))
7877 (lambda.defs-set! L '())
7878 (for-each (lambda (entry)
7879 (lambda.R-set! L (remq entry R)))
7881 (return-loop (cdr assigns) (make-call L2 (list E)))))))
7883 (define (return-loop assigns body)
7885 (let ((L3 (call.proc body)))
7886 (lambda.body-set! L body)
7887 (lambda-lifting L3 L))
7888 (let* ((I (assignment.lhs (car assigns)))
7889 (E (assignment.rhs (car assigns)))
7890 (L3 (call.proc body))
7891 (F (remq I (lambda.F L3)))
7892 (G (remq I (lambda.G L3))))
7893 (flag-as-ignored I L)
7894 (assignments-set! R I '())
7895 (let ((L2 (make-lambda (list I)
7897 (list (R-entry R I))
7903 (lambda.R-set! L (remq (R-entry R I) R))
7904 (lambda-lifting L3 L2)
7905 (return-loop (cdr assigns) (make-call L2 (list E)))))))
7907 (loop (begin.exprs (lambda.body L)) '() #f '())))
7911 ; Temporary definitions.
7913 (define (free-variables exp)
7916 ((lambda) (difference (lambda.F exp)
7917 (make-null-terminated (lambda.args exp))))
7918 ((set!) (union (list (assignment.lhs exp))
7919 (free-variables (assignment.rhs exp))))
7920 ((if) (union (free-variables (if.test exp))
7921 (free-variables (if.then exp))
7922 (free-variables (if.else exp))))
7923 ((begin) (if (variable? exp)
7924 (list (variable.name exp))
7925 (apply union (map free-variables (begin.exprs exp)))))
7926 (else (apply union (map free-variables exp)))))
7928 (define (might-return-twice? exp)
7932 ((set!) (might-return-twice? (assignment.rhs exp)))
7933 ((if) (or (might-return-twice? (if.test exp))
7934 (might-return-twice? (if.then exp))
7935 (might-return-twice? (if.else exp))))
7936 ((begin) (if (variable? exp)
7938 (some? might-return-twice? (begin.exprs exp))))
7942 ; Assignment elimination replaces variables that appear on the left
7943 ; hand side of an assignment by data structures. This is necessary
7944 ; to avoid some nasty complications with lambda lifting.
7946 ; This procedure operates by side effect.
7948 (define (assignment-elimination L)
7949 (let ((R (lambda.R L)))
7951 ; Given a list of entries, return those for assigned variables.
7953 (define (loop entries assigned)
7954 (cond ((null? entries)
7955 (if (not (null? assigned))
7956 (eliminate assigned)))
7957 ((not (null? (R-entry.assignments (car entries))))
7958 (loop (cdr entries) (cons (car entries) assigned)))
7959 ((null? (R-entry.references (car entries)))
7960 (flag-as-ignored (R-entry.name (car entries)) L)
7961 (loop (cdr entries) assigned))
7962 (else (loop (cdr entries) assigned))))
7964 ; Given a list of entries for assigned variables I1 ...,
7965 ; remove the assignments by replacing the body by a LET of the form
7966 ; ((LAMBDA (V1 ...) ...) (MAKE-CELL I1) ...), by replacing references
7967 ; by calls to CELL-REF, and by replacing assignments by calls to
7970 (define (eliminate assigned)
7971 (let* ((oldnames (map R-entry.name assigned))
7972 (newnames (map generate-new-name oldnames)))
7973 (let ((augmented-entries (map list newnames assigned))
7974 (renaming-alist (map cons oldnames newnames))
7975 (defs (lambda.defs L)))
7976 (for-each cellify! augmented-entries)
7977 (for-each (lambda (def)
7978 (do ((free (lambda.F (def.rhs def)) (cdr free)))
7980 (let ((z (assq (car free) renaming-alist)))
7982 (set-car! free (cdr z))))))
7986 (make-lambda (map car augmented-entries)
7988 (union (map (lambda (def)
7989 (R-entry R (def.lhs def)))
7991 (map new-reference-info augmented-entries))
7992 (union (list name:CELL-REF name:CELL-SET!)
7994 (difference (lambda.F L) oldnames))
7995 (union (list name:CELL-REF name:CELL-SET!)
7997 (difference (lambda.G L) oldnames))
8002 (make-call (make-variable name:MAKE-CELL)
8003 (list (make-variable name))))
8004 (map R-entry.name assigned)))))
8005 (lambda.F-set! L (union (list name:MAKE-CELL name:CELL-REF name:CELL-SET!)
8006 (difference (lambda.F L)
8007 (map def.lhs (lambda.defs L)))))
8008 (lambda.defs-set! L '())
8009 (for-each update-old-reference-info!
8011 (car (call.args arg)))
8012 (call.args newbody)))
8013 (lambda.body-set! L newbody)
8014 (lambda-lifting (call.proc newbody) L)))))
8016 (define (generate-new-name name)
8017 (string->symbol (string-append cell-prefix (symbol->string name))))
8019 ; In addition to replacing references and assignments involving the
8020 ; old variable by calls to CELL-REF and CELL-SET! on the new, CELLIFY!
8021 ; uses the old entry to collect the referencing information for the
8024 (define (cellify! augmented-entry)
8025 (let ((newname (car augmented-entry))
8026 (entry (cadr augmented-entry)))
8027 (do ((refs (R-entry.references entry)
8030 (let* ((reference (car refs))
8031 (newref (make-variable newname)))
8032 (set-car! reference (make-variable name:CELL-REF))
8033 (set-car! (cdr reference) newref)
8034 (set-car! refs newref)))
8035 (do ((assigns (R-entry.assignments entry)
8038 (let* ((assignment (car assigns))
8039 (newref (make-variable newname)))
8040 (set-car! assignment (make-variable name:CELL-SET!))
8041 (set-car! (cdr assignment) newref)
8042 (R-entry.references-set! entry
8044 (R-entry.references entry)))))
8045 (R-entry.assignments-set! entry '())))
8047 ; This procedure creates a brand new entry for a new variable, extracting
8048 ; the references stored in the old entry by CELLIFY!.
8050 (define (new-reference-info augmented-entry)
8051 (make-R-entry (car augmented-entry)
8052 (R-entry.references (cadr augmented-entry))
8056 ; This procedure updates the old entry to reflect the fact that it is
8057 ; now referenced once and never assigned.
8059 (define (update-old-reference-info! ref)
8060 (references-set! R (variable.name ref) (list ref))
8061 (assignments-set! R (variable.name ref) '())
8062 (calls-set! R (variable.name ref) '()))
8066 ; Lambda lifting raises internal definitions to outer scopes to avoid
8067 ; having to choose between creating a closure or losing tail recursion.
8068 ; If L is not #f, then L2 is a lambda expression nested within L.
8069 ; Any internal definitions that occur within L2 may be lifted to L
8070 ; by adding extra arguments to the defined procedure and to all calls to it.
8071 ; Lambda lifting is not a clear win, because the extra arguments could
8072 ; easily become more expensive than creating a closure and referring
8073 ; to the non-local arguments through the closure. The heuristics used
8074 ; to decide whether to lift a group of internal definitions are isolated
8075 ; within the POLICY:LIFT? procedure.
8077 ; L2 can be the same as L, so the order of side effects is critical.
8079 (define (lambda-lifting L2 L)
8081 ; The call to sort is optional. It gets the added arguments into
8082 ; the same order they appear in the formals list, which is an
8083 ; advantage for register targeting.
8085 (define (lift L2 L args-to-add)
8086 (let ((formals (make-null-terminated (lambda.args L2))))
8087 (do ((defs (lambda.defs L2) (cdr defs))
8088 (args-to-add args-to-add (cdr args-to-add)))
8090 (let* ((def (car defs))
8091 (entry (R-lookup (lambda.R L2) (def.lhs def)))
8092 (calls (R-entry.calls entry))
8093 (added (twobit-sort (lambda (x y)
8094 (let ((xx (memq x formals))
8095 (yy (memq y formals)))
8097 (> (length xx) (length yy))
8101 ; The flow equation guarantees that these added arguments
8102 ; will occur free by the time this round of lifting is done.
8103 (lambda.F-set! L3 (union added (lambda.F L3)))
8104 (lambda.args-set! L3 (append added (lambda.args L3)))
8105 (for-each (lambda (call)
8106 (let ((newargs (map make-variable added)))
8107 ; The referencing information is made obsolete here!
8108 (call.args-set! call
8109 (append newargs (call.args call)))))
8111 (lambda.R-set! L2 (remq entry (lambda.R L2)))
8112 (lambda.R-set! L (cons entry (lambda.R L)))
8114 (if (not (eq? L2 L))
8116 (lambda.defs-set! L (append (lambda.defs L2) (lambda.defs L)))
8117 (lambda.defs-set! L2 '())))))
8120 (if (not (null? (lambda.defs L2)))
8121 (let ((args-to-add (compute-added-arguments
8123 (make-null-terminated (lambda.args L2)))))
8124 (if (POLICY:LIFT? L2 L args-to-add)
8125 (lift L2 L args-to-add))))))
8127 ; Given a list of definitions ((define f1 ...) ...) and a set of formals
8128 ; N over which the definitions may be lifted, returns a list of the
8129 ; subsets of N that need to be added to each procedure definition
8132 ; Algorithm: Let F_i be the variables that occur free in the body of
8133 ; the lambda expression associated with f_i. Construct the call graph.
8134 ; Solve the flow equations
8136 ; A_i = (F_i /\ N) \/ (\/ {A_j | A_i calls A_j})
8138 ; where /\ is intersection and \/ is union.
8140 (define (compute-added-arguments defs formals)
8141 (let ((procs (map def.lhs defs))
8142 (freevars (map lambda.F (map def.rhs defs))))
8143 (let ((callgraph (map (lambda (names)
8145 (position name procs))
8146 (intersection names procs)))
8148 (added_0 (map (lambda (names)
8149 (intersection names formals))
8153 (make-vector (length procs) '())
8154 (list->vector (map (lambda (term0 indexes)
8155 (lambda (approximations)
8159 (vector-ref approximations i))
8165 (define (position x l)
8166 (cond ((eq? x (car l)) 0)
8167 (else (+ 1 (position x (cdr l))))))
8169 ; Given a vector of starting approximations,
8170 ; a vector of functions that compute a next approximation
8171 ; as a function of the vector of approximations,
8172 ; and an equality predicate,
8173 ; returns a vector of fixed points.
8175 (define (compute-fixedpoint v functions equiv?)
8176 (define (loop i flag)
8179 (loop (- (vector-length v) 1) #f)
8181 (let ((next_i ((vector-ref functions i) v)))
8182 (if (equiv? next_i (vector-ref v i))
8184 (begin (vector-set! v i next_i)
8185 (loop (- i 1) #t))))))
8186 (loop (- (vector-length v) 1) #f))
8189 ; Given a lambda expression L2, its parent lambda expression
8190 ; L (which may be the same as L2, or #f), and a list of the
8191 ; lists of arguments that would need to be added to known
8192 ; local procedures, returns #t iff lambda lifting should be done.
8194 ; Here are some heuristics:
8196 ; Don't lift if it means adding too many arguments.
8197 ; Don't lift large groups of definitions.
8198 ; In questionable cases it is better to lift to an outer
8199 ; lambda expression that already contains internal
8200 ; definitions than to one that doesn't.
8201 ; It is better not to lift if the body contains a lambda
8202 ; expression that has to be closed anyway.
8204 (define (POLICY:LIFT? L2 L args-to-add)
8205 (and (lambda-optimizations)
8206 (not (lambda? (lambda.body L2)))
8207 (every? (lambda (addlist)
8208 (< (length addlist) 6))
8210 ; Copyright 1991 William D Clinger (for SIMPLIFY-CONDITIONAL)
8211 ; Copyright 1999 William D Clinger (for everything else)
8213 ; Permission to copy this software, in whole or in part, to use this
8214 ; software for any lawful noncommercial purpose, and to redistribute
8215 ; this software is granted subject to the restriction that all copies
8216 ; made of this software must include this copyright notice in full.
8218 ; I also request that you send me a copy of any improvements that you
8219 ; make to this software so that they may be incorporated within it to
8220 ; the benefit of the Scheme community.
8224 ; Some source transformations on IF expressions:
8227 ; (if 'K E1 E2) E1 K != #f
8228 ; (if (if B0 '#f '#f) E1 E2) (begin B0 E2)
8229 ; (if (if B0 '#f 'K ) E1 E2) (if B0 E2 E1) K != #f
8230 ; (if (if B0 'K '#f) E1 E2) (if B0 E1 E2) K != #f
8231 ; (if (if B0 'K1 'K2) E1 E2) (begin B0 E1) K1, K2 != #f
8232 ; (if (if B0 (if B1 #t #f) B2) E1 E2) (if (if B0 B1 B2) E1 E2)
8233 ; (if (if B0 B1 (if B2 #t #f)) E1 E2) (if (if B0 B1 B2) E1 E2)
8234 ; (if (if X X B0 ) E1 E2) (if (if X #t B0) E1 E2) X a variable
8235 ; (if (if X B0 X ) E1 E2) (if (if X B0 #f) E1 E2) X a variable
8236 ; (if ((lambda (X) (if ((lambda (X)
8237 ; (if X X B2)) B0) (if X #t (if B2 #t #f))) B0)
8239 ; (if (begin ... B0) E1 E2) (begin ... (if B0 E1 E2))
8240 ; (if (not E0) E1 E2) (if E0 E2 E1) not is integrable
8242 ; FIXME: Three of the transformations above are intended to clean up
8243 ; the output of the OR macro. It isn't yet clear how well this works.
8245 (define (simplify-conditional exp notepad)
8246 (define (coercion-to-boolean? exp)
8247 (and (conditional? exp)
8248 (let ((E1 (if.then exp))
8251 (eq? #t (constant.value E1))
8253 (eq? #f (constant.value E2))))))
8254 (if (not (control-optimization))
8255 (begin (if.test-set! exp (simplify (if.test exp) notepad))
8256 (if.then-set! exp (simplify (if.then exp) notepad))
8257 (if.else-set! exp (simplify (if.else exp) notepad))
8259 (let* ((test (if.test exp)))
8260 (if (and (call? test)
8261 (lambda? (call.proc test))
8262 (let* ((L (call.proc test))
8263 (body (lambda.body L)))
8264 (and (conditional? body)
8265 (let ((R (lambda.R L))
8267 (B1 (if.then body)))
8270 (let ((x (variable.name B0)))
8271 (and (eq? x (variable.name B1))
8274 (= 1 (length (call.args test))))))))))
8275 (let* ((L (call.proc test))
8277 (body (lambda.body L))
8278 (ref (if.then body))
8279 (x (variable.name ref))
8280 (entry (R-entry R x)))
8281 (if.then-set! body (make-constant #t))
8283 (make-conditional (if.else body)
8285 (make-constant #f)))
8286 (R-entry.references-set! entry
8288 (R-entry.references entry)))
8289 (simplify-conditional exp notepad))
8290 (let loop ((test (simplify (if.test exp) notepad)))
8291 (if.test-set! exp test)
8292 (cond ((constant? test)
8293 (simplify (if (constant.value test)
8297 ((and (conditional? test)
8298 (constant? (if.then test))
8299 (constant? (if.else test)))
8300 (cond ((and (constant.value (if.then test))
8301 (constant.value (if.else test)))
8302 (post-simplify-begin
8303 (make-begin (list (if.test test)
8304 (simplify (if.then exp)
8307 ((and (not (constant.value (if.then test)))
8308 (not (constant.value (if.else test))))
8309 (post-simplify-begin
8310 (make-begin (list (if.test test)
8311 (simplify (if.else exp)
8314 (else (if (not (constant.value (if.then test)))
8315 (let ((temp (if.then exp)))
8316 (if.then-set! exp (if.else exp))
8317 (if.else-set! exp temp)))
8318 (if.test-set! exp (if.test test))
8319 (loop (if.test exp)))))
8320 ((and (conditional? test)
8321 (or (coercion-to-boolean? (if.then test))
8322 (coercion-to-boolean? (if.else test))))
8323 (if (coercion-to-boolean? (if.then test))
8324 (if.then-set! test (if.test (if.then test)))
8325 (if.else-set! test (if.test (if.else test))))
8327 ((and (conditional? test)
8328 (variable? (if.test test))
8329 (let ((x (variable.name (if.test test))))
8330 (or (and (variable? (if.then test))
8331 (eq? x (variable.name (if.then test)))
8333 (and (variable? (if.else test))
8334 (eq? x (variable.name (if.else test)))
8339 ((1) (if.then-set! test (make-constant #t)))
8340 ((2) (if.else-set! test (make-constant #f))))
8343 (let ((exprs (reverse (begin.exprs test))))
8344 (if.test-set! exp (car exprs))
8345 (post-simplify-begin
8346 (make-begin (reverse (cons (loop (car exprs))
8350 (variable? (call.proc test))
8351 (eq? (variable.name (call.proc test)) name:NOT)
8352 (integrable? name:NOT)
8353 (integrate-usual-procedures)
8354 (= (length (call.args test)) 1))
8355 (let ((temp (if.then exp)))
8356 (if.then-set! exp (if.else exp))
8357 (if.else-set! exp temp))
8358 (loop (car (call.args test))))
8360 (simplify-case exp notepad))))))))
8362 ; Given a conditional expression whose test has been simplified,
8363 ; simplifies the then and else parts while applying optimizations
8364 ; for CASE expressions.
8365 ; Precondition: (control-optimization) is true.
8367 (define (simplify-case exp notepad)
8368 (let ((E0 (if.test exp)))
8370 (variable? (call.proc E0))
8371 (let ((name (variable.name (call.proc E0))))
8372 ; FIXME: Should ensure that the name is integrable,
8373 ; but MEMQ and MEMV probably aren't according to the
8374 ; INTEGRABLE? predicate.
8375 (or (eq? name name:EQ?)
8376 (eq? name name:EQV?)
8377 (eq? name name:MEMQ)
8378 (eq? name name:MEMV)))
8379 (integrate-usual-procedures)
8380 (= (length (call.args E0)) 2)
8381 (variable? (car (call.args E0)))
8382 (constant? (cadr (call.args E0))))
8383 (simplify-case-clauses (variable.name (car (call.args E0)))
8386 (begin (if.then-set! exp (simplify (if.then exp) notepad))
8387 (if.else-set! exp (simplify (if.else exp) notepad))
8390 ; Code generation for case expressions.
8392 ; A case expression turns into a conditional expression
8395 ; CASE{I} ::= E | (if (PRED I K) E CASE{I})
8396 ; PRED ::= memv | memq | eqv? | eq?
8398 ; The memq and eq? predicates are used when the constant
8399 ; is a (list of) boolean, fixnum, char, empty list, or symbol.
8400 ; The constants will almost always be of these types.
8402 ; The first step is to remove duplicated constants and to
8403 ; collect all the case clauses, sorting them into the following
8404 ; categories based on their simplified list of constants:
8405 ; constants are fixnums
8406 ; constants are characters
8407 ; constants are symbols
8408 ; constants are of mixed or other type
8409 ; After duplicated constants have been removed, the predicates
8410 ; for these clauses can be tested in any order.
8412 ; Given the name of an arbitrary variable, an expression that
8413 ; has not yet been simplified or can safely be simplified again,
8414 ; and a notepad, returns the expression after simplification.
8415 ; If the expression is equivalent to a case expression that dispatches
8416 ; on the given variable, then case-optimization will be applied.
8418 (define (simplify-case-clauses var0 E notepad)
8420 (define notepad2 (make-notepad (notepad.parent notepad)))
8422 (define (collect-clauses E fix chr sym other constants)
8423 (if (not (conditional? E))
8424 (analyze (simplify E notepad2)
8425 fix chr sym other constants)
8426 (let ((test (simplify (if.test E) notepad2))
8427 (code (simplify (if.then E) notepad2)))
8428 (if.test-set! E test)
8429 (if.then-set! E code)
8430 (if (not (call? test))
8431 (finish E fix chr sym other constants)
8432 (let ((proc (call.proc test))
8433 (args (call.args test)))
8434 (if (not (and (variable? proc)
8435 (let ((name (variable.name proc)))
8436 ; FIXME: See note above.
8437 (or (eq? name name:EQ?)
8438 (eq? name name:EQV?)
8439 (eq? name name:MEMQ)
8440 (eq? name name:MEMV)))
8442 (variable? (car args))
8443 (eq? (variable.name (car args)) var0)
8444 (constant? (cadr args))))
8445 (finish E fix chr sym other constants)
8446 (let ((pred (variable.name proc))
8447 (datum (constant.value (cadr args))))
8449 (if (or (and (or (eq? pred name:MEMV)
8450 (eq? pred name:MEMQ))
8451 (not (list? datum)))
8452 (and (eq? pred name:EQ?)
8453 (not (eqv-is-ok? datum)))
8454 (and (eq? pred name:MEMQ)
8455 (not (every? (lambda (datum)
8458 (finish E fix chr sym other constants)
8461 (remove-duplicates (if (or (eq? pred name:EQV?)
8462 (eq? pred name:EQ?))
8466 (lambda (data constants)
8467 (let ((clause (list data code))
8469 (cond ((every? smallint? data)
8476 ((every? char? data)
8483 ((every? symbol? data)
8496 constants))))))))))))))
8498 (define (remove-duplicates data set)
8499 (let loop ((originals data)
8502 (if (null? originals)
8504 (let ((x (car originals))
8505 (originals (cdr originals)))
8507 (loop originals data set)
8508 (loop originals (cons x data) (cons x set)))))))
8510 (define (finish E fix chr sym other constants)
8511 (if.else-set! E (simplify (if.else E) notepad2))
8512 (analyze E fix chr sym other constants))
8514 (define (analyze default fix chr sym other constants)
8515 (notepad-var-add! notepad2 var0)
8516 (for-each (lambda (L)
8517 (notepad-lambda-add! notepad L))
8518 (notepad.lambdas notepad2))
8519 (for-each (lambda (L)
8520 (notepad-nonescaping-add! notepad L))
8521 (notepad.nonescaping notepad2))
8522 (for-each (lambda (var)
8523 (notepad-var-add! notepad var))
8524 (append (list name:FIXNUM?
8531 (notepad.vars notepad2)))
8532 (analyze-clauses (notepad.vars notepad2)
8541 (collect-clauses E '() '() '() '() '()))
8543 ; Returns true if EQ? and EQV? behave the same on x.
8545 (define (eqv-is-ok? x)
8551 ; Returns true if EQ? and EQV? behave the same on x.
8553 (define (eq-is-ok? x)
8556 ; Any case expression that dispatches on a variable var0 and whose
8557 ; constants are disjoint can be compiled as
8559 ; (let ((n (cond ((eq? var0 'K1) ...) ; miscellaneous constants
8562 ; <dispatch-on-fixnum>)
8564 ; <dispatch-on-char>)
8566 ; <dispatch-on-symbols>)
8568 ; <dispatch-on-case-number>)
8570 ; where the <dispatch-on-case-number> uses binary search within
8571 ; the interval [0, p+1), where p is the number of non-default cases.
8573 ; On the SPARC, sequential search is faster if there are fewer than
8574 ; 8 constants, and sequential search uses less than half the space
8575 ; if there are fewer than 10 constants. Most target machines should
8576 ; similar, so I'm hard-wiring this constant.
8577 ; FIXME: The hardwired constant is annoying.
8579 (define (analyze-clauses F var0 default fix chr sym other constants)
8580 (cond ((or (and (null? fix)
8582 (< (length constants) 12))
8583 (implement-clauses-by-sequential-search var0
8585 (append fix chr sym other)))
8587 (implement-clauses F var0 default fix chr sym other constants))))
8589 ; Implements the general technique described above.
8591 (define (implement-clauses F var0 default fix chr sym other constants)
8592 (let* ((name:n ((make-rename-procedure) 'n))
8593 ; Referencing information is destroyed by pass 2.
8594 (entry (make-R-entry name:n '() '() '()))
8595 (F (union (make-set (list name:n)) F))
8604 (implement-case-dispatch
8608 ; The order here must match the order
8609 ; used by IMPLEMENT-DISPATCH.
8610 (append other fix chr sym)))))))
8612 (list (implement-dispatch 0
8619 (define (implement-case-dispatch var0 exprs)
8620 (implement-intervals var0
8621 (map (lambda (n code)
8622 (list n (+ n 1) code))
8623 (iota (length exprs))
8626 ; Given the number of prior clauses,
8627 ; the variable on which to dispatch,
8628 ; a list of constant lists for mixed or miscellaneous clauses,
8629 ; a list of constant lists for the fixnum clauses,
8630 ; a list of constant lists for the character clauses, and
8631 ; a list of constant lists for the symbol clauses,
8632 ; returns code that computes the index of the selected clause.
8633 ; The mixed/miscellaneous clauses must be tested first because
8634 ; Twobit's SMALLINT? predicate might not be true of all fixnums
8635 ; on the target machine, which means that Twobit might classify
8636 ; some fixnums as miscellaneous.
8638 (define (implement-dispatch prior var0 other fix chr sym)
8639 (cond ((not (null? other))
8640 (implement-dispatch-other
8641 (implement-dispatch (+ prior (length other))
8642 var0 fix chr sym '())
8645 (make-conditional (make-call (make-variable name:FIXNUM?)
8646 (list (make-variable var0)))
8647 (implement-dispatch-fixnum prior var0 fix)
8648 (implement-dispatch (+ prior (length fix))
8649 var0 '() chr sym other)))
8651 (make-conditional (make-call (make-variable name:CHAR?)
8652 (list (make-variable var0)))
8653 (implement-dispatch-char prior var0 chr)
8654 (implement-dispatch (+ prior (length chr))
8655 var0 fix '() sym other)))
8657 (make-conditional (make-call (make-variable name:SYMBOL?)
8658 (list (make-variable var0)))
8659 (implement-dispatch-symbol prior var0 sym)
8660 (implement-dispatch (+ prior (length sym))
8661 var0 fix chr '() other)))
8663 (make-constant 0))))
8665 ; The value of var0 will be known to be a fixnum.
8666 ; Can use table lookup, binary search, or sequential search.
8667 ; FIXME: Never uses sequential search, which is best when
8668 ; there are only a few constants, with gaps between them.
8670 (define (implement-dispatch-fixnum prior var0 lists)
8672 (define (calculate-intervals n lists)
8673 (define (loop n lists intervals)
8675 (twobit-sort (lambda (interval1 interval2)
8676 (< (car interval1) (car interval2)))
8678 (let ((constants (twobit-sort < (car lists))))
8681 (append (extract-intervals n constants)
8685 (define (extract-intervals n constants)
8686 (if (null? constants)
8688 (let ((k0 (car constants)))
8689 (do ((constants (cdr constants) (cdr constants))
8690 (k1 (+ k0 1) (+ k1 1)))
8691 ((or (null? constants)
8692 (not (= k1 (car constants))))
8693 (cons (list k0 k1 (make-constant n))
8694 (extract-intervals n constants)))))))
8696 (define (complete-intervals intervals)
8697 (cond ((null? intervals)
8699 ((null? (cdr intervals))
8702 (let* ((i1 (car intervals))
8703 (i2 (cadr intervals))
8706 (intervals (complete-intervals (cdr intervals))))
8710 (cons (list end1 start2 (make-constant 0))
8713 (let* ((intervals (complete-intervals
8714 (calculate-intervals (+ prior 1) lists)))
8715 (lo (car (car intervals)))
8716 (hi (car (car (reverse intervals))))
8717 (p (length intervals)))
8719 (make-call (make-variable name:FX<)
8720 (list (make-variable var0)
8721 (make-constant lo)))
8724 (make-call (make-variable name:FX<)
8725 (list (make-variable var0)
8726 (make-constant (+ hi 1))))
8727 ; The static cost of table lookup is about hi - lo words.
8728 ; The static cost of binary search is about 5 SPARC instructions
8730 (if (< (- hi lo) (* 5 p))
8731 (implement-table-lookup var0 (+ prior 1) lists lo hi)
8732 (implement-intervals var0 intervals))
8733 (make-constant 0)))))
8735 (define (implement-dispatch-char prior var0 lists)
8736 (let* ((lists (map (lambda (constants)
8737 (map compat:char->integer constants))
8739 (name:n ((make-rename-procedure) 'n))
8740 ; Referencing information is destroyed by pass 2.
8741 ;(entry (make-R-entry name:n '() '() '()))
8742 (F (list name:n name:EQ? name:FX< name:FX- name:VECTOR-REF))
8751 (implement-dispatch-fixnum prior name:n lists))))
8753 (make-call (make-variable name:CHAR->INTEGER)
8754 (list (make-variable var0))))))
8756 (define (implement-dispatch-symbol prior var0 lists)
8757 (implement-dispatch-other (make-constant 0) prior var0 lists))
8759 (define (implement-dispatch-other default prior var0 lists)
8762 (let* ((constants (car lists))
8765 (make-conditional (make-call-to-memv var0 constants)
8767 (implement-dispatch-other default n var0 lists)))))
8769 (define (make-call-to-memv var0 constants)
8770 (cond ((null? constants)
8772 ((null? (cdr constants))
8773 (make-call-to-eqv var0 (car constants)))
8775 (make-conditional (make-call-to-eqv var0 (car constants))
8777 (make-call-to-memv var0 (cdr constants))))))
8779 (define (make-call-to-eqv var0 constant)
8780 (make-call (make-variable
8781 (if (eq-is-ok? constant)
8784 (list (make-variable var0)
8785 (make-constant constant))))
8787 ; Given a variable whose value is known to be a fixnum,
8788 ; the clause index for the first fixnum clause,
8789 ; an ordered list of lists of constants for fixnum-only clauses,
8790 ; and the least and greatest constants in those lists,
8791 ; returns code for a table lookup.
8793 (define (implement-table-lookup var0 index lists lo hi)
8794 (let ((v (make-vector (+ 1 (- hi lo)) 0)))
8795 (do ((index index (+ index 1))
8796 (lists lists (cdr lists)))
8798 (for-each (lambda (k)
8799 (vector-set! v (- k lo) index))
8801 (make-call (make-variable name:VECTOR-REF)
8802 (list (make-constant v)
8803 (make-call (make-variable name:FX-)
8804 (list (make-variable var0)
8805 (make-constant lo)))))))
8807 ; Given a variable whose value is known to lie within the
8808 ; half-open interval [m0, mk), and an ordered complete
8809 ; list of intervals of the form
8814 ; (m{k-1} mk code{k-1})
8817 ; returns an expression that finds the unique i such that
8818 ; var0 lies within [mi, m{i+1}), and then executes code{i}.
8820 (define (implement-intervals var0 intervals)
8821 (if (null? (cdr intervals))
8822 (caddr (car intervals))
8823 (let ((n (quotient (length intervals) 2)))
8825 (intervals1 '() (cons (car intervals2) intervals1))
8826 (intervals2 intervals (cdr intervals2)))
8828 (let ((intervals1 (reverse intervals1))
8829 (m (car (car intervals2))))
8830 (make-conditional (make-call (make-variable name:FX<)
8832 (make-variable var0)
8834 (implement-intervals var0 intervals1)
8835 (implement-intervals var0 intervals2))))))))
8837 ; The brute force approach.
8838 ; Given the variable on which the dispatch is being performed, and
8839 ; actual (simplified) code for the default clause and
8840 ; for all other clauses,
8841 ; returns code to perform the dispatch by sequential search.
8843 (define *memq-threshold* 20)
8844 (define *memv-threshold* 4)
8846 (define (implement-clauses-by-sequential-search var0 default clauses)
8849 (let* ((case1 (car clauses))
8850 (clauses (cdr clauses))
8851 (constants1 (car case1))
8852 (code1 (cadr case1)))
8853 (make-conditional (make-call-to-memv var0 constants1)
8855 (implement-clauses-by-sequential-search
8856 var0 default clauses)))))
8857 ; Copyright 1999 William D Clinger.
8859 ; Permission to copy this software, in whole or in part, to use this
8860 ; software for any lawful noncommercial purpose, and to redistribute
8861 ; this software is granted subject to the restriction that all copies
8862 ; made of this software must include this copyright notice in full.
8864 ; I also request that you send me a copy of any improvements that you
8865 ; make to this software so that they may be incorporated within it to
8866 ; the benefit of the Scheme community.
8870 ; The tail and non-tail call graphs of known and unknown procedures.
8872 ; Given an expression E returned by pass 2 of Twobit,
8873 ; returns a list of the following form:
8875 ; ((#t L () <tailcalls> <nontailcalls> <size> #f)
8876 ; (<name> L <vars> <tailcalls> <nontailcalls> <size> #f)
8881 ; Each L is a lambda expression that occurs within E
8882 ; as either an escaping lambda expression or as a known
8883 ; procedure. If L is a known procedure, then <name> is
8884 ; its name; otherwise <name> is #f.
8886 ; <vars> is a list of the non-global variables within whose
8889 ; <tailcalls> is a complete list of names of known local procedures
8890 ; that L calls tail-recursively, disregarding calls from other known
8891 ; procedures or escaping lambda expressions that occur within L.
8893 ; <nontailcalls> is a complete list of names of known local procedures
8894 ; that L calls non-tail-recursively, disregarding calls from other
8895 ; known procedures or escaping lambda expressions that occur within L.
8897 ; <size> is a measure of the size of L, including known procedures
8898 ; and escaping lambda expressions that occur within L.
8900 (define (callgraphnode.name x) (car x))
8901 (define (callgraphnode.code x) (cadr x))
8902 (define (callgraphnode.vars x) (caddr x))
8903 (define (callgraphnode.tailcalls x) (cadddr x))
8904 (define (callgraphnode.nontailcalls x) (car (cddddr x)))
8905 (define (callgraphnode.size x) (cadr (cddddr x)))
8906 (define (callgraphnode.info x) (caddr (cddddr x)))
8908 (define (callgraphnode.size! x v) (set-car! (cdr (cddddr x)) v) #f)
8909 (define (callgraphnode.info! x v) (set-car! (cddr (cddddr x)) v) #f)
8911 (define (callgraph exp)
8913 ; Returns (union (list x) z).
8915 (define (adjoin x z)
8922 ; Given a <name> as described above, a lambda expression, a list
8923 ; of variables that are in scope, and a list of names of known
8924 ; local procedure that are in scope, computes an entry for L and
8925 ; entries for any nested known procedures or escaping lambda
8926 ; expressions, and adds them to the result.
8928 (define (add-vertex! name L vars known)
8930 (let ((tailcalls '())
8934 ; Given an expression, a list of variables that are in scope,
8935 ; a list of names of known local procedures that are in scope,
8936 ; and a boolean indicating whether the expression occurs in a
8937 ; tail context, adds any tail or non-tail calls to known
8938 ; procedures that occur within the expression to the list
8939 ; variables declared above.
8941 (define (graph! exp vars known tail?)
8942 (set! size (+ size 1))
8947 ((lambda) (add-vertex! #f exp vars known)
8950 (callgraphnode.size (car result)))))
8952 ((set!) (graph! (assignment.rhs exp) vars known #f))
8954 ((if) (graph! (if.test exp) vars known #f)
8955 (graph! (if.then exp) vars known tail?)
8956 (graph! (if.else exp) vars known tail?))
8958 ((begin) (if (not (variable? exp))
8959 (do ((exprs (begin.exprs exp) (cdr exprs)))
8960 ((null? (cdr exprs))
8961 (graph! (car exprs) vars known tail?))
8962 (graph! (car exprs) vars known #f))))
8964 (else (let ((proc (call.proc exp)))
8965 (cond ((variable? proc)
8966 (let ((name (variable.name proc)))
8967 (if (memq name known)
8970 (adjoin name tailcalls))
8972 (adjoin name nontailcalls))))))
8974 (graph-lambda! proc vars known tail?))
8976 (graph! proc vars known #f)))
8977 (for-each (lambda (exp)
8978 (graph! exp vars known #f))
8979 (call.args exp))))))
8981 (define (graph-lambda! L vars known tail?)
8982 (let* ((defs (lambda.defs L))
8983 (newknown (map def.lhs defs))
8984 (vars (append newknown
8985 (make-null-terminated
8988 (known (append newknown known)))
8989 (for-each (lambda (def)
8990 (add-vertex! (def.lhs def)
8996 (callgraphnode.size (car result)))))
8998 (graph! (lambda.body L) vars known tail?)))
9000 (graph-lambda! L vars known #t)
9003 (cons (list name L vars tailcalls nontailcalls size #f)
9007 (make-lambda '() '() '() '() '() '() '() exp)
9012 ; Displays the callgraph, for debugging.
9014 (define (view-callgraph g)
9015 (for-each (lambda (entry)
9016 (let ((name (callgraphnode.name entry))
9017 (exp (callgraphnode.code entry))
9018 (vars (callgraphnode.vars entry))
9019 (tail (callgraphnode.tailcalls entry))
9020 (nt (callgraphnode.nontailcalls entry))
9021 (size (callgraphnode.size entry)))
9022 (cond ((symbol? name)
9025 (display "TOP LEVEL EXPRESSION"))
9027 (display "ESCAPING LAMBDA EXPRESSION")))
9034 ;(display "Variables in scope: ")
9037 (display "Tail calls: ")
9040 (display "Non-tail calls: ")
9044 ;(pretty-print (make-readable exp))
9049 ; Copyright 1999 William D Clinger.
9051 ; Permission to copy this software, in whole or in part, to use this
9052 ; software for any lawful noncommercial purpose, and to redistribute
9053 ; this software is granted subject to the restriction that all copies
9054 ; made of this software must include this copyright notice in full.
9056 ; I also request that you send me a copy of any improvements that you
9057 ; make to this software so that they may be incorporated within it to
9058 ; the benefit of the Scheme community.
9062 ; Inlining of known local procedures.
9064 ; First find the known and escaping procedures and compute the call graph.
9066 ; If a known local procedure is not called at all, then delete its code.
9068 ; If a known local procedure is called exactly once,
9069 ; then inline its code at the call site and delete the
9070 ; known local procedure. Change the size of the code
9071 ; at the call site by adding the size of the inlined code.
9073 ; Divide the remaining known and escaping procedures into categories:
9074 ; 1. makes no calls to known local procedures
9075 ; 2. known procedures that call known procedures;
9076 ; within this category, try to sort so that procedures do not
9077 ; call procedures that come later in the sequence; or sort by
9078 ; number of calls and/or size
9079 ; 3. escaping procedures that call known procedures
9081 ; Approve each procedure in category 1 for inlining if its code size
9082 ; is less than some threshold.
9084 ; For each procedure in categories 2 and 3, traverse its code, inlining
9085 ; where it seems like a good idea. The compiler should be more aggressive
9086 ; about inlining non-tail calls than tail calls because:
9088 ; Inlining a non-tail call can eliminate a stack frame
9089 ; or expose the inlined code to loop optimizations.
9091 ; The main reason for inlining a tail call is to enable
9092 ; intraprocedural optimizations or to unroll a loop.
9094 ; After inlining has been performed on a known local procedure,
9095 ; then approve it for inlining if its size is less than some threshold.
9098 ; This strategy avoids infinite unrolling, but it also avoids finite
9099 ; unrolling of loops.
9101 ; Parameters to control inlining.
9102 ; These can be tuned later.
9104 (define *tail-threshold* 10)
9105 (define *nontail-threshold* 20)
9106 (define *multiplier* 300)
9108 ; Given a callgraph, performs inlining of known local procedures
9109 ; by side effect. The original expression must then be copied to
9110 ; reinstate Twobit's invariants.
9112 ; FIXME: This code doesn't yet do the right thing with known local
9113 ; procedures that aren't called or are called in exactly one place.
9115 (define (inline-using-callgraph! g)
9116 (let ((known (make-hashtable))
9119 (for-each (lambda (node)
9120 (let ((name (callgraphnode.name node))
9121 (tcalls (callgraphnode.tailcalls node))
9122 (ncalls (callgraphnode.nontailcalls node)))
9124 (hashtable-put! known name node))
9125 (if (and (null? tcalls)
9127 (if (< (callgraphnode.size node)
9128 *nontail-threshold*)
9129 (callgraphnode.info! node #t))
9131 (set! category2 (cons node category2))
9132 (set! category3 (cons node category3))))))
9134 (set! category2 (twobit-sort (lambda (x y)
9135 (< (callgraphnode.size x)
9136 (callgraphnode.size y)))
9138 (for-each (lambda (node)
9139 (inline-node! node known))
9141 (for-each (lambda (node)
9142 (inline-node! node known))
9145 ; Inlining destroys the callgraph, so maybe this cleanup is useless.
9146 (hashtable-for-each (lambda (name node) (callgraphnode.info! node #f))
9149 ; Given a node of the callgraph and a hash table of nodes for
9150 ; known local procedures, performs inlining by side effect.
9152 (define (inline-node! node known)
9153 (let* ((debugging? #f)
9154 (name (callgraphnode.name node))
9155 (exp (callgraphnode.code node))
9156 (size0 (callgraphnode.size node))
9157 (budget (quotient (* (- *multiplier* 100) size0) 100))
9158 (tail-threshold *tail-threshold*)
9159 (nontail-threshold *nontail-threshold*))
9161 ; Given an expression,
9162 ; a boolean indicating whether the expression is in a tail context,
9163 ; a list of procedures that should not be inlined,
9164 ; and a size budget,
9165 ; performs inlining by side effect and returns the unused budget.
9167 (define (inline exp tail? budget)
9168 (if (positive? budget)
9176 (inline (assignment.rhs exp) #f budget))
9179 (let* ((budget (inline (if.test exp) #f budget))
9180 (budget (inline (if.then exp) tail? budget))
9181 (budget (inline (if.else exp) tail? budget)))
9187 (do ((exprs (begin.exprs exp) (cdr exprs))
9189 (inline (car exprs) #f budget)))
9190 ((null? (cdr exprs))
9191 (inline (car exprs) tail? budget)))))
9194 (let ((budget (do ((exprs (call.args exp) (cdr exprs))
9196 (inline (car exprs) #f budget)))
9199 (let ((proc (call.proc exp)))
9200 (cond ((variable? proc)
9201 (let* ((procname (variable.name proc))
9202 (procnode (hashtable-get known procname)))
9204 (let ((size (callgraphnode.size procnode))
9205 (info (callgraphnode.info procnode)))
9211 nontail-threshold)))
9215 (display " Inlining ")
9216 (write (variable.name proc))
9221 (callgraphnode.code procnode)))
9222 (callgraphnode.size!
9224 (+ (callgraphnode.size node) size))
9227 (if (and #f debugging?)
9229 (display " Declining to inline ")
9230 (write (variable.name proc))
9235 (inline (lambda.body proc) tail? budget))
9237 (inline proc #f budget)))))))
9240 (if (and #f debugging?)
9242 (display "Processing ")
9246 (let ((budget (inline (if (lambda? exp)
9251 (if (and (negative? budget)
9253 ; This shouldn't happen very often.
9254 (begin (display "Ran out of inlining budget for ")
9255 (write (callgraphnode.name node))
9257 (if (<= (callgraphnode.size node) nontail-threshold)
9258 (callgraphnode.info! node #t))
9263 (define (test-inlining test0)
9264 (begin (define exp0 (begin (display "Compiling...")
9266 (pass2 (pass1 test0))))
9267 (define g0 (begin (display "Computing call graph...")
9270 (display "Inlining...")
9272 (inline-using-callgraph! g0)
9273 (pretty-print (make-readable (copy-exp exp0))))
9274 ; Copyright 1999 William D Clinger.
9276 ; Permission to copy this software, in whole or in part, to use this
9277 ; software for any lawful noncommercial purpose, and to redistribute
9278 ; this software is granted subject to the restriction that all copies
9279 ; made of this software must include this copyright notice in full.
9281 ; I also request that you send me a copy of any improvements that you
9282 ; make to this software so that they may be incorporated within it to
9283 ; the benefit of the Scheme community.
9287 ; Interprocedural constant propagation and folding.
9289 ; Constant propagation must converge before constant folding can be
9290 ; performed. Constant folding creates more constants that can be
9291 ; propagated, so these two optimizations must be iterated, but it
9292 ; is safe to stop at any time.
9294 ; Abstract interpretation for constant folding.
9296 ; The abstract values are
9297 ; bottom (represented here by #f)
9298 ; constants (represented by quoted literals)
9299 ; top (represented here by #t)
9301 ; Let [[ E ]] be the abstract interpretation of E over that domain
9302 ; of abstract values, with respect to some arbitrary set of abstract
9303 ; values for local variables.
9305 ; If a is a global variable or a formal parameter of an escaping
9306 ; lambda expression, then [[ a ]] = #t.
9308 ; If x is the ith formal parameter of a known local procedure f,
9309 ; then [[ x ]] = \join_{(f E1 ... En)} [[ Ei ]].
9313 ; [[ (begin E1 ... En) ]] = [[ En ]]
9314 ; [[ (set! I E) ]] = #f
9316 ; If [[ E0 ]] = #t, then [[ (if E0 E1 E2) ]] = [[ E1 ]] \join [[ E2 ]]
9317 ; else if [[ E0 ]] = K, then [[ (if E0 E1 E2) ]] = [[ E1 ]]
9318 ; or [[ (if E0 E1 E2) ]] = [[ E2 ]]
9320 ; else [[ (if E0 E1 E2) ]] = #f
9322 ; If f is a known local procedure with body E,
9323 ; then [[ (f E1 ... En) ]] = [[ E ]]
9325 ; If g is a foldable integrable procedure, then:
9326 ; if there is some i for which [[ Ei ]] = #t,
9327 ; then [[ (g E1 ... En) ]] = #t
9328 ; else if [[ E1 ]] = K1, ..., [[ En ]] = Kn,
9329 ; then [[ (g E1 ... En) ]] = (g K1 ... Kn)
9330 ; else [[ (g E1 ... En) ]] = #f
9332 ; Symbolic representations of abstract values.
9333 ; (Can be thought of as mappings from abstract environments to
9336 ; <symbolic> ::= #t | ( <expressions> )
9337 ; <expressions> ::= <empty> | <expression> <expressions>
9339 ; Parameter to limit constant propagation and folding.
9340 ; This parameter can be tuned later.
9342 (define *constant-propagation-limit* 5)
9344 ; Given an expression as output by pass 2, performs constant
9345 ; propagation and folding.
9347 (define (constant-propagation exp)
9348 (define (constant-propagation exp i)
9349 (if (< i *constant-propagation-limit*)
9351 ;(display "Performing constant propagation and folding...")
9353 (let* ((g (callgraph exp))
9354 (L (callgraphnode.code (car g)))
9355 (variables (constant-propagation-using-callgraph g))
9356 (changed? (constant-folding! L variables)))
9358 (constant-propagation (lambda.body L) (+ i 1))
9359 (lambda.body L))))))
9360 (constant-propagation exp 0))
9362 ; Given a callgraph, returns a hashtable of abstract values for
9363 ; all local variables.
9365 (define (constant-propagation-using-callgraph g)
9366 (let ((debugging? #f)
9367 (folding? (integrate-usual-procedures))
9368 (known (make-hashtable))
9369 (variables (make-hashtable))
9372 ; Computes joins of abstract values.
9383 ; Given a <symbolic> and a vector of abstract values,
9384 ; evaluates the <symbolic> and returns its abstract value.
9386 (define (aeval rep env)
9392 (aeval1 (car rep) env))
9394 (join (aeval1 (car rep) env)
9395 (aeval (cdr rep) env)))))
9397 (define (aeval1 exp env)
9412 (let* ((name (variable.name exp))
9413 (i (hashtable-get variables name)))
9420 (let* ((val0 (aeval1 (if.test exp) env))
9421 (val1 (aeval1 (if.then exp) env))
9422 (val2 (aeval1 (if.else exp) env)))
9423 (cond ((eq? val0 #t)
9426 (if (constant.value val0)
9433 (do ((exprs (reverse (call.args exp)) (cdr exprs))
9434 (vals '() (cons (aeval1 (car exprs) env) vals)))
9436 (let ((proc (call.proc exp)))
9437 (cond ((variable? proc)
9438 (let* ((procname (variable.name proc))
9439 (procnode (hashtable-get known procname))
9441 (constant-folding-entry procname)
9445 (hashtable-get variables
9448 ; FIXME: No constant folding
9450 (else (aeval1-error)))))
9452 (aeval1-error)))))))))
9454 (define (aeval1-error)
9455 (error "Compiler bug: constant propagation (aeval1)"))
9457 ; Combines two <symbolic>s.
9459 (define (combine-symbolic rep1 rep2)
9460 (cond ((eq? rep1 #t) #t)
9463 (append rep1 rep2))))
9465 ; Given an expression, returns a <symbolic> that represents
9466 ; a list of expressions whose abstract values can be joined
9467 ; to obtain the abstract value of the given expression.
9468 ; As a side effect, enters local variables into variables.
9470 (define (collect! exp)
9481 (collect! (assignment.rhs exp))
9487 (do ((exprs (begin.exprs exp) (cdr exprs)))
9488 ((null? (cdr exprs))
9489 (collect! (car exprs)))
9490 (collect! (car exprs)))))
9493 (collect! (if.test exp))
9494 (collect! (if.then exp))
9495 (collect! (if.else exp))
9499 (do ((exprs (reverse (call.args exp)) (cdr exprs))
9500 (reps '() (cons (collect! (car exprs)) reps)))
9502 (let ((proc (call.proc exp)))
9503 (define (put-args! args reps)
9505 (let ((v (car args))
9507 (hashtable-put! variables v rep)
9508 (put-args! (cdr args) (cdr reps))))
9510 (hashtable-put! variables args #t))
9512 (cond ((variable? proc)
9513 (let* ((procname (variable.name proc))
9514 (procnode (hashtable-get known procname))
9516 (constant-folding-entry procname)
9519 (for-each (lambda (v rep)
9524 rep (hashtable-get variables v))))
9526 (callgraphnode.code procnode))
9528 (list (make-variable procname)))
9530 ; FIXME: No constant folding
9534 (put-args! (lambda.args proc) reps)
9535 (collect! (lambda.body proc)))
9540 (for-each (lambda (node)
9541 (let* ((name (callgraphnode.name node))
9542 (code (callgraphnode.code node))
9543 (known? (symbol? name))
9544 (rep (if known? '() #t)))
9546 (hashtable-put! known name node))
9548 (for-each (lambda (var)
9549 (hashtable-put! variables var rep))
9550 (make-null-terminated (lambda.args code))))))
9553 (for-each (lambda (node)
9554 (let ((name (callgraphnode.name node))
9555 (code (callgraphnode.code node)))
9556 (cond ((symbol? name)
9557 (hashtable-put! variables
9559 (collect! (lambda.body code))))
9561 (collect! (lambda.body code))))))
9564 (if (and #f debugging?)
9566 (hashtable-for-each (lambda (v rep)
9573 (display "----------------------------------------")
9576 ;(trace aeval aeval1)
9578 (let* ((n (hashtable-size variables))
9579 (vars (hashtable-map (lambda (v rep) v) variables))
9580 (reps (map (lambda (v) (hashtable-get variables v)) vars))
9581 (init (make-vector n #f))
9582 (next (make-vector n)))
9584 (vars vars (cdr vars))
9585 (reps reps (cdr reps)))
9587 (hashtable-put! variables (car vars) i)
9590 (let ((rep (car reps)))
9593 (compute-fixedpoint init next equal?)
9594 (for-each (lambda (v)
9595 (let* ((i (hashtable-get variables v))
9596 (aval (vector-ref init i)))
9597 (hashtable-put! variables v aval)
9599 (not (eq? aval #t)))
9607 ; Given a lambda expression, performs constant propagation, folding,
9608 ; and simplifications by side effect, using the abstract values in the
9609 ; hash table of variables.
9610 ; Returns #t if any new constants were created by constant folding,
9611 ; otherwise returns #f.
9613 (define (constant-folding! L variables)
9614 (let ((debugging? #f)
9615 (msg1 " Propagating constant value for ")
9618 (folding? (integrate-usual-procedures))
9621 ; Given a known lambda expression L, its original formal parameters,
9622 ; and a list of all calls to L, deletes arguments that are now
9623 ; ignored because of constant propagation.
9625 (define (delete-ignored-args! L formals0 calls)
9626 (let ((formals1 (lambda.args L)))
9627 (for-each (lambda (call)
9628 (do ((formals0 formals0 (cdr formals0))
9629 (formals1 formals1 (cdr formals1))
9630 (args (call.args call)
9633 (if (and (eq? (car formals1) name:IGNORED)
9635 (hashtable-get variables
9638 (cons (car args) newargs))))
9640 (call.args-set! call (reverse newargs)))))
9642 (do ((formals0 formals0 (cdr formals0))
9643 (formals1 formals1 (cdr formals1))
9645 (if (and (not (eq? (car formals0)
9647 (eq? (car formals1) name:IGNORED)
9649 (hashtable-get variables
9652 (cons (car formals1) formals2))))
9654 (lambda.args-set! L (reverse formals2))))))
9663 (let ((Rinfo (lambda.R exp))
9664 (known (map def.lhs (lambda.defs exp))))
9665 (for-each (lambda (entry)
9666 (let* ((v (R-entry.name entry))
9667 (aval (hashtable-fetch variables v #t)))
9668 (if (and (pair? aval)
9669 (not (memq v known)))
9670 (let ((x (constant.value aval)))
9671 (if (or (boolean? x)
9677 (zero? (vector-length x))))
9678 (let ((refs (R-entry.references entry)))
9679 (for-each (lambda (ref)
9680 (variable-set! ref aval))
9682 ; Do not try to use Rinfo in place of
9683 ; (lambda.R exp) below!
9686 (remq entry (lambda.R exp)))
9687 (flag-as-ignored v exp)
9689 (begin (display msg1)
9695 (for-each (lambda (def)
9696 (let* ((name (def.lhs def))
9698 (entry (R-lookup Rinfo name))
9699 (calls (R-entry.calls entry)))
9701 (begin (lambda.defs-set!
9703 (remq def (lambda.defs exp)))
9704 ; Do not try to use Rinfo in place of
9705 ; (lambda.R exp) below!
9708 (remq entry (lambda.R exp))))
9709 (let* ((formals0 (append (lambda.args rhs) '()))
9711 (formals1 (lambda.args L)))
9712 (if (not (equal? formals0 formals1))
9713 (delete-ignored-args! L formals0 calls))))))
9717 (fold! (lambda.body exp)))
9721 (assignment.rhs-set! exp (fold! (assignment.rhs exp)))
9727 (post-simplify-begin (make-begin (map fold! (begin.exprs exp)))
9728 (make-notepad #f))))
9731 (let ((exp0 (fold! (if.test exp)))
9732 (exp1 (fold! (if.then exp)))
9733 (exp2 (fold! (if.else exp))))
9734 (if (constant? exp0)
9735 (let ((newexp (if (constant.value exp0)
9739 (begin (display msg2)
9740 (write (make-readable exp))
9742 (write (make-readable newexp))
9746 (make-conditional exp0 exp1 exp2))))
9749 (let ((args (map fold! (call.args exp)))
9750 (proc (fold! (call.proc exp))))
9751 (cond ((and folding?
9753 (every? constant? args)
9755 (constant-folding-entry (variable.name proc))))
9758 (constant-folding-predicates entry)))
9759 (and (= (length args) (length preds))
9762 (map (lambda (f v) (f v))
9763 (constant-folding-predicates entry)
9764 (map constant.value args))))))))
9768 (apply (constant-folding-folder
9769 (constant-folding-entry
9770 (variable.name proc)))
9771 (map constant.value args)))))
9773 (begin (display msg2)
9774 (write (make-readable (make-call proc args)))
9779 ((and (lambda? proc)
9780 (list? (lambda.args proc)))
9781 ; FIXME: Folding should be done even if there is
9783 (let loop ((formals (reverse (lambda.args proc)))
9784 (actuals (reverse args))
9785 (processed-formals '())
9786 (processed-actuals '())
9788 (cond ((null? formals)
9789 (lambda.args-set! proc processed-formals)
9790 (call.args-set! exp processed-actuals)
9791 (let ((call (if (and (null? processed-formals)
9792 (null? (lambda.defs proc)))
9795 (if (null? for-effect)
9797 (post-simplify-begin
9799 (reverse (cons call for-effect)))
9800 (make-notepad #f)))))
9801 ((ignored? (car formals))
9806 (cons (car actuals) for-effect)))
9810 (cons (car formals) processed-formals)
9811 (cons (car actuals) processed-actuals)
9814 (call.proc-set! exp proc)
9815 (call.args-set! exp args)
9820 ; Copyright 1998 William D Clinger.
9822 ; Permission to copy this software, in whole or in part, to use this
9823 ; software for any lawful noncommercial purpose, and to redistribute
9824 ; this software is granted subject to the restriction that all copies
9825 ; made of this software must include this copyright notice in full.
9827 ; I also request that you send me a copy of any improvements that you
9828 ; make to this software so that they may be incorporated within it to
9829 ; the benefit of the Scheme community.
9833 ; Conversion to A-normal form, with heuristics for
9834 ; choosing a good order of evaluation.
9836 ; This pass operates as a source-to-source transformation on
9837 ; expressions written in the subset of Scheme described by the
9838 ; following grammar, where the input and output expressions
9839 ; satisfy certain additional invariants described below.
9841 ; "X ..." means zero or more occurrences of X.
9843 ; L --> (lambda (I_1 ...)
9845 ; (quote (R F G <decls> <doc>)
9847 ; | (lambda (I_1 ... . I_rest)
9849 ; (quote (R F G <decls> <doc>))
9851 ; D --> (define I L)
9852 ; E --> (quote K) ; constants
9853 ; | (begin I) ; variable references
9854 ; | L ; lambda expressions
9855 ; | (E0 E1 ...) ; calls
9856 ; | (set! I E) ; assignments
9857 ; | (if E0 E1 E2) ; conditionals
9858 ; | (begin E0 E1 E2 ...) ; sequential expressions
9859 ; I --> <identifier>
9861 ; R --> ((I <references> <assignments> <calls>) ...)
9865 ; Invariants that hold for the input only:
9866 ; * There are no assignments except to global variables.
9867 ; * If I is declared by an internal definition, then the right hand
9868 ; side of the internal definition is a lambda expression and I
9869 ; is referenced only in the procedure position of a call.
9870 ; * For each lambda expression, the associated F is a list of all
9871 ; the identifiers that occur free in the body of that lambda
9872 ; expression, and possibly a few extra identifiers that were
9873 ; once free but have been removed by optimization.
9874 ; * For each lambda expression, the associated G is a subset of F
9875 ; that contains every identifier that occurs free within some
9876 ; inner lambda expression that escapes, and possibly a few that
9877 ; don't. (Assignment-elimination does not calculate G exactly.)
9878 ; * Variables named IGNORED are neither referenced nor assigned.
9880 ; Invariants that hold for the output only:
9881 ; * There are no assignments except to global variables.
9882 ; * If I is declared by an internal definition, then the right hand
9883 ; side of the internal definition is a lambda expression and I
9884 ; is referenced only in the procedure position of a call.
9885 ; * R, F, and G are garbage.
9886 ; * There are no sequential expressions.
9887 ; * The output is an expression E with syntax
9903 ; An expression is a LET* such that the rhs of every binding is
9904 ; a conditional with the test already evaluated, or
9905 ; an expression that can be evaluated in one step
9906 ; (treating function calls as a single step)
9908 ; A-normal form corresponds to the control flow graph for a lambda
9911 ; Algorithm: repeated use of these rules:
9913 ; (E0 E1 ...) ((lambda (T0 T1 ...) (T0 T1 ...))
9915 ; (set! I E) ((lambda (T) (set! I T)) E)
9916 ; (if E0 E1 E2) ((lambda (T) (if T E1 E2)) E0)
9917 ; (begin E0 E1 E2 ...) ((lambda (T) (begin E1 E2 ...)) E0)
9919 ; ((lambda (I1 I2 I3 ...) E) ((lambda (I1)
9920 ; E1 E2 E3) ((lambda (I2 I3 ...) E)
9924 ; ((lambda (I2) E) ((lambda (I1)
9925 ; ((lambda (I1) E2) ((lambda (I2) E)
9930 ; Introduce a temporary name for every expression except:
9932 ; the alternatives of a non-tail conditional
9933 ; Convert every LET into a LET*.
9934 ; Get rid of LET* on the right hand side of a binding.
9936 ; Given an expression E in the representation output by pass 2,
9937 ; returns an A-normal form for E in that representation.
9938 ; Except for quoted values, the A-normal form does not share
9939 ; mutable structure with the original expression E.
9943 ; If you call A-normal on a form that has already been converted
9944 ; to A-normal form, then the same temporaries will be generated
9945 ; twice. An optional argument lets you specify a different prefix
9946 ; for temporaries the second time around. Example:
9948 ; (A-normal-form (A-normal-form E ".T")
9951 ; This is the declaration that is used to indicate A-normal form.
9953 (define A-normal-form-declaration (list 'anf))
9955 (define (A-normal-form E . rest)
9957 (define (A-normal-form E)
9958 (anf-make-let* (anf E '() '())))
9962 (define temp-counter 0)
9965 (if (or (null? rest)
9966 (not (string? (car rest))))
9967 (string-append renaming-prefix "T")
9971 (set! temp-counter (+ temp-counter 1))
9973 (string-append temp-prefix
9974 (number->string temp-counter))))
9976 ; Given an expression E as output by pass 2,
9977 ; a list of surrounding LET* bindings,
9978 ; and an ordered list of likely register variables,
9979 ; return a non-empty list of LET* bindings
9980 ; whose first binding associates a dummy variable
9981 ; with an A-expression giving the value for E.
9983 (define (anf E bindings regvars)
9985 ((quote) (anf-bind-dummy E bindings))
9986 ((begin) (if (variable? E)
9987 (anf-bind-dummy E bindings)
9988 (anf-sequential E bindings regvars)))
9989 ((lambda) (anf-lambda E bindings regvars))
9990 ((set!) (anf-assignment E bindings regvars))
9991 ((if) (anf-conditional E bindings regvars))
9992 (else (anf-call E bindings regvars))))
9994 (define anf:dummy (string->symbol "RESULT"))
9996 (define (anf-bind-dummy E bindings)
9997 (cons (list anf:dummy E)
10000 ; Unlike anf-bind-dummy, anf-bind-name and anf-bind convert
10001 ; their expression argument to A-normal form.
10002 ; Don't change anf-bind to call anf-bind-name, because that
10003 ; would name the temporaries in an aesthetically bad order.
10005 (define (anf-bind-name name E bindings regvars)
10006 (let ((bindings (anf E bindings regvars)))
10007 (cons (list name (cadr (car bindings)))
10010 (define (anf-bind E bindings regvars)
10011 (let ((bindings (anf E bindings regvars)))
10012 (cons (list (newtemp) (cadr (car bindings)))
10015 (define (anf-result bindings)
10016 (make-variable (car (car bindings))))
10018 (define (anf-make-let* bindings)
10019 (define (loop bindings body)
10020 (if (null? bindings)
10022 (let ((T1 (car (car bindings)))
10023 (E1 (cadr (car bindings))))
10024 (loop (cdr bindings)
10025 (make-call (make-lambda (list T1)
10030 (list A-normal-form-declaration)
10034 (loop (cdr bindings)
10035 (cadr (car bindings))))
10037 (define (anf-sequential E bindings regvars)
10038 (do ((bindings bindings
10039 (anf-bind (car exprs) bindings regvars))
10040 (exprs (begin.exprs E)
10042 ((null? (cdr exprs))
10043 (anf (car exprs) bindings regvars))))
10045 ; Heuristic: the formal parameters of an escaping lambda or
10046 ; known local procedure are kept in REG1, REG2, et cetera.
10048 (define (anf-lambda L bindings regvars)
10050 (make-lambda (lambda.args L)
10054 (A-normal-form (def.rhs def))))
10059 (cons A-normal-form-declaration
10063 (anf (lambda.body L)
10065 (make-null-terminated (lambda.args L)))))
10068 (define (anf-assignment E bindings regvars)
10069 (let ((I (assignment.lhs E))
10070 (E1 (assignment.rhs E)))
10072 (anf-bind-dummy E bindings)
10073 (let* ((bindings (anf-bind E1 bindings regvars))
10074 (T1 (anf-result bindings)))
10075 (anf-bind-dummy (make-assignment I T1) bindings)))))
10077 (define (anf-conditional E bindings regvars)
10078 (let ((E0 (if.test E))
10082 (let ((E1 (anf-make-let* (anf E1 '() regvars)))
10083 (E2 (anf-make-let* (anf E2 '() regvars))))
10085 (make-conditional E0 E1 E2)
10087 (let* ((bindings (anf-bind E0 bindings regvars))
10088 (E1 (anf-make-let* (anf E1 '() regvars)))
10089 (E2 (anf-make-let* (anf E2 '() regvars))))
10091 (make-conditional (anf-result bindings) E1 E2)
10094 (define (anf-call E bindings regvars)
10095 (let* ((proc (call.proc E))
10096 (args (call.args E)))
10098 ; Evaluates the exprs and returns both a list of bindings and
10099 ; a list of the temporaries that name the results of the exprs.
10100 ; If rename-always? is true, then temporaries are generated even
10101 ; for constants and temporaries.
10103 (define (loop exprs bindings names rename-always?)
10105 (values bindings (reverse names))
10106 (let ((E (car exprs)))
10107 (if (or rename-always?
10108 (not (or (constant? E)
10111 (anf-bind (car exprs) bindings regvars)))
10114 (cons (anf-result bindings) names)
10119 rename-always?)))))
10121 ; Evaluates the exprs, binding them to the vars, and returns
10122 ; a list of bindings.
10124 ; Although LET variables are likely to be kept in registers,
10125 ; trying to guess which register will be allocated is likely
10126 ; to do more harm than good.
10128 (define (let-loop exprs bindings regvars vars)
10130 (if (null? (lambda.defs proc))
10131 (anf (lambda.body proc)
10141 (cons A-normal-form-declaration
10142 (lambda.decls proc))
10144 (lambda.body proc))
10148 (make-call (anf-result bindings) '())
10150 (let-loop (cdr exprs)
10151 (anf-bind-name (car vars)
10158 (cond ((lambda? proc)
10159 (let ((formals (lambda.args proc)))
10160 (if (list? formals)
10161 (let* ((pi (anf-order-of-evaluation args regvars #f))
10162 (exprs (permute args pi))
10163 (names (permute (lambda.args proc) pi)))
10164 (let-loop (reverse exprs) bindings regvars (reverse names)))
10165 (anf-call (normalize-let E) bindings regvars))))
10167 ((not (variable? proc))
10168 (let ((pi (anf-order-of-evaluation args regvars #f)))
10170 (lambda () (loop (permute args pi) bindings '() #t))
10171 (lambda (bindings names)
10172 (let ((bindings (anf-bind proc bindings regvars)))
10174 (make-call (anf-result bindings)
10175 (unpermute names pi))
10178 ((and (integrate-usual-procedures)
10179 (prim-entry (variable.name proc)))
10180 (let ((pi (anf-order-of-evaluation args regvars #t)))
10182 (lambda () (loop (permute args pi) bindings '() #t))
10183 (lambda (bindings names)
10185 (make-call proc (unpermute names pi))
10188 ((memq (variable.name proc) regvars)
10189 (let* ((exprs (cons proc args))
10190 (pi (anf-order-of-evaluation
10192 (cons name:IGNORED regvars)
10195 (lambda () (loop (permute exprs pi) bindings '() #t))
10196 (lambda (bindings names)
10197 (let ((names (unpermute names pi)))
10199 (make-call (car names) (cdr names))
10203 (let ((pi (anf-order-of-evaluation args regvars #f)))
10205 (lambda () (loop (permute args pi) bindings '() #t))
10206 (lambda (bindings names)
10208 (make-call proc (unpermute names pi))
10211 ; Given a list of expressions, a list of likely register contents,
10212 ; and a switch telling whether these are arguments for a primop
10213 ; or something else (such as the arguments for a real call),
10214 ; try to choose a good order in which to evaluate the expressions.
10216 ; Heuristic: If none of the expressions is a call to a non-primop,
10217 ; then parallel assignment optimization gives a good order if the
10218 ; regvars are right, and should do no worse than a random order if
10219 ; the regvars are wrong.
10221 ; Heuristic: If the expressions are arguments to a primop, and
10222 ; none are a call to a non-primop, then the register contents
10223 ; are irrelevant, and the first argument should be evaluated last.
10225 ; Heuristic: If one or more of the expressions is a call to a
10226 ; non-primop, then the following should be a good order:
10228 ; expressions that are neither a constant, variable, or a call
10229 ; calls to non-primops
10230 ; constants and variables
10232 (define (anf-order-of-evaluation exprs regvars for-primop?)
10233 (define (ordering targets exprs alist)
10235 (parallel-assignment targets alist exprs)))
10237 ; Evaluate left to right until a parallel assignment is found.
10238 (cons (car targets)
10239 (ordering (cdr targets)
10242 (if (parallel-assignment-optimization)
10243 (cond ((null? exprs) '())
10244 ((null? (cdr exprs)) '(0))
10246 (let* ((contains-call? #f)
10247 (vexprs (list->vector exprs))
10248 (vindexes (list->vector
10249 (iota (vector-length vexprs))))
10250 (contains-call? #f)
10254 (cond ((constant? E)
10259 (set! contains-call? #t)
10264 (cond (contains-call?
10265 (twobit-sort (lambda (i j)
10266 (< (vector-ref categories i)
10267 (vector-ref categories j)))
10268 (iota (length exprs))))
10270 (reverse (iota (length exprs))))
10272 (let ((targets (iota (length exprs))))
10273 (define (pairup regvars targets)
10274 (if (or (null? targets)
10277 (cons (cons (car regvars)
10279 (pairup (cdr regvars)
10283 (pairup regvars targets))))))))
10284 (iota (length exprs))))
10286 (define (permute things pi)
10287 (let ((v (list->vector things)))
10288 (map (lambda (i) (vector-ref v i))
10291 (define (unpermute things pi)
10292 (let* ((v0 (list->vector things))
10293 (v1 (make-vector (vector-length v0))))
10294 (do ((pi pi (cdr pi))
10298 (vector-set! v1 (car pi) (vector-ref v0 k)))))
10300 ; Given a call whose procedure is a lambda expression that has
10301 ; a rest argument, return a genuine let expression.
10303 (define (normalize-let-error exp)
10304 (if (issue-warnings)
10305 (begin (display "WARNING from compiler: ")
10306 (display "Wrong number of arguments ")
10307 (display "to lambda expression")
10309 (pretty-print (make-readable exp) #t)
10312 (define (normalize-let exp)
10313 (let* ((L (call.proc exp)))
10314 (let loop ((formals (lambda.args L))
10315 (args (call.args exp))
10318 (cond ((null? formals)
10320 (begin (lambda.args-set! L (reverse newformals))
10321 (call.args-set! exp (reverse newargs)))
10322 (begin (normalize-let-error exp)
10323 (loop (list (newtemp))
10329 (loop (cdr formals)
10331 (cons (car formals) newformals)
10332 (cons (car args) newargs))
10333 (begin (normalize-let-error exp)
10335 (cons (make-constant 0)
10340 (loop (list formals)
10341 (list (make-call-to-list args))
10345 ; For heuristic use only.
10346 ; An expression is complicated unless it can probably be evaluated
10347 ; without saving and restoring any registers, even if it occurs in
10348 ; a non-tail position.
10350 (define (complicated? exp)
10351 ; Let's not spend all day on this.
10353 (define (complicated? exp)
10354 (set! budget (- budget 1))
10360 ((set!) (complicated? (assignment.rhs exp)))
10361 ((if) (or (complicated? (if.test exp))
10362 (complicated? (if.then exp))
10363 (complicated? (if.else exp))))
10364 ((begin) (if (variable? exp)
10366 (some? complicated?
10367 (begin.exprs exp))))
10368 (else (let ((proc (call.proc exp)))
10369 (if (and (variable? proc)
10370 (integrate-usual-procedures)
10371 (prim-entry (variable.name proc)))
10372 (some? complicated?
10375 (complicated? exp)))
10378 (define (post-simplify-anf L0 T1 E0 E1 free regbindings L2)
10380 (define (return-normally)
10381 (values (make-call L0 (list E1))
10386 ; Copyright 1999 William D Clinger.
10388 ; Permission to copy this software, in whole or in part, to use this
10389 ; software for any lawful noncommercial purpose, and to redistribute
10390 ; this software is granted subject to the restriction that all copies
10391 ; made of this software must include this copyright notice in full.
10393 ; I also request that you send me a copy of any improvements that you
10394 ; make to this software so that they may be incorporated within it to
10395 ; the benefit of the Scheme community.
10399 ; Intraprocedural common subexpression elimination, constant propagation,
10400 ; copy propagation, dead code elimination, and register targeting.
10402 ; (intraprocedural-commoning E 'commoning)
10404 ; Given an A-normal form E (alpha-converted, with correct free
10405 ; variables and referencing information), returns an optimized
10406 ; A-normal form with correct free variables but incorrect referencing
10409 ; (intraprocedural-commoning E 'target-registers)
10411 ; Given an A-normal form E (alpha-converted, with correct free
10412 ; variables and referencing information), returns an A-normal form
10413 ; with correct free variables but incorrect referencing information,
10414 ; and in which MacScheme machine register names are used as temporary
10415 ; variables. The result is alpha-converted except for register names.
10417 ; (intraprocedural-commoning E 'commoning 'target-registers)
10418 ; (intraprocedural-commoning E)
10420 ; Given an A-normal form as described above, returns an optimized
10421 ; form in which register names are used as temporary variables.
10423 ; Semantics of .check!:
10425 ; (.check! b exn x ...) faults with code exn and arguments x ...
10428 ; The list of argument registers.
10429 ; This can't go in pass3commoning.aux.sch because that file must be
10430 ; loaded before the target-specific file that defines *nregs*.
10432 (define argument-registers
10433 (do ((n (- *nregs* 2) (- n 1))
10435 (cons (string->symbol
10436 (string-append ".REG" (number->string n)))
10441 (define (intraprocedural-commoning E . flags)
10443 (define target-registers? (or (null? flags) (memq 'target-registers flags)))
10444 (define commoning? (or (null? flags) (memq 'commoning flags)))
10446 (define debugging? #f)
10448 (call-with-current-continuation
10451 (define (error . stuff)
10452 (display "Bug detected during intraprocedural optimization")
10454 (for-each (lambda (s)
10455 (display s) (newline))
10457 (return (make-constant #f)))
10459 ; Given an expression, an environment, the available expressions,
10460 ; and an ordered list of likely register variables (used heuristically),
10461 ; returns the transformed expression and its set of free variables.
10463 (define (scan-body E env available regvars)
10465 ; The local variables are those that are bound by a LET within
10466 ; this procedure. The formals of a lambda expression and the
10467 ; known local procedures are counted as non-global, not local,
10468 ; because there is no let-binding for a formal that can be
10469 ; renamed during register targeting.
10470 ; For each local variable, we keep track of how many times it
10471 ; is referenced. This information is not accurate until we
10472 ; are backing out of the recursion, and does not have to be.
10474 (define local-variables (make-hashtable symbol-hash assq))
10476 (define (local-variable? sym)
10477 (hashtable-get local-variables sym))
10479 (define (local-variable-not-used? sym)
10480 (= 0 (hashtable-fetch local-variables sym -1)))
10482 (define (local-variable-used-once? sym)
10483 (= 1 (hashtable-fetch local-variables sym 0)))
10485 (define (record-local-variable! sym)
10486 (hashtable-put! local-variables sym 0))
10488 (define (used-local-variable! sym)
10489 (adjust-local-variable! sym 1))
10491 (define (adjust-local-variable! sym n)
10492 (let ((m (hashtable-get local-variables sym)))
10494 (if (and m (> m 0))
10495 (begin (write (list sym (+ m n)))
10498 (hashtable-put! local-variables
10502 (define (closed-over-local-variable! sym)
10503 ; Set its reference count to infinity so it won't be optimized away.
10504 ; FIXME: One million isn't infinity.
10505 (hashtable-put! local-variables sym 1000000))
10507 (define (used-variable! sym)
10508 (used-local-variable! sym))
10510 (define (abandon-expression! E)
10511 (cond ((variable? E)
10512 (adjust-local-variable! (variable.name E) -1))
10514 (abandon-expression! (if.test E))
10515 (abandon-expression! (if.then E))
10516 (abandon-expression! (if.else E)))
10518 (for-each (lambda (exp)
10519 (if (variable? exp)
10520 (let ((name (variable.name exp)))
10521 (if (local-variable? name)
10522 (adjust-local-variable! name -1)))))
10523 (cons (call.proc E)
10526 ; Environments are represented as hashtrees.
10528 (define (make-empty-environment)
10529 (make-hashtree symbol-hash assq))
10531 (define (environment-extend env sym)
10532 (hashtree-put env sym #t))
10534 (define (environment-extend* env symbols)
10535 (if (null? symbols)
10537 (environment-extend* (hashtree-put env (car symbols) #t)
10540 (define (environment-lookup env sym)
10541 (hashtree-get env sym))
10543 (define (global? x)
10544 (cond ((local-variable? x)
10546 ((environment-lookup env x)
10553 (define (available-add! available T E)
10554 (cond ((constant? E)
10555 (available-extend! available T E available:killer:immortal))
10557 (available-extend! available
10560 (if (global? (variable.name E))
10561 available:killer:globals
10562 available:killer:immortal)))
10564 (let ((entry (prim-call E)))
10566 (let ((killer (prim-lives-until entry)))
10567 (if (not (eq? killer available:killer:dead))
10568 (do ((args (call.args E) (cdr args))
10570 (let ((arg (car args)))
10571 (if (and (variable? arg)
10572 (global? (variable.name arg)))
10573 available:killer:globals
10580 (logior killer k)))))))))))
10582 ; Given an expression E,
10583 ; an environment containing all variables that are in scope,
10584 ; and a table of available expressions,
10585 ; returns multiple values:
10586 ; the transformed E
10587 ; the free variables of E
10588 ; the register bindings to be inserted; each binding has the form
10589 ; (R x (begin R)), where (begin R) is a reference to R.
10593 (define (scan E env available)
10594 (if (not (call? E))
10595 (scan-rhs E env available)
10596 (let ((proc (call.proc E)))
10597 (if (not (lambda? proc))
10598 (scan-rhs E env available)
10599 (let ((vars (lambda.args proc)))
10600 (cond ((null? vars)
10601 (scan-let0 E env available))
10602 ((null? (cdr vars))
10603 (scan-binding E env available))
10605 (error (make-readable E)))))))))
10607 ; E has the form of (let ((T1 E1)) E0).
10609 (define (scan-binding E env available)
10610 (let* ((L (call.proc E))
10611 (T1 (car (lambda.args L)))
10612 (E1 (car (call.args E)))
10613 (E0 (lambda.body L)))
10614 (record-local-variable! T1)
10616 (lambda () (scan-rhs E1 env available))
10617 (lambda (E1 F1 regbindings1)
10618 (available-add! available T1 E1)
10619 (let* ((env (let ((formals
10620 (make-null-terminated (lambda.args L))))
10621 (environment-extend*
10622 (environment-extend* env formals)
10623 (map def.lhs (lambda.defs L)))))
10624 (Fdefs (scan-defs L env available)))
10626 (lambda () (scan E0 env available))
10627 (lambda (E0 F0 regbindings0)
10628 (lambda.body-set! L E0)
10629 (if target-registers?
10630 (scan-binding-phase2
10631 L T1 E0 E1 F0 F1 Fdefs regbindings0 regbindings1)
10632 (scan-binding-phase3
10633 L E0 E1 (union F0 Fdefs)
10634 F1 regbindings0 regbindings1)))))))))
10636 ; Given the lambda expression for a let expression that binds
10637 ; a single variable T1, the transformed body E0 and right hand side E1,
10638 ; their sets of free variables F0 and F1, the set of free variables
10639 ; for the internal definitions of L, and the sets of register
10640 ; bindings that need to be wrapped around E0 and E1, returns the
10641 ; transformed let expression, its free variables, and register
10644 ; This phase is concerned exclusively with register bindings,
10645 ; and is bypassed unless the target-registers flag is specified.
10647 (define (scan-binding-phase2
10648 L T1 E0 E1 F0 F1 Fdefs regbindings0 regbindings1)
10650 ; T1 can't be a register because we haven't
10651 ; yet inserted register bindings that high up.
10653 ; Classify the register bindings that need to wrapped around E0:
10654 ; 1. those that have T1 as their rhs
10655 ; 2. those whose lhs is a register that is likely to hold
10656 ; a variable that occurs free in E1
10660 (do ((rvars regvars (cdr rvars))
10661 (regs argument-registers (cdr regs))
10662 (regs1 '() (if (memq (car rvars) F1)
10663 (cons (car regs) regs1)
10667 ; regs1 is the set of registers that are live for E1
10669 (let loop ((regbindings regbindings0)
10673 (if (null? regbindings)
10674 (phase2b rb1 rb2 rb3)
10675 (let* ((binding (car regbindings))
10676 (regbindings (cdr regbindings))
10677 (lhs (regbinding.lhs binding))
10678 (rhs (regbinding.rhs binding)))
10679 (cond ((eq? rhs T1)
10693 (cons binding rb3))))))))))
10695 ; Determine which categories of register bindings should be
10696 ; wrapped around E0.
10697 ; Always wrap the register bindings in category 2.
10698 ; If E1 is a conditional or a real call, then wrap category 3.
10699 ; If T1 might be used more than once, then wrap category 1.
10701 (define (phase2b rb1 rb2 rb3)
10702 (if (or (conditional? E1)
10704 (phase2c (append rb2 rb3) rb1 '())
10705 (phase2c rb2 rb1 rb3)))
10707 (define (phase2c towrap rb1 regbindings0)
10708 (cond ((and (not (null? rb1))
10709 (local-variable-used-once? T1))
10710 (phase2d towrap rb1 regbindings0))
10712 (phase2e (append rb1 towrap) regbindings0))))
10714 ; T1 is used only once, and there is a register binding (R T1).
10717 (define (phase2d towrap regbindings-T1 regbindings0)
10718 (if (not (null? (cdr regbindings-T1)))
10719 (error "incorrect number of uses" T1))
10720 (let* ((regbinding (car regbindings-T1))
10721 (R (regbinding.lhs regbinding)))
10722 (lambda.args-set! L (list R))
10723 (phase2e towrap regbindings0)))
10725 ; Wrap the selected register bindings around E0.
10727 (define (phase2e towrap regbindings0)
10730 (wrap-with-register-bindings towrap E0 F0))
10732 (let ((F (union Fdefs F0)))
10733 (scan-binding-phase3
10734 L E0 E1 F F1 regbindings0 regbindings1)))))
10738 ; This phase, with arguments as above, constructs the result.
10740 (define (scan-binding-phase3 L E0 E1 F F1 regbindings0 regbindings1)
10741 (let* ((args (lambda.args L))
10743 (free (union F1 (difference F args)))
10744 (simple-let? (simple-lambda? L))
10747 ; At least one of regbindings0 and regbindings1
10748 ; is the empty list.
10750 (cond ((null? regbindings0)
10752 ((null? regbindings1)
10755 (error 'scan-binding 'regbindings)))))
10756 (lambda.body-set! L E0)
10757 (lambda.F-set! L F)
10758 (lambda.G-set! L F)
10759 (cond ((and simple-let?
10761 (no-side-effects? E1))
10762 (abandon-expression! E1)
10763 (values E0 F regbindings0))
10764 ((and target-registers?
10766 (local-variable-used-once? T1))
10767 (post-simplify-anf L T1 E0 E1 free regbindings #f))
10769 (values (make-call L (list E1))
10773 (define (scan-let0 E env available)
10774 (let ((L (call.proc E)))
10775 (if (simple-lambda? L)
10776 (scan (lambda.body L) env available)
10777 (let ((T1 (make-variable name:IGNORED)))
10778 (lambda.args-set! L (list T1))
10780 (lambda () (scan (make-call L (list (make-constant 0)))
10783 (lambda (E F regbindings)
10784 (lambda.args-set! L '())
10785 (values (make-call L '())
10789 ; Optimizes the internal definitions of L and returns their
10792 (define (scan-defs L env available)
10793 (let loop ((defs (lambda.defs L))
10797 (begin (lambda.defs-set! L (reverse newdefs))
10799 (let ((def (car defs)))
10802 (let* ((Ldef (def.rhs def))
10803 (Lformals (make-null-terminated (lambda.args Ldef)))
10804 (Lenv (environment-extend*
10805 (environment-extend* env Lformals)
10806 (map def.lhs (lambda.defs Ldef)))))
10807 (scan Ldef Lenv available)))
10808 (lambda (rhs Frhs empty)
10809 (if (not (null? empty))
10810 (error 'scan-binding 'def))
10812 (cons (make-definition (def.lhs def) rhs)
10814 (union Frhs Fdefs))))))))
10816 ; Given the right-hand side of a let-binding, an environment,
10817 ; and a table of available expressions, returns the transformed
10818 ; expression, its free variables, and the register bindings that
10819 ; need to be wrapped around it.
10821 (define (scan-rhs E env available)
10825 (values E (empty-set) '()))
10828 (let* ((name (variable.name E))
10829 (Enew (and commoning?
10831 (let ((T (available-expression
10836 (available-variable available name)))))
10838 (scan-rhs Enew env available)
10839 (begin (used-variable! name)
10840 (values E (list name) '())))))
10843 (let* ((formals (make-null-terminated (lambda.args E)))
10844 (env (environment-extend*
10845 (environment-extend* env formals)
10846 (map def.lhs (lambda.defs E))))
10847 (Fdefs (scan-defs E env available)))
10850 (let ((available (copy-available-table available)))
10851 (available-kill! available available:killer:all)
10852 (scan-body (lambda.body E)
10856 (lambda (E0 F0 regbindings0)
10859 (wrap-with-register-bindings regbindings0 E0 F0))
10861 (lambda.body-set! E E0)
10862 (let ((F (union Fdefs F0)))
10863 (for-each (lambda (x)
10864 (closed-over-local-variable! x))
10866 (lambda.F-set! E F)
10867 (lambda.G-set! E F)
10870 (make-null-terminated
10875 (let ((E0 (if.test E))
10879 ; FIXME: E1 and E2 might not be a legal rhs,
10880 ; so we can't just return the simplified E1 or E2.
10881 (let ((E1 (if (constant.value E0) E1 E2)))
10883 (lambda () (scan E1 env available))
10884 (lambda (E1 F1 regbindings1)
10885 (cond ((or (not (call? E1))
10886 (not (lambda? (call.proc E1))))
10887 (values E1 F1 regbindings1))
10889 ; FIXME: Must return a valid rhs.
10890 (values (make-conditional
10897 (lambda () (scan E0 env available))
10898 (lambda (E0 F0 regbindings0)
10899 (if (not (null? regbindings0))
10900 (error 'scan-rhs 'if))
10901 (if (not (eq? E0 (if.test E)))
10902 (scan-rhs (make-conditional E0 E1 E2)
10905 (copy-available-table available))
10907 (copy-available-table available)))
10909 (let ((T0 (variable.name E0)))
10911 available2 T0 (make-constant #f)))
10912 (error (make-readable E #t)))
10914 (lambda () (scan E1 env available1))
10915 (lambda (E1 F1 regbindings1)
10918 (wrap-with-register-bindings
10919 regbindings1 E1 F1))
10922 (lambda () (scan E2 env available2))
10923 (lambda (E2 F2 regbindings2)
10926 (wrap-with-register-bindings
10927 regbindings2 E2 F2))
10929 (let ((E (make-conditional
10931 (F (union F0 F1 F2)))
10932 (available-intersect!
10936 (values E F '())))))))))))))))))
10941 (lambda () (scan-rhs (assignment.rhs E) env available))
10942 (lambda (E1 F1 regbindings1)
10943 (if (not (null? regbindings1))
10944 (error 'scan-rhs 'set!))
10945 (available-kill! available available:killer:globals)
10946 (values (make-assignment (assignment.lhs E) E1)
10947 (union (list (assignment.lhs E)) F1)
10951 ; Shouldn't occur in A-normal form.
10952 (error 'scan-rhs 'begin))
10955 (let* ((E0 (call.proc E))
10956 (args (call.args E))
10957 (regcontents (append regvars
10958 (map (lambda (x) #f) args))))
10959 (let loop ((args args)
10960 (regs argument-registers)
10961 (regcontents regcontents)
10964 (F (if (variable? E0)
10965 (let ((f (variable.name E0)))
10969 (cond ((null? args)
10970 (available-kill! available available:killer:all)
10971 (values (make-call E0 (reverse newargs))
10975 (let ((arg (car args)))
10981 (if (variable? arg)
10982 (let ((name (variable.name arg)))
10983 (used-variable! name)
10984 (union (list name) F))
10987 (variable? (car args))
10988 (available-variable
10990 (variable.name (car args))))
10991 (let* ((name (variable.name (car args)))
10992 (Enew (available-variable available name)))
10993 (loop (cons Enew (cdr args))
10994 regs regcontents newargs regbindings F)))
10995 ((and target-registers?
10996 (variable? (car args))
10997 (let ((x (variable.name (car args))))
10998 ; We haven't yet recorded this use.
10999 (or (local-variable-not-used? x)
11000 (and (memq x regvars)
11001 (not (eq? x (car regcontents)))))))
11002 (let* ((x (variable.name (car args)))
11004 (newarg (make-variable R)))
11009 (cons newarg newargs)
11010 (cons (make-regbinding R x newarg)
11012 (union (list R) F))))
11014 (let ((E1 (car args)))
11021 (let ((name (variable.name E1)))
11022 (used-variable! name)
11023 (union (list name) F))
11027 ; Must be a call to a primop.
11028 (let* ((E0 (call.proc E))
11029 (f0 (variable.name E0)))
11030 (let loop ((args (call.args E))
11033 (cond ((null? args)
11034 (let* ((E (make-call E0 (reverse newargs)))
11036 (available-expression
11039 (begin (abandon-expression! E)
11040 (scan-rhs (make-variable T) env available))
11044 (prim-kills (prim-entry f0)))
11045 (cond ((eq? f0 name:check!)
11046 (let ((x (car (call.args E))))
11047 (cond ((not (runtime-safety-checking))
11048 (abandon-expression! E)
11049 ;(values x '() '())
11050 (scan-rhs x env available))
11055 (make-constant #t))
11057 ((constant.value x)
11058 (abandon-expression! E)
11059 (values x '() '()))
11061 (declaration-error E)
11062 (values E F '())))))
11064 (values E F '())))))))
11065 ((variable? (car args))
11066 (let* ((E1 (car args))
11067 (x (variable.name E1))
11070 (available-variable available x))))
11072 ; All of the arguments are constants or
11073 ; variables, so if the variable is replaced
11074 ; here it will be replaced throughout the call.
11075 (loop (cons Enew (cdr args))
11081 (cons (car args) newargs)
11082 (union (list x) F))))))
11085 (cons (car args) newargs)
11089 (error 'scan-rhs (make-readable E)))))
11092 (lambda () (scan E env available))
11093 (lambda (E F regbindings)
11095 (lambda () (wrap-with-register-bindings regbindings E F))
11097 (values E F '()))))))
11102 (make-hashtree symbol-hash assq)
11103 (make-available-table)
11105 (lambda (E F regbindings)
11106 (if (not (null? regbindings))
11107 (error 'scan-body))
11109 ; Copyright 1999 William D Clinger.
11111 ; Permission to copy this software, in whole or in part, to use this
11112 ; software for any lawful noncommercial purpose, and to redistribute
11113 ; this software is granted subject to the restriction that all copies
11114 ; made of this software must include this copyright notice in full.
11116 ; I also request that you send me a copy of any improvements that you
11117 ; make to this software so that they may be incorporated within it to
11118 ; the benefit of the Scheme community.
11122 ; Intraprocedural representation inference.
11124 (define (representation-analysis exp)
11125 (let* ((debugging? #f)
11126 (integrate-usual? (integrate-usual-procedures))
11127 (known (make-hashtable symbol-hash assq))
11128 (types (make-hashtable symbol-hash assq))
11129 (g (callgraph exp))
11130 (schedule (list (callgraphnode.code (car g))))
11134 ; known is a hashtable that maps the name of a known local procedure
11135 ; to a list of the form (tv1 ... tvN), where tv1, ..., tvN
11136 ; are type variables that stand for the representation types of its
11137 ; arguments. The type variable that stands for the representation
11138 ; type of the result of the procedure has the same name as the
11139 ; procedure itself.
11141 ; types is a hashtable that maps local variables and the names
11142 ; of known local procedures to an approximation of their
11143 ; representation type.
11144 ; For a known local procedure, the representation type is for the
11145 ; result of the procedure, not the procedure itself.
11147 ; schedule is a stack of work that needs to be done.
11148 ; Each entry in the stack is either an escaping lambda expression
11149 ; or the name of a known local procedure.
11151 (define (schedule! job)
11152 (if (not (memq job schedule))
11153 (begin (set! schedule (cons job schedule))
11154 (if (not (symbol? job))
11155 (callgraphnode.info! (lookup-node job) #t)))))
11157 ; Schedules a known local procedure.
11159 (define (schedule-known-procedure! name)
11160 ; Mark every known procedure that can actually be called.
11161 (callgraphnode.info! (assq name g) #t)
11164 ; Schedule all code that calls the given known local procedure.
11166 (define (schedule-callers! name)
11167 (for-each (lambda (node)
11168 (if (and (callgraphnode.info node)
11169 (or (memq name (callgraphnode.tailcalls node))
11170 (memq name (callgraphnode.nontailcalls node))))
11171 (let ((caller (callgraphnode.name node)))
11174 (schedule! (callgraphnode.code node))))))
11177 ; Schedules local procedures of a lambda expression.
11179 (define (schedule-local-procedures! L)
11180 (for-each (lambda (def)
11181 (let ((name (def.lhs def)))
11182 (if (known-procedure-is-callable? name)
11183 (schedule! name))))
11186 ; Returns true iff the given known procedure is known to be callable.
11188 (define (known-procedure-is-callable? name)
11189 (callgraphnode.info (assq name g)))
11191 ; Sets CHANGED? to #t and returns #t if the type variable's
11192 ; approximation has changed; otherwise returns #f.
11194 (define (update-typevar! tv type)
11195 (let* ((type0 (hashtable-get types tv))
11197 (begin (hashtable-put! types tv rep:bottom)
11199 (type1 (representation-union type0 type)))
11200 (if (eq? type0 type1)
11202 (begin (hashtable-put! types tv type1)
11204 (if (and debugging? mutate?)
11205 (begin (display "******** Changing type of ")
11208 (display (rep->symbol type0))
11210 (display (rep->symbol type1))
11214 ; GIven the name of a known local procedure, returns its code.
11216 (define (lookup-code name)
11217 (callgraphnode.code (assq name g)))
11219 ; Given a lambda expression, either escaping or the code for
11220 ; a known local procedure, returns its node in the call graph.
11222 (define (lookup-node L)
11225 (error "Unknown lambda expression" (make-readable L #t)))
11226 ((eq? L (callgraphnode.code (car g)))
11231 ; Given: a type variable, expression, and a set of constraints.
11233 ; Update the representation types of all variables that are
11234 ; bound within the expression.
11235 ; Update the representation types of all arguments to known
11236 ; local procedures that are called within the expression.
11237 ; If the representation type of an argument to a known local
11238 ; procedure changes, then schedule that procedure's code
11240 ; Update the constraint set to reflect the constraints that
11241 ; hold following execution of the expression.
11242 ; If mutate? is true, then transform the expression to rely
11243 ; on the representation types that have been inferred.
11244 ; Return: type of the expression under the current assumptions
11247 (define (analyze exp constraints)
11249 (if (and #f debugging?)
11250 (begin (display "Analyzing: ")
11252 (pretty-print (make-readable exp #t))
11258 (representation-of-value (constant.value exp)))
11261 (let* ((name (variable.name exp)))
11262 (representation-typeof name types constraints)))
11269 (analyze (assignment.rhs exp) constraints)
11270 (constraints-kill! constraints available:killer:globals)
11274 (let* ((E0 (if.test exp))
11277 (type0 (analyze E0 constraints)))
11279 (cond ((representation-subtype? type0 rep:true)
11280 (if.test-set! exp (make-constant #t)))
11281 ((representation-subtype? type0 rep:false)
11282 (if.test-set! exp (make-constant #f)))))
11283 (cond ((representation-subtype? type0 rep:true)
11284 (analyze E1 constraints))
11285 ((representation-subtype? type0 rep:false)
11286 (analyze E2 constraints))
11288 (let* ((T0 (variable.name E0))
11289 (ignored (analyze E0 constraints))
11290 (constraints1 (copy-constraints-table constraints))
11291 (constraints2 (copy-constraints-table constraints)))
11292 (constraints-add! types
11294 (make-type-constraint
11295 T0 rep:true available:killer:immortal))
11296 (constraints-add! types
11298 (make-type-constraint
11299 T0 rep:false available:killer:immortal))
11300 (let* ((type1 (analyze E1 constraints1))
11301 (type2 (analyze E2 constraints2))
11302 (type (representation-union type1 type2)))
11303 (constraints-intersect! constraints
11308 (representation-error "Bad ANF" (make-readable exp #t))))))
11311 (let ((proc (call.proc exp))
11312 (args (call.args exp)))
11313 (cond ((lambda? proc)
11314 (cond ((null? args)
11315 (analyze-let0 exp constraints))
11316 ((null? (cdr args))
11317 (analyze-let1 exp constraints))
11319 (error "Compiler bug: pass3rep"))))
11321 (let* ((procname (variable.name proc)))
11322 (cond ((hashtable-get known procname)
11325 (analyze-known-call exp constraints vars)))
11327 (let ((entry (prim-entry procname)))
11329 (analyze-primop-call exp constraints entry)
11330 (analyze-unknown-call exp constraints))))
11332 (analyze-unknown-call exp constraints)))))
11334 (analyze-unknown-call exp constraints)))))))
11336 (define (analyze-let0 exp constraints)
11337 (let ((proc (call.proc exp)))
11338 (schedule-local-procedures! proc)
11339 (if (null? (lambda.args proc))
11340 (analyze (lambda.body exp) constraints)
11341 (analyze-unknown-call exp constraints))))
11343 (define (analyze-let1 exp constraints)
11344 (let* ((proc (call.proc exp))
11345 (vars (lambda.args proc)))
11346 (schedule-local-procedures! proc)
11347 (if (and (pair? vars)
11348 (null? (cdr vars)))
11349 (let* ((T1 (car vars))
11350 (E1 (car (call.args exp))))
11351 (if (and integrate-usual? (call? E1))
11352 (let ((proc (call.proc E1))
11353 (args (call.args E1)))
11354 (if (variable? proc)
11355 (let* ((op (variable.name proc))
11356 (entry (prim-entry op))
11358 (prim-lives-until entry)
11359 available:killer:dead)))
11360 (if (not (= K1 available:killer:dead))
11361 ; Must copy the call to avoid problems
11362 ; with side effects when mutate? is true.
11366 (make-constraint T1
11367 (make-call proc args)
11369 (update-typevar! T1 (analyze E1 constraints))
11370 (analyze (lambda.body proc) constraints))
11371 (analyze-unknown-call exp constraints))))
11373 (define (analyze-primop-call exp constraints entry)
11374 (let* ((op (prim-opcodename entry))
11375 (args (call.args exp))
11376 (argtypes (map (lambda (arg) (analyze arg constraints))
11378 (type (rep-result? op argtypes)))
11379 (constraints-kill! constraints (prim-kills entry))
11380 (cond ((and (eq? op 'check!)
11381 (variable? (car args)))
11382 (let ((varname (variable.name (car args))))
11384 (representation-subtype? (car argtypes) rep:true))
11385 (call.args-set! exp
11386 (cons (make-constant #t) (cdr args))))
11387 (constraints-add! types
11389 (make-type-constraint
11392 available:killer:immortal))))
11393 ((and mutate? (rep-specific? op argtypes))
11396 (call.proc-set! exp (make-variable newop)))))
11397 (or type rep:object)))
11399 (define (analyze-known-call exp constraints vars)
11400 (let* ((procname (variable.name (call.proc exp)))
11401 (args (call.args exp))
11402 (argtypes (map (lambda (arg) (analyze arg constraints))
11404 (if (not (known-procedure-is-callable? procname))
11405 (schedule-known-procedure! procname))
11406 (for-each (lambda (var type)
11407 (if (update-typevar! var type)
11408 (schedule-known-procedure! procname)))
11411 ; FIXME: We aren't analyzing the effects of known local procedures.
11412 (constraints-kill! constraints available:killer:all)
11413 (hashtable-get types procname)))
11415 (define (analyze-unknown-call exp constraints)
11416 (analyze (call.proc exp) constraints)
11417 (for-each (lambda (arg) (analyze arg constraints))
11419 (constraints-kill! constraints available:killer:all)
11422 (define (analyze-known-local-procedure name)
11424 (begin (display "Analyzing ")
11427 (let ((L (lookup-code name))
11428 (constraints (make-constraints-table)))
11429 (schedule-local-procedures! L)
11430 (let ((type (analyze (lambda.body L) constraints)))
11431 (if (update-typevar! name type)
11432 (schedule-callers! name))
11435 (define (analyze-unknown-lambda L)
11437 (begin (display "Analyzing escaping lambda expression")
11439 (schedule-local-procedures! L)
11440 (let ((vars (make-null-terminated (lambda.args L))))
11441 (for-each (lambda (var)
11442 (hashtable-put! types var rep:object))
11444 (analyze (lambda.body L)
11445 (make-constraints-table))))
11449 (define (display-types)
11450 (hashtable-for-each (lambda (f vars)
11452 (display " : returns ")
11453 (write (rep->symbol (hashtable-get types f)))
11455 (for-each (lambda (x)
11459 (write (rep->symbol
11460 (hashtable-get types x)))
11465 (define (display-all-types)
11466 (let* ((vars (hashtable-map (lambda (x type) x) types))
11467 (vars (twobit-sort (lambda (var1 var2)
11468 (string<=? (symbol->string var1)
11469 (symbol->string var2)))
11471 (for-each (lambda (x)
11474 (write (rep->symbol
11475 (hashtable-get types x)))
11480 (begin (pretty-print (make-readable (car schedule) #t))
11483 (view-callgraph g))
11485 (for-each (lambda (node)
11486 (let* ((name (callgraphnode.name node))
11487 (code (callgraphnode.code node))
11488 (vars (make-null-terminated (lambda.args code)))
11489 (known? (symbol? name))
11490 (rep (if known? rep:bottom rep:object)))
11491 (callgraphnode.info! node #f)
11493 (begin (hashtable-put! known name vars)
11494 (hashtable-put! types name rep)))
11495 (for-each (lambda (var)
11496 (hashtable-put! types var rep))
11501 (cond ((not (null? schedule))
11502 (let ((job (car schedule)))
11503 (set! schedule (cdr schedule))
11505 (analyze-known-local-procedure job)
11506 (analyze-unknown-lambda job))
11510 (set! schedule (list (callgraphnode.code (car g))))
11512 (begin (display-all-types) (newline)))
11520 ; We don't want to analyze known procedures that are never called.
11523 (cons (callgraphnode.code (car g))
11524 (map callgraphnode.name
11525 (filter (lambda (node)
11526 (let* ((name (callgraphnode.name node))
11527 (known? (symbol? name))
11529 (known-procedure-is-callable? name)))
11530 (callgraphnode.info! node #f)
11531 (and known? marked?)))
11534 (if (not (null? schedule))
11535 (let ((job (car schedule)))
11536 (set! schedule (cdr schedule))
11538 (analyze-known-local-procedure job)
11539 (analyze-unknown-lambda job))
11543 (error "Compiler bug in representation inference"))
11546 (pretty-print (make-readable (callgraphnode.code (car g)) #t)))
11549 ; Copyright 1999 William D Clinger.
11551 ; Permission to copy this software, in whole or in part, to use this
11552 ; software for any lawful noncommercial purpose, and to redistribute
11553 ; this software is granted subject to the restriction that all copies
11554 ; made of this software must include this copyright notice in full.
11556 ; I also request that you send me a copy of any improvements that you
11557 ; make to this software so that they may be incorporated within it to
11558 ; the benefit of the Scheme community.
11562 ; The third "pass" of the Twobit compiler actually consists of several
11563 ; passes, which are related by the common theme of flow analysis:
11564 ; interprocedural inlining of known local procedures
11565 ; interprocedural constant propagation and folding
11566 ; intraprocedural commoning, copy propagation, and dead code elimination
11567 ; representation inference (not yet implemented)
11568 ; register targeting
11570 ; This pass operates as source-to-source transformations on
11571 ; expressions written in the subset of Scheme described by the
11572 ; following grammar:
11574 ; "X ..." means zero or more occurrences of X.
11576 ; L --> (lambda (I_1 ...)
11578 ; (quote (R F G <decls> <doc>)
11580 ; | (lambda (I_1 ... . I_rest)
11582 ; (quote (R F G <decls> <doc>))
11584 ; D --> (define I L)
11585 ; E --> (quote K) ; constants
11586 ; | (begin I) ; variable references
11587 ; | L ; lambda expressions
11588 ; | (E0 E1 ...) ; calls
11589 ; | (set! I E) ; assignments
11590 ; | (if E0 E1 E2) ; conditionals
11591 ; | (begin E0 E1 E2 ...) ; sequential expressions
11592 ; I --> <identifier>
11594 ; R --> ((I <references> <assignments> <calls>) ...)
11598 ; Invariants that hold for the input only:
11599 ; * There are no assignments except to global variables.
11600 ; * If I is declared by an internal definition, then the right hand
11601 ; side of the internal definition is a lambda expression and I
11602 ; is referenced only in the procedure position of a call.
11603 ; * R, F, and G are garbage.
11604 ; * Variables named IGNORED are neither referenced nor assigned.
11605 ; * The expression does not share structure with the original input,
11606 ; but might share structure with itself.
11608 ; Invariants that hold for the output only:
11609 ; * There are no assignments except to global variables.
11610 ; * If I is declared by an internal definition, then the right hand
11611 ; side of the internal definition is a lambda expression and I
11612 ; is referenced only in the procedure position of a call.
11614 ; * For each lambda expression, the associated F is a list of all
11615 ; the identifiers that occur free in the body of that lambda
11616 ; expression, and possibly a few extra identifiers that were
11617 ; once free but have been removed by optimization.
11618 ; * If a lambda expression is declared to be in A-normal form (see
11619 ; pass3anormal.sch), then it really is in A-normal form.
11621 ; The phases of pass 3 interact with the referencing information R
11622 ; and the free variables F as follows:
11624 ; Inlining ignores R, ignores F, destroys R, destroys F.
11625 ; Constant propagation uses R, ignores F, preserves R, preserves F.
11626 ; Conversion to ANF ignores R, ignores F, destroys R, destroys F.
11627 ; Commoning ignores R, ignores F, destroys R, computes F.
11628 ; Register targeting ignores R, ignores F, destroys R, computes F.
11630 (define (pass3 exp)
11632 (define (phase1 exp)
11633 (if (interprocedural-inlining)
11634 (let ((g (callgraph exp)))
11635 (inline-using-callgraph! g)
11639 (define (phase2 exp)
11640 (if (interprocedural-constant-propagation)
11641 (constant-propagation (copy-exp exp))
11644 (define (phase3 exp)
11645 (if (common-subexpression-elimination)
11646 (let* ((exp (if (interprocedural-constant-propagation)
11650 (exp (a-normal-form exp)))
11651 (if (representation-inference)
11652 (intraprocedural-commoning exp 'commoning)
11653 (intraprocedural-commoning exp)))
11656 (define (phase4 exp)
11657 (if (representation-inference)
11658 (let ((exp (cond ((common-subexpression-elimination)
11660 ((interprocedural-constant-propagation)
11661 (a-normal-form exp))
11664 (a-normal-form (copy-exp exp))))))
11665 (intraprocedural-commoning
11666 (representation-analysis exp)))
11669 (define (finish exp)
11670 (if (and (not (interprocedural-constant-propagation))
11671 (not (common-subexpression-elimination)))
11672 (begin (compute-free-variables! exp)
11674 ;(make-begin (list (make-constant 'anf) exp))))
11677 (define (verify exp)
11678 (check-referencing-invariants exp 'free)
11681 (if (global-optimization)
11682 (verify (finish (phase4 (phase3 (phase2 (phase1 exp))))))
11683 (begin (compute-free-variables! exp)
11685 ; Copyright 1991 Lightship Software, Incorporated.
11687 ; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
11691 ; Implements the following abstract data types.
11699 ; (make-assembly-stream)
11700 ; (assembly-stream-code as)
11701 ; (gen! as . instruction)
11702 ; (gen-instruction! as instruction)
11703 ; (gen-save! as frame)
11704 ; (gen-restore! as frame)
11705 ; (gen-pop! as frame)
11706 ; (gen-setstk! as frame v)
11707 ; (gen-store! as frame r v)
11708 ; (gen-load! as frame r v)
11709 ; (gen-stack! as frame v)
11717 ; register environments
11719 ; (cgreg-copy regs)
11721 ; (cgreg-liveregs regs)
11722 ; (cgreg-live regs r)
11723 ; (cgreg-vars regs)
11724 ; (cgreg-bind! regs r v)
11725 ; (cgreg-bindregs! regs vars)
11726 ; (cgreg-rename! regs alist)
11727 ; (cgreg-release! regs r)
11728 ; (cgreg-clear! regs)
11729 ; (cgreg-lookup regs var)
11730 ; (cgreg-lookup-reg regs r)
11731 ; (cgreg-join! regs1 regs2)
11733 ; stack frame environments
11734 ; (cgframe-initial)
11735 ; (cgframe-size-cell frame)
11736 ; (cgframe-size frame)
11737 ; (cgframe-copy frame)
11738 ; (cgframe-join! frame1 frame2)
11739 ; (cgframe-update-stale! frame)
11740 ; (cgframe-used! frame)
11741 ; (cgframe-bind! frame n v instruction)
11742 ; (cgframe-touch! frame v)
11743 ; (cgframe-rename! frame alist)
11744 ; (cgframe-release! frame v)
11745 ; (cgframe-lookup frame v)
11746 ; (cgframe-spilled? frame v)
11749 ; (entry.name entry)
11750 ; (entry.kind entry)
11751 ; (entry.rib entry)
11752 ; (entry.offset entry)
11753 ; (entry.label entry)
11754 ; (entry.regnum entry)
11755 ; (entry.arity entry)
11757 ; (entry.imm entry)
11759 ; (cgenv-lookup env id)
11760 ; (cgenv-extend env vars procs)
11761 ; (cgenv-bindprocs env procs)
11762 ; (var-lookup var regs frame env)
11766 (define (init-labels)
11767 (set! cg-label-counter 1000))
11769 (define (make-label)
11770 (set! cg-label-counter (+ cg-label-counter 1))
11773 (define cg-label-counter 1000)
11775 ; an assembly stream into which instructions should be emitted
11777 ; the desired target register ('result, a register number, or '#f)
11778 ; a register environment [cgreg]
11779 ; a stack-frame environment [cgframe]
11780 ; contains size of frame, current top of frame
11781 ; a compile-time environment [cgenv]
11782 ; a flag indicating whether the expression is in tail position
11784 ; Assembly streams, into which instructions are emitted by side effect.
11785 ; Represented as a list of two things:
11787 ; Assembly code, represented as a pair whose car is a nonempty list
11788 ; whose cdr is a possibly empty list of MacScheme machine assembly
11789 ; instructions, and whose cdr is the last pair of the car.
11791 ; Any Scheme object that the code generator wants to associate with
11794 (define (make-assembly-stream)
11795 (let ((code (list (list 0))))
11796 (set-cdr! code (car code))
11799 (define (assembly-stream-code output)
11800 (if (local-optimizations)
11801 (filter-basic-blocks (cdar (car output)))
11802 (cdar (car output))))
11804 (define (assembly-stream-info output)
11807 (define (assembly-stream-info! output x)
11808 (set-car! (cdr output) x)
11811 (define (gen-instruction! output instruction)
11812 (let ((pair (list instruction))
11813 (code (car output)))
11814 (set-cdr! (cdr code) pair)
11815 (set-cdr! code pair)
11820 (define (gen! output . instruction)
11821 (gen-instruction! output instruction))
11823 (define (gen-save! output frame t0)
11824 (let ((size (cgframe-size-cell frame)))
11825 (gen-instruction! output (cons $save size))
11826 (gen-store! output frame 0 t0)
11827 (cgframe:stale-set! frame '())))
11829 (define (gen-restore! output frame)
11830 (let ((size (cgframe-size-cell frame)))
11831 (gen-instruction! output (cons $restore size))))
11833 (define (gen-pop! output frame)
11834 (let ((size (cgframe-size-cell frame)))
11835 (gen-instruction! output (cons $pop size))))
11837 (define (gen-setstk! output frame tempname)
11838 (let ((instruction (list $nop $setstk -1)))
11839 (cgframe-bind! frame tempname instruction)
11840 (gen-instruction! output instruction)))
11842 (define (gen-store! output frame r tempname)
11843 (let ((instruction (list $nop $store r -1)))
11844 (cgframe-bind! frame tempname instruction)
11845 (gen-instruction! output instruction)))
11847 (define (gen-load! output frame r tempname)
11848 (cgframe-touch! frame tempname)
11849 (let ((n (entry.slotnum (cgframe-lookup frame tempname))))
11850 (gen! output $load r n)))
11852 (define (gen-stack! output frame tempname)
11853 (cgframe-touch! frame tempname)
11854 (let ((n (entry.slotnum (cgframe-lookup frame tempname))))
11855 (gen! output $stack n)))
11857 ; Returns a temporary name.
11858 ; Temporaries are compared using EQ?, so the use of small
11859 ; exact integers as temporary names is implementation-dependent.
11861 (define (init-temps)
11862 (set! newtemp-counter 5000))
11865 (set! newtemp-counter
11866 (+ newtemp-counter 1))
11869 (define newtemp-counter 5000)
11871 (define (newtemps n)
11875 (newtemps (- n 1)))))
11877 ; New representation of
11878 ; Register environments.
11879 ; Represented as a list of three items:
11880 ; an exact integer, one more than the highest index of a live register
11881 ; a mutable vector with *nregs* elements of the form
11882 ; #f (the register is dead)
11883 ; #t (the register is live)
11884 ; v (the register contains variable v)
11885 ; t (the register contains temporary variable t)
11886 ; a mutable vector of booleans: true if the register might be stale
11888 (define (cgreg-makeregs n v1 v2) (list n v1 v2))
11890 (define (cgreg-liveregs regs)
11893 (define (cgreg-contents regs)
11896 (define (cgreg-stale regs)
11899 (define (cgreg-liveregs-set! regs n)
11903 (define (cgreg-initial)
11904 (let ((v1 (make-vector *nregs* #f))
11905 (v2 (make-vector *nregs* #f)))
11906 (cgreg-makeregs 0 v1 v2)))
11908 (define (cgreg-copy regs)
11909 (let* ((newregs (cgreg-initial))
11910 (v1a (cgreg-contents regs))
11911 (v2a (cgreg-stale regs))
11912 (v1 (cgreg-contents newregs))
11913 (v2 (cgreg-stale newregs))
11914 (n (vector-length v1a)))
11915 (cgreg-liveregs-set! newregs (cgreg-liveregs regs))
11916 (do ((i 0 (+ i 1)))
11919 (vector-set! v1 i (vector-ref v1a i))
11920 (vector-set! v2 i (vector-ref v2a i)))))
11922 (define (cgreg-tos regs)
11923 (- (cgreg-liveregs regs) 1))
11925 (define (cgreg-live regs r)
11926 (if (eq? r 'result)
11928 (max r (cgreg-tos regs))))
11930 (define (cgreg-vars regs)
11931 (let ((m (cgreg-liveregs regs))
11932 (v (cgreg-contents regs)))
11933 (do ((i (- m 1) (- i 1))
11935 (cons (vector-ref v i)
11940 (define (cgreg-bind! regs r t)
11941 (let ((m (cgreg-liveregs regs))
11942 (v (cgreg-contents regs)))
11943 (vector-set! v r t)
11945 (cgreg-liveregs-set! regs (+ r 1)))))
11947 (define (cgreg-bindregs! regs vars)
11948 (do ((m (cgreg-liveregs regs) (+ m 1))
11949 (v (cgreg-contents regs))
11950 (vars vars (cdr vars)))
11952 (cgreg-liveregs-set! regs m)
11954 (vector-set! v m (car vars))))
11956 (define (cgreg-rename! regs alist)
11957 (do ((i (- (cgreg-liveregs regs) 1) (- i 1))
11958 (v (cgreg-contents regs)))
11960 (let ((var (vector-ref v i)))
11962 (let ((probe (assv var alist)))
11964 (vector-set! v i (cdr probe))))))))
11966 (define (cgreg-release! regs r)
11967 (let ((m (cgreg-liveregs regs))
11968 (v (cgreg-contents regs)))
11969 (vector-set! v r #f)
11970 (vector-set! (cgreg-stale regs) r #t)
11972 (do ((m r (- m 1)))
11975 (cgreg-liveregs-set! regs (+ m 1)))))))
11977 (define (cgreg-release-except! regs vars)
11978 (do ((i (- (cgreg-liveregs regs) 1) (- i 1))
11979 (v (cgreg-contents regs)))
11981 (let ((var (vector-ref v i)))
11982 (if (and var (not (memq var vars)))
11983 (cgreg-release! regs i)))))
11985 (define (cgreg-clear! regs)
11986 (let ((m (cgreg-liveregs regs))
11987 (v1 (cgreg-contents regs))
11988 (v2 (cgreg-stale regs)))
11989 (do ((r 0 (+ r 1)))
11991 (cgreg-liveregs-set! regs 0))
11992 (vector-set! v1 r #f)
11993 (vector-set! v2 r #t))))
11995 (define (cgreg-lookup regs var)
11996 (let ((m (cgreg-liveregs regs))
11997 (v (cgreg-contents regs)))
12001 ((eq? var (vector-ref v i))
12002 (list var 'register i '(object)))
12007 (define (cgreg-lookup-reg regs r)
12008 (let ((m (cgreg-liveregs regs))
12009 (v (cgreg-contents regs)))
12012 (vector-ref v r))))
12014 (define (cgreg-join! regs1 regs2)
12015 (let ((m1 (cgreg-liveregs regs1))
12016 (m2 (cgreg-liveregs regs2))
12017 (v1 (cgreg-contents regs1))
12018 (v2 (cgreg-contents regs2))
12019 (stale1 (cgreg-stale regs1)))
12020 (do ((i (- (max m1 m2) 1) (- i 1)))
12022 (cgreg-liveregs-set! regs1 (min m1 m2)))
12023 (let ((x1 (vector-ref v1 i))
12024 (x2 (vector-ref v2 i)))
12029 (vector-set! stale1 i #t)))
12031 (vector-set! v1 i #f)
12032 (vector-set! stale1 i #t)))))))
12034 ; New representation of
12035 ; Stack-frame environments.
12036 ; Represented as a three-element list.
12038 ; Its car is a list whose car is a list of slot entries, each
12040 ; (v n instruction stale)
12042 ; v is the name of a variable or temporary,
12043 ; n is #f or a slot number,
12044 ; instruction is a possibly phantom store or setstk instruction
12045 ; that stores v into slot n, and
12046 ; stale is a list of stale slot entries, each of the form
12049 ; where slot n had been allocated, initialized, and released
12050 ; before the store or setstk instruction was generated.
12051 ; Slot entries are updated by side effect.
12053 ; Its cadr is the list of currently stale slots.
12055 ; Its caddr is a list of variables that are free in the continuation,
12056 ; or #f if that information is unknown.
12057 ; This information allows a direct-style code generator to know when
12058 ; a slot becomes stale.
12060 ; Its cadddr is the size of the stack frame, which can be
12061 ; increased but not decreased. The cdddr of the stack frame
12062 ; environment is shared with the save instruction that
12063 ; created the frame. What a horrible crock!
12065 ; This stuff is private to the implementation of stack-frame
12068 (define cgframe:slots car)
12069 (define cgframe:stale cadr)
12070 (define cgframe:livevars caddr)
12071 (define cgframe:slot.name car)
12072 (define cgframe:slot.offset cadr)
12073 (define cgframe:slot.instruction caddr)
12074 (define cgframe:slot.stale cadddr)
12076 (define cgframe:slots-set! set-car!)
12077 (define (cgframe:stale-set! frame stale)
12078 (set-car! (cdr frame) stale))
12079 (define (cgframe:livevars-set! frame vars)
12080 (set-car! (cddr frame) vars))
12082 (define cgframe:slot.name-set! set-car!)
12084 (define (cgframe:slot.offset-set! entry n)
12085 (let ((instruction (caddr entry)))
12086 (if (or (not (eq? #f (cadr entry)))
12087 (not (eq? $nop (car instruction))))
12088 (error "Compiler bug: cgframe" entry)
12090 (set-car! (cdr entry) n)
12091 (set-car! instruction (cadr instruction))
12092 (set-cdr! instruction (cddr instruction))
12093 (if (eq? $setstk (car instruction))
12094 (set-car! (cdr instruction) n)
12095 (set-car! (cddr instruction) n))))))
12097 ; Reserves a slot offset that was unused where the instruction
12098 ; of the slot entry was generated, and returns that offset.
12100 (define (cgframe:unused-slot frame entry)
12101 (let* ((stale (cgframe:slot.stale entry))
12102 (probe (assq #t stale)))
12104 (let ((n (cdr probe)))
12106 (cgframe-used! frame))
12107 (set-car! probe #f)
12109 (let* ((cell (cgframe-size-cell frame))
12110 (n (+ 1 (car cell))))
12113 (cgframe:unused-slot frame entry)
12116 ; Public entry points.
12118 ; The runtime system requires slot 0 of a frame to contain
12119 ; a closure whose code pointer contains the return address
12121 ; To prevent slot 0 from being used for some other purpose,
12122 ; we rely on a complex trick: Slot 0 is initially stale.
12123 ; Gen-save! generates a store instruction for register 0,
12124 ; with slot 0 as the only stale slot for that instruction;
12125 ; then gen-save! clears the frame's set of stale slots, which
12126 ; prevents other store instructions from using slot 0.
12128 (define (cgframe-initial)
12134 (define cgframe-livevars cgframe:livevars)
12135 (define cgframe-livevars-set! cgframe:livevars-set!)
12137 (define (cgframe-size-cell frame)
12140 (define (cgframe-size frame)
12141 (car (cgframe-size-cell frame)))
12143 (define (cgframe-used! frame)
12144 (if (negative? (cgframe-size frame))
12145 (set-car! (cgframe-size-cell frame) 0)))
12147 ; Called only by gen-store!, gen-setstk!
12149 (define (cgframe-bind! frame var instruction)
12150 (cgframe:slots-set! frame
12151 (cons (list var #f instruction (cgframe:stale frame))
12152 (cgframe:slots frame))))
12154 ; Called only by gen-load!, gen-stack!
12156 (define (cgframe-touch! frame var)
12157 (let ((entry (assq var (cgframe:slots frame))))
12159 (let ((n (cgframe:slot.offset entry)))
12161 (let ((n (cgframe:unused-slot frame entry)))
12162 (cgframe:slot.offset-set! entry n))))
12163 (error "Compiler bug: cgframe-touch!" frame var))))
12165 (define (cgframe-rename! frame alist)
12166 (for-each (lambda (entry)
12167 (let ((probe (assq (cgframe:slot.name entry) alist)))
12169 (cgframe:slot.name-set! entry (cdr probe)))))
12170 (cgframe:slots frame)))
12172 (define (cgframe-release! frame var)
12173 (let* ((slots (cgframe:slots frame))
12174 (entry (assq var slots)))
12176 (begin (cgframe:slots-set! frame (remq entry slots))
12177 (let ((n (cgframe:slot.offset entry)))
12178 (if (and (not (eq? #f n))
12180 (cgframe:stale-set!
12183 (cgframe:stale frame)))))))))
12185 (define (cgframe-release-except! frame vars)
12186 (let loop ((slots (reverse (cgframe:slots frame)))
12188 (stale (cgframe:stale frame)))
12190 (begin (cgframe:slots-set! frame newslots)
12191 (cgframe:stale-set! frame stale))
12192 (let ((slot (car slots)))
12193 (if (memq (cgframe:slot.name slot) vars)
12195 (cons slot newslots)
12197 (let ((n (cgframe:slot.offset slot)))
12204 (cons slot newslots)
12209 (cons (cons #t n) stale))))))))))
12211 (define (cgframe-lookup frame var)
12212 (let ((entry (assq var (cgframe:slots frame))))
12214 (let ((n (cgframe:slot.offset entry)))
12216 (cgframe-touch! frame var))
12217 (list var 'frame (cgframe:slot.offset entry) '(object)))
12220 (define (cgframe-spilled? frame var)
12221 (let ((entry (assq var (cgframe:slots frame))))
12223 (let ((n (cgframe:slot.offset entry)))
12227 ; For a conditional expression, the then and else parts must be
12228 ; evaluated using separate copies of the frame environment,
12229 ; and those copies must be resolved at the join point. The
12230 ; nature of the resolution depends upon whether the conditional
12231 ; expression is in a tail position.
12233 ; Critical invariant:
12234 ; Any store instructions that are generated within either arm of the
12235 ; conditional involve variables and temporaries that are local to the
12238 ; If the conditional expression is in a tail position, then a slot
12239 ; that is stale after the test can be allocated independently by the
12240 ; two arms of the conditional. If the conditional expression is in a
12241 ; non-tail position, then the slot can be allocated independently
12242 ; provided it is not a candidate destination for any previous emitted
12243 ; store instruction.
12245 (define (cgframe-copy frame)
12248 (cons (caddr frame)
12251 (define (cgframe-update-stale! frame)
12252 (let* ((n (cgframe-size frame))
12253 (v (make-vector (+ 1 n) #t))
12254 (stale (cgframe:stale frame)))
12255 (for-each (lambda (x)
12259 (vector-set! v i #f)))))
12261 (for-each (lambda (slot)
12262 (let ((offset (cgframe:slot.offset slot)))
12264 (vector-set! v offset #f)
12265 (for-each (lambda (stale)
12267 (let ((i (cdr stale)))
12269 (vector-set! v i #f)))))
12270 (cgframe:slot.stale slot)))))
12271 (cgframe:slots frame))
12273 (stale (filter car stale)
12274 (if (vector-ref v i)
12275 (cons (cons #t i) stale)
12278 (cgframe:stale-set! frame stale)))))
12280 (define (cgframe-join! frame1 frame2)
12281 (let* ((slots1 (cgframe:slots frame1))
12282 (slots2 (cgframe:slots frame2))
12283 (slots (intersection slots1 slots2))
12284 (deadslots (append (difference slots1 slots)
12285 (difference slots2 slots)))
12286 (deadoffsets (make-set
12287 (filter (lambda (x) (not (eq? x #f)))
12288 (map cgframe:slot.offset deadslots))))
12289 (stale1 (cgframe:stale frame1))
12290 (stale2 (cgframe:stale frame2))
12291 (stale (intersection stale1 stale2))
12292 (stale (append (map (lambda (n) (cons #t n))
12295 (cgframe:slots-set! frame1 slots)
12296 (cgframe:stale-set! frame1 stale)))
12300 ; Each identifier has one of the following kinds of entry.
12302 ; (<name> register <number> (object))
12303 ; (<name> frame <slot> (object))
12304 ; (<name> lexical <rib> <offset> (object))
12305 ; (<name> procedure <rib> <label> (object))
12306 ; (<name> integrable <arity> <op> <imm> (object))
12307 ; (<name> global (object))
12311 ; An environment is represented as a list of the form
12313 ; ((<entry> ...) ; lexical rib
12316 ; where each <entry> has one of the forms
12318 ; (<name> lexical <offset> (object))
12319 ; (<name> procedure <rib> <label> (object))
12320 ; (<name> integrable <arity> <op> <imm> (object))
12322 (define entry.name car)
12323 (define entry.kind cadr)
12324 (define entry.rib caddr)
12325 (define entry.offset cadddr)
12326 (define entry.label cadddr)
12327 (define entry.regnum caddr)
12328 (define entry.slotnum caddr)
12329 (define entry.arity caddr)
12330 (define entry.op cadddr)
12331 (define (entry.imm entry) (car (cddddr entry)))
12333 (define (cgenv-initial integrable)
12334 (list (map (lambda (x)
12343 (define (cgenv-lookup env id)
12344 (define (loop ribs m)
12346 (cons id '(global (object)))
12347 (let ((x (assq id (car ribs))))
12353 (cons m (cddr x)))))
12357 (cons m (cddr x)))))
12359 (if (integrate-usual-procedures)
12363 (loop (cdr ribs) (+ m 1))))))
12366 (define (cgenv-extend env vars procs)
12367 (cons (do ((n 0 (+ n 1))
12368 (vars vars (cdr vars))
12369 (rib (map (lambda (id)
12370 (list id 'procedure (make-label) '(object)))
12372 (cons (list (car vars) 'lexical n '(object)) rib)))
12373 ((null? vars) rib))
12376 (define (cgenv-bindprocs env procs)
12377 (cons (append (map (lambda (id)
12378 (list id 'procedure (make-label) '(object)))
12383 (define (var-lookup var regs frame env)
12384 (or (cgreg-lookup regs var)
12385 (cgframe-lookup frame var)
12386 (cgenv-lookup env var)))
12392 (pass4 (pass3 (pass2 (pass1 x))) $usual-integrable-procedures$)))
12394 (define compile-block
12396 (pass4 (pass3 (pass2 (pass1-block x))) $usual-integrable-procedures$)))
12402 (pretty-print (compile x))))
12404 ; Find the smallest number of registers such that
12405 ; adding more registers does not affect the code
12406 ; generated for x (from 4 to 32 registers).
12408 (define (minregs x)
12409 (define (defregs R)
12411 (set! *lastreg* (- *nregs* 1))
12412 (set! *fullregs* (quotient *nregs* 2)))
12414 (let ((code (assemble (compile x))))
12415 (define (binary-search m1 m2)
12416 (if (= (+ m1 1) m2)
12418 (let ((midpt (quotient (+ m1 m2) 2)))
12420 (if (equal? code (assemble (compile x)))
12421 (binary-search m1 midpt)
12422 (binary-search midpt m2)))))
12424 (let ((newcode (assemble (compile x))))
12425 (if (equal? code newcode)
12427 (binary-search 4 32)))))
12436 ; fft 28 (changing the named lets to macros didn't matter)
12437 ; Copyright 1991 William Clinger
12439 ; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
12443 ; Fourth pass of the Twobit compiler:
12444 ; code generation for the MacScheme machine.
12446 ; This pass operates on input expressions described by the
12447 ; following grammar and the invariants that follow it.
12449 ; "X ..." means zero or more occurrences of X.
12451 ; L --> (lambda (I_1 ...)
12453 ; (quote (R F G <decls> <doc>)
12455 ; | (lambda (I_1 ... . I_rest)
12457 ; (quote (R F G <decls> <doc>))
12459 ; D --> (define I L)
12460 ; E --> (quote K) ; constants
12461 ; | (begin I) ; variable references
12462 ; | L ; lambda expressions
12463 ; | (E0 E1 ...) ; calls
12464 ; | (set! I E) ; assignments
12465 ; | (if E0 E1 E2) ; conditionals
12466 ; | (begin E0 E1 E2 ...) ; sequential expressions
12467 ; I --> <identifier>
12469 ; R --> ((I <references> <assignments> <calls>) ...)
12473 ; Invariants that hold for the input
12474 ; * There are no assignments except to global variables.
12475 ; * If I is declared by an internal definition, then the right hand
12476 ; side of the internal definition is a lambda expression and I
12477 ; is referenced only in the procedure position of a call.
12478 ; * Every procedure defined by an internal definition takes a
12479 ; fixed number of arguments.
12480 ; * Every call to a procedure defined by an internal definition
12481 ; passes the correct number of arguments.
12482 ; * For each lambda expression, the associated F is a list of all
12483 ; the identifiers that occur free in the body of that lambda
12484 ; expression, and possibly a few extra identifiers that were
12485 ; once free but have been removed by optimization.
12486 ; * For each lambda expression, the associated G is a subset of F
12487 ; that contains every identifier that occurs free within some
12488 ; inner lambda expression that escapes, and possibly a few that
12489 ; don't. (Assignment-elimination does not calculate G exactly.)
12490 ; * Variables named IGNORED are neither referenced nor assigned.
12491 ; * Any lambda expression that is declared to be in A-normal form
12492 ; really is in A-normal form.
12495 ; Stack frames are created by "save" instructions.
12496 ; A save instruction is generated
12498 ; * at the beginning of each lambda body
12499 ; * at the beginning of the code for each arm of a conditional,
12501 ; the conditional is in a tail position
12502 ; the frames that were allocated by the save instructions
12503 ; that dominate the arms of the conditional have not been
12504 ; used (those save instructions will be eliminated during
12507 ; The operand of a save instruction, and of its matching pop instructions,
12508 ; increases automatically as frame slots are allocated.
12510 ; The code generated to return from a procedure is
12515 ; The code generated for a tail call is
12520 ; Invariant: When the code generator reserves an argument register
12521 ; to hold a value, that value is named, and is stored into the current
12522 ; stack frame. These store instructions are eliminated during assembly
12523 ; unless there is a matching load instruction. If all of the instructions
12524 ; that store into a stack frame are eliminated, then the stack frame
12525 ; itself is eliminated.
12526 ; Exception: An argument register may be used without naming or storing
12527 ; its value provided the register is not in use and no expressions are
12528 ; evaluated while it contains the unnamed and unstored value.
12531 (define (pass4 exp integrable)
12534 (let ((output (make-assembly-stream))
12535 (frame (cgframe-initial))
12536 (regs (cgreg-initial))
12538 (assembly-stream-info! output (make-hashtable equal-hash assoc))
12539 (cgreg-bind! regs 0 t0)
12540 (gen-save! output frame t0)
12546 (cgenv-initial integrable)
12548 (pass4-code output)))
12550 (define (pass4-code output)
12551 (hashtable-for-each (lambda (situation label)
12552 (cg-trap output situation label))
12553 (assembly-stream-info output))
12554 (assembly-stream-code output))
12557 ; an assembly stream into which instructions should be emitted
12559 ; the target register
12560 ; ('result, a register number, or '#f; tail position implies 'result)
12561 ; a register environment [cgreg]
12562 ; a stack-frame environment [cgframe]
12563 ; a compile-time environment [cgenv]
12564 ; a flag indicating whether the expression is in tail position
12566 ; the target register ('result or a register number)
12568 ; may change the register and stack-frame environments
12569 ; may increase the size of the stack frame, which changes previously
12570 ; emitted instructions
12571 ; writes instructions to the assembly stream
12573 (define (cg0 output exp target regs frame env tail?)
12575 ((quote) (gen! output $const (constant.value exp))
12577 (begin (gen-pop! output frame)
12578 (gen! output $return)
12580 (cg-move output frame regs 'result target)))
12581 ((lambda) (cg-lambda output exp regs frame env)
12583 (begin (gen-pop! output frame)
12584 (gen! output $return)
12586 (cg-move output frame regs 'result target)))
12587 ((set!) (cg0 output (assignment.rhs exp) 'result regs frame env #f)
12588 (cg-assignment-result output exp target regs frame env tail?))
12589 ((if) (cg-if output exp target regs frame env tail?))
12590 ((begin) (if (variable? exp)
12591 (cg-variable output exp target regs frame env tail?)
12592 (cg-sequential output exp target regs frame env tail?)))
12593 (else (cg-call output exp target regs frame env tail?))))
12595 ; Lambda expressions that evaluate to closures.
12596 ; This is hard because the MacScheme machine's lambda instruction
12597 ; closes over the values that are in argument registers 0 through r
12598 ; (where r can be larger than *nregs*).
12599 ; The set of free variables is calculated and then sorted to minimize
12600 ; register shuffling.
12602 ; Returns: nothing.
12604 (define (cg-lambda output exp regs frame env)
12605 (let* ((args (lambda.args exp))
12606 (vars (make-null-terminated args))
12607 (free (difference (lambda.F exp) vars))
12608 (free (cg-sort-vars free regs frame env))
12609 (newenv (cgenv-extend env (cons #t free) '()))
12610 (newoutput (make-assembly-stream)))
12611 (assembly-stream-info! newoutput (make-hashtable equal-hash assoc))
12612 (gen! newoutput $.proc)
12614 (gen! newoutput $args= (length args))
12615 (gen! newoutput $args>= (- (length vars) 1)))
12616 (cg-known-lambda newoutput exp newenv)
12617 (cg-eval-vars output free regs frame env)
12620 (if (not (ignore-space-leaks))
12621 ; FIXME: Is this the right constant?
12622 (begin (gen! output $const #f)
12623 (gen! output $setreg 0)))
12626 (pass4-code newoutput)
12631 (if (not (ignore-space-leaks))
12632 ; FIXME: This load forces a stack frame to be allocated.
12633 (gen-load! output frame 0 (cgreg-lookup-reg regs 0)))))
12635 ; Given a list of free variables, filters out the ones that
12636 ; need to be copied into a closure, and sorts them into an order
12637 ; that reduces register shuffling. Returns a sorted version of
12638 ; the list in which the first element (element 0) should go
12639 ; into register 1, the second into register 2, and so on.
12641 (define (cg-sort-vars free regs frame env)
12642 (let* ((free (filter (lambda (var)
12644 (var-lookup var regs frame env))
12648 (not (ignore-space-leaks)))
12652 (m (min n (- *nregs* 1)))
12653 (vec (make-vector m #f)))
12654 (define (loop1 free free-notregister)
12656 (loop2 0 free-notregister)
12657 (let* ((var (car free))
12658 (entry (cgreg-lookup regs var)))
12660 (let ((r (entry.regnum entry)))
12662 (begin (vector-set! vec (- r 1) var)
12666 (cons var free-notregister))))
12668 (cons var free-notregister))))))
12669 (define (loop2 i free)
12670 (cond ((null? free)
12671 (vector->list vec))
12673 (append (vector->list vec) free))
12674 ((vector-ref vec i)
12675 (loop2 (+ i 1) free))
12677 (vector-set! vec i (car free))
12678 (loop2 (+ i 1) (cdr free)))))
12681 ; Fetches the given list of free variables into the corresponding
12682 ; registers in preparation for a $lambda or $lexes instruction.
12684 (define (cg-eval-vars output free regs frame env)
12685 (let ((n (length free))
12686 (R-1 (- *nregs* 1)))
12688 (begin (gen! output $const '())
12689 (gen! output $setreg R-1)
12690 (cgreg-release! regs R-1)))
12692 (vars (reverse free) (cdr vars)))
12694 (let* ((v (car vars))
12695 (entry (var-lookup v regs frame env)))
12696 (case (entry.kind entry)
12698 (let ((r1 (entry.regnum entry)))
12699 (if (not (eqv? r r1))
12701 (begin (gen! output $movereg r1 r)
12702 (cgreg-bind! regs r v))
12703 (gen! output $reg r1 v)))))
12706 (begin (gen-load! output frame r v)
12707 (cgreg-bind! regs r v))
12708 (gen-stack! output frame v)))
12710 (gen! output $lexical
12712 (entry.offset entry)
12715 (begin (gen! output $setreg r)
12716 (cgreg-bind! regs r v)
12717 (gen-store! output frame r v))))
12719 (error "Bug in cg-close-lambda")))
12721 (begin (gen! output $op2 $cons R-1)
12722 (gen! output $setreg R-1)))))))
12724 ; Lambda expressions that appear on the rhs of a definition are
12725 ; compiled here. They don't need an args= instruction at their head.
12727 ; Returns: nothing.
12729 (define (cg-known-lambda output exp env)
12730 (let* ((vars (make-null-terminated (lambda.args exp)))
12731 (regs (cgreg-initial))
12732 (frame (cgframe-initial))
12734 (if (member A-normal-form-declaration (lambda.decls exp))
12735 (cgframe-livevars-set! frame '()))
12736 (cgreg-bind! regs 0 t0)
12737 (gen-save! output frame t0)
12739 (vars vars (cdr vars)))
12742 (if (not (null? vars))
12743 (begin (gen! output $movereg *lastreg* 1)
12744 (cgreg-release! regs 1)
12745 (do ((vars vars (cdr vars)))
12747 (gen! output $reg 1)
12748 (gen! output $op1 $car:pair)
12749 (gen-setstk! output frame (car vars))
12750 (gen! output $reg 1)
12751 (gen! output $op1 $cdr:pair)
12752 (gen! output $setreg 1)))))
12753 (cgreg-bind! regs r (car vars))
12754 (gen-store! output frame r (car vars)))
12763 ; Compiles a let or lambda body.
12764 ; The arguments of the lambda expression L are already in
12765 ; registers or the stack frame, as specified by regs and frame.
12767 ; The problem here is that the free variables of an internal
12768 ; definition must be in a heap-allocated environment, so any
12769 ; such variables in registers must be copied to the heap.
12771 ; Returns: destination register.
12773 (define (cg-body output L target regs frame env tail?)
12774 (let* ((exp (lambda.body L))
12775 (defs (lambda.defs L))
12778 (let ((L (def.rhs def)))
12779 (difference (lambda.F L)
12782 (cond ((or (null? defs) (constant? exp) (variable? exp))
12783 (cg0 output exp target regs frame env tail?))
12785 (let* ((free (cg-sort-vars
12789 (make-null-terminated (lambda.args exp))))
12791 (newenv1 (cgenv-extend env
12793 (map def.lhs defs)))
12794 (args (lambda.args exp))
12795 (vars (make-null-terminated args))
12796 (newoutput (make-assembly-stream)))
12797 (assembly-stream-info! newoutput (make-hashtable equal-hash assoc))
12798 (gen! newoutput $.proc)
12800 (gen! newoutput $args= (length args))
12801 (gen! newoutput $args>= (- (length vars) 1)))
12802 (cg-known-lambda newoutput exp newenv1)
12803 (cg-defs newoutput defs newenv1)
12804 (cg-eval-vars output free regs frame env)
12807 (pass4-code newoutput)
12811 (begin (gen-pop! output frame)
12812 (gen! output $return)
12814 (cg-move output frame regs 'result target))))
12815 ((every? (lambda (def)
12816 (every? (lambda (v)
12818 (var-lookup v regs frame env))
12819 ((register frame) #f)
12821 (let ((Ldef (def.rhs def)))
12822 (difference (lambda.F Ldef)
12823 (lambda.args Ldef)))))
12825 (let* ((newenv (cgenv-bindprocs env (map def.lhs defs)))
12827 (r (cg0 output exp target regs frame newenv tail?)))
12829 (gen! output $skip L (cgreg-live regs r)))
12830 (cg-defs output defs newenv)
12832 (gen! output $.label L))
12835 (let ((free (cg-sort-vars free regs frame env)))
12836 (cg-eval-vars output free regs frame env)
12837 ; FIXME: Have to restore it too!
12839 (if (not (ignore-space-leaks))
12840 ; FIXME: Is this constant the right one?
12841 (begin (gen! output $const #f)
12842 (gen! output $setreg 0)))
12843 (let ((t0 (cgreg-lookup-reg regs 0))
12845 (newenv (cgenv-extend env
12847 (map def.lhs defs)))
12849 (gen! output $lexes (length free) free)
12850 (gen! output $setreg 0)
12851 (cgreg-bind! regs 0 t1)
12853 (begin (cgframe-release! frame t0)
12854 (gen-store! output frame 0 t1)
12855 (cg0 output exp 'result regs frame newenv #t)
12856 (cg-defs output defs newenv)
12858 (begin (gen-store! output frame 0 t1)
12859 (cg0 output exp 'result regs frame newenv #f)
12860 (gen! output $skip L (cgreg-tos regs))
12861 (cg-defs output defs newenv)
12862 (gen! output $.label L)
12863 (gen-load! output frame 0 t0)
12864 (cgreg-bind! regs 0 t0)
12865 (cgframe-release! frame t1)
12866 (cg-move output frame regs 'result target)))))))))
12868 (define (cg-defs output defs env)
12869 (for-each (lambda (def)
12870 (gen! output $.align 4)
12871 (gen! output $.label
12873 (cgenv-lookup env (def.lhs def))))
12874 (gen! output $.proc)
12875 (gen! output $.proc-doc (lambda.doc (def.rhs def)))
12876 (cg-known-lambda output
12881 ; The right hand side has already been evaluated into the result register.
12883 (define (cg-assignment-result output exp target regs frame env tail?)
12884 (gen! output $setglbl (assignment.lhs exp))
12886 (begin (gen-pop! output frame)
12887 (gen! output $return)
12889 (cg-move output frame regs 'result target)))
12891 (define (cg-if output exp target regs frame env tail?)
12892 ; The test can be a constant, because it is awkward
12893 ; to remove constant tests from an A-normal form.
12894 (if (constant? (if.test exp))
12896 (if (constant.value (if.test exp))
12899 target regs frame env tail?)
12901 (cg0 output (if.test exp) 'result regs frame env #f)
12902 (cg-if-result output exp target regs frame env tail?))))
12904 ; The test expression has already been evaluated into the result register.
12906 (define (cg-if-result output exp target regs frame env tail?)
12907 (let ((L1 (make-label))
12909 (gen! output $branchf L1 (cgreg-tos regs))
12910 (let* ((regs2 (cgreg-copy regs))
12911 (frame1 (if (and tail?
12912 (negative? (cgframe-size frame)))
12915 (frame2 (if (eq? frame frame1)
12916 (cgframe-copy frame1)
12917 (cgframe-initial)))
12918 (t0 (cgreg-lookup-reg regs 0)))
12919 (if (not (eq? frame frame1))
12920 (let ((live (cgframe-livevars frame)))
12921 (cgframe-livevars-set! frame1 live)
12922 (cgframe-livevars-set! frame2 live)
12923 (gen-save! output frame1 t0)
12924 (cg-saveregs output regs frame1)))
12925 (let ((r (cg0 output (if.then exp) target regs frame1 env tail?)))
12927 (gen! output $skip L2 (cgreg-live regs r)))
12928 (gen! output $.label L1)
12929 (if (not (eq? frame frame1))
12930 (begin (gen-save! output frame2 t0)
12931 (cg-saveregs output regs2 frame2))
12932 (cgframe-update-stale! frame2))
12933 (cg0 output (if.else exp) r regs2 frame2 env tail?)
12935 (begin (gen! output $.label L2)
12936 (cgreg-join! regs regs2)
12937 (cgframe-join! frame1 frame2)))
12938 (if (and (not target)
12939 (not (eq? r 'result))
12940 (not (cgreg-lookup-reg regs r)))
12941 (cg-move output frame regs r 'result)
12944 (define (cg-variable output exp target regs frame env tail?)
12945 (define (return id)
12947 (begin (gen-pop! output frame)
12948 (gen! output $return)
12951 (not (eq? 'result target)))
12952 (begin (gen! output $setreg target)
12953 (cgreg-bind! regs target id)
12954 (gen-store! output frame target id)
12957 ; Same as return, but doesn't emit a store instruction.
12958 (define (return-nostore id)
12960 (begin (gen-pop! output frame)
12961 (gen! output $return)
12964 (not (eq? 'result target)))
12965 (begin (gen! output $setreg target)
12966 (cgreg-bind! regs target id)
12969 (let* ((id (variable.name exp))
12970 (entry (var-lookup id regs frame env)))
12971 (case (entry.kind entry)
12972 ((global integrable)
12973 (gen! output $global id)
12974 (return (newtemp)))
12976 (let ((m (entry.rib entry))
12977 (n (entry.offset entry)))
12978 (gen! output $lexical m n id)
12980 (negative? (cgframe-size frame)))
12981 (return-nostore id)
12983 ((procedure) (error "Bug in cg-variable" exp))
12985 (let ((r (entry.regnum entry)))
12987 (and target (not (eqv? target r))))
12988 (begin (gen! output $reg (entry.regnum entry) id)
12989 (return-nostore id))
12992 (cond ((eq? target 'result)
12993 (gen-stack! output frame id)
12996 ; Must be non-tail.
12997 (gen-load! output frame target id)
12998 (cgreg-bind! regs target id)
13001 ; Must be non-tail.
13002 (let ((r (choose-register regs frame)))
13003 (gen-load! output frame r id)
13004 (cgreg-bind! regs r id)
13006 (else (error "Bug in cg-variable" exp)))))
13008 (define (cg-sequential output exp target regs frame env tail?)
13009 (cg-sequential-loop output (begin.exprs exp) target regs frame env tail?))
13011 (define (cg-sequential-loop output exprs target regs frame env tail?)
13012 (cond ((null? exprs)
13013 (gen! output $const unspecified)
13015 (begin (gen-pop! output frame)
13016 (gen! output $return)
13018 (cg-move output frame regs 'result target)))
13019 ((null? (cdr exprs))
13020 (cg0 output (car exprs) target regs frame env tail?))
13021 (else (cg0 output (car exprs) #f regs frame env #f)
13022 (cg-sequential-loop output
13024 target regs frame env tail?))))
13026 (define (cg-saveregs output regs frame)
13028 (vars (cdr (cgreg-vars regs)) (cdr vars)))
13030 (let ((t (car vars)))
13032 (gen-store! output frame i t)))))
13034 (define (cg-move output frame regs src dst)
13036 (let ((temp (newtemp)))
13037 (cgreg-bind! regs dst temp)
13038 (gen-store! output frame dst temp)
13045 (gen! output $reg src)
13048 (gen! output $setreg dst)
13050 ((and (not (zero? src))
13052 (gen! output $movereg src dst)
13055 (gen! output $reg src)
13056 (gen! output $setreg dst)
13059 ; On-the-fly register allocator.
13060 ; Tries to allocate:
13061 ; a hardware register that isn't being used
13062 ; a hardware register whose contents have already been spilled
13063 ; a software register that isn't being used, unless a stack
13064 ; frame has already been created, in which case it is better to use
13065 ; a hardware register that is in use and hasn't yet been spilled
13067 ; All else equal, it is better to allocate a higher-numbered register
13068 ; because the lower-numbered registers are targets when arguments
13069 ; are being evaluated.
13071 ; Invariant: Every register that is returned by this allocator
13072 ; is either not in use or has been spilled.
13074 (define (choose-register regs frame)
13075 (car (choose-registers regs frame 1)))
13077 (define (choose-registers regs frame n)
13079 ; Find unused hardware registers.
13080 (define (loop1 i n good)
13084 (if (negative? (cgframe-size frame))
13086 (loop2 (- *nhwregs* 1) n good)))
13088 (if (cgreg-lookup-reg regs i)
13089 (loop1 (- i 1) n good)
13094 ; Find already spilled hardware registers.
13095 (define (loop2 i n good)
13101 (let ((t (cgreg-lookup-reg regs i)))
13102 (if (and t (cgframe-spilled? frame t))
13106 (loop2 (- i 1) n good))))))
13108 ; This is ridiculous.
13109 ; Fortunately the correctness of the compiler is independent
13110 ; of the predicate used for this sort.
13113 (let* ((frame-exists? (not (negative? (cgframe-size frame))))
13116 (let* ((t (cgreg-lookup-reg regs r))
13119 (cgframe-spilled? frame t))))
13120 (list r t spilled?)))
13121 (cdr (iota *nregs*))))
13125 (let ((r1 (car x1))
13129 (cond ((< r1 *nhwregs*)
13130 (cond ((not t1) #t)
13132 (cond ((not t2) #f)
13140 (cond (frame-exists? #f)
13145 (if (and (caddr x1)
13152 ; FIXME: What was this for?
13154 (for-each (lambda (register)
13155 (let ((t (cadr register))
13156 (spilled? (caddr register)))
13157 (if (and t (not spilled?))
13158 (cgframe-touch! frame t))))
13160 (do ((sorted (map car registers) (cdr sorted))
13161 (rs '() (cons (car sorted) rs))
13167 (loop1 (- *nhwregs* 1) n '())
13168 (error (string-append "Compiler bug: can't allocate "
13170 " registers on this target."))))
13171 ; Copyright 1991 William Clinger
13173 ; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
13179 (define (cg-call output exp target regs frame env tail?)
13180 (let ((proc (call.proc exp)))
13181 (cond ((and (lambda? proc)
13182 (list? (lambda.args proc)))
13183 (cg-let output exp target regs frame env tail?))
13184 ((not (variable? proc))
13185 (cg-unknown-call output exp target regs frame env tail?))
13187 (var-lookup (variable.name proc) regs frame env)))
13188 (case (entry.kind entry)
13189 ((global lexical frame register)
13190 (cg-unknown-call output
13192 target regs frame env tail?))
13194 (cg-integrable-call output
13196 target regs frame env tail?))
13198 (cg-known-call output
13200 target regs frame env tail?))
13201 (else (error "Bug in cg-call" exp))))))))
13203 (define (cg-unknown-call output exp target regs frame env tail?)
13204 (let* ((proc (call.proc exp))
13205 (args (call.args exp))
13208 (cond ((>= (+ n 1) *lastreg*)
13209 (cg-big-call output exp target regs frame env tail?))
13211 (let ((r0 (cgreg-lookup-reg regs 0)))
13212 (if (variable? proc)
13213 (let ((entry (cgreg-lookup regs (variable.name proc))))
13215 (<= (entry.regnum entry) n))
13216 (begin (cg-arguments output
13218 (append args (list proc))
13220 (gen! output $reg (+ n 1)))
13221 (begin (cg-arguments output
13225 (cg0 output proc 'result regs frame env #f)))
13227 (gen-pop! output frame)
13228 (begin (cgframe-used! frame)
13229 (gen! output $setrtn L)))
13230 (gen! output $invoke n))
13231 (begin (cg-arguments output
13233 (append args (list proc))
13235 (gen! output $reg (+ n 1))
13237 (gen-pop! output frame)
13238 (begin (cgframe-used! frame)
13239 (gen! output $setrtn L)))
13240 (gen! output $invoke n)))
13243 (begin (gen! output $.align 4)
13244 (gen! output $.label L)
13245 (gen! output $.cont)
13246 (cgreg-clear! regs)
13247 (cgreg-bind! regs 0 r0)
13248 (gen-load! output frame 0 r0)
13249 (cg-move output frame regs 'result target))))))))
13251 (define (cg-known-call output exp target regs frame env tail?)
13252 (let* ((args (call.args exp))
13255 (cond ((>= (+ n 1) *lastreg*)
13256 (cg-big-call output exp target regs frame env tail?))
13258 (let ((r0 (cgreg-lookup-reg regs 0)))
13259 (cg-arguments output (iota1 n) args regs frame env)
13261 (gen-pop! output frame)
13262 (begin (cgframe-used! frame)
13263 (gen! output $setrtn L)))
13264 (let* ((entry (cgenv-lookup env (variable.name (call.proc exp))))
13265 (label (entry.label entry))
13266 (m (entry.rib entry)))
13268 (gen! output $branch label n)
13269 (gen! output $jump m label n)))
13272 (begin (gen! output $.align 4)
13273 (gen! output $.label L)
13274 (gen! output $.cont)
13275 (cgreg-clear! regs)
13276 (cgreg-bind! regs 0 r0)
13277 (gen-load! output frame 0 r0)
13278 (cg-move output frame regs 'result target))))))))
13280 ; Any call can be compiled as follows, even if there are no free registers.
13282 ; Let T0, T1, ..., Tn be newly allocated stack temporaries.
13288 ; ... |- evaluate args into stack frame
13296 ; ... |- cons up overflow args
13302 ; ... |- pop remaining args into registers
13308 (define (cg-big-call output exp target regs frame env tail?)
13309 (let* ((proc (call.proc exp))
13310 (args (call.args exp))
13312 (argslots (newtemps n))
13313 (procslot (newtemp))
13314 (r0 (cgreg-lookup-reg regs 0))
13315 (R-1 (- *nregs* 1))
13316 (entry (if (variable? proc)
13318 (var-lookup (variable.name proc)
13320 (if (eq? (entry.kind entry) 'procedure)
13327 (cg0 output proc 'result regs frame env #f)
13328 (gen-setstk! output frame procslot)))
13329 (for-each (lambda (arg argslot)
13330 (cg0 output arg 'result regs frame env #f)
13331 (gen-setstk! output frame argslot))
13334 (cgreg-clear! regs)
13335 (gen! output $const '())
13336 (gen! output $setreg R-1)
13338 (slots (reverse argslots) (cdr slots)))
13341 (gen-load! output frame i (car slots))
13342 (begin (gen-stack! output frame (car slots))
13343 (gen! output $op2 $cons R-1)
13344 (gen! output $setreg R-1))))
13346 (gen-stack! output frame procslot))
13348 (gen-pop! output frame)
13349 (begin (cgframe-used! frame)
13350 (gen! output $setrtn L)))
13352 (let ((label (entry.label entry))
13353 (m (entry.rib entry)))
13355 (gen! output $branch label n)
13356 (gen! output $jump m label n)))
13357 (gen! output $invoke n))
13360 (begin (gen! output $.align 4)
13361 (gen! output $.label L)
13362 (gen! output $.cont)
13363 (cgreg-clear! regs) ; redundant, see above
13364 (cgreg-bind! regs 0 r0)
13365 (gen-load! output frame 0 r0)
13366 (cg-move output frame regs 'result target)))))
13368 (define (cg-integrable-call output exp target regs frame env tail?)
13369 (let ((args (call.args exp))
13370 (entry (var-lookup (variable.name (call.proc exp)) regs frame env)))
13371 (if (= (entry.arity entry) (length args))
13372 (begin (case (entry.arity entry)
13373 ((0) (gen! output $op1 (entry.op entry)))
13374 ((1) (cg0 output (car args) 'result regs frame env #f)
13375 (gen! output $op1 (entry.op entry)))
13376 ((2) (cg-integrable-call2 output
13380 ((3) (cg-integrable-call3 output
13384 (else (error "Bug detected by cg-integrable-call"
13385 (make-readable exp))))
13387 (begin (gen-pop! output frame)
13388 (gen! output $return)
13390 (cg-move output frame regs 'result target)))
13391 (if (negative? (entry.arity entry))
13392 (cg-special output exp target regs frame env tail?)
13393 (error "Wrong number of arguments to integrable procedure"
13394 (make-readable exp))))))
13396 (define (cg-integrable-call2 output entry args regs frame env)
13397 (let ((op (entry.op entry)))
13398 (if (and (entry.imm entry)
13399 (constant? (cadr args))
13400 ((entry.imm entry) (constant.value (cadr args))))
13401 (begin (cg0 output (car args) 'result regs frame env #f)
13402 (gen! output $op2imm
13404 (constant.value (cadr args))))
13405 (let* ((reg2 (cg0 output (cadr args) #f regs frame env #f))
13406 (r2 (choose-register regs frame))
13407 (t2 (if (eq? reg2 'result)
13408 (let ((t2 (newtemp)))
13409 (gen! output $setreg r2)
13410 (cgreg-bind! regs r2 t2)
13411 (gen-store! output frame r2 t2)
13413 (cgreg-lookup-reg regs reg2))))
13414 (cg0 output (car args) 'result regs frame env #f)
13415 (let* ((r2 (or (let ((entry (cgreg-lookup regs t2)))
13417 (entry.regnum entry)
13419 (let ((r2 (choose-register regs frame)))
13420 (cgreg-bind! regs r2 t2)
13421 (gen-load! output frame r2 t2)
13423 (gen! output $op2 (entry.op entry) r2)
13424 (if (eq? reg2 'result)
13425 (begin (cgreg-release! regs r2)
13426 (cgframe-release! frame t2)))))))
13429 (define (cg-integrable-call3 output entry args regs frame env)
13430 (let* ((reg2 (cg0 output (cadr args) #f regs frame env #f))
13431 (r2 (choose-register regs frame))
13432 (t2 (if (eq? reg2 'result)
13433 (let ((t2 (newtemp)))
13434 (gen! output $setreg r2)
13435 (cgreg-bind! regs r2 t2)
13436 (gen-store! output frame r2 t2)
13438 (cgreg-lookup-reg regs reg2)))
13439 (reg3 (cg0 output (caddr args) #f regs frame env #f))
13440 (spillregs (choose-registers regs frame 2))
13441 (t3 (if (eq? reg3 'result)
13442 (let ((t3 (newtemp))
13443 (r3 (if (eq? t2 (cgreg-lookup-reg
13444 regs (car spillregs)))
13447 (gen! output $setreg r3)
13448 (cgreg-bind! regs r3 t3)
13449 (gen-store! output frame r3 t3)
13451 (cgreg-lookup-reg regs reg3))))
13452 (cg0 output (car args) 'result regs frame env #f)
13453 (let* ((spillregs (choose-registers regs frame 2))
13454 (r2 (or (let ((entry (cgreg-lookup regs t2)))
13456 (entry.regnum entry)
13458 (let ((r2 (car spillregs)))
13459 (cgreg-bind! regs r2 t2)
13460 (gen-load! output frame r2 t2)
13462 (r3 (or (let ((entry (cgreg-lookup regs t3)))
13464 (entry.regnum entry)
13466 (let ((r3 (if (eq? r2 (car spillregs))
13469 (cgreg-bind! regs r3 t3)
13470 (gen-load! output frame r3 t3)
13472 (gen! output $op3 (entry.op entry) r2 r3)
13473 (if (eq? reg2 'result)
13474 (begin (cgreg-release! regs r2)
13475 (cgframe-release! frame t2)))
13476 (if (eq? reg3 'result)
13477 (begin (cgreg-release! regs r3)
13478 (cgframe-release! frame t3)))))
13481 ; Given a short list of expressions that can be evaluated in any order,
13482 ; evaluates the first into the result register and the others into any
13483 ; register, and returns an ordered list of the registers that contain
13484 ; the arguments that follow the first.
13485 ; The number of expressions must be less than the number of argument
13488 (define (cg-primop-args output args regs frame env)
13490 ; Given a list of expressions to evaluate, a list of variables
13491 ; and temporary names for arguments that have already been
13492 ; evaluated, in reverse order, and a mask of booleans that
13493 ; indicate which temporaries should be released before returning,
13494 ; returns the correct result.
13496 (define (eval-loop args temps mask)
13498 (eval-first-into-result temps mask)
13499 (let ((reg (cg0 output (car args) #f regs frame env #f)))
13500 (if (eq? reg 'result)
13501 (let* ((r (choose-register regs frame))
13503 (gen! output $setreg r)
13504 (cgreg-bind! regs r t)
13505 (gen-store! output frame r t)
13506 (eval-loop (cdr args)
13509 (eval-loop (cdr args)
13510 (cons (cgreg-lookup-reg regs reg) temps)
13511 (cons #f mask))))))
13513 (define (eval-first-into-result temps mask)
13514 (cg0 output (car args) 'result regs frame env #f)
13515 (finish-loop (choose-registers regs frame (length temps))
13520 ; Given a sufficient number of disjoint registers, a list of
13521 ; variable and temporary names that may need to be loaded into
13522 ; registers, a mask of booleans that indicates which temporaries
13523 ; should be released, and a list of registers in forward order,
13524 ; returns the correct result.
13526 (define (finish-loop disjoint temps mask registers)
13529 (let* ((t (car temps))
13530 (entry (cgreg-lookup regs t)))
13532 (let ((r (entry.regnum entry)))
13534 (begin (cgreg-release! regs r)
13535 (cgframe-release! frame t)))
13536 (finish-loop disjoint
13539 (cons r registers)))
13540 (let ((r (car disjoint)))
13541 (if (memv r registers)
13542 (finish-loop (cdr disjoint) temps mask registers)
13543 (begin (gen-load! output frame r t)
13544 (cgreg-bind! regs r t)
13546 (begin (cgreg-release! regs r)
13547 (cgframe-release! frame t)))
13548 (finish-loop disjoint
13551 (cons r registers)))))))))
13553 (if (< (length args) *nregs*)
13554 (eval-loop (cdr args) '() '())
13555 (error "Bug detected by cg-primop-args" args)))
13558 ; Parallel assignment.
13560 ; Given a list of target registers, a list of expressions, and a
13561 ; compile-time environment, generates code to evaluate the expressions
13562 ; into the registers.
13564 ; Argument evaluation proceeds as follows:
13566 ; 1. Evaluate all but one of the complicated arguments.
13567 ; 2. Evaluate remaining arguments.
13568 ; 3. Load spilled arguments from stack.
13570 (define (cg-arguments output targets args regs frame env)
13572 ; Sorts the args and their targets into complicated and
13573 ; uncomplicated args and targets.
13574 ; Then it calls evalargs.
13576 (define (sortargs targets args targets1 args1 targets2 args2)
13578 (evalargs targets1 args1 targets2 args2)
13579 (let ((target (car targets))
13581 (targets (cdr targets))
13583 (if (complicated? arg env)
13586 (cons target targets1)
13594 (cons target targets2)
13595 (cons arg args2))))))
13597 ; Given the complicated args1 and their targets1,
13598 ; and the uncomplicated args2 and their targets2,
13599 ; evaluates all the arguments into their target registers.
13601 (define (evalargs targets1 args1 targets2 args2)
13602 (let* ((temps1 (newtemps (length targets1)))
13603 (temps2 (newtemps (length targets2))))
13604 (if (not (null? args1))
13605 (for-each (lambda (arg temp)
13606 (cg0 output arg 'result regs frame env #f)
13607 (gen-setstk! output frame temp))
13610 (if (not (null? args1))
13611 (evalargs0 (cons (car targets1) targets2)
13612 (cons (car args1) args2)
13613 (cons (car temps1) temps2))
13614 (evalargs0 targets2 args2 temps2))
13615 (for-each (lambda (r t)
13616 (let ((temp (cgreg-lookup-reg regs r)))
13617 (if (not (eq? temp t))
13618 (let ((entry (var-lookup t regs frame env)))
13619 (case (entry.kind entry)
13621 (gen! output $movereg (entry.regnum entry) r))
13623 (gen-load! output frame r t)))
13624 (cgreg-bind! regs r t)))
13625 (cgframe-release! frame t)))
13626 (append targets1 targets2)
13627 (append temps1 temps2))))
13629 (define (evalargs0 targets args temps)
13630 (if (not (null? targets))
13631 (let ((para (let* ((regvars (map (lambda (reg)
13632 (cgreg-lookup-reg regs reg))
13634 (parallel-assignment targets
13635 (map cons regvars targets)
13638 (let ((targets para)
13639 (args (cg-permute args targets para))
13640 (temps (cg-permute temps targets para)))
13641 (for-each (lambda (arg r t)
13642 (cg0 output arg r regs frame env #f)
13643 (cgreg-bind! regs r t)
13644 (gen-store! output frame r t))
13648 (let ((r (choose-register regs frame))
13650 (cg0 output (car args) r regs frame env #f)
13651 (cgreg-bind! regs r t)
13652 (gen-store! output frame r t)
13653 (evalargs0 (cdr targets)
13657 (if (parallel-assignment-optimization)
13658 (sortargs (reverse targets) (reverse args) '() '() '() '())
13659 (cg-evalargs output targets args regs frame env)))
13661 ; Left-to-right evaluation of arguments directly into targets.
13663 (define (cg-evalargs output targets args regs frame env)
13664 (let ((temps (newtemps (length targets))))
13665 (for-each (lambda (arg r t)
13666 (cg0 output arg r regs frame env #f)
13667 (cgreg-bind! regs r t)
13668 (gen-store! output frame r t))
13672 (for-each (lambda (r t)
13673 (let ((temp (cgreg-lookup-reg regs r)))
13674 (if (not (eq? temp t))
13675 (begin (gen-load! output frame r t)
13676 (cgreg-bind! regs r t)))
13677 (cgframe-release! frame t)))
13681 ; For heuristic use only.
13682 ; An expression is complicated unless it can probably be evaluated
13683 ; without saving and restoring any registers, even if it occurs in
13684 ; a non-tail position.
13686 (define (complicated? exp env)
13690 ((set!) (complicated? (assignment.rhs exp) env))
13691 ((if) (or (complicated? (if.test exp) env)
13692 (complicated? (if.then exp) env)
13693 (complicated? (if.else exp) env)))
13694 ((begin) (if (variable? exp)
13696 (some? (lambda (exp)
13697 (complicated? exp env))
13698 (begin.exprs exp))))
13699 (else (let ((proc (call.proc exp)))
13700 (if (and (variable? proc)
13702 (cgenv-lookup env (variable.name proc))))
13703 (eq? (entry.kind entry) 'integrable)))
13704 (some? (lambda (exp)
13705 (complicated? exp env))
13709 ; Returns a permutation of the src list, permuted the same way the
13710 ; key list was permuted to obtain newkey.
13712 (define (cg-permute src key newkey)
13713 (let ((alist (map cons key (iota (length key)))))
13714 (do ((newkey newkey (cdr newkey))
13716 (cons (list-ref src (cdr (assq (car newkey) alist)))
13718 ((null? newkey) (reverse dest)))))
13720 ; Given a list of register numbers,
13721 ; an association list with entries of the form (name . regnum) giving
13722 ; the variable names by which those registers are known in code,
13723 ; and a list of expressions giving new values for those registers,
13724 ; returns an ordering of the register assignments that implements a
13725 ; parallel assignment if one can be found, otherwise returns #f.
13727 (define parallel-assignment
13728 (lambda (regnums alist exps)
13729 (if (null? regnums)
13731 (let ((x (toposort (dependency-graph regnums alist exps))))
13732 (if x (reverse x) #f)))))
13734 (define dependency-graph
13735 (lambda (regnums alist exps)
13736 (let ((names (map car alist)))
13737 (do ((regnums regnums (cdr regnums))
13738 (exps exps (cdr exps))
13739 (l '() (cons (cons (car regnums)
13740 (map (lambda (var) (cdr (assq var alist)))
13741 (intersection (freevariables (car exps))
13744 ((null? regnums) l)))))
13746 ; Given a nonempty graph represented as a list of the form
13747 ; ((node1 . <list of nodes that node1 is less than or equal to>)
13748 ; (node2 . <list of nodes that node2 is less than or equal to>)
13750 ; returns a topological sort of the nodes if one can be found,
13751 ; otherwise returns #f.
13755 (cond ((null? (cdr graph)) (list (caar graph)))
13756 (else (toposort2 graph '())))))
13759 (lambda (totry tried)
13760 (cond ((null? totry) #f)
13761 ((or (null? (cdr (car totry)))
13762 (and (null? (cddr (car totry)))
13763 (eq? (cadr (car totry))
13764 (car (car totry)))))
13765 (if (and (null? (cdr totry)) (null? tried))
13766 (list (caar totry))
13767 (let* ((node (caar totry))
13768 (x (toposort2 (map (lambda (y)
13769 (cons (car y) (remove node (cdr y))))
13770 (append (cdr totry) tried))
13775 (else (toposort2 (cdr totry) (cons (car totry) tried))))))
13777 (define iota (lambda (n) (iota2 n '())))
13779 (define iota1 (lambda (n) (cdr (iota2 (+ n 1) '()))))
13786 (iota2 n (cons n l))))))
13788 (define (freevariables exp)
13789 (freevars2 exp '()))
13791 (define (freevars2 exp env)
13792 (cond ((symbol? exp)
13793 (if (memq exp env) '() (list exp)))
13794 ((not (pair? exp)) '())
13795 (else (let ((keyword (car exp)))
13796 (cond ((eq? keyword 'quote) '())
13797 ((eq? keyword 'lambda)
13798 (let ((env (append (make-null-terminated (cadr exp))
13801 (map (lambda (x) (freevars2 x env))
13803 ((memq keyword '(if set! begin))
13805 (map (lambda (x) (freevars2 x env))
13808 (map (lambda (x) (freevars2 x env))
13810 ; Copyright 1991 William Clinger (cg-let and cg-let-body)
13811 ; Copyright 1999 William Clinger (everything else)
13815 ; Generates code for a let expression.
13817 (define (cg-let output exp target regs frame env tail?)
13818 (let* ((proc (call.proc exp))
13819 (vars (lambda.args proc))
13821 (free (lambda.F proc))
13822 (live (cgframe-livevars frame)))
13823 (if (and (null? (lambda.defs proc))
13825 (cg-let1 output exp target regs frame env tail?)
13826 (let* ((args (call.args exp))
13827 (temps (newtemps n))
13828 (alist (map cons temps vars)))
13829 (for-each (lambda (arg t)
13830 (let ((r (choose-register regs frame)))
13831 (cg0 output arg r regs frame env #f)
13832 (cgreg-bind! regs r t)
13833 (gen-store! output frame r t)))
13836 (cgreg-rename! regs alist)
13837 (cgframe-rename! frame alist)
13838 (cg-let-release! free live regs frame tail?)
13839 (cg-let-body output proc target regs frame env tail?)))))
13841 ; Given the free variables of a let body, and the variables that are
13842 ; live after the let expression, and the usual regs, frame, and tail?
13843 ; arguments, releases any registers and frame slots that don't need
13844 ; to be preserved across the body of the let.
13846 (define (cg-let-release! free live regs frame tail?)
13847 ; The tail case is easy because there are no live temporaries,
13848 ; and there are no free variables in the context.
13849 ; The non-tail case assumes A-normal form.
13851 (let ((keepers (cons (cgreg-lookup-reg regs 0) free)))
13852 (cgreg-release-except! regs keepers)
13853 (cgframe-release-except! frame keepers)))
13855 (let ((keepers (cons (cgreg-lookup-reg regs 0)
13856 (union live free))))
13857 (cgreg-release-except! regs keepers)
13858 (cgframe-release-except! frame keepers)))))
13860 ; Generates code for the body of a let.
13862 (define (cg-let-body output L target regs frame env tail?)
13863 (let ((vars (lambda.args L))
13864 (free (lambda.F L))
13865 (live (cgframe-livevars frame)))
13866 (let ((r (cg-body output L target regs frame env tail?)))
13867 (for-each (lambda (v)
13868 (let ((entry (cgreg-lookup regs v)))
13870 (cgreg-release! regs (entry.regnum entry)))
13871 (cgframe-release! frame v)))
13873 (if (and (not target)
13874 (not (eq? r 'result))
13875 (not (cgreg-lookup-reg regs r)))
13876 (cg-move output frame regs r 'result)
13879 ; Generates code for a let expression that binds exactly one variable
13880 ; and has no internal definitions. These let expressions are very
13881 ; common in A-normal form, and there are many special cases with
13882 ; respect to register allocation and order of evaluation.
13884 (define (cg-let1 output exp target regs frame env tail?)
13885 (let* ((proc (call.proc exp))
13886 (v (car (lambda.args proc)))
13887 (arg (car (call.args exp)))
13888 (free (lambda.F proc))
13889 (live (cgframe-livevars frame))
13890 (body (lambda.body proc)))
13892 (define (evaluate-into-register r)
13893 (cg0 output arg r regs frame env #f)
13894 (cgreg-bind! regs r v)
13895 (gen-store! output frame r v)
13898 (define (release-registers!)
13899 (cgframe-livevars-set! frame live)
13900 (cg-let-release! free live regs frame tail?))
13903 (release-registers!)
13904 (cg-let-body output proc target regs frame env tail?))
13907 (cgframe-livevars-set! frame (union live free)))
13909 (cond ((assq v *regnames*)
13910 (evaluate-into-register (cdr (assq v *regnames*)))
13912 ((not (memq v free))
13913 (cg0 output arg #f regs frame env #f)
13916 (cg0 output arg 'result regs frame env #f)
13917 (release-registers!)
13918 (cg-let1-result output exp target regs frame env tail?))
13920 (evaluate-into-register (choose-register regs frame))
13923 ; Given a let expression that binds one variable whose value has already
13924 ; been evaluated into the result register, generates code for the rest
13925 ; of the let expression.
13926 ; The main difficulty is an unfortunate interaction between A-normal
13927 ; form and the MacScheme machine architecture: We don't want to move
13928 ; a value from the result register into a general register if it has
13929 ; only one use and can remain in the result register until that use.
13931 (define (cg-let1-result output exp target regs frame env tail?)
13932 (let* ((proc (call.proc exp))
13933 (v (car (lambda.args proc)))
13934 (free (lambda.F proc))
13935 (live (cgframe-livevars frame))
13936 (body (lambda.body proc))
13937 (pattern (cg-let-used-once v body)))
13939 (define (move-to-register r)
13940 (gen! output $setreg r)
13941 (cgreg-bind! regs r v)
13942 (gen-store! output frame r v)
13945 (define (release-registers!)
13946 (cgframe-livevars-set! frame live)
13947 (cg-let-release! free live regs frame tail?))
13949 ; FIXME: The live variables must be correct in the frame.
13953 (cg-if-result output body target regs frame env tail?))
13956 (cgframe-livevars-set! frame (union live free)))
13957 (cg-if-result output
13958 (car (call.args body))
13959 'result regs frame env #f)
13960 (release-registers!)
13961 (cg-let1-result output body target regs frame env tail?))
13963 (cg-assignment-result output
13964 body target regs frame env tail?))
13966 (cg-assignment-result output
13967 (car (call.args body))
13968 'result regs frame env #f)
13969 (cg-let1-result output body target regs frame env tail?))
13971 (cg-primop-result output body target regs frame env tail?))
13973 (cg-primop-result output
13974 (car (call.args body))
13975 'result regs frame env #f)
13976 (cg-let1-result output body target regs frame env tail?))
13979 (cg-call-result output body target regs frame env tail?))
13982 (cg-call-result output
13983 (car (call.args body))
13984 'result regs frame env #f)
13985 (cg-let1-result output body target regs frame env tail?))
13987 ; FIXME: The first case was handled by cg-let1.
13988 (cond ((assq v *regnames*)
13989 (move-to-register (cdr (assq v *regnames*))))
13991 (move-to-register (choose-register regs frame))))
13992 (cg-let-body output proc target regs frame env tail?)))))
13994 ; Given a call to a primop whose first argument has already been
13995 ; evaluated into the result register and whose remaining arguments
13996 ; consist of constants and variable references, generates code for
13999 (define (cg-primop-result output exp target regs frame env tail?)
14000 (let ((args (call.args exp))
14001 (entry (var-lookup (variable.name (call.proc exp)) regs frame env)))
14002 (if (= (entry.arity entry) (length args))
14003 (begin (case (entry.arity entry)
14004 ((0) (gen! output $op1 (entry.op entry)))
14005 ((1) (gen! output $op1 (entry.op entry)))
14006 ((2) (cg-primop2-result! output entry args regs frame env))
14007 ((3) (let ((rs (cg-result-args output args regs frame env)))
14009 $op3 (entry.op entry) (car rs) (cadr rs))))
14010 (else (error "Bug detected by cg-primop-result"
14011 (make-readable exp))))
14013 (begin (gen-pop! output frame)
14014 (gen! output $return)
14016 (cg-move output frame regs 'result target)))
14017 (if (negative? (entry.arity entry))
14018 (cg-special-result output exp target regs frame env tail?)
14019 (error "Wrong number of arguments to integrable procedure"
14020 (make-readable exp))))))
14022 (define (cg-primop2-result! output entry args regs frame env)
14023 (let ((op (entry.op entry))
14024 (arg2 (cadr args)))
14025 (if (and (constant? arg2)
14027 ((entry.imm entry) (constant.value arg2)))
14028 (gen! output $op2imm op (constant.value arg2))
14029 (let ((rs (cg-result-args output args regs frame env)))
14030 (gen! output $op2 op (car rs))))))
14032 ; Given a short list of constants and variable references to be evaluated
14033 ; into arbitrary general registers, evaluates them into registers without
14034 ; disturbing the result register and returns a list of the registers into
14035 ; which they are evaluated. Before returning, any registers that were
14036 ; allocated by this routine are released.
14038 (define (cg-result-args output args regs frame env)
14040 ; Given a list of unevaluated arguments,
14041 ; a longer list of disjoint general registers,
14042 ; the register that holds the first evaluated argument,
14043 ; a list of registers in reverse order that hold other arguments,
14044 ; and a list of registers to be released afterwards,
14045 ; generates code to evaluate the arguments,
14046 ; deallocates any registers that were evaluated to hold the arguments,
14047 ; and returns the list of registers that contain the arguments.
14049 (define (loop args registers rr rs temps)
14051 (begin (if (not (eq? rr 'result))
14052 (gen! output $reg rr))
14053 (for-each (lambda (r) (cgreg-release! regs r))
14056 (let ((arg (car args)))
14057 (cond ((constant? arg)
14058 (let ((r (car registers)))
14059 (gen! output $const/setreg (constant.value arg) r)
14060 (cgreg-bind! regs r #t)
14067 (let* ((id (variable.name arg))
14068 (entry (var-lookup id regs frame env)))
14069 (case (entry.kind entry)
14070 ((global integrable)
14071 (if (eq? rr 'result)
14072 (save-result! args registers rr rs temps)
14073 (let ((r (car registers)))
14074 (gen! output $global id)
14075 (gen! output $setreg r)
14076 (cgreg-bind! regs r id)
14083 (if (eq? rr 'result)
14084 (save-result! args registers rr rs temps)
14085 (let ((m (entry.rib entry))
14086 (n (entry.offset entry))
14087 (r (car registers)))
14088 (gen! output $lexical m n id)
14089 (gen! output $setreg r)
14090 (cgreg-bind! regs r id)
14096 ((procedure) (error "Bug in cg-variable" arg))
14098 (let ((r (entry.regnum entry)))
14105 (let ((r (car registers)))
14106 (gen-load! output frame r id)
14107 (cgreg-bind! regs r id)
14113 (else (error "Bug in cg-result-args" arg)))))
14115 (error "Bug in cg-result-args"))))))
14117 (define (save-result! args registers rr rs temps)
14118 (let ((r (car registers)))
14119 (gen! output $setreg r)
14127 (choose-registers regs frame (length args))
14130 ; Given a local variable T1 and an expression in A-normal form,
14131 ; cg-let-used-once returns a symbol if the local variable is used
14132 ; exactly once in the expression and the expression matches one of
14133 ; the patterns below. Otherwise returns #f. The symbol that is
14134 ; returned is the name of the pattern that is matched.
14136 ; pattern symbol returned
14138 ; (if T1 ... ...) if
14140 ; (<primop> T1 ...) primop
14144 ; (set! ... T1) set!
14146 ; (let ((T2 (if T1 ... ...))) let-if
14149 ; (let ((T2 (<primop> T1 ...))) let-primop
14152 ; (let ((T2 (T1 ...))) let-called
14155 ; (let ((T2 (set! ... T1))) let-set!
14158 ; This implementation sometimes returns #f incorrectly, but it always
14159 ; returns an answer in constant time (assuming A-normal form).
14161 (define (cg-let-used-once T1 exp)
14163 (define (cg-let-used-once T1 exp)
14164 (define (used? T1 exp)
14165 (set! budget (- budget 1))
14166 (cond ((negative? budget) #t)
14167 ((constant? exp) #f)
14169 (eq? T1 (variable.name exp)))
14171 (memq T1 (lambda.F exp)))
14173 (used? T1 (assignment.rhs exp)))
14175 (or (used? T1 (call.proc exp))
14176 (used-in-args? T1 (call.args exp))))
14177 ((conditional? exp)
14178 (or (used? T1 (if.test exp))
14179 (used? T1 (if.then exp))
14180 (used? T1 (if.else exp))))
14182 (define (used-in-args? T1 args)
14185 (or (used? T1 (car args))
14186 (used-in-args? T1 (cdr args)))))
14187 (set! budget (- budget 1))
14188 (cond ((negative? budget) #f)
14190 (let ((proc (call.proc exp))
14191 (args (call.args exp)))
14192 (cond ((variable? proc)
14193 (let ((f (variable.name proc)))
14195 (and (not (used-in-args? T1 args))
14197 ((and (integrable? f)
14199 (variable? (car args))
14200 (eq? T1 (variable.name (car args))))
14201 (and (not (used-in-args? T1 (cdr args)))
14205 (and (not (memq T1 (lambda.F proc)))
14208 (case (cg-let-used-once T1 (car args))
14210 ((primop) 'let-primop)
14211 ((called) 'let-called)
14215 ((conditional? exp)
14216 (let ((E0 (if.test exp)))
14217 (and (variable? E0)
14218 (eq? T1 (variable.name E0))
14219 (not (used? T1 (if.then exp)))
14220 (not (used? T1 (if.else exp)))
14223 (let ((rhs (assignment.rhs exp)))
14224 (and (variable? rhs)
14225 (eq? T1 (variable.name rhs))
14228 (cg-let-used-once T1 exp))
14230 ; Given the name of a let-body pattern, an expression that matches that
14231 ; pattern, and an expression to be substituted for the let variable,
14232 ; returns the transformed expression.
14234 ; FIXME: No longer used.
14236 (define (cg-let-transform pattern exp E1)
14239 (make-conditional E1 (if.then exp) (if.else exp)))
14241 (make-call (call.proc exp)
14242 (cons E1 (cdr (call.args exp)))))
14244 (make-call E1 (call.args exp)))
14246 (make-assignment (assignment.lhs exp) E1))
14247 ((let-if let-primop let-called let-set!)
14248 (make-call (call.proc exp)
14249 (list (cg-let-transform (case pattern
14251 ((let-primop) 'primop)
14252 ((let-called) 'called)
14253 ((let-set!) 'set!))
14254 (car (call.args exp))
14257 (error "Unrecognized pattern in cg-let-transform" pattern)))); Copyright 1999 William Clinger
14259 ; Code for special primitives, used to generate runtime safety checks,
14260 ; efficient code for call-with-values, and other weird things.
14264 (define (cg-special output exp target regs frame env tail?)
14265 (let ((name (variable.name (call.proc exp))))
14266 (cond ((eq? name name:CHECK!)
14267 (if (runtime-safety-checking)
14268 (cg-check output exp target regs frame env tail?)))
14270 (error "Compiler bug: cg-special" (make-readable exp))))))
14272 (define (cg-special-result output exp target regs frame env tail?)
14273 (let ((name (variable.name (call.proc exp))))
14274 (cond ((eq? name name:CHECK!)
14275 (if (runtime-safety-checking)
14276 (cg-check-result output exp target regs frame env tail?)))
14278 (error "Compiler bug: cg-special" (make-readable exp))))))
14280 (define (cg-check output exp target regs frame env tail?)
14281 (cg0 output (car (call.args exp)) 'result regs frame env #f)
14282 (cg-check-result output exp target regs frame env tail?))
14284 (define (cg-check-result output exp target regs frame env tail?)
14285 (let* ((args (call.args exp))
14286 (nargs (length args))
14287 (valexps (cddr args)))
14288 (if (and (<= 2 nargs 5)
14289 (constant? (cadr args))
14290 (every? (lambda (exp)
14291 (or (constant? exp)
14294 (let* ((exn (constant.value (cadr args)))
14295 (vars (filter variable? valexps))
14296 (rs (cg-result-args output
14297 (cons (car args) vars)
14300 ; Construct the trap situation:
14301 ; the exception number followed by an ordered list of
14302 ; register numbers and constant expressions.
14304 (let loop ((registers rs)
14307 (cond ((null? exps)
14308 (let* ((situation (cons exn (reverse operands)))
14309 (ht (assembly-stream-info output))
14310 (L1 (or (hashtable-get ht situation)
14311 (let ((L1 (make-label)))
14312 (hashtable-put! ht situation L1)
14314 (define (translate r)
14315 (if (number? r) r 0))
14316 (case (length operands)
14317 ((0) (gen! output $check 0 0 0 L1))
14318 ((1) (gen! output $check
14319 (translate (car operands))
14321 ((2) (gen! output $check
14322 (translate (car operands))
14323 (translate (cadr operands))
14325 ((3) (gen! output $check
14326 (translate (car operands))
14327 (translate (cadr operands))
14328 (translate (caddr operands))
14330 ((constant? (car exps))
14333 (cons (car exps) operands)))
14335 (loop (cdr registers)
14337 (cons (car registers) operands))))))
14338 (error "Compiler bug: runtime check" (make-readable exp)))))
14340 ; Given an assembly stream and the description of a trap as recorded
14341 ; by cg-check above, generates a non-continuable trap at that label for
14342 ; that trap, passing the operands to the exception handler.
14344 (define (cg-trap output situation L1)
14345 (let* ((exn (car situation))
14346 (operands (cdr situation)))
14347 (gen! output $.label L1)
14348 (let ((liveregs (filter number? operands)))
14349 (define (loop operands registers r)
14350 (cond ((null? operands)
14351 (case (length registers)
14352 ((0) (gen! output $trap 0 0 0 exn))
14353 ((1) (gen! output $trap (car registers) 0 0 exn))
14354 ((2) (gen! output $trap
14359 ((3) (gen! output $trap
14364 (else "Compiler bug: trap")))
14365 ((number? (car operands))
14366 (loop (cdr operands)
14367 (cons (car operands) registers)
14370 (loop operands registers (+ r 1)))
14372 (gen! output $const (constant.value (car operands)))
14373 (gen! output $setreg r)
14374 (loop (cdr operands)
14377 (loop (reverse operands) '() 1))))
14379 ; Given a short list of expressions that can be evaluated in any order,
14380 ; evaluates the first into the result register and the others into any
14381 ; register, and returns an ordered list of the registers that contain
14382 ; the arguments that follow the first.
14383 ; The number of expressions must be less than the number of argument
14386 ; FIXME: No longer used.
14388 (define (cg-check-args output args regs frame env)
14390 ; Given a list of expressions to evaluate, a list of variables
14391 ; and temporary names for arguments that have already been
14392 ; evaluated, in reverse order, and a mask of booleans that
14393 ; indicate which temporaries should be released before returning,
14394 ; returns the correct result.
14396 (define (eval-loop args temps mask)
14398 (eval-first-into-result temps mask)
14399 (let ((reg (cg0 output (car args) #f regs frame env #f)))
14400 (if (eq? reg 'result)
14401 (let* ((r (choose-register regs frame))
14403 (gen! output $setreg r)
14404 (cgreg-bind! regs r t)
14405 (gen-store! output frame r t)
14406 (eval-loop (cdr args)
14409 (eval-loop (cdr args)
14410 (cons (cgreg-lookup-reg regs reg) temps)
14411 (cons #f mask))))))
14413 (define (eval-first-into-result temps mask)
14414 (cg0 output (car args) 'result regs frame env #f)
14415 (finish-loop (choose-registers regs frame (length temps))
14420 ; Given a sufficient number of disjoint registers, a list of
14421 ; variable and temporary names that may need to be loaded into
14422 ; registers, a mask of booleans that indicates which temporaries
14423 ; should be released, and a list of registers in forward order,
14424 ; returns the correct result.
14426 (define (finish-loop disjoint temps mask registers)
14429 (let* ((t (car temps))
14430 (entry (cgreg-lookup regs t)))
14432 (let ((r (entry.regnum entry)))
14434 (begin (cgreg-release! regs r)
14435 (cgframe-release! frame t)))
14436 (finish-loop disjoint
14439 (cons r registers)))
14440 (let ((r (car disjoint)))
14441 (if (memv r registers)
14442 (finish-loop (cdr disjoint) temps mask registers)
14443 (begin (gen-load! output frame r t)
14444 (cgreg-bind! regs r t)
14446 (begin (cgreg-release! regs r)
14447 (cgframe-release! frame t)))
14448 (finish-loop disjoint
14451 (cons r registers)))))))))
14453 (if (< (length args) *nregs*)
14454 (eval-loop (cdr args) '() '())
14455 (error "Bug detected by cg-primop-args" args)))
14456 ; Copyright 1998 William Clinger.
14458 ; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
14462 ; Local optimizations for MacScheme machine assembly code.
14464 ; Branch tensioning.
14465 ; Suppress nop instructions.
14466 ; Suppress save, restore, and pop instructions whose operand is -1.
14467 ; Suppress redundant stores.
14468 ; Suppress definitions (primarily loads) of dead registers.
14470 ; Note: Twobit never generates a locally redundant load or store,
14471 ; so this code must be tested with a different code generator.
14473 ; To perform these optimizations, the basic block must be traversed
14474 ; both forwards and backwards.
14475 ; The forward traversal keeps track of registers that were defined
14477 ; The backward traversal keeps track of live registers.
14479 (define filter-basic-blocks
14481 (let* ((suppression-message
14482 "Local optimization detected a useless instruction.")
14484 ; Each instruction is mapping to an encoding of the actions
14485 ; to be performed when it is encountered during the forward
14486 ; or backward traversal.
14490 (forward:ends-block 2)
14491 (forward:interesting 3)
14492 (forward:kills-all-registers 4)
14493 (forward:nop-if-arg1-is-negative 5)
14495 (backward:normal 0)
14496 (backward:ends-block 1)
14497 (backward:begins-block 2)
14498 (backward:uses-arg1 4)
14499 (backward:uses-arg2 8)
14500 (backward:uses-arg3 16)
14501 (backward:kills-arg1 32)
14502 (backward:kills-arg2 64)
14503 (backward:uses-many 128)
14505 ; largest mnemonic + 1
14507 (dispatch-table-size *number-of-mnemonics*)
14509 ; Dispatch table for the forwards traversal.
14511 (forward-table (make-bytevector dispatch-table-size))
14513 ; Dispatch table for the backwards traversal.
14515 (backward-table (make-bytevector dispatch-table-size)))
14517 (do ((i 0 (+ i 1)))
14518 ((= i dispatch-table-size))
14519 (bytevector-set! forward-table i forward:normal)
14520 (bytevector-set! backward-table i backward:normal))
14522 (bytevector-set! forward-table $nop forward:nop)
14524 (bytevector-set! forward-table $invoke forward:ends-block)
14525 (bytevector-set! forward-table $return forward:ends-block)
14526 (bytevector-set! forward-table $skip forward:ends-block)
14527 (bytevector-set! forward-table $branch forward:ends-block)
14528 (bytevector-set! forward-table $branchf forward:ends-block)
14529 (bytevector-set! forward-table $jump forward:ends-block)
14530 (bytevector-set! forward-table $.align forward:ends-block)
14531 (bytevector-set! forward-table $.proc forward:ends-block)
14532 (bytevector-set! forward-table $.cont forward:ends-block)
14533 (bytevector-set! forward-table $.label forward:ends-block)
14535 (bytevector-set! forward-table $store forward:interesting)
14536 (bytevector-set! forward-table $load forward:interesting)
14537 (bytevector-set! forward-table $setstk forward:interesting)
14538 (bytevector-set! forward-table $setreg forward:interesting)
14539 (bytevector-set! forward-table $movereg forward:interesting)
14540 (bytevector-set! forward-table $const/setreg
14541 forward:interesting)
14543 (bytevector-set! forward-table $args>= forward:kills-all-registers)
14544 (bytevector-set! forward-table $popstk forward:kills-all-registers)
14546 ; These instructions also kill all registers.
14548 (bytevector-set! forward-table $save forward:nop-if-arg1-is-negative)
14549 (bytevector-set! forward-table $restore forward:nop-if-arg1-is-negative)
14550 (bytevector-set! forward-table $pop forward:nop-if-arg1-is-negative)
14552 (bytevector-set! backward-table $invoke backward:ends-block)
14553 (bytevector-set! backward-table $return backward:ends-block)
14554 (bytevector-set! backward-table $skip backward:ends-block)
14555 (bytevector-set! backward-table $branch backward:ends-block)
14556 (bytevector-set! backward-table $branchf backward:ends-block)
14558 (bytevector-set! backward-table $jump backward:begins-block) ; [sic]
14559 (bytevector-set! backward-table $.align backward:begins-block)
14560 (bytevector-set! backward-table $.proc backward:begins-block)
14561 (bytevector-set! backward-table $.cont backward:begins-block)
14562 (bytevector-set! backward-table $.label backward:begins-block)
14564 (bytevector-set! backward-table $op2 backward:uses-arg2)
14565 (bytevector-set! backward-table $op3 (logior backward:uses-arg2
14566 backward:uses-arg3))
14567 (bytevector-set! backward-table $check (logior
14569 (logior backward:uses-arg2
14570 backward:uses-arg3)))
14571 (bytevector-set! backward-table $trap (logior
14573 (logior backward:uses-arg2
14574 backward:uses-arg3)))
14575 (bytevector-set! backward-table $store backward:uses-arg1)
14576 (bytevector-set! backward-table $reg backward:uses-arg1)
14577 (bytevector-set! backward-table $load backward:kills-arg1)
14578 (bytevector-set! backward-table $setreg backward:kills-arg1)
14579 (bytevector-set! backward-table $movereg (logior backward:uses-arg1
14580 backward:kills-arg2))
14581 (bytevector-set! backward-table $const/setreg
14582 backward:kills-arg2)
14583 (bytevector-set! backward-table $lambda backward:uses-many)
14584 (bytevector-set! backward-table $lexes backward:uses-many)
14585 (bytevector-set! backward-table $args>= backward:uses-many)
14587 (lambda (instructions)
14589 (let* ((*nregs* *nregs*) ; locals might be faster than globals
14591 ; During the forwards traversal:
14592 ; (vector-ref registers i) = #f
14593 ; means the content of register i is unknown
14594 ; (vector-ref registers i) = j
14595 ; means register was defined by load i,j
14597 ; During the backwards traversal:
14598 ; (vector-ref registers i) = #f means register i is dead
14599 ; (vector-ref registers i) = #t means register i is live
14601 (registers (make-vector *nregs* #f))
14603 ; During the forwards traversal, the label of a block that
14604 ; falls through into another block or consists of a skip
14605 ; to another block is mapped to another label.
14606 ; This mapping is implemented by a hash table.
14607 ; Before the backwards traversal, the transitive closure
14608 ; is computed. The graph has no cycles, and the maximum
14609 ; out-degree is 1, so this is easy.
14611 (label-table (make-hashtable (lambda (n) n) assv)))
14613 (define (compute-transitive-closure!)
14615 (let ((y (hashtable-get label-table x)))
14619 (hashtable-for-each (lambda (x y)
14620 (hashtable-put! label-table x (lookup y)))
14623 ; Don't use this procedure until the preceding procedure
14626 (define (lookup-label x)
14627 (hashtable-fetch label-table x x))
14629 (define (vector-fill! v x)
14630 (subvector-fill! v 0 (vector-length v) x))
14632 (define (subvector-fill! v i j x)
14634 (begin (vector-set! v i x)
14635 (subvector-fill! v (+ i 1) j x))))
14637 (define (kill-stack! j)
14638 (do ((i 0 (+ i 1)))
14640 (let ((x (vector-ref registers i)))
14641 (if (and x (= x j))
14642 (vector-set! registers i #f)))))
14644 ; Dispatch procedure for the forwards traversal.
14646 (define (forwards instructions filtered)
14647 (if (null? instructions)
14648 (begin (vector-fill! registers #f)
14649 (vector-set! registers 0 #t)
14650 (compute-transitive-closure!)
14651 (backwards0 filtered '()))
14652 (let* ((instruction (car instructions))
14653 (instructions (cdr instructions))
14654 (op (instruction.op instruction))
14655 (flags (bytevector-ref forward-table op)))
14656 (cond ((eqv? flags forward:normal)
14657 (forwards instructions (cons instruction filtered)))
14658 ((eqv? flags forward:nop)
14659 (forwards instructions filtered))
14660 ((eqv? flags forward:nop-if-arg1-is-negative)
14661 (if (negative? (instruction.arg1 instruction))
14662 (forwards instructions filtered)
14663 (begin (vector-fill! registers #f)
14664 (forwards instructions
14665 (cons instruction filtered)))))
14666 ((eqv? flags forward:kills-all-registers)
14667 (vector-fill! registers #f)
14668 (forwards instructions
14669 (cons instruction filtered)))
14670 ((eqv? flags forward:ends-block)
14671 (vector-fill! registers #f)
14672 (if (eqv? op $.label)
14673 (forwards-label instruction
14676 (forwards instructions
14677 (cons instruction filtered))))
14678 ((eqv? flags forward:interesting)
14679 (cond ((eqv? op $setreg)
14680 (vector-set! registers
14681 (instruction.arg1 instruction)
14683 (forwards instructions
14684 (cons instruction filtered)))
14685 ((eqv? op $const/setreg)
14686 (vector-set! registers
14687 (instruction.arg2 instruction)
14689 (forwards instructions
14690 (cons instruction filtered)))
14691 ((eqv? op $movereg)
14692 (vector-set! registers
14693 (instruction.arg2 instruction)
14695 (forwards instructions
14696 (cons instruction filtered)))
14698 (kill-stack! (instruction.arg1 instruction))
14699 (forwards instructions
14700 (cons instruction filtered)))
14702 (let ((i (instruction.arg1 instruction))
14703 (j (instruction.arg2 instruction)))
14704 (if (eqv? (vector-ref registers i) j)
14705 ; Suppress redundant load.
14706 ; Should never happen with Twobit.
14707 (suppress-forwards instruction
14710 (begin (vector-set! registers i j)
14711 (forwards instructions
14715 (let ((i (instruction.arg1 instruction))
14716 (j (instruction.arg2 instruction)))
14717 (if (eqv? (vector-ref registers i) j)
14718 ; Suppress redundant store.
14719 ; Should never happen with Twobit.
14720 (suppress-forwards instruction
14723 (begin (kill-stack! j)
14724 (forwards instructions
14728 (local-optimization-error op))))
14730 (local-optimization-error op))))))
14732 ; Enters labels into a table for branch tensioning.
14734 (define (forwards-label instruction1 instructions filtered)
14735 (let ((label1 (instruction.arg1 instruction1)))
14736 (if (null? instructions)
14737 ; This is ok provided the label is unreachable.
14738 (forwards instructions (cdr filtered))
14739 (let loop ((instructions instructions)
14740 (filtered (cons instruction1 filtered)))
14741 (let* ((instruction (car instructions))
14742 (op (instruction.op instruction))
14743 (flags (bytevector-ref forward-table op)))
14744 (cond ((eqv? flags forward:nop)
14745 (loop (cdr instructions) filtered))
14746 ((and (eqv? flags forward:nop-if-arg1-is-negative)
14747 (negative? (instruction.arg1 instruction)))
14748 (loop (cdr instructions) filtered))
14750 (let ((label2 (instruction.arg1 instruction)))
14751 (hashtable-put! label-table label1 label2)
14752 (forwards-label instruction
14756 (let ((label2 (instruction.arg1 instruction)))
14757 (hashtable-put! label-table label1 label2)
14758 ; We can't get rid of the skip instruction
14759 ; because control might fall into this block,
14760 ; but we can get rid of the label.
14761 (forwards instructions (cdr filtered))))
14763 (forwards instructions filtered))))))))
14765 ; Dispatch procedure for the backwards traversal.
14767 (define (backwards instructions filtered)
14768 (if (null? instructions)
14770 (let* ((instruction (car instructions))
14771 (instructions (cdr instructions))
14772 (op (instruction.op instruction))
14773 (flags (bytevector-ref backward-table op)))
14774 (cond ((eqv? flags backward:normal)
14775 (backwards instructions (cons instruction filtered)))
14776 ((eqv? flags backward:ends-block)
14777 (backwards0 (cons instruction instructions)
14779 ((eqv? flags backward:begins-block)
14780 (backwards0 instructions
14781 (cons instruction filtered)))
14782 ((eqv? flags backward:uses-many)
14783 (cond ((or (eqv? op $lambda)
14786 (if (eqv? op $lexes)
14787 (instruction.arg1 instruction)
14788 (instruction.arg2 instruction))))
14789 (subvector-fill! registers
14791 (min *nregs* (+ 1 live))
14793 (backwards instructions
14794 (cons instruction filtered))))
14796 (vector-fill! registers #t)
14797 (backwards instructions
14798 (cons instruction filtered)))
14800 (local-optimization-error op))))
14801 ((and (eqv? (logand flags backward:kills-arg1)
14802 backward:kills-arg1)
14803 (not (vector-ref registers
14804 (instruction.arg1 instruction))))
14805 ; Suppress initialization of dead register.
14806 (suppress-backwards instruction
14809 ((and (eqv? (logand flags backward:kills-arg2)
14810 backward:kills-arg2)
14811 (not (vector-ref registers
14812 (instruction.arg2 instruction))))
14813 ; Suppress initialization of dead register.
14814 (suppress-backwards instruction
14817 ((and (eqv? op $movereg)
14818 (= (instruction.arg1 instruction)
14819 (instruction.arg2 instruction)))
14820 (backwards instructions filtered))
14822 (let ((filtered (cons instruction filtered)))
14823 (if (eqv? (logand flags backward:kills-arg1)
14824 backward:kills-arg1)
14825 (vector-set! registers
14826 (instruction.arg1 instruction)
14828 (if (eqv? (logand flags backward:kills-arg2)
14829 backward:kills-arg2)
14830 (vector-set! registers
14831 (instruction.arg2 instruction)
14833 (if (eqv? (logand flags backward:uses-arg1)
14834 backward:uses-arg1)
14835 (vector-set! registers
14836 (instruction.arg1 instruction)
14838 (if (eqv? (logand flags backward:uses-arg2)
14839 backward:uses-arg2)
14840 (vector-set! registers
14841 (instruction.arg2 instruction)
14843 (if (eqv? (logand flags backward:uses-arg3)
14844 backward:uses-arg3)
14845 (vector-set! registers
14846 (instruction.arg3 instruction)
14848 (backwards instructions filtered)))))))
14850 ; Given a list of instructions in reverse order, whose first
14851 ; element is the last instruction of a basic block,
14852 ; and a filtered list of instructions in forward order,
14853 ; returns a filtered list of instructions in the correct order.
14855 (define (backwards0 instructions filtered)
14856 (if (null? instructions)
14858 (let* ((instruction (car instructions))
14859 (mnemonic (instruction.op instruction)))
14860 (cond ((or (eqv? mnemonic $.label)
14861 (eqv? mnemonic $.proc)
14862 (eqv? mnemonic $.cont)
14863 (eqv? mnemonic $.align))
14864 (backwards0 (cdr instructions)
14865 (cons instruction filtered)))
14866 ; all registers are dead at a $return
14867 ((eqv? mnemonic $return)
14868 (vector-fill! registers #f)
14869 (vector-set! registers 0 #t)
14870 (backwards (cdr instructions)
14871 (cons instruction filtered)))
14872 ; all but the argument registers are dead at an $invoke
14873 ((eqv? mnemonic $invoke)
14874 (let ((n+1 (min *nregs*
14875 (+ (instruction.arg1 instruction) 1))))
14876 (subvector-fill! registers 0 n+1 #t)
14877 (subvector-fill! registers n+1 *nregs* #f)
14878 (backwards (cdr instructions)
14879 (cons instruction filtered))))
14880 ; the compiler says which registers are live at the
14881 ; target of $skip, $branch, $branchf, or $jump
14882 ((or (eqv? mnemonic $skip)
14883 (eqv? mnemonic $branch))
14884 (let* ((live (instruction.arg2 instruction))
14885 (n+1 (min *nregs* (+ live 1))))
14886 (subvector-fill! registers 0 n+1 #t)
14887 (subvector-fill! registers n+1 *nregs* #f)
14892 (instruction.arg1 instruction))
14894 (backwards (cdr instructions)
14895 (cons instruction filtered)))))
14896 ((eqv? mnemonic $jump)
14897 (let ((n+1 (min *nregs*
14898 (+ (instruction.arg3 instruction) 1))))
14899 (subvector-fill! registers 0 n+1 #t)
14900 (subvector-fill! registers n+1 *nregs* #f)
14901 (backwards (cdr instructions)
14902 (cons instruction filtered))))
14903 ; the live registers at the target of a $branchf must be
14904 ; combined with the live registers at the $branchf
14905 ((eqv? mnemonic $branchf)
14906 (let* ((live (instruction.arg2 instruction))
14907 (n+1 (min *nregs* (+ live 1))))
14908 (subvector-fill! registers 0 n+1 #t)
14913 (instruction.arg1 instruction))
14915 (backwards (cdr instructions)
14916 (cons instruction filtered)))))
14917 (else (backwards instructions filtered))))))
14919 (define (suppress-forwards instruction instructions filtered)
14920 (if (issue-warnings)
14921 '(begin (display suppression-message)
14923 (forwards instructions filtered))
14925 (define (suppress-backwards instruction instructions filtered)
14926 (if (issue-warnings)
14927 '(begin (display suppression-message)
14929 (backwards instructions filtered))
14931 (define (local-optimization-error op)
14932 (error "Compiler bug: local optimization" op))
14934 (vector-fill! registers #f)
14935 (forwards instructions '())))))
14936 ; Copyright 1998 Lars T Hansen.
14938 ; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
14942 ; compile313 -- compilation parameters and driver procedures.
14945 ; File types -- these may differ between operating systems.
14947 (define *scheme-file-types* '(".sch" ".scm"))
14948 (define *lap-file-type* ".lap")
14949 (define *mal-file-type* ".mal")
14950 (define *lop-file-type* ".lop")
14951 (define *fasl-file-type* ".fasl")
14953 ; Compile and assemble a scheme source file and produce a fastload file.
14955 (define (compile-file infilename . rest)
14959 (if (not (null? rest))
14961 (rewrite-file-type infilename
14962 *scheme-file-types*
14963 *fasl-file-type*)))
14965 (assembly-user-data)))
14966 (if (and (not (integrate-usual-procedures))
14969 (display "WARNING from compiler: ")
14970 (display "integrate-usual-procedures is turned off")
14972 (display "Performance is likely to be poor.")
14974 (if (benchmark-block-mode)
14975 (process-file-block infilename
14977 dump-fasl-segment-to-port
14979 (assemble (compile-block forms) user)))
14980 (process-file infilename
14982 dump-fasl-segment-to-port
14984 (assemble (compile expr) user))))
14987 (if (eq? (nbuild-parameter 'target-machine) 'standard-c)
14988 (error "Compile-file not supported on this target architecture.")
14992 ; Assemble a MAL or LOP file and produce a FASL file.
14994 (define (assemble-file infilename . rest)
14997 (if (not (null? rest))
14999 (rewrite-file-type infilename
15000 (list *lap-file-type* *mal-file-type*)
15001 *fasl-file-type*)))
15003 (file-type=? infilename *mal-file-type*))
15005 (assembly-user-data)))
15006 (process-file infilename
15008 dump-fasl-segment-to-port
15009 (lambda (x) (assemble (if malfile? (eval x) x) user)))
15012 (if (eq? (nbuild-parameter 'target-machine) 'standard-c)
15013 (error "Assemble-file not supported on this target architecture.")
15017 ; Compile and assemble a single expression; return the LOP segment.
15019 (define compile-expression
15022 (define (compile-expression expr env)
15024 (case (environment-tag env)
15025 ((0 1) (make-standard-syntactic-environment))
15026 ((2) global-syntactic-environment)
15028 (error "Invalid environment for compile-expression: " env)
15030 (let ((current-env global-syntactic-environment))
15033 (set! global-syntactic-environment syntax-env))
15035 (assemble (compile expr)))
15037 (set! global-syntactic-environment current-env))))))
15039 compile-expression))
15042 (define macro-expand-expression
15045 (define (macro-expand-expression expr env)
15047 (case (environment-tag env)
15048 ((0 1) (make-standard-syntactic-environment))
15049 ((2) global-syntactic-environment)
15051 (error "Invalid environment for compile-expression: " env)
15053 (let ((current-env global-syntactic-environment))
15056 (set! global-syntactic-environment syntax-env))
15059 (macro-expand expr)))
15061 (set! global-syntactic-environment current-env))))))
15063 macro-expand-expression))
15066 ; Compile a scheme source file to a LAP file.
15068 (define (compile313 infilename . rest)
15070 (if (not (null? rest))
15072 (rewrite-file-type infilename
15073 *scheme-file-types*
15076 (lambda (item port)
15080 (if (benchmark-block-mode)
15081 (process-file-block infilename outfilename write-lap compile-block)
15082 (process-file infilename outfilename write-lap compile))
15086 ; Assemble a LAP or MAL file to a LOP file.
15088 (define (assemble313 file . rest)
15090 (if (not (null? rest))
15092 (rewrite-file-type file
15093 (list *lap-file-type* *mal-file-type*)
15096 (file-type=? file *mal-file-type*))
15098 (assembly-user-data)))
15102 (lambda (x) (assemble (if malfile? (eval x) x) user)))
15106 ; Compile and assemble a Scheme source file to a LOP file.
15108 (define (compile-and-assemble313 input-file . rest)
15110 (if (not (null? rest))
15112 (rewrite-file-type input-file
15113 *scheme-file-types*
15116 (assembly-user-data)))
15117 (if (benchmark-block-mode)
15118 (process-file-block input-file
15121 (lambda (x) (assemble (compile-block x) user)))
15122 (process-file input-file
15125 (lambda (x) (assemble (compile x) user))))
15129 ; Convert a LOP file to a FASL file.
15131 (define (make-fasl infilename . rest)
15134 (if (not (null? rest))
15136 (rewrite-file-type infilename
15138 *fasl-file-type*))))
15139 (process-file infilename
15141 dump-fasl-segment-to-port
15145 (if (eq? (nbuild-parameter 'target-machine) 'standard-c)
15146 (error "Make-fasl not supported on this target architecture.")
15150 ; Disassemble a procedure's code vector.
15152 (define (disassemble item . rest)
15153 (let ((output-port (if (null? rest)
15154 (current-output-port)
15156 (disassemble-item item #f output-port)
15160 ; The item can be either a procedure or a pair (assumed to be a segment).
15162 (define (disassemble-item item segment-no port)
15164 (define (print . rest)
15165 (for-each (lambda (x) (display x port)) rest)
15168 (define (print-constvector cv)
15169 (do ((i 0 (+ i 1)))
15170 ((= i (vector-length cv)))
15171 (print "------------------------------------------")
15172 (print "Constant vector element # " i)
15173 (case (car (vector-ref cv i))
15175 (print "Code vector")
15176 (print-instructions (disassemble-codevector
15177 (cadr (vector-ref cv i)))
15180 (print "Constant vector")
15181 (print-constvector (cadr (vector-ref cv i))))
15183 (print "Global: " (cadr (vector-ref cv i))))
15185 (print "Data: " (cadr (vector-ref cv i)))))))
15187 (define (print-segment segment)
15188 (print "Segment # " segment-no)
15189 (print-instructions (disassemble-codevector (car segment)) port)
15190 (print-constvector (cdr segment))
15191 (print "========================================"))
15193 (cond ((procedure? item)
15194 (print-instructions (disassemble-codevector (procedure-ref item 0))
15197 (bytevector? (car item))
15198 (vector? (cdr item)))
15199 (print-segment item))
15201 (error "disassemble-item: " item " is not disassemblable."))))
15204 ; Disassemble a ".lop" or ".fasl" file; dump output to screen or
15205 ; other (optional) file.
15207 (define (disassemble-file file . rest)
15209 (define (doit input-port output-port)
15210 (display "; From " output-port)
15211 (display file output-port)
15212 (newline output-port)
15213 (do ((segment-no 0 (+ segment-no 1))
15214 (segment (read input-port) (read input-port)))
15215 ((eof-object? segment))
15216 (disassemble-item segment segment-no output-port)))
15220 (call-with-input-file
15222 (lambda (input-port)
15224 (doit input-port (current-output-port))
15226 (delete-file (car rest))
15227 (call-with-output-file
15229 (lambda (output-port) (doit input-port output-port)))))))
15233 ; Display and manipulate the compiler switches.
15235 (define (compiler-switches . rest)
15237 (define (slow-code)
15238 (set-compiler-flags! 'no-optimization)
15239 (set-assembler-flags! 'no-optimization))
15241 (define (standard-code)
15242 (set-compiler-flags! 'standard)
15243 (set-assembler-flags! 'standard))
15245 (define (fast-safe-code)
15246 (set-compiler-flags! 'fast-safe)
15247 (set-assembler-flags! 'fast-safe))
15249 (define (fast-unsafe-code)
15250 (set-compiler-flags! 'fast-unsafe)
15251 (set-assembler-flags! 'fast-unsafe))
15253 (cond ((null? rest)
15254 (display "Debugging:")
15256 (display-twobit-flags 'debugging)
15257 (display-assembler-flags 'debugging)
15259 (display "Safety:")
15261 (display-twobit-flags 'safety)
15262 (display-assembler-flags 'safety)
15266 (display-twobit-flags 'optimization)
15267 (display-assembler-flags 'optimization)
15269 ((null? (cdr rest))
15271 ((0 slow) (slow-code))
15272 ((1 standard) (standard-code))
15273 ((2 fast-safe) (fast-safe-code))
15274 ((3 fast-unsafe) (fast-unsafe-code))
15276 factory-settings) (fast-safe-code)
15277 (include-source-code #t)
15278 (benchmark-mode #f)
15279 (benchmark-block-mode #f)
15280 (common-subexpression-elimination #f)
15281 (representation-inference #f))
15283 (error "Unrecognized flag " (car rest) " to compiler-switches.")))
15286 (error "Too many arguments to compiler-switches."))))
15288 ; Read and process one file, producing another.
15289 ; Preserves the global syntactic environment.
15291 (define (process-file infilename outfilename writer processer)
15293 (delete-file outfilename)
15294 (call-with-output-file
15297 (call-with-input-file
15300 (let loop ((x (read inport)))
15301 (if (eof-object? x)
15303 (begin (writer (processer x) outport)
15304 (loop (read inport))))))))))
15305 (let ((current-syntactic-environment
15306 (syntactic-copy global-syntactic-environment)))
15311 (set! global-syntactic-environment
15312 current-syntactic-environment)))))
15314 ; Same as above, but passes a list of the entire file's contents
15315 ; to the processer.
15316 ; FIXME: Both versions of PROCESS-FILE always delete the output file.
15317 ; Shouldn't it be left alone if the input file can't be opened?
15319 (define (process-file-block infilename outfilename writer processer)
15321 (delete-file outfilename)
15322 (call-with-output-file
15325 (call-with-input-file
15328 (do ((x (read inport) (read inport))
15329 (forms '() (cons x forms)))
15331 (writer (processer (reverse forms)) outport))))))))
15332 (let ((current-syntactic-environment
15333 (syntactic-copy global-syntactic-environment)))
15338 (set! global-syntactic-environment
15339 current-syntactic-environment)))))
15342 ; Given a file name with some type, produce another with some other type.
15344 (define (rewrite-file-type filename matches new)
15345 (if (not (pair? matches))
15346 (rewrite-file-type filename (list matches) new)
15347 (let ((j (string-length filename)))
15348 (let loop ((m matches))
15350 (string-append filename new))
15353 (l (string-length n)))
15354 (if (file-type=? filename n)
15355 (string-append (substring filename 0 (- j l)) new)
15356 (loop (cdr m))))))))))
15358 (define (file-type=? file-name type-name)
15359 (let ((fl (string-length file-name))
15360 (tl (string-length type-name)))
15362 (string-ci=? type-name
15363 (substring file-name (- fl tl) fl)))))
15366 ; Copyright 1998 William Clinger.
15368 ; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
15370 ; Procedures that make .LAP structures human-readable
15372 (define (readify-lap code)
15374 (let ((iname (cdr (assv (car x) *mnemonic-names*))))
15375 (if (not (= (car x) $lambda))
15376 (cons iname (cdr x))
15377 (list iname (readify-lap (cadr x)) (caddr x)))))
15380 (define (readify-file f . o)
15383 (let ((i (open-input-file f)))
15384 (let loop ((x (read i)))
15385 (if (not (eof-object? x))
15386 (begin (pretty-print (readify-lap x))
15387 (loop (read i)))))))
15391 (begin (delete-file (car o))
15392 (with-output-to-file (car o) doit))))
15395 ; Copyright 1991 Lightship Software, Incorporated.
15397 ; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
15399 ; Target-independent part of the assembler.
15401 ; This is a simple, table-driven, one-pass assembler.
15402 ; Part of it assumes a big-endian target machine.
15404 ; The input to this pass is a list of symbolic MacScheme machine
15405 ; instructions and pseudo-instructions. Each symbolic MacScheme
15406 ; machine instruction or pseudo-instruction is a list whose car
15407 ; is a small non-negative fixnum that acts as the mnemonic for the
15408 ; instruction. The rest of the list is interpreted as indicated
15411 ; The output is a pair consisting of machine code (a bytevector or
15412 ; string) and a constant vector.
15414 ; This assembler is table-driven, and may be customized to emit
15415 ; machine code for different target machines. The table consists
15416 ; of a vector of procedures indexed by mnemonics. Each procedure
15417 ; in the table should take two arguments: an assembly structure
15418 ; and a source instruction. The procedure should just assemble
15419 ; the instruction using the operations defined below.
15421 ; The table and target can be changed by redefining the following
15424 (define (assembly-table) (error "No assembly table defined."))
15425 (define (assembly-start as) #t)
15426 (define (assembly-end as segment) segment)
15427 (define (assembly-user-data) #f)
15429 ; The main entry point.
15431 (define (assemble source . rest)
15432 (let* ((user (if (null? rest) (assembly-user-data) (car rest)))
15433 (as (make-assembly-structure source (assembly-table) user)))
15434 (assembly-start as)
15437 (let ((segment (assemble-pasteup as)))
15438 (assemble-finalize! as)
15439 (assembly-end as segment)))
15442 ; The following procedures are to be called by table routines.
15444 ; The assembly source for nested lambda expressions should be
15445 ; assembled by calling this procedure. This allows an inner
15446 ; lambda to refer to labels defined by outer lambdas.
15448 ; We delay the assembly of the nested lambda until after the outer lambda
15449 ; has been finalized so that all labels in the outer lambda are known
15450 ; to the inner lambda.
15452 ; The continuation procedure k is called to backpatch the constant
15453 ; vector of the outer lambda after the inner lambda has been
15454 ; finalized. This is necessary because of the delayed evaluation: the
15455 ; outer lambda holds code and constants for the inner lambda in its
15458 (define (assemble-nested-lambda as source doc k . rest)
15459 (let* ((user (if (null? rest) #f (car rest)))
15460 (nested-as (make-assembly-structure source (as-table as) user)))
15461 (as-parent! nested-as as)
15462 (as-nested! as (cons (lambda ()
15463 (assemble1 nested-as
15464 (lambda (nested-as)
15466 (assemble-pasteup nested-as)))
15467 (assemble-finalize! nested-as)
15468 (k nested-as segment)))
15472 (define operand0 car) ; the mnemonic
15473 (define operand1 cadr)
15474 (define operand2 caddr)
15475 (define operand3 cadddr)
15476 (define (operand4 i) (car (cddddr i)))
15478 ; Emits the bits contained in the bytevector bv.
15480 (define (emit! as bv)
15481 (as-code! as (cons bv (as-code as)))
15482 (as-lc! as (+ (as-lc as) (bytevector-length bv))))
15484 ; Emits the characters contained in the string s as code (for C generation).
15486 (define (emit-string! as s)
15487 (as-code! as (cons s (as-code as)))
15488 (as-lc! as (+ (as-lc as) (string-length s))))
15490 ; Given any Scheme object that may legally be quoted, returns an
15491 ; index into the constant vector for that constant.
15493 (define (emit-constant as x)
15495 (y (as-constants as) (cdr y)))
15496 ((or (null? y) (equal? x (car y)))
15498 (as-constants! as (append! (as-constants as) (list x))))
15501 (define (emit-datum as x)
15502 (emit-constant as (list 'data x)))
15504 (define (emit-global as x)
15505 (emit-constant as (list 'global x)))
15507 (define (emit-codevector as x)
15508 (emit-constants as (list 'codevector x)))
15510 (define (emit-constantvector as x)
15511 (emit-constants as (list 'constantvector x)))
15513 ; Set-constant changes the datum stored, without affecting the tag.
15514 ; It can operate on the list form because the pair stored in the list
15515 ; is shared between the list and any vector created from the list.
15517 (define (set-constant! as n datum)
15518 (let ((pair (list-ref (as-constants as) n)))
15519 (set-car! (cdr pair) datum)))
15521 ; Guarantees that the constants will not share structure
15522 ; with any others, and will occupy consecutive positions
15523 ; in the constant vector. Returns the index of the first
15526 (define (emit-constants as x . rest)
15527 (let* ((constants (as-constants as))
15528 (i (length constants)))
15529 (as-constants! as (append! constants (cons x rest)))
15532 ; Defines the given label using the current location counter.
15534 (define (emit-label! as L)
15535 (set-cdr! L (as-lc as)))
15537 ; Adds the integer n to the size code bytes beginning at the
15538 ; given byte offset from the current value of the location counter.
15540 (define (emit-fixup! as offset size n)
15541 (as-fixups! as (cons (list (+ offset (as-lc as)) size n)
15544 ; Adds the value of the label L to the size code bytes beginning
15545 ; at the given byte offset from the current location counter.
15547 (define (emit-fixup-label! as offset size L)
15548 (as-fixups! as (cons (list (+ offset (as-lc as)) size (list L))
15551 ; Allows the procedure proc of two arguments (code vector and current
15552 ; location counter) to modify the code vector at will, at fixup time.
15554 (define (emit-fixup-proc! as proc)
15555 (as-fixups! as (cons (list (as-lc as) 0 proc)
15560 ; The current value of the location counter.
15562 (define (here as) (as-lc as))
15564 ; Given a MAL label (a number), create an assembler label.
15566 (define (make-asm-label as label)
15567 (let ((probe (find-label as label)))
15570 (let ((l (cons label #f)))
15571 (as-labels! as (cons l (as-labels as)))
15574 ; This can use hashed lookup.
15576 (define (find-label as L)
15578 (define (lookup-label-loop x labels parent)
15579 (let ((entry (assq x labels)))
15583 (lookup-label-loop x (as-labels parent) (as-parent parent))))))
15585 (lookup-label-loop L (as-labels as) (as-parent as)))
15587 ; Create a new assembler label, distinguishable from a MAL label.
15595 ; Given a value name (a number), return the label value or #f.
15597 (define (label-value as L) (cdr L))
15599 ; For peephole optimization.
15601 (define (next-instruction as)
15602 (let ((source (as-source as)))
15607 (define (consume-next-instruction! as)
15608 (as-source! as (cdr (as-source as))))
15610 (define (push-instruction as instruction)
15611 (as-source! as (cons instruction (as-source as))))
15613 ; For use by the machine assembler: assoc lists connected to as structure.
15615 (define (assembler-value as key)
15616 (let ((probe (assq key (as-values as))))
15621 (define (assembler-value! as key value)
15622 (let ((probe (assq key (as-values as))))
15624 (set-cdr! probe value)
15625 (as-values! as (cons (cons key value) (as-values as))))))
15627 ; For documentation.
15629 ; The value must be a documentation structure (a vector).
15631 (define (add-documentation as doc)
15632 (let* ((existing-constants (cadr (car (as-constants as))))
15634 (twobit-sort (lambda (a b)
15635 (< (car a) (car b)))
15636 (cond ((not existing-constants)
15637 (list (cons (here as) doc)))
15638 ((pair? existing-constants)
15639 (cons (cons (here as) doc)
15640 existing-constants))
15642 (list (cons (here as) doc)
15643 (cons 0 existing-constants)))))))
15644 (set-car! (cdar (as-constants as)) new-constants)))
15646 ; This is called when a value is too large to be handled by the assembler.
15647 ; Info is a string, expr an assembler expression, and val the resulting
15648 ; value. The default behavior is to signal an error.
15650 (define (asm-value-too-large as info expr val)
15653 (asm-error info ": Value too large: " expr " = " val)))
15655 ; The implementations of asm-error and disasm-error depend on the host
15658 (define (asm-error msg . rest)
15659 (cond ((eq? host-system 'chez)
15660 (error 'assembler "~a" (list msg rest)))
15662 (apply error msg rest))))
15664 (define (disasm-error msg . rest)
15665 (cond ((eq? host-system 'chez)
15666 (error 'disassembler "~a" (list msg rest)))
15668 (apply error msg rest))))
15670 \f; The remaining procedures in this file are local to the assembler.
15672 ; An assembly structure is a vector consisting of
15674 ; table (a table of assembly routines)
15675 ; source (a list of symbolic instructions)
15676 ; lc (location counter; an integer)
15677 ; code (a list of bytevectors)
15678 ; constants (a list)
15679 ; labels (an alist of labels and values)
15680 ; fixups (an alist of locations, sizes, and labels or fixnums)
15681 ; nested (a list of assembly procedures for nested lambdas)
15682 ; values (an assoc list)
15683 ; parent (an assembly structure or #f)
15684 ; retry (a thunk or #f)
15685 ; user-data (anything)
15687 ; In fixups, labels are of the form (<L>) to distinguish them from fixnums.
15689 (define (label? x) (and (pair? x) (fixnum? (car x))))
15690 (define label.ident car)
15692 (define (make-assembly-structure source table user-data)
15706 (define (as-reset! as source)
15707 (as-source! as source)
15710 (as-constants! as '())
15711 (as-labels! as '())
15712 (as-fixups! as '())
15713 (as-nested! as '())
15714 (as-values! as '())
15717 (define (as-table as) (vector-ref as 0))
15718 (define (as-source as) (vector-ref as 1))
15719 (define (as-lc as) (vector-ref as 2))
15720 (define (as-code as) (vector-ref as 3))
15721 (define (as-constants as) (vector-ref as 4))
15722 (define (as-labels as) (vector-ref as 5))
15723 (define (as-fixups as) (vector-ref as 6))
15724 (define (as-nested as) (vector-ref as 7))
15725 (define (as-values as) (vector-ref as 8))
15726 (define (as-parent as) (vector-ref as 9))
15727 (define (as-retry as) (vector-ref as 10))
15728 (define (as-user as) (vector-ref as 11))
15730 (define (as-source! as x) (vector-set! as 1 x))
15731 (define (as-lc! as x) (vector-set! as 2 x))
15732 (define (as-code! as x) (vector-set! as 3 x))
15733 (define (as-constants! as x) (vector-set! as 4 x))
15734 (define (as-labels! as x) (vector-set! as 5 x))
15735 (define (as-fixups! as x) (vector-set! as 6 x))
15736 (define (as-nested! as x) (vector-set! as 7 x))
15737 (define (as-values! as x) (vector-set! as 8 x))
15738 (define (as-parent! as x) (vector-set! as 9 x))
15739 (define (as-retry! as x) (vector-set! as 10 x))
15740 (define (as-user! as x) (vector-set! as 11 x))
15742 ; The guts of the assembler.
15744 (define (assemble1 as finalize doc)
15745 (let ((assembly-table (as-table as))
15746 (peep? (peephole-optimization))
15747 (step? (single-stepping))
15748 (step-instr (list $.singlestep))
15749 (end-instr (list $.end)))
15752 (let ((source (as-source as)))
15754 (begin ((vector-ref assembly-table $.end) end-instr as)
15757 ((vector-ref assembly-table $.singlestep)
15761 (let peeploop ((src1 source))
15763 (let ((src2 (as-source as)))
15764 (if (not (eq? src1 src2))
15765 (peeploop src2)))))
15766 (let ((source (as-source as)))
15767 (as-source! as (cdr source))
15768 ((vector-ref assembly-table (caar source))
15774 (emit-datum as doc)
15777 (let* ((source (as-source as))
15778 (r (call-with-current-continuation
15780 (as-retry! as (lambda () (k 'retry)))
15783 (let ((old (short-effective-addresses)))
15784 (as-reset! as source)
15787 (short-effective-addresses #f))
15790 (short-effective-addresses old))))
15793 (define (assemble-pasteup as)
15795 (define (pasteup-code)
15796 (let ((code (make-bytevector (as-lc as)))
15797 (constants (list->vector (as-constants as))))
15799 ; The bytevectors: byte 0 is most significant.
15801 (define (paste-code! bvs i)
15802 (if (not (null? bvs))
15803 (let* ((bv (car bvs))
15804 (n (bytevector-length bv)))
15806 (j (- n 1) (- j 1))) ; (j 0 (+ j 1))
15808 (paste-code! (cdr bvs) i))
15809 (bytevector-set! code i (bytevector-ref bv j))))))
15811 (paste-code! (as-code as) (- (as-lc as) 1))
15812 (as-code! as (list code))
15813 (cons code constants)))
15815 (define (pasteup-strings)
15816 (let ((code (make-string (as-lc as)))
15817 (constants (list->vector (as-constants as))))
15819 (define (paste-code! strs i)
15820 (if (not (null? strs))
15821 (let* ((s (car strs))
15822 (n (string-length s)))
15824 (j (- n 1) (- j 1))) ; (j 0 (+ j 1))
15826 (paste-code! (cdr strs) i))
15827 (string-set! code i (string-ref s j))))))
15829 (paste-code! (as-code as) (- (as-lc as) 1))
15830 (as-code! as (list code))
15831 (cons code constants)))
15833 (if (bytevector? (car (as-code as)))
15835 (pasteup-strings)))
15837 (define (assemble-finalize! as)
15838 (let ((code (car (as-code as))))
15840 (define (apply-fixups! fixups)
15841 (if (not (null? fixups))
15842 (let* ((fixup (car fixups))
15844 (size (cadr fixup))
15845 (adjustment (caddr fixup)) ; may be procedure
15846 (n (if (label? adjustment)
15847 (lookup-label adjustment)
15850 ((0) (fixup-proc code i n))
15851 ((1) (fixup1 code i n))
15852 ((2) (fixup2 code i n))
15853 ((3) (fixup3 code i n))
15854 ((4) (fixup4 code i n))
15856 (apply-fixups! (cdr fixups)))))
15858 (define (lookup-label L)
15859 (or (label-value as (label.ident L))
15860 (asm-error "Assembler error -- undefined label " L)))
15862 (apply-fixups! (reverse! (as-fixups as)))
15864 (for-each (lambda (nested-as-proc)
15869 ; These fixup routines assume a big-endian target machine.
15871 (define (fixup1 code i n)
15872 (bytevector-set! code i (+ n (bytevector-ref code i))))
15874 (define (fixup2 code i n)
15875 (let* ((x (+ (* 256 (bytevector-ref code i))
15876 (bytevector-ref code (+ i 1))))
15878 (y0 (modulo y 256))
15879 (y1 (modulo (quotient (- y y0) 256) 256)))
15880 (bytevector-set! code i y1)
15881 (bytevector-set! code (+ i 1) y0)))
15883 (define (fixup3 code i n)
15884 (let* ((x (+ (* 65536 (bytevector-ref code i))
15885 (* 256 (bytevector-ref code (+ i 1)))
15886 (bytevector-ref code (+ i 2))))
15888 (y0 (modulo y 256))
15889 (y1 (modulo (quotient (- y y0) 256) 256))
15890 (y2 (modulo (quotient (- y (* 256 y1) y0) 256) 256)))
15891 (bytevector-set! code i y2)
15892 (bytevector-set! code (+ i 1) y1)
15893 (bytevector-set! code (+ i 2) y0)))
15895 (define (fixup4 code i n)
15896 (let* ((x (+ (* 16777216 (bytevector-ref code i))
15897 (* 65536 (bytevector-ref code (+ i 1)))
15898 (* 256 (bytevector-ref code (+ i 2)))
15899 (bytevector-ref code (+ i 3))))
15901 (y0 (modulo y 256))
15902 (y1 (modulo (quotient (- y y0) 256) 256))
15903 (y2 (modulo (quotient (- y (* 256 y1) y0) 256) 256))
15904 (y3 (modulo (quotient (- y (* 65536 y2)
15909 (bytevector-set! code i y3)
15910 (bytevector-set! code (+ i 1) y2)
15911 (bytevector-set! code (+ i 2) y1)
15912 (bytevector-set! code (+ i 3) y0)))
15914 (define (fixup-proc code i p)
15919 (define (view-segment segment)
15920 (define (display-bytevector bv)
15921 (let ((n (bytevector-length bv)))
15922 (do ((i 0 (+ i 1)))
15924 (if (zero? (remainder i 4))
15925 (write-char #\space))
15926 (if (zero? (remainder i 8))
15927 (write-char #\space))
15928 (if (zero? (remainder i 32))
15930 (let ((byte (bytevector-ref bv i)))
15932 (string-ref (number->string (quotient byte 16) 16) 0))
15934 (string-ref (number->string (remainder byte 16) 16) 0))))))
15935 (if (and (pair? segment)
15936 (bytevector? (car segment))
15937 (vector? (cdr segment)))
15938 (begin (display-bytevector (car segment))
15940 (write (cdr segment))
15942 (do ((constants (vector->list (cdr segment))
15944 ((or (null? constants)
15945 (null? (cdr constants))))
15946 (if (and (bytevector? (car constants))
15947 (vector? (cadr constants)))
15948 (view-segment (cons (car constants)
15949 (cadr constants))))))))
15951 ; emit is a procedure that takes an as and emits instructions into it.
15953 (define (test-asm emit)
15954 (let ((as (make-assembly-structure #f #f #f)))
15956 (let ((segment (assemble-pasteup as)))
15957 (assemble-finalize! as)
15958 (disassemble segment))))
15960 (define (compile&assemble x)
15961 (view-segment (assemble (compile x))))
15964 ; Copyright 1998 Lars T Hansen.
15966 ; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
15968 ; Common assembler -- miscellaneous utility procedures.
15970 ; Given any Scheme object, return its printable representation as a string.
15971 ; This code is largely portable (see comments).
15973 (define (format-object x)
15975 (define (format-list x)
15980 (list (format-object (car x)) ")"))
15982 (cons (format-object (car x))
15984 (loop (cdr x)))))))
15985 (apply string-append (cons "(" (loop x))))
15987 (define (format-improper-list x)
15989 (if (pair? (cdr x))
15990 (cons (format-object (car x))
15993 (list (format-object (car x))
15995 (format-object (cdr x))
15997 (apply string-append (cons "(" (loop x))))
15999 (cond ((null? x) "()")
16002 ((symbol? x) (symbol->string x))
16003 ((number? x) (number->string x))
16004 ((char? x) (string x))
16006 ((procedure? x) "#<procedure>")
16007 ((bytevector? x) "#<bytevector>") ; Larceny
16008 ((eof-object? x) "#<eof>")
16009 ((port? x) "#<port>")
16010 ((eq? x (unspecified)) "#!unspecified") ; Larceny
16011 ((eq? x (undefined)) "#!undefined") ; Larceny
16013 (string-append "#" (format-list (vector->list x))))
16017 (format-improper-list x))
16018 (else "#<weird>")))
16021 ; Copyright 1998 Lars T Hansen.
16023 ; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
16025 ; Larceny assembler -- 32-bit big-endian utility procedures.
16027 ; 32-bit numbers are represented as 4-byte bytevectors where byte 3
16028 ; is the least significant and byte 0 is the most significant.
16030 ; Logically, the 'big' end is on the left and the 'little' end
16031 ; is on the right, so a left shift shifts towards the 'big' end.
16033 ; Performance: poor, for good reasons. See asmutil32.sch.
16035 ; Identifies the code loaded.
16037 (define asm:endianness 'big)
16040 ; Given four bytes, create a length-4 bytevector.
16041 ; N1 is the most significant byte, n4 the least significant.
16043 (define (asm:bv n1 n2 n3 n4)
16044 (let ((bv (make-bytevector 4)))
16045 (bytevector-set! bv 0 n1)
16046 (bytevector-set! bv 1 n2)
16047 (bytevector-set! bv 2 n3)
16048 (bytevector-set! bv 3 n4)
16052 ; Given a length-4 bytevector, convert it to an integer.
16054 (define (asm:bv->int bv)
16055 (let ((i (+ (* (+ (* (+ (* (bytevector-ref bv 0) 256)
16056 (bytevector-ref bv 1))
16058 (bytevector-ref bv 2))
16060 (bytevector-ref bv 3))))
16061 (if (> (bytevector-ref bv 0) 127)
16066 ; Shift the bits of m left by n bits, shifting in zeroes at the right end.
16067 ; Returns a length-4 bytevector.
16069 ; M may be an exact integer or a length-4 bytevector.
16070 ; N must be an exact nonnegative integer; it's interpreted modulo 33.
16072 (define (asm:lsh m n)
16073 (if (not (bytevector? m))
16074 (asm:lsh (asm:int->bv m) n)
16075 (let ((m (bytevector-copy m))
16076 (n (remainder n 33)))
16078 (let ((k (quotient n 8)))
16079 (do ((i 0 (+ i 1)))
16081 (do ((i i (+ i 1)))
16083 (bytevector-set! m i 0)))
16084 (bytevector-set! m i (bytevector-ref m (+ i k))))))
16085 (let* ((d0 (bytevector-ref m 0))
16086 (d1 (bytevector-ref m 1))
16087 (d2 (bytevector-ref m 2))
16088 (d3 (bytevector-ref m 3))
16089 (n (remainder n 8))
16091 (asm:bv (logand (logior (lsh d0 n) (rshl d1 n-)) 255)
16092 (logand (logior (lsh d1 n) (rshl d2 n-)) 255)
16093 (logand (logior (lsh d2 n) (rshl d3 n-)) 255)
16094 (logand (lsh d3 n) 255))))))
16097 ; Shift the bits of m right by n bits, shifting in zeroes at the high end.
16098 ; Returns a length-4 bytevector.
16100 ; M may be an exact integer or a length-4 bytevector.
16101 ; N must be an exact nonnegative integer; it's interpreted modulo 33.
16103 (define (asm:rshl m n)
16104 (if (not (bytevector? m))
16105 (asm:rshl (asm:int->bv m) n)
16106 (let ((m (bytevector-copy m))
16107 (n (remainder n 33)))
16109 (let ((k (quotient n 8)))
16110 (do ((i 3 (- i 1)))
16112 (do ((i i (- i 1)))
16114 (bytevector-set! m i 0)))
16115 (bytevector-set! m i (bytevector-ref m (- i k))))))
16116 (let* ((d0 (bytevector-ref m 0))
16117 (d1 (bytevector-ref m 1))
16118 (d2 (bytevector-ref m 2))
16119 (d3 (bytevector-ref m 3))
16120 (n (remainder n 8))
16122 (asm:bv (rshl d0 n)
16123 (logand (logior (rshl d1 n) (lsh d0 n-)) 255)
16124 (logand (logior (rshl d2 n) (lsh d1 n-)) 255)
16125 (logand (logior (rshl d3 n) (lsh d2 n-)) 255))))))
16128 ; Shift the bits of m right by n bits, shifting in the sign bit at the
16129 ; high end. Returns a length-4 bytevector.
16131 ; M may be an exact integer or a length-4 bytevector.
16132 ; N must be an exact nonnegative integer; it's interpreted modulo 33.
16135 (let ((ones (asm:bv #xff #xff #xff #xff)))
16137 (let* ((m (if (bytevector? m) m (asm:int->bv m)))
16138 (n (remainder n 33))
16139 (h (rshl (bytevector-ref m 0) 7))
16140 (k (asm:rshl m n)))
16141 ; (format #t "~a ~a ~a~%" h (bytevector-ref m 0) n)
16142 ; (prnx (asm:lsh ones (- 32 n))) (newline)
16145 (asm:logior k (asm:lsh ones (- 32 n))))))))
16148 ; Copyright 1998 Lars T Hansen.
16150 ; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
16152 ; Larceny assembler -- 32-bit endianness-independent utility procedures.
16154 ; 32-bit numbers are represented as 4-byte bytevectors where the
16155 ; exact layout depends on whether the little-endian or big-endian
16156 ; module has been loaded. One of them must be loaded prior to loading
16159 ; Logically, the 'big' end is on the left and the 'little' end
16160 ; is on the right, so a left shift shifts towards the big end.
16162 ; Generally, performance is not a major issue in this module. The
16163 ; assemblers should use more specialized code for truly good performance.
16164 ; These procedures are mainly suitable for one-time construction of
16165 ; instruction templates, and during development.
16167 ; Endian-ness specific operations are in asmutil32be.sch and asmutil32le.sch:
16169 ; (asm:bv n0 n1 n2 n3) ; Construct bytevector
16170 ; (asm:bv->int bv) ; Convert bytevector to integer
16171 ; (asm:lsh m k) ; Shift left logical k bits
16172 ; (asm:rshl m k) ; Shift right logical k bits
16173 ; (asm:rsha m k) ; Shirt right arithmetic k bits
16176 ; Convert an integer to a length-4 bytevector using two's complement
16177 ; representation for negative numbers.
16178 ; Returns length-4 bytevector.
16180 ; The procedure handles numbers in the range -2^31..2^32-1 [sic].
16181 ; It is an error for the number to be outside this range.
16183 ; FIXME: quotient/remainder may be slow; we could have special fixnum
16184 ; case that uses shifts (that could be in-lined as macro). It could
16185 ; work for negative numbers too.
16186 ; FIXME: should probably check that the number is within range.
16188 (define asm:int->bv
16189 (let ((two^32 (expt 2 32)))
16191 (let* ((m (if (< m 0) (+ two^32 m) m))
16192 (b0 (remainder m 256))
16193 (m (quotient m 256))
16194 (b1 (remainder m 256))
16195 (m (quotient m 256))
16196 (b2 (remainder m 256))
16197 (m (quotient m 256))
16198 (b3 (remainder m 256)))
16199 (asm:bv b3 b2 b1 b0)))))
16202 ; `Or' the bits of multiple operands together.
16203 ; Each operand may be an exact integer or a length-4 bytevector.
16204 ; Returns a length-4 bytevector.
16206 (define (asm:logior . ops)
16207 (let ((r (asm:bv 0 0 0 0)))
16208 (do ((ops ops (cdr ops)))
16210 (let* ((op (car ops))
16211 (op (if (bytevector? op) op (asm:int->bv op))))
16212 (bytevector-set! r 0 (logior (bytevector-ref r 0)
16213 (bytevector-ref op 0)))
16214 (bytevector-set! r 1 (logior (bytevector-ref r 1)
16215 (bytevector-ref op 1)))
16216 (bytevector-set! r 2 (logior (bytevector-ref r 2)
16217 (bytevector-ref op 2)))
16218 (bytevector-set! r 3 (logior (bytevector-ref r 3)
16219 (bytevector-ref op 3)))))))
16222 ; `And' the bits of two operands together.
16223 ; Either may be an exact integer or length-4 bytevector.
16224 ; Returns length-4 bytevector.
16226 (define (asm:logand op1 op2)
16227 (let ((op1 (if (bytevector? op1) op1 (asm:int->bv op1)))
16228 (op2 (if (bytevector? op2) op2 (asm:int->bv op2)))
16229 (bv (make-bytevector 4)))
16230 (bytevector-set! bv 0 (logand (bytevector-ref op1 0)
16231 (bytevector-ref op2 0)))
16232 (bytevector-set! bv 1 (logand (bytevector-ref op1 1)
16233 (bytevector-ref op2 1)))
16234 (bytevector-set! bv 2 (logand (bytevector-ref op1 2)
16235 (bytevector-ref op2 2)))
16236 (bytevector-set! bv 3 (logand (bytevector-ref op1 3)
16237 (bytevector-ref op2 3)))
16241 ; Extract the n low-order bits of m.
16242 ; m may be an exact integer or a length-4 bytevector.
16243 ; n must be an exact nonnegative integer, interpreted modulo 32.
16244 ; Returns length-4 bytevector.
16246 ; Does not depend on endian-ness.
16249 (let ((v (make-vector 33)))
16250 (do ((i 0 (+ i 1)))
16252 (vector-set! v i (asm:int->bv (- (expt 2 i) 1))))
16254 (asm:logand m (vector-ref v (remainder n 33))))))
16256 ; Extract the n high-order bits of m.
16257 ; m may be an exact integer or a length-4 bytevector.
16258 ; n must be an exact nonnegative integer, interpreted modulo 33.
16259 ; Returns length-4 bytevector with the high-order bits of m at low end.
16261 ; Does not depend on endian-ness.
16263 (define (asm:hibits m n)
16264 (asm:rshl m (- 32 (remainder n 33))))
16266 ; Test that the given number (not! bytevector) m fits in an n-bit
16269 ; Does not depend on endian-ness.
16272 (let ((v (make-vector 33)))
16273 (do ((i 0 (+ i 1)))
16275 (vector-set! v i (expt 2 i)))
16277 (<= (- (vector-ref v (- n 1))) m (- (vector-ref v (- n 1)) 1)))))
16279 ; Test that the given number (not! bytevector) m fits in an n-bit
16282 ; Does not depend on endian-ness.
16284 (define asm:fits-unsigned?
16285 (let ((v (make-vector 33)))
16286 (do ((i 0 (+ i 1)))
16288 (vector-set! v i (expt 2 i)))
16290 (<= 0 m (- (vector-ref v n) 1)))))
16292 ; Add two operands (numbers or bytevectors).
16294 ; Does not depend on endian-ness.
16296 (define (asm:add a b)
16297 (asm:int->bv (+ (if (bytevector? a) (asm:bv->int a) a)
16298 (if (bytevector? b) (asm:bv->int b) b))))
16300 ; Given an unsigned 32-bit number, return it as a signed number
16303 ; Does not depend on endian-ness.
16305 (define (asm:signed n)
16306 (if (< n 2147483647)
16311 (define (asm:print-bv bv)
16313 (define hex "0123456789abcdef")
16316 (display (string-ref hex (quotient k 16)))
16317 (display (string-ref hex (remainder k 16)))
16320 (if (eq? asm:endianness 'little)
16321 (do ((i 3 (- i 1)))
16323 (pdig (bytevector-ref bv i)))
16324 (do ((i 0 (+ i 1)))
16326 (pdig (bytevector-ref bv i)))))
16330 ; Copyright 1998 Lars T Hansen.
16332 ; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
16334 ; Procedure that writes fastload segment.
16336 ; The procedure 'dump-fasl-segment-to-port' takes a segment and an output
16337 ; port as arguments and dumps the segment in fastload format on that port.
16338 ; The port must be a binary (untranslated) port.
16340 ; A fastload segment looks like a Scheme expression, and in fact,
16341 ; fastload files can mix compiled and uncompiled expressions. A compiled
16342 ; expression (as created by dump-fasl-segment-to-port) is a list with
16343 ; a literal procedure in the operator position and no arguments.
16345 ; A literal procedure is a three-element list prefixed by #^P. The three
16346 ; elements are code (a bytevector), constants (a regular vector), and
16347 ; R0/static link slot (always #f).
16349 ; A bytevector is a string prefixed by #^B. The string may contain
16350 ; control characters; \ and " must be quoted as usual.
16352 ; A global variable reference in the constant vector is a symbol prefixed
16353 ; by #^G. On reading, the reference is replaced by (a pointer to) the
16356 ; This code is highly bummed. The procedure write-bytevector-like has the
16357 ; same meaning as display, but in Larceny, the former is currently much
16358 ; faster than the latter.
16360 (define (dump-fasl-segment-to-port segment outp . rest)
16361 (let* ((omit-code? (not (null? rest)))
16364 (integer->char (- (char->integer char) (char->integer #\@)))))
16365 (CTRLP (controllify #\P))
16366 (CTRLB (controllify #\B))
16367 (CTRLG (controllify #\G))
16368 (DOUBLEQUOTE (char->integer #\"))
16369 (BACKSLASH (char->integer #\\))
16372 (define buffer (make-string len #\&))
16377 (write-bytevector-like (substring buffer 0 ptr) outp)
16378 (write-bytevector-like buffer outp))
16382 (if (= ptr len) (flush))
16383 (string-set! buffer ptr c)
16384 (set! ptr (+ ptr 1)))
16387 (if (= ptr len) (flush))
16388 (string-set! buffer ptr (integer->char b))
16389 (set! ptr (+ ptr 1)))
16392 (let ((ls (string-length s)))
16393 (if (>= (+ ptr ls) len)
16395 (write-bytevector-like s outp))
16396 (do ((i (- ls 1) (- i 1))
16397 (p (+ ptr ls -1) (- p 1)))
16399 (set! ptr (+ ptr ls)))
16400 (string-set! buffer p (string-ref s i))))))
16404 (write-fasl-datum d outp))
16406 (define (dump-codevec bv)
16413 (let ((limit (bytevector-length bv)))
16414 (do ((i 0 (+ i 1)))
16415 ((= i limit) (putc #\")
16417 (let ((c (bytevector-ref bv i)))
16418 (cond ((= c DOUBLEQUOTE) (putc #\\))
16419 ((= c BACKSLASH) (putc #\\)))
16422 (define (dump-constvec cv)
16424 (for-each (lambda (const)
16428 (putd (cadr const)))
16430 (dump-constvec (cadr const)))
16432 (dump-codevec (cadr const)))
16436 (putd (cadr const)))
16438 (error "BITS attribute is not supported in fasl files."))
16440 (error "Faulty .lop file."))))
16445 (define (dump-fasl-segment segment)
16446 (if (not omit-code?) (putc #\())
16450 (dump-codevec (car segment))
16452 (dump-constvec (cdr segment))
16454 (if (not omit-code?) (putc #\)))
16457 (dump-fasl-segment segment)
16461 ; Copyright 1998 Lars T Hansen.
16463 ; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
16465 ; Bootstrap heap dumper.
16467 ; Usage: (build-heap-image outputfile inputfile-list)
16469 ; Each input file is a sequence of segments, the structure of which
16470 ; depends on the target architecture, but at least segment.code and
16471 ; segment.constants exist as accessors.
16473 ; The code is a bytevector. The constant vector contains tagged
16474 ; entries (represented using length-2 lists), where the tags are
16475 ; `data', `codevector', `constantvector', `global', or `bits'.
16477 ; `build-heap-image' reads its file arguments into the heap, creates
16478 ; thunks from the segments, and creates a list of the thunks. It also
16479 ; creates a list of all symbols present in the loaded files. Finally,
16480 ; it generates an initialization procedure (the LAP of which is hardcoded
16481 ; into this file; see below). A pointer to this procedure is installed
16482 ; in the SCHEME_ENTRY root pointer; hence, this procedure (a thunk, as
16483 ; it were) is called when the heap image is loaded.
16485 ; The initialization procedure calls each procedure in the thunk list in
16486 ; order. It then invokes the procedure `go', which takes one argument:
16487 ; the list of symbols. Typically, `go' will initialize the symbol table
16488 ; and other system tables and then call `main', but this is by no means
16491 ; The Scheme assembler must be co-resident, since it is used by
16492 ; `build-heap-image' procedure to assemble the final startup code. This
16493 ; could be avoided by pre-assembling the code and patching it here, but
16494 ; the way it is now, this procedure is entirely portable -- no target
16497 ; The code is structured to allow most procedures to be overridden for
16498 ; target architectures with more complex needs (notably the C backend).
16500 (define generate-global-symbols
16501 (make-twobit-flag 'generate-global-symbols))
16502 (generate-global-symbols #t)
16504 (define heap.version-number 9) ; Heap version number
16506 (define heap.root-names ; Roots in heap version 9
16507 '(result argreg2 argreg3
16508 reg0 reg1 reg2 reg3 reg3 reg5 reg6 reg7 reg8 reg9 reg10 reg11 reg12
16509 reg13 reg14 reg15 reg16 reg17 reg18 reg19 reg20 reg21 reg22 reg23
16510 reg24 reg25 reg26 reg27 reg28 reg29 reg30 reg31
16511 cont startup callouts schcall-arg4 alloci-tmp))
16513 (define (build-heap-image output-file input-files)
16515 (define tmp-file "HEAPDATA.dat")
16517 (define (process-input-files heap)
16518 (let loop ((files input-files) (inits '()))
16519 (cond ((null? files)
16520 (heap.thunks! heap (apply append inits)))
16522 (let ((filename (car files)))
16523 (display "Loading ")
16527 (append inits (list (dump-file! heap filename)))))))))
16529 (delete-file tmp-file)
16530 (let ((heap (make-heap #f (open-output-file tmp-file))))
16531 (before-all-files heap output-file input-files)
16532 (process-input-files heap)
16533 (heap.set-root! heap
16535 (dump-startup-procedure! heap))
16536 (heap.set-root! heap
16538 (dump-global! heap 'millicode-support))
16539 (write-header heap output-file)
16540 (after-all-files heap output-file input-files)
16541 (close-output-port (heap.output-port heap))
16542 (append-file-shell-command tmp-file output-file)
16546 (define (before-all-files heap output-file-name input-file-names) #t)
16547 (define (after-all-files heap output-file-name input-file-names) #t)
16551 ; A 'heap' is a data structure with the following public fields; none
16552 ; of them are constant unless so annotated:
16554 ; version a fixnum (constant) - heap type version number
16555 ; roots an assoc list that maps root names to values
16556 ; top an exact nonnegative integer: the address of the
16557 ; next byte to be emitted
16558 ; symbol-table a symbol table abstract data type
16559 ; extra any value - a client-extension field
16560 ; output-port an output port (for the data stream)
16561 ; thunks a list of codevector addresses
16563 ; Bytes are emitted with the heap.byte! and heap.word! procedures,
16564 ; which emit a byte and a 4-byte word respectively. These update
16567 (define (make-heap extra output-port)
16568 (vector heap.version-number ; version
16571 (make-heap-symbol-table) ; symtab
16573 output-port ; output port
16577 (define (heap.version h) (vector-ref h 0))
16578 (define (heap.roots h) (vector-ref h 1))
16579 (define (heap.top h) (vector-ref h 2))
16580 (define (heap.symbol-table h) (vector-ref h 3))
16581 (define (heap.extra h) (vector-ref h 4))
16582 (define (heap.output-port h) (vector-ref h 5))
16583 (define (heap.thunks h) (vector-ref h 6))
16585 (define (heap.roots! h x) (vector-set! h 1 x))
16586 (define (heap.top! h x) (vector-set! h 2 x))
16587 (define (heap.thunks! h x) (vector-set! h 6 x))
16592 ; The symbol table maps names to symbol structures, and a symbol
16593 ; structure contains information about that symbol.
16595 ; The structure has four fields:
16596 ; name a symbol - the print name
16597 ; symloc a fixnum or null - if fixnum, the location in the
16598 ; heap of the symbol structure.
16599 ; valloc a fixnum or null - if fixnum, the location in the
16600 ; heap of the global variable cell that has this
16601 ; symbol for its name.
16602 ; valno a fixnum or null - if fixnum, the serial number of
16603 ; the global variable cell (largely obsolete).
16605 ; Note therefore that the symbol table maintains information about
16606 ; whether the symbol is used as a symbol (in a datum), as a global
16607 ; variable, or both.
16609 (define (make-heap-symbol-table)
16612 (define (symtab.symbols st) (vector-ref st 0))
16613 (define (symtab.cell-no st) (vector-ref st 1))
16615 (define (symtab.symbols! st x) (vector-set! st 0 x))
16616 (define (symtab.cell-no! st x) (vector-set! st 1 x))
16618 (define (make-symcell name)
16619 (vector name '() '() '()))
16621 (define (symcell.name sc) (vector-ref sc 0)) ; name
16622 (define (symcell.symloc sc) (vector-ref sc 1)) ; symbol location (if any)
16623 (define (symcell.valloc sc) (vector-ref sc 2)) ; value cell location (ditto)
16624 (define (symcell.valno sc) (vector-ref sc 3)) ; value cell number (ditto)
16626 (define (symcell.symloc! sc x) (vector-set! sc 1 x))
16627 (define (symcell.valloc! sc x) (vector-set! sc 2 x))
16628 (define (symcell.valno! sc x) (vector-set! sc 3 x))
16630 ; Find a symcell in the table, or make a new one if there's none.
16632 (define (symbol-cell h name)
16633 (let ((symtab (heap.symbol-table h)))
16634 (let loop ((symbols (symtab.symbols symtab)))
16635 (cond ((null? symbols)
16636 (let ((new-sym (make-symcell name)))
16637 (symtab.symbols! symtab (cons new-sym
16638 (symtab.symbols symtab)))
16640 ((eq? name (symcell.name (car symbols)))
16643 (loop (cdr symbols)))))))
16646 ; Fundamental data emitters
16648 (define twofiftysix^3 (* 256 256 256))
16649 (define twofiftysix^2 (* 256 256))
16650 (define twofiftysix 256)
16652 (define (heap.word-be! h w)
16653 (heap.byte! h (quotient w twofiftysix^3))
16654 (heap.byte! h (quotient (remainder w twofiftysix^3) twofiftysix^2))
16655 (heap.byte! h (quotient (remainder w twofiftysix^2) twofiftysix))
16656 (heap.byte! h (remainder w twofiftysix)))
16658 (define (heap.word-el! h w)
16659 (heap.byte! h (remainder w twofiftysix))
16660 (heap.byte! h (quotient (remainder w twofiftysix^2) twofiftysix))
16661 (heap.byte! h (quotient (remainder w twofiftysix^3) twofiftysix^2))
16662 (heap.byte! h (quotient w twofiftysix^3)))
16664 (define heap.word! heap.word-be!)
16666 (define (dumpheap.set-endianness! which)
16668 ((big) (set! heap.word! heap.word-be!))
16669 ((little) (set! heap.word! heap.word-el!))
16672 (define (heap.byte! h b)
16673 (write-char (integer->char b) (heap.output-port h))
16674 (heap.top! h (+ 1 (heap.top h))))
16677 ; Useful abstractions and constants.
16679 (define (heap.header-word! h immediate length)
16680 (heap.word! h (+ (* length 256) immediate)))
16682 (define (heap.adjust! h)
16683 (let ((p (heap.top h)))
16684 (let loop ((i (- (* 8 (quotient (+ p 7) 8)) p)))
16687 (begin (heap.byte! h 0)
16688 (loop (- i 1)))))))
16690 (define heap.largest-fixnum (- (expt 2 29) 1))
16691 (define heap.smallest-fixnum (- (expt 2 29)))
16693 (define (heap.set-root! h name value)
16694 (heap.roots! h (cons (cons name value) (heap.roots h))))
16697 ;;; The segment.* procedures may be overridden by custom code.
16699 (define segment.code car)
16700 (define segment.constants cdr)
16702 ;;; The dump-*! procedures may be overridden by custom code.
16704 ; Load a LOP file into the heap, create a thunk in the heap to hold the
16705 ; code and constant vector, and return the list of thunk addresses in
16706 ; the order dumped.
16708 (define (dump-file! h filename)
16709 (before-dump-file h filename)
16710 (call-with-input-file filename
16712 (do ((segment (read in) (read in))
16713 (thunks '() (cons (dump-segment! h segment) thunks)))
16714 ((eof-object? segment)
16715 (after-dump-file h filename)
16716 (reverse thunks))))))
16718 (define (before-dump-file h filename) #t)
16719 (define (after-dump-file h filename) #t)
16721 ; Dump a segment and return the heap address of the resulting thunk.
16723 (define (dump-segment! h segment)
16724 (let* ((the-code (dump-codevector! h (segment.code segment)))
16725 (the-consts (dump-constantvector! h (segment.constants segment))))
16726 (dump-thunk! h the-code the-consts)))
16728 (define (dump-tagged-item! h item)
16731 (dump-codevector! h (cadr item)))
16733 (dump-constantvector! h (cadr item)))
16735 (dump-datum! h (cadr item)))
16737 (dump-global! h (cadr item)))
16741 (error 'dump-tagged-item! "Unknown item ~a" item))))
16743 (define (dump-datum! h datum)
16745 (define (fixnum? x)
16748 (<= heap.smallest-fixnum x heap.largest-fixnum)))
16750 (define (bignum? x)
16753 (or (> x heap.largest-fixnum)
16754 (< x heap.smallest-fixnum))))
16756 (define (ratnum? x)
16757 (and (rational? x) (exact? x) (not (integer? x))))
16759 (define (flonum? x)
16760 (and (real? x) (inexact? x)))
16762 (define (compnum? x)
16763 (and (complex? x) (inexact? x) (not (real? x))))
16765 (define (rectnum? x)
16766 (and (complex? x) (exact? x) (not (real? x))))
16768 (cond ((fixnum? datum)
16769 (dump-fixnum! h datum))
16771 (dump-bignum! h datum))
16773 (dump-ratnum! h datum))
16775 (dump-flonum! h datum))
16777 (dump-compnum! h datum))
16779 (dump-rectnum! h datum))
16781 (dump-char! h datum))
16788 ((equal? datum (unspecified))
16790 ((equal? datum (undefined))
16793 (dump-vector! h datum $tag.vector-typetag))
16794 ((bytevector? datum)
16795 (dump-bytevector! h datum $tag.bytevector-typetag))
16797 (dump-pair! h datum))
16799 (dump-string! h datum))
16801 (dump-symbol! h datum))
16803 (error 'dump-datum! "Unsupported type of datum ~a" datum))))
16805 ; Returns the two's complement representation as a positive number.
16807 (define (dump-fixnum! h f)
16809 (- #x100000000 (* (abs f) 4))
16812 (define (dump-char! h c)
16813 (+ (* (char->integer c) twofiftysix^2) $imm.character))
16815 (define (dump-bignum! h b)
16816 (dump-bytevector! h (bignum->bytevector b) $tag.bignum-typetag))
16818 (define (dump-ratnum! h r)
16820 (vector (numerator r) (denominator r))
16821 $tag.ratnum-typetag))
16823 (define (dump-flonum! h f)
16824 (dump-bytevector! h (flonum->bytevector f) $tag.flonum-typetag))
16826 (define (dump-compnum! h c)
16827 (dump-bytevector! h (compnum->bytevector c) $tag.compnum-typetag))
16829 (define (dump-rectnum! h r)
16831 (vector (real-part r) (imag-part r))
16832 $tag.rectnum-typetag))
16834 (define (dump-string! h s)
16835 (dump-bytevector! h (string->bytevector s) $tag.string-typetag))
16837 (define (dump-pair! h p)
16838 (let ((the-car (dump-datum! h (car p)))
16839 (the-cdr (dump-datum! h (cdr p))))
16840 (let ((base (heap.top h)))
16841 (heap.word! h the-car)
16842 (heap.word! h the-cdr)
16843 (+ base $tag.pair-tag))))
16845 (define (dump-bytevector! h bv variation)
16846 (let ((base (heap.top h))
16847 (l (bytevector-length bv)))
16848 (heap.header-word! h (+ $imm.bytevector-header variation) l)
16851 (begin (heap.byte! h (bytevector-ref bv i))
16853 (begin (heap.adjust! h)
16854 (+ base $tag.bytevector-tag))))))
16856 (define (dump-vector! h v variation)
16857 (dump-vector-like! h v dump-datum! variation))
16859 (define (dump-vector-like! h cv recur! variation)
16860 (let* ((l (vector-length cv))
16861 (v (make-vector l '())))
16864 (begin (vector-set! v i (recur! h (vector-ref cv i)))
16866 (let ((base (heap.top h)))
16867 (heap.header-word! h (+ $imm.vector-header variation) (* l 4))
16870 (begin (heap.word! h (vector-ref v i))
16872 (begin (heap.adjust! h)
16873 (+ base $tag.vector-tag)))))))))
16875 (define (dump-codevector! h cv)
16876 (dump-bytevector! h cv $tag.bytevector-typetag))
16878 (define (dump-constantvector! h cv)
16879 (dump-vector-like! h cv dump-tagged-item! $tag.vector-typetag))
16881 (define (dump-symbol! h s)
16882 (let ((x (symbol-cell h s)))
16883 (if (null? (symcell.symloc x))
16884 (symcell.symloc! x (create-symbol! h s)))
16885 (symcell.symloc x)))
16887 (define (dump-global! h g)
16888 (let ((x (symbol-cell h g)))
16889 (if (null? (symcell.valloc x))
16890 (let ((cell (create-cell! h g)))
16891 (symcell.valloc! x (car cell))
16892 (symcell.valno! x (cdr cell))))
16893 (symcell.valloc x)))
16895 (define (dump-thunk! h code constants)
16896 (let ((base (heap.top h)))
16897 (heap.header-word! h $imm.procedure-header 8)
16898 (heap.word! h code)
16899 (heap.word! h constants)
16901 (+ base $tag.procedure-tag)))
16903 ; The car's are all heap pointers, so they should not be messed with.
16904 ; The cdr must be dumped, and then the pair.
16906 (define (dump-list-spine! h l)
16909 (let ((the-car (car l))
16910 (the-cdr (dump-list-spine! h (cdr l))))
16911 (let ((base (heap.top h)))
16912 (heap.word! h the-car)
16913 (heap.word! h the-cdr)
16914 (+ base $tag.pair-tag)))))
16916 (define (dump-startup-procedure! h)
16917 (let ((thunks (dump-list-spine! h (heap.thunks h)))
16918 (symbols (dump-list-spine! h (symbol-locations h))))
16919 (dump-segment! h (construct-startup-procedure symbols thunks))))
16921 ; The initialization procedure. The lists are magically patched into
16922 ; the constant vector after the procedure has been assembled but before
16923 ; it is dumped into the heap. See below.
16925 ; (define (init-proc argv)
16926 ; (let loop ((l <list-of-thunks>))
16928 ; (go <list-of-symbols> argv)
16930 ; (loop (cdr l))))))
16935 (,$reg 1) ; argv into
16936 (,$setreg 2) ; register 2
16937 (,$const (thunks)) ; dummy list of thunks.
16941 (,$op1 null?) ; (null? l)
16943 (,$const (symbols)) ; dummy list of symbols
16947 (,$invoke 2) ; (go <list of symbols> argv)
16956 (,$invoke 0) ; ((car l))
16964 (,$branch 0))) ; (loop (cdr l))
16967 ;;; Non-overridable code beyond this point
16969 ; Stuff a new symbol into the heap, return its location.
16971 (define (create-symbol! h s)
16974 (vector `(bits ,(dump-string! h (symbol->string s)))
16978 $tag.symbol-typetag))
16981 ; Stuff a value cell into the heap, return a pair of its location
16982 ; and its cell number.
16984 (define (create-cell! h s)
16985 (let* ((symtab (heap.symbol-table h))
16986 (n (symtab.cell-no symtab))
16987 (p (dump-pair! h (cons (undefined)
16988 (if (generate-global-symbols)
16991 (symtab.cell-no! symtab (+ n 1))
16995 (define (construct-startup-procedure symbol-list-addr init-list-addr)
16997 ; Given some value which might appear in the constant vector,
16998 ; replace the entries matching that value with a new value.
17000 (define (patch-constant-vector! v old new)
17001 (let loop ((i (- (vector-length v) 1)))
17003 (begin (if (equal? (vector-ref v i) old)
17004 (vector-set! v i new))
17007 ; Assemble the startup thunk, patch it, and return it.
17009 (display "Assembling final procedure") (newline)
17010 (let ((e (single-stepping)))
17011 (single-stepping #f)
17012 (let ((segment (assemble init-proc)))
17013 (single-stepping e)
17014 (patch-constant-vector! (segment.constants segment)
17016 `(bits ,init-list-addr))
17017 (patch-constant-vector! (segment.constants segment)
17019 `(bits ,symbol-list-addr))
17023 ; Return a list of symbol locations for symbols in the heap, in order.
17025 (define (symbol-locations h)
17026 (let loop ((symbols (symtab.symbols (heap.symbol-table h))) (res '()))
17027 (cond ((null? symbols)
17029 ((not (null? (symcell.symloc (car symbols))))
17030 (loop (cdr symbols)
17031 (cons (symcell.symloc (car symbols)) res)))
17033 (loop (cdr symbols) res)))))
17035 ; Return list of variable name to cell number mappings for global vars.
17037 (define (load-map h)
17038 (let loop ((symbols (symtab.symbols (heap.symbol-table h))) (res '()))
17039 (cond ((null? symbols)
17041 ((not (null? (symcell.valloc (car symbols))))
17042 (loop (cdr symbols)
17043 (cons (cons (symcell.name (car symbols))
17044 (symcell.valno (car symbols)))
17047 (loop (cdr symbols) res)))))
17050 (define (write-header h output-file)
17051 (delete-file output-file)
17052 (call-with-output-file output-file
17055 (define (write-word w)
17056 (display (integer->char (quotient w twofiftysix^3)) out)
17057 (display (integer->char (quotient (remainder w twofiftysix^3)
17060 (display (integer->char (quotient (remainder w twofiftysix^2)
17063 (display (integer->char (remainder w twofiftysix)) out))
17065 (define (write-roots)
17066 (let ((assigned-roots (heap.roots h)))
17067 (for-each (lambda (root-name)
17068 (let ((probe (assq root-name assigned-roots)))
17070 (write-word (cdr probe))
17071 (write-word $imm.false))))
17074 (write-word heap.version-number)
17076 (write-word (quotient (heap.top h) 4)))))
17079 ; This is a gross hack that happens to work very well.
17081 (define (append-file-shell-command file-to-append file-to-append-to)
17084 (display "You must execute the command") (newline)
17085 (display " cat ") (display file-to-append)
17086 (display " >> ") (display file-to-append-to) (newline)
17087 (display "to create the final heap image.") (newline))
17091 (display "Creating final image in \"")
17092 (display file-to-append-to) (display "\"...") (newline)
17093 (if (zero? (system (string-append "cat " file-to-append " >> "
17094 file-to-append-to)))
17095 (delete-file file-to-append)
17096 (begin (display "Failed to create image!")
17102 ; Copyright 1991 Lightship Software, Incorporated.
17104 ; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
17106 ; 11 June 1999 / wdc
17108 ; Asm/Sparc/pass5p2.sch -- Sparc machine assembler, top level
17110 ; Overrides the procedure of the same name in Asm/Common/pass5p1.sch.
17112 (define (assembly-table) $sparc-assembly-table$)
17114 ; Controls listing of instructions during assembly.
17116 (define listify? #f)
17118 ; Table of assembler procedures.
17120 (define $sparc-assembly-table$
17122 *number-of-mnemonics*
17123 (lambda (instruction as)
17124 (asm-error "Unrecognized mnemonic " instruction))))
17126 (define (define-instruction i proc)
17127 (vector-set! $sparc-assembly-table$ i proc)
17130 (define (list-instruction name instruction)
17132 (begin (display list-indentation)
17135 (display (make-string (max (- 12 (string-length name)) 1)
17137 (if (not (null? (cdr instruction)))
17138 (begin (write (cadr instruction))
17139 (do ((operands (cddr instruction)
17143 (write (car operands)))))
17145 (flush-output-port))))
17147 (define (list-label instruction)
17149 (begin (display list-indentation)
17151 (write (cadr instruction))
17154 (define (list-lambda-start instruction)
17155 (list-instruction "lambda" (list $lambda '* (operand2 instruction)))
17156 (set! list-indentation (string-append list-indentation "| ")))
17158 (define (list-lambda-end)
17159 (set! list-indentation
17160 (substring list-indentation
17162 (- (string-length list-indentation) 4))))
17164 (define list-indentation "")
17168 ; Pseudo-instructions.
17170 (define-instruction $.label
17171 (lambda (instruction as)
17172 (list-label instruction)
17173 (sparc.label as (make-asm-label as (operand1 instruction)))))
17175 (define-instruction $.proc
17176 (lambda (instruction as)
17177 (list-instruction ".proc" instruction)
17180 (define-instruction $.proc-doc
17181 (lambda (instruction as)
17182 (list-instruction ".proc-doc" instruction)
17183 (add-documentation as (operand1 instruction))
17186 (define-instruction $.cont
17187 (lambda (instruction as)
17188 (list-instruction ".cont" instruction)
17191 (define-instruction $.align
17192 (lambda (instruction as)
17193 (list-instruction ".align" instruction)
17196 (define-instruction $.end
17197 (lambda (instruction as)
17200 (define-instruction $.singlestep
17201 (lambda (instruction as)
17202 (let ((instr (car (as-source as))))
17205 (let ((op (operand0 instr)))
17210 (and (= op $load) (= 0 (operand1 instr))))))
17212 (define (readify-instr)
17213 (if (= (operand0 instr) $lambda)
17214 (list 'lambda '(...) (caddr instr) (cadddr instr))
17215 (car (readify-lap (list instr)))))
17217 (if (not (special?))
17218 (let ((repr (format-object (readify-instr)))
17219 (funky? (= (operand0 instr) $restore)))
17220 (let ((o (emit-datum as repr)))
17221 (emit-singlestep-instr! as funky? 0 o)))))))
17226 (define-instruction $op1
17227 (lambda (instruction as)
17228 (list-instruction "op1" instruction)
17229 (emit-primop.1arg! as (operand1 instruction))))
17231 (define-instruction $op2
17232 (lambda (instruction as)
17233 (list-instruction "op2" instruction)
17234 (emit-primop.2arg! as
17235 (operand1 instruction)
17236 (regname (operand2 instruction)))))
17238 (define-instruction $op3
17239 (lambda (instruction as)
17240 (list-instruction "op3" instruction)
17241 (emit-primop.3arg! as
17242 (operand1 instruction)
17243 (regname (operand2 instruction))
17244 (regname (operand3 instruction)))))
17246 (define-instruction $op2imm
17247 (lambda (instruction as)
17248 (list-instruction "op2imm" instruction)
17249 (let ((op (case (operand1 instruction)
17250 ((+) 'internal:+/imm)
17251 ((-) 'internal:-/imm)
17252 ((fx+) 'internal:fx+/imm)
17253 ((fx-) 'internal:fx-/imm)
17254 ((fx=) 'internal:fx=/imm)
17255 ((fx<) 'internal:fx</imm)
17256 ((fx<=) 'internal:fx<=/imm)
17257 ((fx>) 'internal:fx>/imm)
17258 ((fx>=) 'internal:fx>=/imm)
17259 ((=:fix:fix) 'internal:=:fix:fix/imm)
17260 ((<:fix:fix) 'internal:<:fix:fix/imm)
17261 ((<=:fix:fix) 'internal:<=:fix:fix/imm)
17262 ((>:fix:fix) 'internal:>:fix:fix/imm)
17263 ((>=:fix:fix) 'internal:>=:fix:fix/imm)
17266 (emit-primop.4arg! as op $r.result (operand2 instruction) $r.result)
17268 (emit-constant->register as (operand2 instruction) $r.argreg2)
17269 (emit-primop.2arg! as
17270 (operand1 instruction)
17273 (define-instruction $const
17274 (lambda (instruction as)
17275 (list-instruction "const" instruction)
17276 (emit-constant->register as (operand1 instruction) $r.result)))
17278 (define-instruction $global
17279 (lambda (instruction as)
17280 (list-instruction "global" instruction)
17281 (emit-global->register! as
17282 (emit-global as (operand1 instruction))
17285 (define-instruction $setglbl
17286 (lambda (instruction as)
17287 (list-instruction "setglbl" instruction)
17288 (emit-register->global! as
17290 (emit-global as (operand1 instruction)))))
17292 ; FIXME: A problem is that the listing is messed up because of the delayed
17293 ; assembly; somehow we should fix this by putting an identifying label
17294 ; in the listing and emitting this label later, with the code.
17296 (define-instruction $lambda
17297 (lambda (instruction as)
17298 (let ((code-offset #f)
17300 (list-lambda-start instruction)
17301 (assemble-nested-lambda as
17302 (operand1 instruction)
17303 (operand3 instruction) ; documentation
17304 (lambda (nested-as segment)
17305 (set-constant! as code-offset (car segment))
17306 (set-constant! as const-offset (cdr segment))))
17308 (set! code-offset (emit-codevector as 0))
17309 (set! const-offset (emit-constantvector as 0))
17313 (operand2 instruction)))))
17315 (define-instruction $lexes
17316 (lambda (instruction as)
17317 (list-instruction "lexes" instruction)
17318 (emit-lexes! as (operand1 instruction))))
17320 (define-instruction $args=
17321 (lambda (instruction as)
17322 (list-instruction "args=" instruction)
17323 (emit-args=! as (operand1 instruction))))
17325 (define-instruction $args>=
17326 (lambda (instruction as)
17327 (list-instruction "args>=" instruction)
17328 (emit-args>=! as (operand1 instruction))))
17330 (define-instruction $invoke
17331 (lambda (instruction as)
17332 (list-instruction "invoke" instruction)
17333 (emit-invoke as (operand1 instruction) #f $m.invoke-ex)))
17335 (define-instruction $restore
17336 (lambda (instruction as)
17337 (if (not (negative? (operand1 instruction)))
17339 (list-instruction "restore" instruction)
17340 (emit-restore! as (operand1 instruction))))))
17342 (define-instruction $pop
17343 (lambda (instruction as)
17344 (if (not (negative? (operand1 instruction)))
17346 (list-instruction "pop" instruction)
17347 (let ((next (next-instruction as)))
17348 (if (and (peephole-optimization)
17349 (eqv? $return (operand0 next)))
17350 (begin (list-instruction "return" next)
17351 (consume-next-instruction! as)
17352 (emit-pop! as (operand1 instruction) #t))
17353 (emit-pop! as (operand1 instruction) #f)))))))
17355 (define-instruction $stack
17356 (lambda (instruction as)
17357 (list-instruction "stack" instruction)
17358 (emit-load! as (operand1 instruction) $r.result)))
17360 (define-instruction $setstk
17361 (lambda (instruction as)
17362 (list-instruction "setstk" instruction)
17363 (emit-store! as $r.result (operand1 instruction))))
17365 (define-instruction $load
17366 (lambda (instruction as)
17367 (list-instruction "load" instruction)
17368 (emit-load! as (operand2 instruction) (regname (operand1 instruction)))))
17370 (define-instruction $store
17371 (lambda (instruction as)
17372 (list-instruction "store" instruction)
17373 (emit-store! as (regname (operand1 instruction)) (operand2 instruction))))
17375 (define-instruction $lexical
17376 (lambda (instruction as)
17377 (list-instruction "lexical" instruction)
17378 (emit-lexical! as (operand1 instruction) (operand2 instruction))))
17380 (define-instruction $setlex
17381 (lambda (instruction as)
17382 (list-instruction "setlex" instruction)
17383 (emit-setlex! as (operand1 instruction) (operand2 instruction))))
17385 (define-instruction $reg
17386 (lambda (instruction as)
17387 (list-instruction "reg" instruction)
17388 (emit-register->register! as (regname (operand1 instruction)) $r.result)))
17390 (define-instruction $setreg
17391 (lambda (instruction as)
17392 (list-instruction "setreg" instruction)
17393 (emit-register->register! as $r.result (regname (operand1 instruction)))))
17395 (define-instruction $movereg
17396 (lambda (instruction as)
17397 (list-instruction "movereg" instruction)
17398 (emit-register->register! as
17399 (regname (operand1 instruction))
17400 (regname (operand2 instruction)))))
17402 (define-instruction $return
17403 (lambda (instruction as)
17404 (list-instruction "return" instruction)
17405 (emit-return! as)))
17407 (define-instruction $reg/return
17408 (lambda (instruction as)
17409 (list-instruction "reg/return" instruction)
17410 (emit-return-reg! as (regname (operand1 instruction)))))
17412 (define-instruction $const/return
17413 (lambda (instruction as)
17414 (list-instruction "const/return" instruction)
17415 (emit-return-const! as (operand1 instruction))))
17417 (define-instruction $nop
17418 (lambda (instruction as)
17419 (list-instruction "nop" instruction)))
17421 (define-instruction $save
17422 (lambda (instruction as)
17423 (if (not (negative? (operand1 instruction)))
17425 (list-instruction "save" instruction)
17426 (let* ((n (operand1 instruction))
17427 (v (make-vector (+ n 1) #t)))
17429 (if (peephole-optimization)
17430 (let loop ((instruction (next-instruction as)))
17431 (if (eqv? $store (operand0 instruction))
17432 (begin (list-instruction "store" instruction)
17434 (regname (operand1 instruction))
17435 (operand2 instruction))
17436 (consume-next-instruction! as)
17437 (vector-set! v (operand2 instruction) #f)
17438 (loop (next-instruction as))))))
17439 (emit-save1! as v))))))
17441 (define-instruction $setrtn
17442 (lambda (instruction as)
17443 (list-instruction "setrtn" instruction)
17444 (emit-setrtn! as (make-asm-label as (operand1 instruction)))))
17446 (define-instruction $apply
17447 (lambda (instruction as)
17448 (list-instruction "apply" instruction)
17450 (regname (operand1 instruction))
17451 (regname (operand2 instruction)))))
17453 (define-instruction $jump
17454 (lambda (instruction as)
17455 (list-instruction "jump" instruction)
17457 (operand1 instruction)
17458 (make-asm-label as (operand2 instruction)))))
17460 (define-instruction $skip
17461 (lambda (instruction as)
17462 (list-instruction "skip" instruction)
17463 (emit-branch! as #f (make-asm-label as (operand1 instruction)))))
17465 (define-instruction $branch
17466 (lambda (instruction as)
17467 (list-instruction "branch" instruction)
17468 (emit-branch! as #t (make-asm-label as (operand1 instruction)))))
17470 (define-instruction $branchf
17471 (lambda (instruction as)
17472 (list-instruction "branchf" instruction)
17473 (emit-branchf! as (make-asm-label as (operand1 instruction)))))
17475 (define-instruction $check
17476 (lambda (instruction as)
17477 (list-instruction "check" instruction)
17478 (if (not (unsafe-code))
17479 (emit-check! as $r.result
17480 (make-asm-label as (operand4 instruction))
17481 (list (regname (operand1 instruction))
17482 (regname (operand2 instruction))
17483 (regname (operand3 instruction)))))))
17485 (define-instruction $trap
17486 (lambda (instruction as)
17487 (list-instruction "trap" instruction)
17489 (regname (operand1 instruction))
17490 (regname (operand2 instruction))
17491 (regname (operand3 instruction))
17492 (operand4 instruction))))
17494 (define-instruction $const/setreg
17495 (lambda (instruction as)
17496 (list-instruction "const/setreg" instruction)
17497 (let ((x (operand1 instruction))
17498 (r (operand2 instruction)))
17500 (emit-constant->register as x (regname r))
17501 (begin (emit-constant->register as x $r.tmp0)
17502 (emit-register->register! as $r.tmp0 (regname r)))))))
17504 ; Operations introduced by the peephole optimizer.
17506 (define (peep-regname r)
17507 (if (eq? r 'RESULT) $r.result (regname r)))
17509 (define-instruction $reg/op1/branchf
17510 (lambda (instruction as)
17511 (list-instruction "reg/op1/branchf" instruction)
17512 (emit-primop.3arg! as
17513 (operand1 instruction)
17514 (peep-regname (operand2 instruction))
17515 (make-asm-label as (operand3 instruction)))))
17517 (define-instruction $reg/op2/branchf
17518 (lambda (instruction as)
17519 (list-instruction "reg/op2/branchf" instruction)
17520 (emit-primop.4arg! as
17521 (operand1 instruction)
17522 (peep-regname (operand2 instruction))
17523 (peep-regname (operand3 instruction))
17524 (make-asm-label as (operand4 instruction)))))
17526 (define-instruction $reg/op2imm/branchf
17527 (lambda (instruction as)
17528 (list-instruction "reg/op2imm/branchf" instruction)
17529 (emit-primop.4arg! as
17530 (operand1 instruction)
17531 (peep-regname (operand2 instruction))
17532 (operand3 instruction)
17533 (make-asm-label as (operand4 instruction)))))
17535 ; These three are like the corresponding branchf sequences except that
17536 ; there is a strong prediction that the branch will not be taken.
17538 (define-instruction $reg/op1/check
17539 (lambda (instruction as)
17540 (list-instruction "reg/op1/check" instruction)
17541 (emit-primop.4arg! as
17542 (operand1 instruction)
17543 (peep-regname (operand2 instruction))
17544 (make-asm-label as (operand3 instruction))
17545 (map peep-regname (operand4 instruction)))))
17547 (define-instruction $reg/op2/check
17548 (lambda (instruction as)
17549 (list-instruction "reg/op2/check" instruction)
17550 (emit-primop.5arg! as
17551 (operand1 instruction)
17552 (peep-regname (operand2 instruction))
17553 (peep-regname (operand3 instruction))
17554 (make-asm-label as (operand4 instruction))
17555 (map peep-regname (operand5 instruction)))))
17557 (define-instruction $reg/op2imm/check
17558 (lambda (instruction as)
17559 (list-instruction "reg/op2imm/check" instruction)
17560 (emit-primop.5arg! as
17561 (operand1 instruction)
17562 (peep-regname (operand2 instruction))
17563 (operand3 instruction)
17564 (make-asm-label as (operand4 instruction))
17565 (map peep-regname (operand5 instruction)))))
17569 (define-instruction $reg/op1/setreg
17570 (lambda (instruction as)
17571 (list-instruction "reg/op1/setreg" instruction)
17572 (emit-primop.3arg! as
17573 (operand1 instruction)
17574 (peep-regname (operand2 instruction))
17575 (peep-regname (operand3 instruction)))))
17577 (define-instruction $reg/op2/setreg
17578 (lambda (instruction as)
17579 (list-instruction "reg/op2/setreg" instruction)
17580 (emit-primop.4arg! as
17581 (operand1 instruction)
17582 (peep-regname (operand2 instruction))
17583 (peep-regname (operand3 instruction))
17584 (peep-regname (operand4 instruction)))))
17586 (define-instruction $reg/op2imm/setreg
17587 (lambda (instruction as)
17588 (list-instruction "reg/op2imm/setreg" instruction)
17589 (emit-primop.4arg! as
17590 (operand1 instruction)
17591 (peep-regname (operand2 instruction))
17592 (operand3 instruction)
17593 (peep-regname (operand4 instruction)))))
17595 (define-instruction $reg/op3
17596 (lambda (instruction as)
17597 (list-instruction "reg/op3" instruction)
17598 (emit-primop.4arg! as
17599 (operand1 instruction)
17600 (peep-regname (operand2 instruction))
17601 (peep-regname (operand3 instruction))
17602 (peep-regname (operand4 instruction)))))
17604 (define-instruction $reg/branchf
17605 (lambda (instruction as)
17606 (list-instruction "reg/branchf" instruction)
17607 (emit-branchfreg! as
17608 (regname (operand1 instruction))
17609 (make-asm-label as (operand2 instruction)))))
17611 (define-instruction $setrtn/branch
17612 (lambda (instruction as)
17613 (list-instruction "setrtn/branch" instruction)
17614 (emit-branch-with-setrtn! as (make-asm-label as (operand1 instruction)))))
17616 (define-instruction $setrtn/invoke
17617 (lambda (instruction as)
17618 (list-instruction "setrtn/invoke" instruction)
17619 (emit-invoke as (operand1 instruction) #t $m.invoke-ex)))
17621 (define-instruction $global/setreg
17622 (lambda (instruction as)
17623 (list-instruction "global/setreg" instruction)
17624 (emit-global->register! as
17625 (emit-global as (operand1 instruction))
17626 (regname (operand2 instruction)))))
17628 (define-instruction $global/invoke
17629 (lambda (instruction as)
17630 (list-instruction "global/invoke" instruction)
17631 (emit-load-global as
17632 (emit-global as (operand1 instruction))
17635 (emit-invoke as (operand2 instruction) #f $m.global-invoke-ex)))
17637 (define-instruction $reg/setglbl
17638 (lambda (instruction as)
17639 (list-instruction "reg/setglbl" instruction)
17640 (emit-register->global! as
17641 (regname (operand1 instruction))
17642 (emit-global as (operand2 instruction)))))
17645 ; Copyright 1998 Lars T Hansen.
17647 ; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
17651 ; Asm/Sparc/peepopt.sch -- MAL peephole optimizer, for the SPARC assembler.
17653 ; The procedure `peep' is called on the as structure before every
17654 ; instruction is assembled. It may replace the prefix of the instruction
17655 ; stream by some other instruction sequence.
17657 ; Invariant: if the peephole optimizer doesn't change anything, then
17659 ; (let ((x (as-source as)))
17661 ; (eq? x (as-source as))) => #t
17663 ; Note this still isn't right -- it should be integrated with pass5p2 --
17664 ; but it's a step in the right direction.
17666 (define *peephole-table* (make-vector *number-of-mnemonics* #f))
17668 (define (define-peephole n p)
17669 (vector-set! *peephole-table* n p)
17673 (let ((t0 (as-source as)))
17674 (if (not (null? t0))
17675 (let ((i1 (car t0)))
17676 (let ((p (vector-ref *peephole-table* (car i1))))
17678 (let* ((t1 (if (null? t0) t0 (cdr t0)))
17679 (i2 (if (null? t1) '(-1 0 0 0) (car t1)))
17680 (t2 (if (null? t1) t1 (cdr t1)))
17681 (i3 (if (null? t2) '(-1 0 0 0) (car t2)))
17682 (t3 (if (null? t2) t2 (cdr t2))))
17683 (p as i1 i2 i3 t1 t2 t3))))))))
17685 (define-peephole $reg
17686 (lambda (as i1 i2 i3 t1 t2 t3)
17687 (cond ((= (car i2) $return)
17688 (reg-return as i1 i2 t2))
17689 ((= (car i2) $setglbl)
17690 (reg-setglbl as i1 i2 t2))
17692 (cond ((= (car i3) $setreg)
17693 (reg-op1-setreg as i1 i2 i3 t2 t3))
17694 ((= (car i3) $branchf)
17695 (reg-op1-branchf as i1 i2 i3 t3))
17696 ((= (car i3) $check)
17697 (reg-op1-check as i1 i2 i3 t3))
17699 (reg-op1 as i1 i2 t2))))
17701 (cond ((= (car i3) $setreg)
17702 (reg-op2-setreg as i1 i2 i3 t2 t3))
17703 ((= (car i3) $branchf)
17704 (reg-op2-branchf as i1 i2 i3 t3))
17705 ((= (car i3) $check)
17706 (reg-op2-check as i1 i2 i3 t3))
17708 (reg-op2 as i1 i2 t2))))
17709 ((= (car i2) $op2imm)
17710 (cond ((= (car i3) $setreg)
17711 (reg-op2imm-setreg as i1 i2 i3 t2 t3))
17712 ((= (car i3) $branchf)
17713 (reg-op2imm-branchf as i1 i2 i3 t3))
17714 ((= (car i3) $check)
17715 (reg-op2imm-check as i1 i2 i3 t3))
17717 (reg-op2imm as i1 i2 t2))))
17719 (reg-op3 as i1 i2 t2))
17720 ((= (car i2) $setreg)
17721 (reg-setreg as i1 i2 t2))
17722 ((= (car i2) $branchf)
17723 (reg-branchf as i1 i2 t2)))))
17725 (define-peephole $op1
17726 (lambda (as i1 i2 i3 t1 t2 t3)
17727 (cond ((= (car i2) $branchf)
17728 (op1-branchf as i1 i2 t2))
17729 ((= (car i2) $setreg)
17730 (op1-setreg as i1 i2 t2))
17731 ((= (car i2) $check)
17732 (op1-check as i1 i2 t2)))))
17734 (define-peephole $op2
17735 (lambda (as i1 i2 i3 t1 t2 t3)
17736 (cond ((= (car i2) $branchf)
17737 (op2-branchf as i1 i2 t2))
17738 ((= (car i2) $setreg)
17739 (op2-setreg as i1 i2 t2))
17740 ((= (car i2) $check)
17741 (op2-check as i1 i2 t2)))))
17743 (define-peephole $op2imm
17744 (lambda (as i1 i2 i3 t1 t2 t3)
17745 (cond ((= (car i2) $branchf)
17746 (op2imm-branchf as i1 i2 t2))
17747 ((= (car i2) $setreg)
17748 (op2imm-setreg as i1 i2 t2))
17749 ((= (car i2) $check)
17750 (op2imm-check as i1 i2 t2)))))
17752 (define-peephole $const
17753 (lambda (as i1 i2 i3 t1 t2 t3)
17754 (cond ((= (car i2) $setreg)
17755 (const-setreg as i1 i2 t2))
17757 (const-op2 as i1 i2 t2))
17758 ((= (car i2) $return)
17759 (const-return as i1 i2 t2)))))
17761 (define-peephole $setrtn
17762 (lambda (as i1 i2 i3 t1 t2 t3)
17763 (cond ((= (car i2) $branch)
17764 (cond ((= (car i3) $.align)
17765 (if (not (null? t3))
17766 (let ((i4 (car t3))
17768 (cond ((= (car i4) $.label)
17769 (setrtn-branch as i1 i2 i3 i4 t4))))))))
17770 ((= (car i2) $invoke)
17771 (cond ((= (car i3) $.align)
17772 (if (not (null? t3))
17773 (let ((i4 (car t3))
17775 (cond ((= (car i4) $.label)
17776 (setrtn-invoke as i1 i2 i3 i4 t4)))))))))))
17778 (define-peephole $branch
17779 (lambda (as i1 i2 i3 t1 t2 t3)
17780 (cond ((= (car i2) $.align)
17781 (cond ((= (car i3) $.label)
17782 (branch-and-label as i1 i2 i3 t3)))))))
17784 (define-peephole $global
17785 (lambda (as i1 i2 i3 t1 t2 t3)
17786 (cond ((= (car i2) $setreg)
17787 (global-setreg as i1 i2 t2))
17788 ((= (car i2) $invoke)
17789 (global-invoke as i1 i2 t2))
17790 ((= (car i2) $setrtn)
17791 (cond ((= (car i3) $invoke)
17792 (global-setrtn-invoke as i1 i2 i3 t3)))))))
17794 (define-peephole $reg/op1/check
17795 (lambda (as i1 i2 i3 t1 t2 t3)
17796 (cond ((= (car i2) $reg)
17797 (cond ((= (car i3) $op1)
17798 (if (not (null? t3))
17799 (let ((i4 (car t3))
17801 (cond ((= (car i4) $setreg)
17802 (reg/op1/check-reg-op1-setreg
17803 as i1 i2 i3 i4 t4)))))))))))
17805 (define-peephole $reg/op2/check
17806 (lambda (as i1 i2 i3 t1 t2 t3)
17807 (cond ((= (car i2) $reg)
17808 (cond ((= (car i3) $op2imm)
17809 (if (not (null? t3))
17810 (let ((i4 (car t3))
17812 (cond ((= (car i4) $check)
17813 (reg/op2/check-reg-op2imm-check
17814 as i1 i2 i3 i4 t4)))))))))))
17816 ; Worker procedures.
17818 (define (reg-return as i:reg i:return tail)
17819 (let ((rs (operand1 i:reg)))
17821 (as-source! as (cons (list $reg/return rs) tail)))))
17823 (define (reg-op1-setreg as i:reg i:op1 i:setreg tail-1 tail)
17824 (let ((rs (operand1 i:reg))
17825 (rd (operand1 i:setreg))
17826 (op (operand1 i:op1)))
17829 (peep-reg/op1/setreg as op rs rd tail)
17830 (peep-reg/op1/setreg as op rs 'RESULT tail-1)))))
17832 (define (reg-op1 as i:reg i:op1 tail)
17833 (let ((rs (operand1 i:reg))
17834 (op (operand1 i:op1)))
17836 (peep-reg/op1/setreg as op rs 'RESULT tail))))
17838 (define (op1-setreg as i:op1 i:setreg tail)
17839 (let ((op (operand1 i:op1))
17840 (rd (operand1 i:setreg)))
17842 (peep-reg/op1/setreg as op 'RESULT rd tail))))
17844 (define (peep-reg/op1/setreg as op rs rd tail)
17846 ((car) 'internal:car)
17847 ((cdr) 'internal:cdr)
17848 ((car:pair) 'internal:car:pair)
17849 ((cdr:pair) 'internal:cdr:pair)
17850 ((cell-ref) 'internal:cell-ref)
17851 ((vector-length) 'internal:vector-length)
17852 ((vector-length:vec) 'internal:vector-length:vec)
17853 ((string-length) 'internal:string-length)
17854 ((--) 'internal:--)
17855 ((fx--) 'internal:fx--)
17856 ((fxpositive?) 'internal:fxpositive?)
17857 ((fxnegative?) 'internal:fxnegative?)
17858 ((fxzero?) 'internal:fxzero?)
17861 (as-source! as (cons (list $reg/op1/setreg op rs rd) tail)))))
17863 (define (reg-op2-setreg as i:reg i:op2 i:setreg tail-1 tail)
17864 (let ((rs1 (operand1 i:reg))
17865 (rs2 (operand2 i:op2))
17866 (op (operand1 i:op2))
17867 (rd (operand1 i:setreg)))
17870 (peep-reg/op2/setreg as op rs1 rs2 rd tail)
17871 (peep-reg/op2/setreg as op rs1 rs2 'RESULT tail-1)))))
17873 (define (reg-op2 as i:reg i:op2 tail)
17874 (let ((rs1 (operand1 i:reg))
17875 (rs2 (operand2 i:op2))
17876 (op (operand1 i:op2)))
17878 (peep-reg/op2/setreg as op rs1 rs2 'RESULT tail))))
17880 (define (op2-setreg as i:op2 i:setreg tail)
17881 (let ((op (operand1 i:op2))
17882 (rs2 (operand2 i:op2))
17883 (rd (operand1 i:setreg)))
17885 (peep-reg/op2/setreg as op 'RESULT rs2 rd tail))))
17887 (define (peep-reg/op2/setreg as op rs1 rs2 rd tail)
17891 ((fx+) 'internal:fx+)
17892 ((fx-) 'internal:fx-)
17893 ((fx=) 'internal:fx=)
17894 ((fx>) 'internal:fx>)
17895 ((fx>=) 'internal:fx>=)
17896 ((fx<) 'internal:fx<)
17897 ((fx<=) 'internal:fx<=)
17898 ((eq?) 'internal:eq?)
17899 ((cons) 'internal:cons)
17900 ((vector-ref) 'internal:vector-ref)
17901 ((vector-ref:trusted) 'internal:vector-ref:trusted)
17902 ((string-ref) 'internal:string-ref)
17903 ((set-car!) 'internal:set-car!)
17904 ((set-cdr!) 'internal:set-cdr!)
17905 ((cell-set!) 'internal:cell-set!)
17908 (as-source! as (cons (list $reg/op2/setreg op rs1 rs2 rd) tail)))))
17910 (define (reg-op2imm-setreg as i:reg i:op2imm i:setreg tail-1 tail)
17911 (let ((rs (operand1 i:reg))
17912 (imm (operand2 i:op2imm))
17913 (op (operand1 i:op2imm))
17914 (rd (operand1 i:setreg)))
17917 (peep-reg/op2imm/setreg as op rs imm rd tail)
17918 (peep-reg/op2imm/setreg as op rs imm 'RESULT tail-1)))))
17920 (define (reg-op2imm as i:reg i:op2imm tail)
17921 (let ((rs (operand1 i:reg))
17922 (imm (operand2 i:op2imm))
17923 (op (operand1 i:op2imm)))
17925 (peep-reg/op2imm/setreg as op rs imm 'RESULT tail))))
17927 (define (op2imm-setreg as i:op2imm i:setreg tail)
17928 (let ((op (operand1 i:op2imm))
17929 (imm (operand2 i:op2imm))
17930 (rd (operand1 i:setreg)))
17932 (peep-reg/op2imm/setreg as op 'RESULT imm rd tail))))
17934 (define (peep-reg/op2imm/setreg as op rs imm rd tail)
17936 ((+) 'internal:+/imm)
17937 ((-) 'internal:-/imm)
17938 ((fx+) 'internal:fx+/imm)
17939 ((fx-) 'internal:fx-/imm)
17940 ((fx=) 'internal:fx=/imm)
17941 ((fx<) 'internal:fx</imm)
17942 ((fx<=) 'internal:fx<=/imm)
17943 ((fx>) 'internal:fx>/imm)
17944 ((fx>=) 'internal:fx>=/imm)
17945 ((eq?) 'internal:eq?/imm)
17946 ((vector-ref) 'internal:vector-ref/imm)
17947 ((string-ref) 'internal:string-ref/imm)
17950 (as-source! as (cons (list $reg/op2imm/setreg op rs imm rd) tail)))))
17952 (define (reg-op1-branchf as i:reg i:op1 i:branchf tail)
17953 (let ((rs (operand1 i:reg))
17954 (op (operand1 i:op1))
17955 (L (operand1 i:branchf)))
17957 (peep-reg/op1/branchf as op rs L tail))))
17959 (define (op1-branchf as i:op1 i:branchf tail)
17960 (let ((op (operand1 i:op1))
17961 (L (operand1 i:branchf)))
17962 (peep-reg/op1/branchf as op 'RESULT L tail)))
17964 (define (peep-reg/op1/branchf as op rs L tail)
17966 ((null?) 'internal:branchf-null?)
17967 ((pair?) 'internal:branchf-pair?)
17968 ((zero?) 'internal:branchf-zero?)
17969 ((eof-object?) 'internal:branchf-eof-object?)
17970 ((fixnum?) 'internal:branchf-fixnum?)
17971 ((char?) 'internal:branchf-char?)
17972 ((fxzero?) 'internal:branchf-fxzero?)
17973 ((fxnegative?) 'internal:branchf-fxnegative?)
17974 ((fxpositive?) 'internal:branchf-fxpositive?)
17977 (as-source! as (cons (list $reg/op1/branchf op rs L) tail)))))
17979 (define (reg-op2-branchf as i:reg i:op2 i:branchf tail)
17980 (let ((rs1 (operand1 i:reg))
17981 (rs2 (operand2 i:op2))
17982 (op (operand1 i:op2))
17983 (L (operand1 i:branchf)))
17985 (peep-reg/op2/branchf as op rs1 rs2 L tail))))
17987 (define (op2-branchf as i:op2 i:branchf tail)
17988 (let ((op (operand1 i:op2))
17989 (rs2 (operand2 i:op2))
17990 (L (operand1 i:branchf)))
17991 (peep-reg/op2/branchf as op 'RESULT rs2 L tail)))
17993 (define (peep-reg/op2/branchf as op rs1 rs2 L tail)
17995 ((<) 'internal:branchf-<)
17996 ((>) 'internal:branchf->)
17997 ((>=) 'internal:branchf->=)
17998 ((<=) 'internal:branchf-<=)
17999 ((=) 'internal:branchf-=)
18000 ((eq?) 'internal:branchf-eq?)
18001 ((char=?) 'internal:branchf-char=?)
18002 ((char>=?) 'internal:branchf-char>=?)
18003 ((char>?) 'internal:branchf-char>?)
18004 ((char<=?) 'internal:branchf-char<=?)
18005 ((char<?) 'internal:branchf-char<?)
18006 ((fx=) 'internal:branchf-fx=)
18007 ((fx>) 'internal:branchf-fx>)
18008 ((fx>=) 'internal:branchf-fx>=)
18009 ((fx<) 'internal:branchf-fx<)
18010 ((fx<=) 'internal:branchf-fx<=)
18014 (cons (list $reg/op2/branchf op rs1 rs2 L)
18017 (define (reg-op2imm-branchf as i:reg i:op2imm i:branchf tail)
18018 (let ((rs (operand1 i:reg))
18019 (imm (operand2 i:op2imm))
18020 (op (operand1 i:op2imm))
18021 (L (operand1 i:branchf)))
18023 (peep-reg/op2imm/branchf as op rs imm L tail))))
18025 (define (op2imm-branchf as i:op2imm i:branchf tail)
18026 (let ((op (operand1 i:op2imm))
18027 (imm (operand2 i:op2imm))
18028 (L (operand1 i:branchf)))
18029 (peep-reg/op2imm/branchf as op 'RESULT imm L tail)))
18031 (define (peep-reg/op2imm/branchf as op rs imm L tail)
18033 ((<) 'internal:branchf-</imm)
18034 ((>) 'internal:branchf->/imm)
18035 ((>=) 'internal:branchf->=/imm)
18036 ((<=) 'internal:branchf-<=/imm)
18037 ((=) 'internal:branchf-=/imm)
18038 ((eq?) 'internal:branchf-eq?/imm)
18039 ((char=?) 'internal:branchf-char=?/imm)
18040 ((char>=?) 'internal:branchf-char>=?/imm)
18041 ((char>?) 'internal:branchf-char>?/imm)
18042 ((char<=?) 'internal:branchf-char<=?/imm)
18043 ((char<?) 'internal:branchf-char<?/imm)
18044 ((fx=) 'internal:branchf-fx=/imm)
18045 ((fx>) 'internal:branchf-fx>/imm)
18046 ((fx>=) 'internal:branchf-fx>=/imm)
18047 ((fx<) 'internal:branchf-fx</imm)
18048 ((fx<=) 'internal:branchf-fx<=/imm)
18052 (cons (list $reg/op2imm/branchf op rs imm L)
18055 ; Check optimization.
18057 (define (reg-op1-check as i:reg i:op1 i:check tail)
18058 (let ((rs (operand1 i:reg))
18059 (op (operand1 i:op1)))
18061 (peep-reg/op1/check as
18065 (list (operand1 i:check)
18067 (operand3 i:check))
18070 (define (op1-check as i:op1 i:check tail)
18071 (let ((op (operand1 i:op1)))
18072 (peep-reg/op1/check as
18076 (list (operand1 i:check)
18078 (operand3 i:check))
18081 (define (peep-reg/op1/check as op rs L1 liveregs tail)
18083 ((fixnum?) 'internal:check-fixnum?)
18084 ((pair?) 'internal:check-pair?)
18085 ((vector?) 'internal:check-vector?)
18089 (cons (list $reg/op1/check op rs L1 liveregs)
18092 (define (reg-op2-check as i:reg i:op2 i:check tail)
18093 (let ((rs1 (operand1 i:reg))
18094 (rs2 (operand2 i:op2))
18095 (op (operand1 i:op2)))
18097 (peep-reg/op2/check as
18102 (list (operand1 i:check)
18104 (operand3 i:check))
18107 (define (op2-check as i:op2 i:check tail)
18108 (let ((rs2 (operand2 i:op2))
18109 (op (operand1 i:op2)))
18110 (peep-reg/op2/check as
18115 (list (operand1 i:check)
18117 (operand3 i:check))
18120 (define (peep-reg/op2/check as op rs1 rs2 L1 liveregs tail)
18122 ((<:fix:fix) 'internal:check-<:fix:fix)
18123 ((<=:fix:fix) 'internal:check-<=:fix:fix)
18124 ((>=:fix:fix) 'internal:check->=:fix:fix)
18128 (cons (list $reg/op2/check op rs1 rs2 L1 liveregs)
18131 (define (reg-op2imm-check as i:reg i:op2imm i:check tail)
18132 (let ((rs1 (operand1 i:reg))
18133 (op (operand1 i:op2imm))
18134 (imm (operand2 i:op2imm)))
18136 (peep-reg/op2imm/check as
18141 (list (operand1 i:check)
18143 (operand3 i:check))
18146 (define (op2imm-check as i:op2imm i:check tail)
18147 (let ((op (operand1 i:op2imm))
18148 (imm (operand2 i:op2imm)))
18149 (peep-reg/op2imm/check as
18154 (list (operand1 i:check)
18156 (operand3 i:check))
18159 (define (peep-reg/op2imm/check as op rs1 imm L1 liveregs tail)
18161 ((<:fix:fix) 'internal:check-<:fix:fix/imm)
18162 ((<=:fix:fix) 'internal:check-<=:fix:fix/imm)
18163 ((>=:fix:fix) 'internal:check->=:fix:fix/imm)
18167 (cons (list $reg/op2imm/check op rs1 imm L1 liveregs)
18170 (define (reg/op1/check-reg-op1-setreg as i:ro1check i:reg i:op1 i:setreg tail)
18171 (let ((o1 (operand1 i:ro1check))
18172 (r1 (operand2 i:ro1check))
18173 (r2 (operand1 i:reg))
18174 (o2 (operand1 i:op1))
18175 (r3 (operand1 i:setreg)))
18176 (if (and (eq? o1 'internal:check-vector?)
18178 (eq? o2 'vector-length:vec)
18182 (cons (list $reg/op2/check
18183 'internal:check-vector?/vector-length:vec
18186 (operand3 i:ro1check)
18187 (operand4 i:ro1check))
18190 ; Range checks of the form 0 <= i < n can be performed by a single check.
18191 ; This peephole optimization recognizes
18193 ; op2 <:fix:fix,rs2
18195 ; reg rs1 ; must match earlier reg
18196 ; op2imm >=:fix:fix,0
18197 ; check r1,r2,r3,L ; label must match earlier check
18199 (define (reg/op2/check-reg-op2imm-check
18200 as i:ro2check i:reg i:op2imm i:check tail)
18201 (let ((o1 (operand1 i:ro2check))
18202 (rs1 (operand2 i:ro2check))
18203 (rs2 (operand3 i:ro2check))
18204 (L1 (operand4 i:ro2check))
18205 (live (operand5 i:ro2check))
18206 (rs3 (operand1 i:reg))
18207 (o2 (operand1 i:op2imm))
18208 (x (operand2 i:op2imm))
18209 (L2 (operand4 i:check)))
18210 (if (and (eq? o1 'internal:check-<:fix:fix)
18211 (eq? o2 '>=:fix:fix)
18216 (cons (list $reg/op2/check 'internal:check-range
18220 ; End of check optimization.
18222 (define (reg-op3 as i:reg i:op3 tail)
18223 (let ((rs1 (operand1 i:reg))
18224 (rs2 (operand2 i:op3))
18225 (rs3 (operand3 i:op3))
18226 (op (operand1 i:op3)))
18229 ((vector-set!) 'internal:vector-set!)
18230 ((string-set!) 'internal:string-set!)
18233 (as-source! as (cons (list $reg/op3 op rs1 rs2 rs3) tail)))))))
18235 ; Reg-setreg is not restricted to hardware registers, as $movereg is
18236 ; a standard instruction.
18238 (define (reg-setreg as i:reg i:setreg tail)
18239 (let ((rs (operand1 i:reg))
18240 (rd (operand1 i:setreg)))
18242 (as-source! as tail)
18243 (as-source! as (cons (list $movereg rs rd) tail)))))
18245 (define (reg-branchf as i:reg i:branchf tail)
18246 (let ((rs (operand1 i:reg))
18247 (L (operand1 i:branchf)))
18249 (as-source! as (cons (list $reg/branchf rs L) tail)))))
18251 (define (const-setreg as i:const i:setreg tail)
18252 (let ((c (operand1 i:const))
18253 (rd (operand1 i:setreg)))
18255 (as-source! as (cons (list $const/setreg c rd) tail)))))
18257 ; Make-vector on vectors of known short length.
18259 (define (const-op2 as i:const i:op2 tail)
18260 (let ((vn '#(make-vector:0 make-vector:1 make-vector:2 make-vector:3
18261 make-vector:4 make-vector:5 make-vector:6 make-vector:7
18262 make-vector:8 make-vector:9))
18263 (c (operand1 i:const))
18264 (op (operand1 i:op2))
18265 (r (operand2 i:op2)))
18266 (if (and (eq? op 'make-vector)
18269 (as-source! as (cons (list $op2 (vector-ref vn c) r) tail)))))
18271 ; Constants that can be synthesized in a single instruction can be
18272 ; moved into RESULT in the delay slot of the return instruction.
18274 (define (const-return as i:const i:return tail)
18275 (let ((c (operand1 i:const)))
18276 (if (or (and (number? c) (immediate-int? c))
18279 (as-source! as (cons (list $const/return c) tail)))))
18281 ; This allows the use of hardware 'call' instructions.
18284 ; (.align k) Ignored on SPARC
18286 ; => (setrtn/branch Ly k)
18289 (define (setrtn-branch as i:setrtn i:branch i:align i:label tail)
18290 (let ((return-label (operand1 i:setrtn))
18291 (branch-ops (cdr i:branch))
18292 (label (operand1 i:label)))
18293 (if (= return-label label)
18294 (as-source! as (cons (cons $setrtn/branch branch-ops)
18298 ; Ditto for 'invoke'.
18300 ; Disabled because it does _not_ pay off on the SPARC currently --
18301 ; probably, the dependency created between 'jmpl' and 'st' is not
18302 ; handled well on the test machine (an Ultrasparc). Might work
18303 ; better if the return address were to be kept in a register always.
18305 (define (setrtn-invoke as i:setrtn i:invoke i:align i:label tail)
18306 (let ((return-label (operand1 i:setrtn))
18307 (invoke-ops (operand1 i:invoke))
18308 (label (operand1 i:label)))
18309 (if (and #f ; DISABLED
18310 (= return-label label))
18311 (as-source! as (cons (cons $setrtn/invoke invoke-ops)
18315 ; Gets rid of spurious branch-to-next-instruction
18322 (define (branch-and-label as i:branch i:align i:label tail)
18323 (let ((branch-label (operand1 i:branch))
18324 (label (operand1 i:label)))
18325 (if (= branch-label label)
18326 (as-source! as (cons i:align (cons i:label tail))))))
18328 (define (global-setreg as i:global i:setreg tail)
18329 (let ((global (operand1 i:global))
18330 (rd (operand1 i:setreg)))
18332 (as-source! as (cons (list $global/setreg global rd) tail)))))
18334 ; Obscure guard: unsafe-code = #t implies that global/invoke will not
18335 ; check the value of the global variable, yet unsafe-code and
18336 ; catch-undefined-globals are supposed to be independent.
18338 (define (global-invoke as i:global i:invoke tail)
18339 (let ((global (operand1 i:global))
18340 (argc (operand1 i:invoke)))
18341 (if (not (and (unsafe-code) (catch-undefined-globals)))
18342 (as-source! as (cons (list $global/invoke global argc) tail)))))
18344 ; Obscure guard: see comment for previous procedure.
18345 ; FIXME! This implementation is temporary until setrtn-invoke is enabled.
18347 (define (global-setrtn-invoke as i:global i:setrtn i:invoke tail)
18348 (let ((global (operand1 i:global))
18349 (argc (operand1 i:invoke)))
18350 (if (not (and (unsafe-code) (catch-undefined-globals)))
18351 (as-source! as (cons i:setrtn
18352 (cons (list $global/invoke global argc)
18355 (define (reg-setglbl as i:reg i:setglbl tail)
18356 (let ((rs (operand1 i:reg))
18357 (global (operand1 i:setglbl)))
18359 (as-source! as (cons (list $reg/setglbl rs global) tail)))))
18365 (define (peeptest istream)
18366 (let ((as (make-assembly-structure istream)))
18367 (let loop ((l '()))
18368 (if (null? (as-source as))
18371 (let ((a (car (as-source as))))
18372 (as-source! as (cdr (as-source as)))
18373 (loop (cons a l))))))))
18377 ; Copyright 1998 Lars T Hansen.
18379 ; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
18381 ; SPARC assembler machine parameters & utility procedures.
18383 ; 13 May 1999 / wdc
18385 ; Round up to nearest 8.
18387 (define (roundup8 n)
18388 (* (quotient (+ n 7) 8) 8))
18390 ; Given an integer code for a register, return its register label.
18391 ; This register label is the register number for a h.w. register and the
18392 ; offsets from GLOBALS[ r0 ] for a s.w. register.
18395 (let ((v (vector $r.reg0 $r.reg1 $r.reg2 $r.reg3 $r.reg4 $r.reg5
18396 $r.reg6 $r.reg7 $r.reg8 $r.reg9 $r.reg10 $r.reg11
18397 $r.reg12 $r.reg13 $r.reg14 $r.reg15 $r.reg16 $r.reg17
18398 $r.reg18 $r.reg19 $r.reg20 $r.reg21 $r.reg22 $r.reg23
18399 $r.reg24 $r.reg25 $r.reg26 $r.reg27 $r.reg28 $r.reg29
18400 $r.reg30 $r.reg31)))
18402 (vector-ref v r))))
18404 ; Is a general-purpose register mapped to a hardware register?
18405 ; This is fragile! FIXME.
18407 (define (hardware-mapped? r)
18408 (or (and (>= r $r.reg0) (<= r $r.reg7))
18417 ; Used by peephole optimizer
18422 (define (immediate-int? x)
18425 (<= -1024 x 1023)))
18427 ; Given an exact integer, can it be represented as a fixnum?
18429 (define fixnum-range?
18430 (let ((-two^29 (- (expt 2 29)))
18431 (two^29-1 (- (expt 2 29) 1)))
18433 (<= -two^29 x two^29-1))))
18435 ; Does the integer x fit in the immediate field of an instruction?
18437 (define (immediate-literal? x)
18440 ; Return the offset in the %GLOBALS table of the given memory-mapped
18441 ; register. A memory-mapped register is represented by an integer which
18442 ; is its offet, so just return the value.
18444 (define (swreg-global-offset r) r)
18446 ; Return a bit representation of a character constant.
18448 (define (char->immediate c)
18449 (+ (* (char->integer c) 65536) $imm.character))
18451 ; Convert an integer to a fixnum.
18453 (define (thefixnum x) (* x 4))
18455 ; The offset of data slot 'n' within a procedure structure, not adjusting
18456 ; for tag. The proc is a header followed by code, const, and then data.
18458 (define (procedure-slot-offset n)
18461 ; Src is a register, hwreg is a hardware register. If src is a
18462 ; hardware register, return src. Otherwise, emit an instruction to load
18463 ; src into hwreg and return hwreg.
18465 (define (force-hwreg! as src hwreg)
18466 (if (hardware-mapped? src)
18468 (emit-load-reg! as src hwreg)))
18470 ; Given an arbitrary constant opd, generate code to load it into a
18473 (define (emit-constant->register as opd r)
18474 (cond ((and (integer? opd) (exact? opd))
18475 (if (fixnum-range? opd)
18476 (emit-immediate->register! as (thefixnum opd) r)
18477 (emit-const->register! as (emit-datum as opd) r)))
18479 (emit-immediate->register! as
18484 ((equal? opd (eof-object))
18485 (emit-immediate->register! as $imm.eof r))
18486 ((equal? opd (unspecified))
18487 (emit-immediate->register! as $imm.unspecified r))
18488 ((equal? opd (undefined))
18489 (emit-immediate->register! as $imm.undefined r))
18491 (emit-immediate->register! as $imm.null r))
18493 (emit-immediate->register! as (char->immediate opd) r))
18495 (emit-const->register! as (emit-datum as opd) r))))
18498 ; Stuff a bitpattern or symbolic expression into a register.
18499 ; (CONST, for immediate constants.)
18501 ; FIXME(?): if this had access to eval-expr (currently hidden inside the
18502 ; sparc assembler) it could attempt to evaluate symbolic expressions,
18503 ; thereby selecting better code sequences when possible.
18505 (define (emit-immediate->register! as i r)
18506 (let ((dest (if (not (hardware-mapped? r)) $r.tmp0 r)))
18507 (cond ((and (number? i) (immediate-literal? i))
18508 (sparc.set as i dest))
18509 ((and (number? i) (zero? (remainder (abs i) 1024)))
18510 (sparc.sethi as `(hi ,i) dest))
18512 (sparc.sethi as `(hi ,i) dest)
18513 (sparc.ori as dest `(lo ,i) dest)))
18514 (if (not (hardware-mapped? r))
18515 (emit-store-reg! as r dest))))
18518 ; Reference the constants vector and put the constant reference in a register.
18519 ; `offset' is an integer offset into the constants vector (a constant) for
18520 ; the current procedure.
18521 ; Destroys $r.tmp0 and $r.tmp1, but either can be the destination register.
18522 ; (CONST, for structured constants, GLOBAL, SETGLBL, LAMBDA).
18524 (define (emit-const->register! as offset r)
18525 (let ((cvlabel (+ 4 (- (* offset 4) $tag.vector-tag))))
18526 (cond ((hardware-mapped? r)
18527 (sparc.ldi as $r.reg0 $p.constvector $r.tmp0)
18528 (if (asm:fits? cvlabel 13)
18529 (sparc.ldi as $r.tmp0 cvlabel r)
18530 (begin (sparc.sethi as `(hi ,cvlabel) $r.tmp1)
18531 (sparc.addr as $r.tmp0 $r.tmp1 $r.tmp0)
18532 (sparc.ldi as $r.tmp0 `(lo ,cvlabel) r))))
18534 (emit-const->register! as offset $r.tmp0)
18535 (emit-store-reg! as $r.tmp0 r)))))
18539 ; Emit single instruction to load sw-mapped reg into another reg, and return
18540 ; the destination reg.
18542 (define (emit-load-reg! as from to)
18543 (if (or (hardware-mapped? from) (not (hardware-mapped? to)))
18544 (asm-error "emit-load-reg: " from to)
18545 (begin (sparc.ldi as $r.globals (swreg-global-offset from) to)
18548 (define (emit-store-reg! as from to)
18549 (if (or (not (hardware-mapped? from)) (hardware-mapped? to))
18550 (asm-error "emit-store-reg: " from to)
18551 (begin (sparc.sti as from (swreg-global-offset to) $r.globals)
18554 ; Generic move-reg-to-HW-reg
18556 (define (emit-move2hwreg! as from to)
18557 (if (hardware-mapped? from)
18558 (sparc.move as from to)
18559 (emit-load-reg! as from to))
18562 ; Evaluation of condition code for value or control.
18564 ; branchf.a is an annulled conditional branch that tests the condition codes
18565 ; and branches if some condition is false.
18566 ; rd is #f or a hardware register.
18567 ; target is #f or a label.
18568 ; Exactly one of rd and target must be #f.
18570 ; (Why isn't this split into two separate procedures? Because dozens of
18571 ; this procedure's callers have the value/control duality, and it saves
18572 ; space to put the test here instead of putting it in each caller.)
18574 (define (emit-evaluate-cc! as branchf.a rd target)
18576 (begin (branchf.a as target)
18578 (let ((target (new-label)))
18579 (branchf.a as target)
18580 (sparc.set as $imm.false rd)
18581 (sparc.set as $imm.true rd)
18582 (sparc.label as target))))
18584 ; Code for runtime safety checking.
18586 (define (emit-check! as rs0 L1 liveregs)
18587 (sparc.cmpi as rs0 $imm.false)
18588 (emit-checkcc! as sparc.be L1 liveregs))
18590 ; FIXME: This should call the exception handler for non-continuable exceptions.
18592 (define (emit-trap! as rs1 rs2 rs3 exn)
18593 (if (not (= rs3 $r.reg0))
18594 (emit-move2hwreg! as rs3 $r.argreg3))
18595 (if (not (= rs2 $r.reg0))
18596 (emit-move2hwreg! as rs2 $r.argreg2))
18597 (if (not (= rs1 $r.reg0))
18598 (emit-move2hwreg! as rs1 $r.result))
18599 (millicode-call/numarg-in-reg as $m.exception (thefixnum exn) $r.tmp0))
18602 ; an annulled conditional branch that branches
18603 ; if the check is ok
18604 ; a non-annulled conditional branch that branches
18605 ; if the check is not ok
18606 ; #f, or a procedure that takes an assembly segment as
18607 ; argument and emits an instruction that goes into
18608 ; the delay slot of either branch
18609 ; three registers whose contents should be passed to the
18610 ; exception handler if the check is not ok
18611 ; the exception code
18612 ; Emits code to call the millicode exception routine with
18613 ; the given exception code if the condition is false.
18615 ; FIXME: The nop can often be replaced by the instruction that
18620 (define (emit-checkcc-and-fill-slot!
18621 as branch-ok.a branch-bad slot-filler L1)
18622 (let* ((situation (list exn rs1 rs2 rs3))
18623 (L1 (exception-label as situation)))
18625 (begin (branch-bad as L1)
18629 (let* ((L1 (new-label))
18631 (exception-label-set! as situation L1)
18632 (branch-ok.a as L2)
18636 (sparc.label as L1)
18637 (cond ((= rs3 $r.reg0)
18639 ((hardware-mapped? $r.argreg3)
18640 (emit-move2hwreg! as rs3 $r.argreg3))
18641 ((hardware-mapped? rs3)
18642 (emit-store-reg! as rs3 $r.argreg3))
18644 (emit-move2hwreg! as rs3 $r.tmp0)
18645 (emit-store-reg! as $r.tmp0 $r.argreg3)))
18646 (if (not (= rs2 $r.reg0))
18647 (emit-move2hwreg! as rs2 $r.argreg2))
18648 (if (not (= rs1 $r.reg0))
18649 (emit-move2hwreg! as rs1 $r.result))
18650 ; FIXME: This should be a non-continuable exception.
18651 (sparc.jmpli as $r.millicode $m.exception $r.o7)
18652 (emit-immediate->register! as (thefixnum exn) $r.tmp0)
18653 (sparc.label as L2)))))
18657 (define (emit-checkcc! as branch-bad L1 liveregs)
18659 (apply sparc.slot2 as liveregs))
18661 ; Generation of millicode calls for non-continuable exceptions.
18665 ; To create only one millicode call per code segment per non-continuable
18666 ; exception situation, we use the "as-user" feature of assembly segments.
18667 ; Could use a hash table here.
18669 (define (exception-label as situation)
18670 (let ((user-data (as-user as)))
18672 (let ((exception-labels (assq 'exception-labels user-data)))
18673 (if exception-labels
18674 (let ((probe (assoc situation (cdr exception-labels))))
18681 (define (exception-label-set! as situation label)
18682 (let ((user-data (as-user as)))
18684 (let ((exception-labels (assq 'exception-labels user-data)))
18685 (if exception-labels
18686 (let ((probe (assoc situation (cdr exception-labels))))
18688 (error "COMPILER BUG: Exception situation defined twice")
18689 (set-cdr! exception-labels
18690 (cons (cons situation label)
18691 (cdr exception-labels)))))
18692 (begin (as-user! as
18693 (cons (list 'exception-labels)
18695 (exception-label-set! as situation label))))
18696 (begin (as-user! as '())
18697 (exception-label-set! as situation label)))))
18701 ; Millicode calling
18703 (define (millicode-call/0arg as mproc)
18704 (sparc.jmpli as $r.millicode mproc $r.o7)
18707 (define (millicode-call/1arg as mproc r)
18708 (sparc.jmpli as $r.millicode mproc $r.o7)
18709 (emit-move2hwreg! as r $r.argreg2))
18711 (define (millicode-call/1arg-in-result as mproc r)
18712 (millicode-call/1arg-in-reg as mproc r $r.result))
18714 (define (millicode-call/1arg-in-reg as mproc rs rd)
18715 (sparc.jmpli as $r.millicode mproc $r.o7)
18716 (emit-move2hwreg! as rs rd))
18718 (define (millicode-call/numarg-in-result as mproc num)
18719 (sparc.jmpli as $r.millicode mproc $r.o7)
18720 (sparc.set as num $r.result))
18722 (define (millicode-call/numarg-in-reg as mproc num reg)
18723 (if (not (hardware-mapped? reg))
18724 (asm-error "millicode-call/numarg-in-reg requires HW register: " reg))
18725 (sparc.jmpli as $r.millicode mproc $r.o7)
18726 (sparc.set as num reg))
18728 (define (millicode-call/2arg as mproc r1 r2)
18729 (emit-move2hwreg! as r1 $r.argreg2)
18730 (sparc.jmpli as $r.millicode mproc $r.o7)
18731 (emit-move2hwreg! as r2 $r.argreg3))
18733 ; NOTE: Don't use TMP0 since TMP0 is sometimes a millicode argument
18734 ; register (for example to m_exception).
18736 ; NOTE: Don't use sparc.set rather than sethi/ori; we need to know that
18737 ; two instructions get generated.
18739 ; FIXME: Should calculate the value if possible to get better precision
18740 ; and to avoid generating a fixup. See emit-return-address! in gen-msi.sch.
18742 (define (millicode-call/ret as mproc label)
18743 (cond ((short-effective-addresses)
18744 (sparc.jmpli as $r.millicode mproc $r.o7)
18745 (sparc.addi as $r.o7 `(- ,label (- ,(here as) 4) 8) $r.o7))
18747 (let ((val `(- ,label (+ ,(here as) 8) 8)))
18748 (sparc.sethi as `(hi ,val) $r.tmp1)
18749 (sparc.ori as $r.tmp1 `(lo ,val) $r.tmp1)
18750 (sparc.jmpli as $r.millicode mproc $r.o7)
18751 (sparc.addr as $r.o7 $r.tmp1 $r.o7)))))
18753 (define (check-timer as DESTINATION RETRY)
18754 (sparc.subicc as $r.timer 1 $r.timer)
18755 (sparc.bne.a as DESTINATION)
18757 (millicode-call/ret as $m.timer-exception RETRY))
18759 ; When the destination and retry labels are the same, and follow the
18760 ; timer check immediately, then this code saves two static instructions.
18762 (define (check-timer0 as)
18763 (sparc.subicc as $r.timer 1 $r.timer)
18764 (sparc.bne.a as (+ (here as) 16))
18766 (sparc.jmpli as $r.millicode $m.timer-exception $r.o7)
18770 ; Copyright 1998 Lars T Hansen.
18772 ; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
18776 ; SPARC machine assembler.
18778 ; The procedure `sparc-instruction' takes an instruction class keyword and
18779 ; some operands and returns an assembler procedure for the instruction
18780 ; denoted by the class and the operands.
18782 ; All assembler procedures for SPARC mnemonics are defined in sparcasm2.sch.
18784 ; The SPARC has 32-bit, big-endian words. All instructions are 1 word.
18785 ; This assembler currently accepts a subset of the SPARC v8 instruction set.
18787 ; Each assembler procedure takes an `as' assembly structure (see
18788 ; Asm/Common/pass5p1.sch) and operands relevant to the instruction, and
18789 ; side-effects the assembly structure by emitting bits for the instruction
18790 ; and any necessary fixups. There are separate instruction mnemonics and
18791 ; assembler procedures for instructions which in the SPARC instruction set
18792 ; are normally considered the "same". For example, the `add' instruction is
18793 ; split into two operations here: `sparc.addr' takes a register as operand2,
18794 ; and `sparc.addi' takes an immediate. We could remove this restriction
18795 ; by using objects with identity rather than numbers for registers, but it
18796 ; does not seem to be an important problem.
18798 ; Operands that denote values (addresses, immediates, offsets) may be
18799 ; expressed using symbolic expressions. These expressions must conform
18800 ; to the following grammar:
18802 ; <expr> --> ( <number> . <obj> ) ; label
18803 ; | <number> ; literal value (exact integer)
18804 ; | (+ <expr> ... ) ; sum
18805 ; | (- <expr> ... ) ; difference
18806 ; | (hi <expr>) ; high 22 bits
18807 ; | (lo <expr>) ; low 10 bits
18809 ; Each assembler procedure will check that its value operand(s) fit in
18810 ; their instruction fields. It is a fatal error for an operand not
18811 ; to fit, and the assembler calls `asm-error' to signal this error.
18812 ; However, in some cases the assembler will instead call the error
18813 ; procedure `asm-value-too-large', which allows the higher-level assembler
18814 ; to retry the assembly with different settings (typically, by splitting
18815 ; a jump instruction into an offset calculation and a jump).
18817 ; Note: the idiom that is seen in this file,
18818 ; (emit-fixup-proc! as (lambda (b l) (fixup b l)))
18819 ; when `fixup' is a local procedure, avoids allocation of the closure
18820 ; except in the cases where the fixup is in fact needed, for gains in
18821 ; speed and reduction in allocation. (Ask me if you want numbers.)
18823 ; If FILL-DELAY-SLOTS returns true, then this assembler supports two
18824 ; distinct mechanisms for filling branch delay slots.
18826 ; An annulled conditional branch or an un-annulled unconditional branch
18827 ; may be followed by the strange instruction SPARC.SLOT, which turns into
18828 ; a nop in the delay slot that may be replaced by copying the instruction
18829 ; at the target of the branch into the delay slot and increasing the branch
18832 ; An un-annulled conditional branch whose target depends upon a known set
18833 ; of general registers, and does not depend upon the condition codes, may
18834 ; be followed by the strange instruction SPARC.SLOT2, which takes any
18835 ; number of registers as operands. This strange instruction turns into
18836 ; nothing at all if the following instruction has no side effects except
18837 ; to the condition codes and/or to a destination register that is distinct
18838 ; from the specified registers plus the stack pointer and %o7; otherwise
18839 ; the SPARC.SLOT2 instruction becomes a nop in the delay slot. The
18840 ; implementation of this uses a buffer that must be cleared when a label
18841 ; is emitted or when the current offset is obtained.
18843 (define sparc-instruction)
18845 (let ((original-emit-label! emit-label!)
18846 (original-here here))
18849 (assembler-value! as 'slot2-info #f)
18850 (original-emit-label! as L)))
18853 (assembler-value! as 'slot2-info #f)
18854 (original-here as)))
18857 (let ((emit! (lambda (as bits)
18858 (assembler-value! as 'slot2-info #f)
18860 (emit-fixup-proc! (lambda (as proc)
18861 (assembler-value! as 'slot2-info #f)
18862 (emit-fixup-proc! as proc)))
18863 (goes-in-delay-slot2? (lambda (as rd)
18864 (let ((regs (assembler-value as 'slot2-info)))
18867 (not (= rd $r.stkp))
18869 (not (memv rd regs)))))))
18871 (define ibit (asm:bv 0 0 #x20 0)) ; immediate bit: 2^13
18872 (define abit (asm:bv #x20 0 0 0)) ; annul bit: 2^29
18873 (define zero (asm:bv 0 0 0 0)) ; all zero bits
18875 (define two^32 (expt 2 32))
18877 ; Constant expression evaluation. If the expression cannot be
18878 ; evaluated, eval-expr returns #f, otherwise a number.
18879 ; The symbol table lookup must fail by returning #f.
18881 (define (eval-expr as e)
18883 (define (complement x)
18884 (modulo (+ two^32 x) two^32))
18889 (complement (quotient (complement e) 1024)))
18891 (quotient e 1024))))
18896 (remainder (complement e) 1024))
18898 (remainder e 1024))))
18900 (define (evaluate e)
18901 (cond ((integer? e) e)
18902 ((label? e) (label-value as e))
18903 ((eq? 'hi (car e)) (hibits (evaluate (cadr e))))
18904 ((eq? 'lo (car e)) (lobits (evaluate (cadr e))))
18906 (let loop ((e (cdr e)) (s 0))
18908 (let ((op (evaluate (car e))))
18910 (loop (cdr e) (+ s op)))))))
18912 (let loop ((e (cdr e)) (d #f))
18914 (let ((op (evaluate (car e))))
18916 (loop (cdr e) (if d (- d op) op)))))))
18918 (signal-error 'badexpr e))))
18922 ; Common error handling.
18924 (define (signal-error code . rest)
18925 (define msg "SPARC assembler: ")
18928 (asm-error msg "invalid expression " (car rest)))
18930 (asm-error msg "value too large in " (car rest) ": "
18931 (cadr rest) " = " (caddr rest)))
18933 (asm-error msg "fixup failed in " (car rest) " for " (cadr rest)))
18935 (asm-error msg "unaligned target in " (car rest) ": " (cadr rest)))
18937 (error "Invalid error code in assembler: " code))))
18939 ; The following procedures construct instructions by depositing field
18940 ; values directly into bytevectors; the location parameter in the dep-*!
18941 ; procedures is the address in the bytevector of the most significant byte.
18943 (define (copy! bv k bits)
18944 (bytevector-set! bv k (bytevector-ref bits 0))
18945 (bytevector-set! bv (+ k 1) (bytevector-ref bits 1))
18946 (bytevector-set! bv (+ k 2) (bytevector-ref bits 2))
18947 (bytevector-set! bv (+ k 3) (bytevector-ref bits 3))
18950 (define (copy bits)
18951 (let ((bv (make-bytevector 4)))
18952 (bytevector-set! bv 0 (bytevector-ref bits 0))
18953 (bytevector-set! bv 1 (bytevector-ref bits 1))
18954 (bytevector-set! bv 2 (bytevector-ref bits 2))
18955 (bytevector-set! bv 3 (bytevector-ref bits 3))
18958 (define (copy-instr bv from to)
18959 (bytevector-set! bv to (bytevector-ref bv from))
18960 (bytevector-set! bv (+ to 1) (bytevector-ref bv (+ from 1)))
18961 (bytevector-set! bv (+ to 2) (bytevector-ref bv (+ from 2)))
18962 (bytevector-set! bv (+ to 3) (bytevector-ref bv (+ from 3))))
18964 (define (dep-rs1! bits k rs1)
18965 (bytevector-set! bits (+ k 1)
18966 (logior (bytevector-ref bits (+ k 1))
18968 (bytevector-set! bits (+ k 2)
18969 (logior (bytevector-ref bits (+ k 2))
18970 (lsh (logand rs1 3) 6))))
18972 (define (dep-rs2! bits k rs2)
18973 (bytevector-set! bits (+ k 3)
18974 (logior (bytevector-ref bits (+ k 3)) rs2)))
18976 (define (dep-rd! bits k rd)
18977 (bytevector-set! bits k
18978 (logior (bytevector-ref bits k) (lsh rd 1))))
18980 (define (dep-imm! bits k imm)
18981 (cond ((fixnum? imm)
18982 (bytevector-set! bits (+ k 3) (logand imm 255))
18983 (bytevector-set! bits (+ k 2)
18984 (logior (bytevector-ref bits (+ k 2))
18985 (logand (rsha imm 8) 31))))
18987 (bytevector-set! bits (+ k 3) (bytevector-ref imm 0))
18988 (bytevector-set! bits (+ k 2)
18989 (logior (bytevector-ref bits (+ k 2))
18990 (logand (bytevector-ref imm 1)
18993 (dep-imm! bits k (asm:int->bv imm)))))
18995 (define (dep-branch-offset! bits k offs)
18996 (cond ((fixnum? offs)
18997 (if (not (= (logand offs 3) 0))
18998 (signal-error 'unaligned "branch" offs))
18999 (dep-imm22! bits k (rsha offs 2)))
19000 ((bytevector? offs)
19001 (if (not (= (logand (bytevector-ref offs 3) 3) 0))
19002 (signal-error 'unaligned "branch" (asm:bv->int offs)))
19003 (dep-imm22! bits k (asm:rsha offs 2)))
19005 (dep-branch-offset! bits k (asm:int->bv offs)))))
19007 (define (dep-imm22! bits k imm)
19008 (cond ((fixnum? imm)
19009 (bytevector-set! bits (+ k 3) (logand imm 255))
19010 (bytevector-set! bits (+ k 2)
19011 (logand (rsha imm 8) 255))
19012 (bytevector-set! bits (+ k 1)
19013 (logior (bytevector-ref bits (+ k 1))
19014 (logand (rsha imm 16) 63))))
19016 (bytevector-set! bits (+ k 3) (bytevector-ref imm 3))
19017 (bytevector-set! bits (+ k 2) (bytevector-ref imm 2))
19018 (bytevector-set! bits (+ k 1)
19019 (logior (bytevector-ref bits (+ k 1))
19020 (logand (bytevector-ref imm 1)
19023 (dep-imm22! bits k (asm:int->bv imm)))))
19025 (define (dep-call-offset! bits k offs)
19026 (cond ((fixnum? offs)
19027 (if (not (= (logand offs 3) 0))
19028 (signal-error 'unaligned "call" offs))
19029 (bytevector-set! bits (+ k 3) (logand (rsha offs 2) 255))
19030 (bytevector-set! bits (+ k 2) (logand (rsha offs 10) 255))
19031 (bytevector-set! bits (+ k 1) (logand (rsha offs 18) 255))
19032 (bytevector-set! bits k (logior (bytevector-ref bits k)
19033 (logand (rsha offs 26) 63))))
19034 ((bytevector? offs)
19035 (if (not (= (logand (bytevector-ref offs 3) 3) 0))
19036 (signal-error 'unaligned "call" (asm:bv->int offs)))
19037 (let ((offs (asm:rsha offs 2)))
19038 (bytevector-set! bits (+ k 3) (bytevector-ref offs 3))
19039 (bytevector-set! bits (+ k 2) (bytevector-ref offs 2))
19040 (bytevector-set! bits (+ k 1) (bytevector-ref offs 1))
19041 (bytevector-set! bits k (logior (bytevector-ref bits k)
19042 (logand (bytevector-ref offs 0)
19045 (dep-call-offset! bits k (asm:int->bv offs)))))
19047 ; Add 1 to an instruction (to bump a branch offset by 4).
19048 ; FIXME: should check for field overflow.
19050 (define (add1 bv loc)
19051 (let* ((r0 (+ (bytevector-ref bv (+ loc 3)) 1))
19052 (d0 (logand r0 255))
19054 (bytevector-set! bv (+ loc 3) d0)
19055 (let* ((r1 (+ (bytevector-ref bv (+ loc 2)) c0))
19056 (d1 (logand r1 255))
19058 (bytevector-set! bv (+ loc 2) d1)
19059 (let* ((r2 (+ (bytevector-ref bv (+ loc 1)) c1))
19060 (d2 (logand r2 255)))
19061 (bytevector-set! bv (+ loc 1) d2)))))
19063 ; For delay slot filling -- uses the assembler value scratchpad in
19064 ; the as structure. Delay slot filling is discussed in the comments
19065 ; for `branch' and `class-slot', below.
19067 (define (remember-branch-target as obj)
19068 (assembler-value! as 'branch-target obj))
19070 (define (recover-branch-target as)
19071 (assembler-value as 'branch-target))
19073 ; Mark the instruction at the current address as not being eligible
19074 ; for being lifted into a branch delay slot.
19076 ; FIXME: should perhaps be a hash table; see BOOT-STATUS file for details.
19078 (define (not-a-delay-slot-instruction as)
19079 (assembler-value! as 'not-dsi
19081 (or (assembler-value as 'not-dsi) '()))))
19083 (define (is-a-delay-slot-instruction? as bv addr)
19084 (and (not (memv addr (or (assembler-value as 'not-dsi) '())))
19085 (< addr (bytevector-length bv))))
19089 (define (class-sethi bits)
19090 (let ((bits (asm:lsh bits 22)))
19091 (lambda (as val rd)
19093 (define (fixup bv loc)
19095 (or (eval-expr as val)
19096 (signal-error 'fixup "sethi" val))))
19098 (define (fixup2 bv loc)
19099 (copy! bv loc bits)
19100 (dep-rd! bv loc rd)
19103 (if (goes-in-delay-slot2? as rd)
19104 (emit-fixup-proc! as
19106 (fixup2 b (- l 4))))
19108 (let ((bits (copy bits))
19109 (e (eval-expr as val)))
19111 (dep-imm22! bits 0 e)
19112 (emit-fixup-proc! as (lambda (b l) (fixup b l))))
19113 (dep-rd! bits 0 rd)
19114 (emit! as bits))))))
19116 ; NOP is a peculiar sethi
19118 (define (class-nop i)
19119 (let ((instr (class-sethi i)))
19121 (instr as 0 $r.g0))))
19126 (define (class00b i) (branch #b010 i zero)) ; Un-annulled IU branches.
19127 (define (class00a i) (branch #b010 i abit)) ; Annulled IU branches.
19128 (define (classf00b i) (branch #b110 i zero)) ; Un-annulled FP branches.
19129 (define (classf00a i) (branch #b110 i abit)) ; Annulled FP branches.
19131 ; The `type' parameter is #b010 for IU branches, #b110 for FP branches.
19132 ; The `bits' parameter is the bits for the cond field.
19133 ; The `annul' parameter is either `zero' or `abit' (see top of file).
19135 ; Annuled branches require special treatement for delay slot
19136 ; filling based on the `slot' pseudo-instruction.
19138 ; Strategy: when a branch with the annul bit set is assembled, remember
19139 ; its target in a one-element cache in the AS structure. When a slot
19140 ; instruction is found (it has its own class) then the cached
19141 ; value (possibly a delayed expression) is gotten, and a fixup for the
19142 ; slot is registered. When the fixup is later evaluated, the branch
19143 ; target instruction can be found, examined, and evaluated.
19145 ; The cached value is always valid when the slot instruction is assembled,
19146 ; because a slot instruction is always directly preceded by an annulled
19147 ; branch (which will always set the cache).
19149 (define (branch type bits annul)
19150 ; The delay slot should be filled if this is an annulled branch
19151 ; or an unconditional branch.
19152 (let ((fill-delay-slot? (or (not (eq? annul zero))
19153 (eq? bits #b1000)))
19154 (bits (asm:logior (asm:lsh bits 25) (asm:lsh type 22) annul)))
19155 (lambda (as target0)
19156 (let ((target `(- ,target0 ,(here as))))
19159 (let ((e (eval-expr as target)))
19162 ((not (zero? (logand e 3)))
19163 (signal-error 'unaligned "branch" target0))
19167 (asm-value-too-large as "branch" target e)))))
19169 (define (fixup bv loc)
19172 (dep-branch-offset! bv loc e)
19173 (signal-error 'fixup "branch" target0))))
19175 (if fill-delay-slot?
19176 (remember-branch-target as target0)
19177 (remember-branch-target as #f)) ; Clears the cache.
19178 (not-a-delay-slot-instruction as)
19179 (let ((bits (copy bits))
19182 (dep-branch-offset! bits 0 e)
19183 (emit-fixup-proc! as (lambda (b l) (fixup b l))))
19184 (emit! as bits))))))
19186 ; Branch delay slot pseudo-instruction.
19188 ; Get the branch target expression from the cache in the AS structure,
19189 ; and if it is not #f, register a fixup procedure for the delay slot that
19190 ; will copy the target instruction to the slot and add 4 to the branch
19191 ; offset (unless that will overflow the offset or the instruction at the
19192 ; target is not suitable for lifting).
19194 ; It's important that this fixup run _after_ any fixups for the branch
19195 ; instruction itself!
19197 (define (class-slot)
19198 (let ((nop-instr (class-nop #b100)))
19201 ; The branch target is the expression denoting the target location.
19203 (define branch-target (recover-branch-target as))
19205 (define (fixup bv loc)
19206 (let ((bt (or (eval-expr as branch-target)
19207 (asm-error "Branch fixup: can't happen: "
19209 (if (is-a-delay-slot-instruction? as bv bt)
19211 (copy-instr bv bt loc)
19212 (add1 bv (- loc 4))))))
19214 (if (and branch-target (fill-delay-slots))
19215 (emit-fixup-proc! as (lambda (b l) (fixup b l))))
19218 ; Branch delay slot pseudo-instruction 2.
19220 ; Emit a nop, but record the information that will allow this nop to be
19221 ; replaced by a sufficiently harmless ALU instruction.
19223 (define (class-slot2)
19224 (let ((nop-instr (class-nop #b100)))
19225 (lambda (as . regs)
19227 (assembler-value! as 'slot2-info regs))))
19229 ; ALU stuff, register operand, rdy, wryr. Also: jump.
19231 (define (class10r bits . extra)
19232 (cond ((and (not (null? extra)) (eq? (car extra) 'rdy))
19233 (let ((op (class10r bits)))
19236 ((and (not (null? extra)) (eq? (car extra) 'wry))
19237 (let ((op (class10r bits)))
19241 (let ((bits (asm:logior (asm:lsh #b10 30) (asm:lsh bits 19)))
19242 (jump? (and (not (null? extra)) (eq? (car extra) 'jump))))
19243 (lambda (as rs1 rs2 rd)
19244 (let ((bits (copy bits)))
19245 (dep-rs1! bits 0 rs1)
19246 (dep-rs2! bits 0 rs2)
19247 (dep-rd! bits 0 rd)
19249 (not-a-delay-slot-instruction as)
19251 ((goes-in-delay-slot2? as rd)
19255 (copy! bv (- loc 4) bits))))
19257 (emit! as bits)))))))))
19260 ; ALU stuff, immediate operand, wryi. Also: jump.
19262 (define (class10i bits . extra)
19263 (if (and (not (null? extra)) (eq? (car extra) 'wry))
19264 (let ((op (class10i bits)))
19267 (let ((bits (asm:logior (asm:lsh #b10 30) (asm:lsh bits 19) ibit))
19268 (jump? (and (not (null? extra)) (eq? (car extra) 'jump))))
19269 (lambda (as rs1 e rd)
19272 (let ((imm (eval-expr as e)))
19275 ((asm:fits? imm 13)
19278 (asm-value-too-large as "`jmpli'" e imm))
19280 (asm-value-too-large as "ALU instruction" e imm)))))
19282 (define (fixup bv loc)
19285 (dep-imm! bv loc e)
19286 (signal-error 'fixup "ALU instruction" e))))
19288 (let ((bits (copy bits))
19291 (dep-imm! bits 0 e)
19292 (emit-fixup-proc! as (lambda (b l) (fixup b l))))
19293 (dep-rs1! bits 0 rs1)
19294 (dep-rd! bits 0 rd)
19296 (not-a-delay-slot-instruction as)
19298 ((goes-in-delay-slot2? as rd)
19302 (copy! bv (- loc 4) bits))))
19304 (emit! as bits))))))))
19306 ; Memory stuff, register operand.
19308 (define (class11r bits)
19309 (let ((bits (asm:logior (asm:lsh #b11 30) (asm:lsh bits 19))))
19310 (lambda (as rs1 rs2 rd)
19311 (let ((bits (copy bits)))
19312 (dep-rs1! bits 0 rs1)
19313 (dep-rs2! bits 0 rs2)
19314 (dep-rd! bits 0 rd)
19315 (emit! as bits)))))
19317 ; Memory stuff, immediate operand.
19319 (define (class11i bits)
19320 (let ((bits (asm:logior (asm:lsh #b11 30) (asm:lsh bits 19) ibit)))
19321 (lambda (as rs1 e rd)
19324 (let ((imm (eval-expr as e)))
19325 (cond ((not imm) imm)
19326 ((asm:fits? imm 13) imm)
19328 (signal-error 'toolarge "Memory instruction" e imm)))))
19330 (define (fixup bv loc)
19333 (dep-imm! bv loc e)
19334 (signal-error 'fixup "Memory instruction" e))))
19336 (let ((bits (copy bits))
19338 (dep-rs1! bits 0 rs1)
19339 (dep-rd! bits 0 rd)
19341 (dep-imm! bits 0 e)
19342 (emit-fixup-proc! as (lambda (b l) (fixup b l))))
19343 (emit! as bits)))))
19345 ; For store instructions. The syntax is (st a b c) meaning m[ b+c ] <- a.
19346 ; However, on the Sparc, the destination (rd) field is the source of
19347 ; a store, so we transform the instruction into (st c b a) and pass it
19348 ; to the real store procedure.
19350 (define (class11sr bits)
19351 (let ((store-instr (class11r bits)))
19353 (store-instr as c b a))))
19355 (define (class11si bits)
19356 (let ((store-instr (class11i bits)))
19358 (store-instr as c b a))))
19360 ; Call is a class all by itself.
19362 (define (class-call)
19363 (let ((code (asm:lsh #b01 30)))
19364 (lambda (as target0)
19365 (let ((target `(- ,target0 ,(here as))))
19367 (define (fixup bv loc)
19368 (let ((e (eval-expr as target)))
19370 (dep-call-offset! bv loc e)
19371 (signal-error 'fixup "call" target0))))
19373 (let ((bits (copy code))
19374 (e (eval-expr as target)))
19375 (not-a-delay-slot-instruction as)
19377 (dep-call-offset! bits 0 e)
19378 (emit-fixup-proc! as (lambda (b l) (fixup b l))))
19379 (emit! as bits))))))
19381 (define (class-label)
19383 (emit-label! as label)))
19385 ; FP operation, don't set CC.
19387 (define (class-fpop1 i) (fpop #b110100 i))
19389 ; FP operation, set CC
19391 (define (class-fpop2 i) (fpop #b110101 i))
19393 (define (fpop type opf)
19394 (let ((bits (asm:logior (asm:lsh #b10 30)
19397 (lambda (as rs1 rs2 rd)
19398 (let ((bits (copy bits)))
19399 (dep-rs1! bits 0 rs1)
19400 (dep-rs2! bits 0 rs2)
19401 (dep-rd! bits 0 rd)
19402 (emit! as bits)))))
19404 (set! sparc-instruction
19405 (lambda (kwd . ops)
19407 ((i11) (apply class11i ops))
19408 ((r11) (apply class11r ops))
19409 ((si11) (apply class11si ops))
19410 ((sr11) (apply class11sr ops))
19411 ((sethi) (apply class-sethi ops))
19412 ((r10) (apply class10r ops))
19413 ((i10) (apply class10i ops))
19414 ((b00) (apply class00b ops))
19415 ((a00) (apply class00a ops))
19416 ((call) (apply class-call ops))
19417 ((label) (apply class-label ops))
19418 ((nop) (apply class-nop ops))
19419 ((slot) (apply class-slot ops))
19420 ((slot2) (apply class-slot2 ops))
19421 ((fb00) (apply classf00b ops))
19422 ((fa00) (apply classf00a ops))
19423 ((fp) (apply class-fpop1 ops))
19424 ((fpcc) (apply class-fpop2 ops))
19426 (asm-error "sparc-instruction: unrecognized class: " kwd)))))
19427 'sparc-instruction)
19430 ; Instruction mnemonics
19432 (define sparc.lddi (sparc-instruction 'i11 #b000011))
19433 (define sparc.lddr (sparc-instruction 'r11 #b000011))
19434 (define sparc.ldi (sparc-instruction 'i11 #b000000))
19435 (define sparc.ldr (sparc-instruction 'r11 #b000000))
19436 (define sparc.ldhi (sparc-instruction 'i11 #b000010))
19437 (define sparc.ldhr (sparc-instruction 'r11 #b000010))
19438 (define sparc.ldbi (sparc-instruction 'i11 #b000001))
19439 (define sparc.ldbr (sparc-instruction 'r11 #b000001))
19440 (define sparc.lddfi (sparc-instruction 'i11 #b100011))
19441 (define sparc.lddfr (sparc-instruction 'r11 #b100011))
19442 (define sparc.stdi (sparc-instruction 'si11 #b000111))
19443 (define sparc.stdr (sparc-instruction 'sr11 #b000111))
19444 (define sparc.sti (sparc-instruction 'si11 #b000100))
19445 (define sparc.str (sparc-instruction 'sr11 #b000100))
19446 (define sparc.sthi (sparc-instruction 'si11 #b000110))
19447 (define sparc.sthr (sparc-instruction 'sr11 #b000110))
19448 (define sparc.stbi (sparc-instruction 'si11 #b000101))
19449 (define sparc.stbr (sparc-instruction 'sr11 #b000101))
19450 (define sparc.stdfi (sparc-instruction 'si11 #b100111))
19451 (define sparc.stdfr (sparc-instruction 'sr11 #b100111))
19452 (define sparc.sethi (sparc-instruction 'sethi #b100))
19453 (define sparc.andr (sparc-instruction 'r10 #b000001))
19454 (define sparc.andrcc (sparc-instruction 'r10 #b010001))
19455 (define sparc.andi (sparc-instruction 'i10 #b000001))
19456 (define sparc.andicc (sparc-instruction 'i10 #b010001))
19457 (define sparc.orr (sparc-instruction 'r10 #b000010))
19458 (define sparc.orrcc (sparc-instruction 'r10 #b010010))
19459 (define sparc.ori (sparc-instruction 'i10 #b000010))
19460 (define sparc.oricc (sparc-instruction 'i10 #b010010))
19461 (define sparc.xorr (sparc-instruction 'r10 #b000011))
19462 (define sparc.xorrcc (sparc-instruction 'r10 #b010011))
19463 (define sparc.xori (sparc-instruction 'i10 #b000011))
19464 (define sparc.xoricc (sparc-instruction 'i10 #b010011))
19465 (define sparc.sllr (sparc-instruction 'r10 #b100101))
19466 (define sparc.slli (sparc-instruction 'i10 #b100101))
19467 (define sparc.srlr (sparc-instruction 'r10 #b100110))
19468 (define sparc.srli (sparc-instruction 'i10 #b100110))
19469 (define sparc.srar (sparc-instruction 'r10 #b100111))
19470 (define sparc.srai (sparc-instruction 'i10 #b100111))
19471 (define sparc.addr (sparc-instruction 'r10 #b000000))
19472 (define sparc.addrcc (sparc-instruction 'r10 #b010000))
19473 (define sparc.addi (sparc-instruction 'i10 #b000000))
19474 (define sparc.addicc (sparc-instruction 'i10 #b010000))
19475 (define sparc.taddrcc (sparc-instruction 'r10 #b100000))
19476 (define sparc.taddicc (sparc-instruction 'i10 #b100000))
19477 (define sparc.subr (sparc-instruction 'r10 #b000100))
19478 (define sparc.subrcc (sparc-instruction 'r10 #b010100))
19479 (define sparc.subi (sparc-instruction 'i10 #b000100))
19480 (define sparc.subicc (sparc-instruction 'i10 #b010100))
19481 (define sparc.tsubrcc (sparc-instruction 'r10 #b100001))
19482 (define sparc.tsubicc (sparc-instruction 'i10 #b100001))
19483 (define sparc.smulr (sparc-instruction 'r10 #b001011))
19484 (define sparc.smulrcc (sparc-instruction 'r10 #b011011))
19485 (define sparc.smuli (sparc-instruction 'i10 #b001011))
19486 (define sparc.smulicc (sparc-instruction 'i10 #b011011))
19487 (define sparc.sdivr (sparc-instruction 'r10 #b001111))
19488 (define sparc.sdivrcc (sparc-instruction 'r10 #b011111))
19489 (define sparc.sdivi (sparc-instruction 'i10 #b001111))
19490 (define sparc.sdivicc (sparc-instruction 'i10 #b011111))
19491 (define sparc.b (sparc-instruction 'b00 #b1000))
19492 (define sparc.b.a (sparc-instruction 'a00 #b1000))
19493 (define sparc.bne (sparc-instruction 'b00 #b1001))
19494 (define sparc.bne.a (sparc-instruction 'a00 #b1001))
19495 (define sparc.be (sparc-instruction 'b00 #b0001))
19496 (define sparc.be.a (sparc-instruction 'a00 #b0001))
19497 (define sparc.bg (sparc-instruction 'b00 #b1010))
19498 (define sparc.bg.a (sparc-instruction 'a00 #b1010))
19499 (define sparc.ble (sparc-instruction 'b00 #b0010))
19500 (define sparc.ble.a (sparc-instruction 'a00 #b0010))
19501 (define sparc.bge (sparc-instruction 'b00 #b1011))
19502 (define sparc.bge.a (sparc-instruction 'a00 #b1011))
19503 (define sparc.bl (sparc-instruction 'b00 #b0011))
19504 (define sparc.bl.a (sparc-instruction 'a00 #b0011))
19505 (define sparc.bgu (sparc-instruction 'b00 #b1100))
19506 (define sparc.bgu.a (sparc-instruction 'a00 #b1100))
19507 (define sparc.bleu (sparc-instruction 'b00 #b0100))
19508 (define sparc.bleu.a (sparc-instruction 'a00 #b0100))
19509 (define sparc.bcc (sparc-instruction 'b00 #b1101))
19510 (define sparc.bcc.a (sparc-instruction 'a00 #b1101))
19511 (define sparc.bcs (sparc-instruction 'b00 #b0101))
19512 (define sparc.bcs.a (sparc-instruction 'a00 #b0101))
19513 (define sparc.bpos (sparc-instruction 'b00 #b1110))
19514 (define sparc.bpos.a (sparc-instruction 'a00 #b1110))
19515 (define sparc.bneg (sparc-instruction 'b00 #b0110))
19516 (define sparc.bneg.a (sparc-instruction 'a00 #b0110))
19517 (define sparc.bvc (sparc-instruction 'b00 #b1111))
19518 (define sparc.bvc.a (sparc-instruction 'a00 #b1111))
19519 (define sparc.bvs (sparc-instruction 'b00 #b0111))
19520 (define sparc.bvs.a (sparc-instruction 'a00 #b0111))
19521 (define sparc.call (sparc-instruction 'call))
19522 (define sparc.jmplr (sparc-instruction 'r10 #b111000 'jump))
19523 (define sparc.jmpli (sparc-instruction 'i10 #b111000 'jump))
19524 (define sparc.nop (sparc-instruction 'nop #b100))
19525 (define sparc.ornr (sparc-instruction 'r10 #b000110))
19526 (define sparc.orni (sparc-instruction 'i10 #b000110))
19527 (define sparc.ornrcc (sparc-instruction 'r10 #b010110))
19528 (define sparc.ornicc (sparc-instruction 'i10 #b010110))
19529 (define sparc.andni (sparc-instruction 'i10 #b000101))
19530 (define sparc.andnr (sparc-instruction 'r10 #b000101))
19531 (define sparc.andnicc (sparc-instruction 'i10 #b010101))
19532 (define sparc.andnrcc (sparc-instruction 'r10 #b010101))
19533 (define sparc.rdy (sparc-instruction 'r10 #b101000 'rdy))
19534 (define sparc.wryr (sparc-instruction 'r10 #b110000 'wry))
19535 (define sparc.wryi (sparc-instruction 'i10 #b110000 'wry))
19536 (define sparc.fb (sparc-instruction 'fb00 #b1000))
19537 (define sparc.fb.a (sparc-instruction 'fa00 #b1000))
19538 (define sparc.fbn (sparc-instruction 'fb00 #b0000))
19539 (define sparc.fbn.a (sparc-instruction 'fa00 #b0000))
19540 (define sparc.fbu (sparc-instruction 'fb00 #b0111))
19541 (define sparc.fbu.a (sparc-instruction 'fa00 #b0111))
19542 (define sparc.fbg (sparc-instruction 'fb00 #b0110))
19543 (define sparc.fbg.a (sparc-instruction 'fa00 #b0110))
19544 (define sparc.fbug (sparc-instruction 'fb00 #b0101))
19545 (define sparc.fbug.a (sparc-instruction 'fa00 #b0101))
19546 (define sparc.fbl (sparc-instruction 'fb00 #b0100))
19547 (define sparc.fbl.a (sparc-instruction 'fa00 #b0100))
19548 (define sparc.fbul (sparc-instruction 'fb00 #b0011))
19549 (define sparc.fbul.a (sparc-instruction 'fa00 #b0011))
19550 (define sparc.fblg (sparc-instruction 'fb00 #b0010))
19551 (define sparc.fblg.a (sparc-instruction 'fa00 #b0010))
19552 (define sparc.fbne (sparc-instruction 'fb00 #b0001))
19553 (define sparc.fbne.a (sparc-instruction 'fa00 #b0001))
19554 (define sparc.fbe (sparc-instruction 'fb00 #b1001))
19555 (define sparc.fbe.a (sparc-instruction 'fa00 #b1001))
19556 (define sparc.fbue (sparc-instruction 'fb00 #b1010))
19557 (define sparc.fbue.a (sparc-instruction 'fa00 #b1010))
19558 (define sparc.fbge (sparc-instruction 'fb00 #b1011))
19559 (define sparc.fbge.a (sparc-instruction 'fa00 #b1011))
19560 (define sparc.fbuge (sparc-instruction 'fb00 #b1100))
19561 (define sparc.fbuge.a (sparc-instruction 'fa00 #b1100))
19562 (define sparc.fble (sparc-instruction 'fb00 #b1101))
19563 (define sparc.fble.a (sparc-instruction 'fa00 #b1101))
19564 (define sparc.fbule (sparc-instruction 'fb00 #b1110))
19565 (define sparc.fbule.a (sparc-instruction 'fa00 #b1110))
19566 (define sparc.fbo (sparc-instruction 'fb00 #b1111))
19567 (define sparc.fbo.a (sparc-instruction 'fa00 #b1111))
19568 (define sparc.faddd (sparc-instruction 'fp #b001000010))
19569 (define sparc.fsubd (sparc-instruction 'fp #b001000110))
19570 (define sparc.fmuld (sparc-instruction 'fp #b001001010))
19571 (define sparc.fdivd (sparc-instruction 'fp #b001001110))
19572 (define sparc%fnegs (sparc-instruction 'fp #b000000101)) ; See below
19573 (define sparc%fmovs (sparc-instruction 'fp #b000000001)) ; See below
19574 (define sparc%fabss (sparc-instruction 'fp #b000001001)) ; See below
19575 (define sparc%fcmpdcc (sparc-instruction 'fpcc #b001010010)) ; See below
19577 ; Strange instructions.
19579 (define sparc.slot (sparc-instruction 'slot))
19580 (define sparc.slot2 (sparc-instruction 'slot2))
19581 (define sparc.label (sparc-instruction 'label))
19585 (define sparc.bnz sparc.bne)
19586 (define sparc.bnz.a sparc.bne.a)
19587 (define sparc.bz sparc.be)
19588 (define sparc.bz.a sparc.be.a)
19589 (define sparc.bgeu sparc.bcc)
19590 (define sparc.bgeu.a sparc.bcc.a)
19591 (define sparc.blu sparc.bcs)
19592 (define sparc.blu.a sparc.bcs.a)
19596 (define (sparc.cmpr as r1 r2) (sparc.subrcc as r1 r2 $r.g0))
19597 (define (sparc.cmpi as r imm) (sparc.subicc as r imm $r.g0))
19598 (define (sparc.move as rs rd) (sparc.orr as $r.g0 rs rd))
19599 (define (sparc.set as imm rd) (sparc.ori as $r.g0 imm rd))
19600 (define (sparc.btsti as rs imm) (sparc.andicc as rs imm $r.g0))
19601 (define (sparc.clr as rd) (sparc.move as $r.g0 rd))
19603 (define (sparc.deccc as rs . rest)
19604 (let ((k (cond ((null? rest) 1)
19605 ((null? (cdr rest)) (car rest))
19606 (else (asm-error "sparc.deccc: too many operands: " rest)))))
19607 (sparc.subicc as rs k rs)))
19609 ; Floating-point abstractions
19611 ; For fmovd, fnegd, and fabsd, we must synthesize the instruction from
19612 ; fmovs, fnegs, and fabss -- SPARC V8 has only the latter. (SPARC V9 add
19615 (define (sparc.fmovd as rs rd)
19616 (sparc%fmovs as rs 0 rd)
19617 (sparc%fmovs as (+ rs 1) 0 (+ rd 1)))
19619 (define (sparc.fnegd as rs rd)
19620 (sparc%fnegs as rs 0 rd)
19621 (if (not (= rs rd))
19622 (sparc%fmovs as (+ rs 1) 0 (+ rd 1))))
19624 (define (sparc.fabsd as rs rd)
19625 (sparc%fabss as rs 0 rd)
19626 (if (not (= rs rd))
19627 (sparc%fmovs as (+ rs 1) 0 (+ rd 1))))
19629 (define (sparc.fcmpd as rs1 rs2)
19630 (sparc%fcmpdcc as rs1 rs2 0))
19633 ; Copyright 1998 Lars T Hansen.
19635 ; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
19637 ; Asm/Sparc/gen-msi.sch -- SPARC assembler code emitters for
19638 ; core MacScheme instructions
19645 ; RS must be a hardware register.
19647 ; A global cell is a pair, where the car holds the value.
19649 (define (emit-register->global! as rs offset)
19650 (cond ((= rs $r.result)
19651 (sparc.move as $r.result $r.argreg2)
19652 (emit-const->register! as offset $r.result)
19653 (if (write-barrier)
19654 (sparc.jmpli as $r.millicode $m.addtrans $r.o7))
19655 (sparc.sti as $r.argreg2 (- $tag.pair-tag) $r.result))
19657 (emit-const->register! as offset $r.result)
19658 (sparc.sti as rs (- $tag.pair-tag) $r.result)
19659 (if (write-barrier)
19660 (millicode-call/1arg as $m.addtrans rs)))))
19665 ; A global cell is a pair, where the car holds the value.
19666 ; If (catch-undefined-globals) is true, then code will be emitted to
19667 ; check whether the global is #!undefined when loaded. If it is,
19668 ; an exception will be taken, with the global in question in $r.result.
19670 (define (emit-global->register! as offset r)
19671 (emit-load-global as offset r (catch-undefined-globals)))
19673 ; This leaves the cell in ARGREG2. That fact is utilized by global/invoke
19674 ; to signal an appropriate error message.
19676 (define (emit-load-global as offset r check?)
19678 (define (emit-undef-check! as r)
19680 (let ((GLOBAL-OK (new-label)))
19681 (sparc.cmpi as r $imm.undefined)
19682 (sparc.bne.a as GLOBAL-OK)
19684 (millicode-call/0arg as $m.global-ex) ; Cell in ARGREG2.
19685 (sparc.label as GLOBAL-OK))))
19687 (emit-const->register! as offset $r.argreg2) ; Load cell.
19688 (if (hardware-mapped? r)
19689 (begin (sparc.ldi as $r.argreg2 (- $tag.pair-tag) r)
19690 (emit-undef-check! as r))
19691 (begin (sparc.ldi as $r.argreg2 (- $tag.pair-tag) $r.tmp0)
19692 (emit-store-reg! as $r.tmp0 r)
19693 (emit-undef-check! as $r.tmp0))))
19698 (define (emit-register->register! as from to)
19699 (if (not (= from to))
19700 (cond ((and (hardware-mapped? from) (hardware-mapped? to))
19701 (sparc.move as from to))
19702 ((hardware-mapped? from)
19703 (emit-store-reg! as from to))
19704 ((hardware-mapped? to)
19705 (emit-load-reg! as from to))
19707 (emit-load-reg! as from $r.tmp0)
19708 (emit-store-reg! as $r.tmp0 to)))))
19713 (define (emit-args=! as n)
19714 (if (not (unsafe-code))
19715 (let ((L2 (new-label)))
19716 (sparc.cmpi as $r.result (thefixnum n)) ; FIXME: limit 1023 args
19719 (millicode-call/numarg-in-reg as $m.argc-ex (thefixnum n) $r.argreg2)
19720 (sparc.label as L2))))
19725 ; The cases for 0 and 1 rest arguments are handled in-line; all other
19726 ; cases, including too few, are handled in millicode (really: a C call-out).
19728 ; The fast path only applies when we don't have to mess with the last
19729 ; register, hence the test.
19731 (define (emit-args>=! as n)
19732 (let ((L0 (new-label))
19735 (if (< n (- *lastreg* 1))
19736 (let ((dest (regname (+ n 1))))
19737 (sparc.cmpi as $r.result (thefixnum n)) ; n args
19738 (if (hardware-mapped? dest)
19740 (sparc.be.a as L99)
19741 (sparc.set as $imm.null dest))
19743 (sparc.set as $imm.null $r.tmp0)
19744 (sparc.be.a as L99)
19745 (sparc.sti as $r.tmp0 (swreg-global-offset dest) $r.globals)))
19746 (sparc.cmpi as $r.result (thefixnum (+ n 1))) ; n+1 args
19747 (sparc.bne.a as L98)
19749 (millicode-call/numarg-in-result as $m.alloc 8)
19750 (let ((src1 (force-hwreg! as dest $r.tmp1)))
19751 (sparc.set as $imm.null $r.tmp0)
19752 (sparc.sti as src1 0 $r.result)
19753 (sparc.sti as $r.tmp0 4 $r.result)
19754 (sparc.addi as $r.result $tag.pair-tag $r.result)
19756 (if (hardware-mapped? dest)
19757 (sparc.move as $r.result dest)
19758 (sparc.sti as $r.result (swreg-global-offset dest)
19761 (sparc.label as L98)
19762 (sparc.move as $r.reg0 $r.argreg3) ; FIXME in Sparc/mcode.s
19763 (millicode-call/numarg-in-reg as $m.varargs (thefixnum n) $r.argreg2)
19764 (sparc.label as L99)))
19770 ; Bummed. Can still do better when the procedure to call is in a general
19771 ; register (avoids the redundant move to RESULT preceding INVOKE).
19773 ; Note we must set up the argument count even in unsafe mode, because we
19774 ; may be calling code that was not compiled unsafe.
19776 (define (emit-invoke as n setrtn? mc-exception)
19777 (let ((START (new-label))
19778 (TIMER-OK (new-label))
19779 (PROC-OK (new-label)))
19780 (cond ((not (unsafe-code))
19781 (sparc.label as START)
19782 (sparc.subicc as $r.timer 1 $r.timer)
19783 (sparc.bne as TIMER-OK)
19784 (sparc.andi as $r.result $tag.tagmask $r.tmp0)
19785 (millicode-call/ret as $m.timer-exception START)
19786 (sparc.label as TIMER-OK)
19787 (sparc.cmpi as $r.tmp0 $tag.procedure-tag)
19788 (sparc.be.a as PROC-OK)
19789 (sparc.ldi as $r.result $p.codevector $r.tmp0)
19790 (millicode-call/ret as mc-exception START)
19791 (sparc.label as PROC-OK))
19793 (sparc.label as START)
19794 (sparc.subicc as $r.timer 1 $r.timer)
19795 (sparc.bne.a as TIMER-OK)
19796 (sparc.ldi as $r.result $p.codevector $r.tmp0)
19797 (millicode-call/ret as $m.timer-exception START)
19798 (sparc.label as TIMER-OK)))
19799 (sparc.move as $r.result $r.reg0)
19800 ;; FIXME: limit 1023 args
19802 (sparc.set as (thefixnum n) $r.result)
19803 (sparc.jmpli as $r.tmp0 $p.codeoffset $r.o7)
19804 (sparc.sti as $r.o7 4 $r.stkp))
19806 (sparc.jmpli as $r.tmp0 $p.codeoffset $r.g0)
19807 (sparc.set as (thefixnum n) $r.result)))))
19809 ; SAVE -- for new compiler
19811 ; Create stack frame. To avoid confusing the garbage collector, the
19812 ; slots must be initialized to something definite unless they will
19813 ; immediately be initialized by a MacScheme machine store instruction.
19814 ; The creation is done by emit-save0!, and the initialization is done
19817 (define (emit-save0! as n)
19818 (let* ((L1 (new-label))
19820 (framesize (+ 8 (* (+ n 1) 4)))
19821 (realsize (roundup8 (+ framesize 4))))
19822 (sparc.label as L0)
19823 (sparc.subi as $r.stkp realsize $r.stkp)
19824 (sparc.cmpr as $r.stklim $r.stkp)
19825 (sparc.ble.a as L1)
19826 (sparc.set as framesize $r.tmp0)
19827 (sparc.addi as $r.stkp realsize $r.stkp)
19828 (millicode-call/ret as $m.stkoflow L0)
19829 (sparc.label as L1)
19830 ; initialize size and return fields of stack frame
19831 (sparc.sti as $r.tmp0 0 $r.stkp)
19832 (sparc.sti as $r.g0 4 $r.stkp)))
19834 ; Given a vector v of booleans, initializes slot i of the stack frame
19835 ; if and only if (vector-ref v i).
19837 (define (emit-save1! as v)
19838 (let ((n (vector-length v)))
19839 (let loop ((i 0) (offset 12))
19843 (sparc.sti as $r.g0 offset $r.stkp)
19844 (loop (+ i 1) (+ offset 4)))
19846 (loop (+ i 1) (+ offset 4)))))))
19851 ; Restore registers from stack frame
19852 ; FIXME: Use ldd/std here; see comments for emit-save!, above.
19853 ; We pop only actual registers.
19855 (define (emit-restore! as n)
19856 (let ((n (min n 31)))
19858 (offset 12 (+ offset 4)))
19860 (let ((r (regname i)))
19861 (if (hardware-mapped? r)
19862 (sparc.ldi as $r.stkp offset r)
19863 (begin (sparc.ldi as $r.stkp offset $r.tmp0)
19864 (emit-store-reg! as $r.tmp0 r)))))))
19866 ; POP -- for new compiler
19869 ; If returning?, then emit the return as well and put the pop
19870 ; in its delay slot.
19872 (define (emit-pop! as n returning?)
19873 (let* ((framesize (+ 8 (* (+ n 1) 4)))
19874 (realsize (roundup8 (+ framesize 4))))
19876 (begin (sparc.ldi as $r.stkp (+ realsize 4) $r.o7)
19877 (sparc.jmpli as $r.o7 8 $r.g0)
19878 (sparc.addi as $r.stkp realsize $r.stkp))
19879 (sparc.addi as $r.stkp realsize $r.stkp))))
19884 ; Change the return address in the stack frame.
19886 (define (emit-setrtn! as label)
19887 (emit-return-address! as label)
19888 (sparc.sti as $r.o7 4 $r.stkp))
19893 ; `apply' falls into millicode.
19895 ; The timer check is performed here because it is not very easy for the
19896 ; millicode to do this.
19898 (define (emit-apply! as r1 r2)
19899 (let ((L0 (new-label)))
19901 (sparc.label as L0)
19902 (emit-move2hwreg! as r1 $r.argreg2)
19903 (emit-move2hwreg! as r2 $r.argreg3)
19904 (millicode-call/0arg as $m.apply)))
19909 (define (emit-load! as slot dest-reg)
19910 (if (hardware-mapped? dest-reg)
19911 (sparc.ldi as $r.stkp (+ 12 (* slot 4)) dest-reg)
19912 (begin (sparc.ldi as $r.stkp (+ 12 (* slot 4)) $r.tmp0)
19913 (emit-store-reg! as $r.tmp0 dest-reg))))
19918 (define (emit-store! as k n)
19919 (if (hardware-mapped? k)
19920 (sparc.sti as k (+ 12 (* n 4)) $r.stkp)
19921 (begin (emit-load-reg! as k $r.tmp0)
19922 (sparc.sti as $r.tmp0 (+ 12 (* n 4)) $r.stkp))))
19927 (define (emit-lexical! as m n)
19928 (let ((base (emit-follow-chain! as m)))
19929 (sparc.ldi as base (- (procedure-slot-offset n) $tag.procedure-tag)
19934 ; FIXME: should allow an in-line barrier
19936 (define (emit-setlex! as m n)
19937 (let ((base (emit-follow-chain! as m)))
19938 (sparc.sti as $r.result (- (procedure-slot-offset n) $tag.procedure-tag)
19940 (if (write-barrier)
19942 (sparc.move as $r.result $r.argreg2)
19943 (millicode-call/1arg-in-result as $m.addtrans base)))))
19946 ; Follow static links.
19948 ; By using and leaving the result in ARGREG3 rather than in RESULT,
19949 ; we save a temporary register.
19951 (define (emit-follow-chain! as m)
19953 (cond ((not (zero? q))
19955 (if (= q m) $r.reg0 $r.argreg3)
19966 (define (emit-return! as)
19967 (sparc.ldi as $r.stkp 4 $r.o7)
19968 (sparc.jmpli as $r.o7 8 $r.g0)
19974 (define (emit-return-reg! as r)
19975 (sparc.ldi as $r.stkp 4 $r.o7)
19976 (sparc.jmpli as $r.o7 8 $r.g0)
19977 (sparc.move as r $r.result))
19982 ; The constant c must be synthesizable in a single instruction.
19984 (define (emit-return-const! as c)
19985 (sparc.ldi as $r.stkp 4 $r.o7)
19986 (sparc.jmpli as $r.o7 8 $r.g0)
19987 (emit-constant->register as c $r.result))
19992 (define (emit-mvrtn! as)
19993 (asm-error "multiple-value return has not been implemented (yet)."))
19998 (define (emit-lexes! as n-slots)
19999 (emit-alloc-proc! as n-slots)
20000 (sparc.ldi as $r.reg0 $p.codevector $r.tmp0)
20001 (sparc.ldi as $r.reg0 $p.constvector $r.tmp1)
20002 (sparc.sti as $r.tmp0 $p.codevector $r.result)
20003 (sparc.sti as $r.tmp1 $p.constvector $r.result)
20004 (emit-init-proc-slots! as n-slots))
20009 (define (emit-lambda! as code-offs0 const-offs0 n-slots)
20010 (let* ((code-offs (+ 4 (- (* 4 code-offs0) $tag.vector-tag)))
20011 (const-offs (+ 4 (- (* 4 const-offs0) $tag.vector-tag)))
20012 (fits? (asm:fits? const-offs 13)))
20013 (emit-alloc-proc! as n-slots)
20015 (begin (sparc.ldi as $r.reg0 $p.constvector $r.tmp0)
20016 (sparc.ldi as $r.tmp0 code-offs $r.tmp1))
20017 (emit-const->register! as code-offs0 $r.tmp1))
20018 (sparc.sti as $r.tmp1 $p.codevector $r.result)
20020 (begin (sparc.ldi as $r.reg0 $p.constvector $r.tmp0)
20021 (sparc.ldi as $r.tmp0 const-offs $r.tmp1))
20022 (emit-const->register! as const-offs0 $r.tmp1))
20023 (sparc.sti as $r.tmp1 $p.constvector $r.result)
20024 (emit-init-proc-slots! as n-slots)))
20026 ; Allocate procedure with room for n register slots; return tagged pointer.
20028 (define emit-alloc-proc!
20029 (let ((two^12 (expt 2 12)))
20031 (millicode-call/numarg-in-result as $m.alloc (* (+ n 4) 4))
20032 (let ((header (+ (* (* (+ n 3) 4) 256) $imm.procedure-header)))
20033 (emit-immediate->register! as header $r.tmp0)
20034 (sparc.sti as $r.tmp0 0 $r.result)
20035 (sparc.addi as $r.result $tag.procedure-tag $r.result)))))
20037 ; Initialize data slots in procedure from current registers as specified for
20038 ; `lamba' and `lexes'. If there are more data slots than registers, then
20039 ; we must generate code to cdr down the list in the last register to obtain
20040 ; the rest of the data. The list is expected to have at least the minimal
20043 ; The tagged pointer to the procedure is in $r.result.
20045 (define (emit-init-proc-slots! as n)
20047 (define (save-registers lo hi offset)
20048 (do ((lo lo (+ lo 1))
20049 (offset offset (+ offset 4)))
20051 (let ((r (force-hwreg! as (regname lo) $r.tmp0)))
20052 (sparc.sti as r offset $r.result))))
20054 (define (save-list lo hi offset)
20055 (emit-load-reg! as $r.reg31 $r.tmp0)
20056 (do ((lo lo (+ lo 1))
20057 (offset offset (+ offset 4)))
20059 (sparc.ldi as $r.tmp0 (- $tag.pair-tag) $r.tmp1)
20060 (sparc.sti as $r.tmp1 offset $r.result)
20063 (sparc.ldi as $r.tmp0 (+ (- $tag.pair-tag) 4) $r.tmp0)))))
20065 (cond ((< n *lastreg*)
20066 (save-registers 0 n $p.reg0))
20068 (save-registers 0 (- *lastreg* 1) $p.reg0)
20069 (save-list *lastreg* n (+ $p.reg0 (* *lastreg* 4))))))
20073 (define (emit-branch! as check-timer? label)
20075 (check-timer as label label)
20076 (begin (sparc.b as label)
20082 (define (emit-branchf! as label)
20083 (emit-branchfreg! as $r.result label))
20086 ; BRANCHFREG -- introduced by peephole optimization.
20088 (define (emit-branchfreg! as hwreg label)
20089 (sparc.cmpi as hwreg $imm.false)
20090 (sparc.be.a as label)
20094 ; BRANCH-WITH-SETRTN -- introduced by peephole optimization
20096 (define (emit-branch-with-setrtn! as label)
20098 (sparc.call as label)
20099 (sparc.sti as $r.o7 4 $r.stkp))
20103 ; Given the finalization order (outer is finalized before inner is assembled)
20104 ; the label value will always be available when a jump is assembled. The
20105 ; only exception is when m = 0, but does this ever happen? This code handles
20108 (define (emit-jump! as m label)
20109 (let* ((r (emit-follow-chain! as m))
20110 (labelv (label-value as label))
20111 (v (if (number? labelv)
20112 (+ labelv $p.codeoffset)
20113 (list '+ label $p.codeoffset))))
20114 (sparc.ldi as r $p.codevector $r.tmp0)
20115 (if (and (number? v) (immediate-literal? v))
20116 (sparc.jmpli as $r.tmp0 v $r.g0)
20117 (begin (emit-immediate->register! as v $r.tmp1)
20118 (sparc.jmplr as $r.tmp0 $r.tmp1 $r.g0)))
20119 (sparc.move as r $r.reg0)))
20124 ; Single step: jump to millicode; pass index of documentation string in
20125 ; %TMP0. Some instructions execute when reg0 is not a valid pointer to
20126 ; the current procedure (because this is just after returning); in this
20127 ; case we restore reg0 from the stack location given by 'funkyloc'.
20129 (define (emit-singlestep-instr! as funky? funkyloc cvlabel)
20131 (sparc.ldi as $r.stkp (+ (thefixnum funkyloc) 12) $r.reg0))
20132 (millicode-call/numarg-in-reg as $m.singlestep
20133 (thefixnum cvlabel)
20137 ; Emit the effective address of a label-8 into %o7.
20139 ; There are multiple ways to do this. If the call causes an expensive
20140 ; bubble in the pipeline it is probably much less expensive to grub
20141 ; the code vector address out of the procedure in REG0 and calculate it
20142 ; that way. FIXME: We need to benchmark these options.
20144 ; In general the point is moot as the common-case sequence
20148 ; should be peephole-optimized into the obvious fast code.
20150 (define (emit-return-address! as label)
20151 (let* ((loc (here as))
20152 (lloc (label-value as label)))
20154 (define (emit-short val)
20155 (sparc.call as (+ loc 8))
20156 (sparc.addi as $r.o7 val $r.o7))
20158 (define (emit-long val)
20159 ; Don't use sparc.set: we need to know that two instructions get
20161 (sparc.sethi as `(hi ,val) $r.tmp0)
20162 (sparc.ori as $r.tmp0 `(lo ,val) $r.tmp0)
20163 (sparc.call as (+ loc 16))
20164 (sparc.addr as $r.o7 $r.tmp0 $r.o7))
20167 (let ((target-rel-addr (- lloc loc 8)))
20168 (if (immediate-literal? target-rel-addr)
20169 (emit-short target-rel-addr)
20170 (emit-long (- target-rel-addr 8)))))
20171 ((short-effective-addresses)
20172 (emit-short `(- ,label ,loc 8)))
20174 (emit-long `(- ,label ,loc 16))))))
20177 ; Copyright 1998 Lars T Hansen.
20179 ; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
20181 ; 22 April 1999 / wdc
20183 ; SPARC code generation macros for primitives, part 1:
20184 ; primitives defined in Compiler/sparc.imp.sch.
20186 ; These extend Asm/Common/pass5p1.sch.
20188 (define (operand5 instruction)
20189 (car (cddddr (cdr instruction))))
20191 (define (operand6 instruction)
20192 (cadr (cddddr (cdr instruction))))
20194 (define (operand7 instruction)
20195 (caddr (cddddr (cdr instruction))))
20200 (define (emit-primop.1arg! as op)
20201 ((find-primop op) as))
20203 (define (emit-primop.2arg! as op r)
20204 ((find-primop op) as r))
20206 (define (emit-primop.3arg! as a1 a2 a3)
20207 ((find-primop a1) as a2 a3))
20209 (define (emit-primop.4arg! as a1 a2 a3 a4)
20210 ((find-primop a1) as a2 a3 a4))
20212 (define (emit-primop.5arg! as a1 a2 a3 a4 a5)
20213 ((find-primop a1) as a2 a3 a4 a5))
20215 (define (emit-primop.6arg! as a1 a2 a3 a4 a5 a6)
20216 ((find-primop a1) as a2 a3 a4 a5 a6))
20218 (define (emit-primop.7arg! as a1 a2 a3 a4 a5 a6 a7)
20219 ((find-primop a1) as a2 a3 a4 a5 a6 a7))
20222 ; Hash table of primops
20224 (define primop-vector (make-vector 256 '()))
20226 (define (define-primop name proc)
20227 (let ((h (logand (symbol-hash name) 255)))
20228 (vector-set! primop-vector h (cons (cons name proc)
20229 (vector-ref primop-vector h)))
20232 (define (find-primop name)
20233 (let ((h (logand (symbol-hash name) 255)))
20234 (cdr (assq name (vector-ref primop-vector h)))))
20236 (define (for-each-primop proc)
20237 (do ((i 0 (+ i 1)))
20238 ((= i (vector-length primop-vector)))
20239 (for-each (lambda (p)
20241 (vector-ref primop-vector i))))
20245 (define-primop 'unspecified
20247 (emit-immediate->register! as $imm.unspecified $r.result)))
20249 (define-primop 'undefined
20251 (emit-immediate->register! as $imm.undefined $r.result)))
20253 (define-primop 'eof-object
20255 (emit-immediate->register! as $imm.eof $r.result)))
20257 (define-primop 'enable-interrupts
20259 (millicode-call/0arg as $m.enable-interrupts)))
20261 (define-primop 'disable-interrupts
20263 (millicode-call/0arg as $m.disable-interrupts)))
20265 (define-primop 'gc-counter
20267 (sparc.ldi as $r.globals $g.gccnt $r.result)))
20269 (define-primop 'zero?
20271 (emit-cmp-primop! as sparc.be.a $m.zerop $r.g0)))
20275 (emit-cmp-primop! as sparc.be.a $m.numeq r)))
20279 (emit-cmp-primop! as sparc.bl.a $m.numlt r)))
20283 (emit-cmp-primop! as sparc.ble.a $m.numle r)))
20287 (emit-cmp-primop! as sparc.bg.a $m.numgt r)))
20291 (emit-cmp-primop! as sparc.bge.a $m.numge r)))
20293 (define-primop 'complex?
20295 (millicode-call/0arg as $m.complexp)))
20297 (define-primop 'real?
20299 (millicode-call/0arg as $m.realp)))
20301 (define-primop 'rational?
20303 (millicode-call/0arg as $m.rationalp)))
20305 (define-primop 'integer?
20307 (millicode-call/0arg as $m.integerp)))
20309 (define-primop 'exact?
20311 (millicode-call/0arg as $m.exactp)))
20313 (define-primop 'inexact?
20315 (millicode-call/0arg as $m.inexactp)))
20317 (define-primop 'fixnum?
20319 (sparc.btsti as $r.result 3)
20320 (emit-set-boolean! as)))
20324 (emit-primop.4arg! as 'internal:+ $r.result r $r.result)))
20328 (emit-primop.4arg! as 'internal:- $r.result r $r.result)))
20332 (emit-multiply-code as rs2 #f)))
20334 (define (emit-multiply-code as rs2 fixnum-arithmetic?)
20335 (if (and (unsafe-code) fixnum-arithmetic?)
20337 (sparc.srai as $r.result 2 $r.tmp0)
20338 (sparc.smulr as $r.tmp0 rs2 $r.result))
20339 (let ((rs2 (force-hwreg! as rs2 $r.argreg2))
20340 (Lstart (new-label))
20341 (Ltagok (new-label))
20342 (Loflo (new-label))
20343 (Ldone (new-label)))
20344 (sparc.label as Lstart)
20345 (sparc.orr as $r.result rs2 $r.tmp0)
20346 (sparc.btsti as $r.tmp0 3)
20347 (sparc.be.a as Ltagok)
20348 (sparc.srai as $r.result 2 $r.tmp0)
20349 (sparc.label as Loflo)
20350 (if (not (= rs2 $r.argreg2)) (sparc.move as rs2 $r.argreg2))
20351 (if (not fixnum-arithmetic?)
20353 (millicode-call/ret as $m.multiply Ldone))
20355 (sparc.set as (thefixnum $ex.fx*) $r.tmp0)
20356 (millicode-call/ret as $m.exception Lstart)))
20357 (sparc.label as Ltagok)
20358 (sparc.smulr as $r.tmp0 rs2 $r.tmp0)
20359 (sparc.rdy as $r.tmp1)
20360 (sparc.srai as $r.tmp0 31 $r.tmp2)
20361 (sparc.cmpr as $r.tmp1 $r.tmp2)
20362 (sparc.bne.a as Loflo)
20364 (sparc.move as $r.tmp0 $r.result)
20365 (sparc.label as Ldone))))
20369 (millicode-call/1arg as $m.divide r)))
20371 (define-primop 'quotient
20373 (millicode-call/1arg as $m.quotient r)))
20375 (define-primop 'remainder
20377 (millicode-call/1arg as $m.remainder r)))
20381 (emit-negate as $r.result $r.result)))
20383 (define-primop 'round
20385 (millicode-call/0arg as $m.round)))
20387 (define-primop 'truncate
20389 (millicode-call/0arg as $m.truncate)))
20391 (define-primop 'lognot
20393 (if (not (unsafe-code))
20394 (emit-assert-fixnum! as $r.result $ex.lognot))
20395 (sparc.ornr as $r.g0 $r.result $r.result) ; argument order matters
20396 (sparc.xori as $r.result 3 $r.result)))
20398 (define-primop 'logand
20400 (logical-op as $r.result x $r.result sparc.andr $ex.logand)))
20402 (define-primop 'logior
20404 (logical-op as $r.result x $r.result sparc.orr $ex.logior)))
20406 (define-primop 'logxor
20408 (logical-op as $r.result x $r.result sparc.xorr $ex.logxor)))
20412 ; Only positive shifts are meaningful.
20413 ; FIXME: These are incompatible with MacScheme and MIT Scheme.
20414 ; FIXME: need to return to start of sequence after fault.
20416 (define-primop 'lsh
20418 (emit-shift-operation as $ex.lsh $r.result x $r.result)))
20420 (define-primop 'rshl
20422 (emit-shift-operation as $ex.rshl $r.result x $r.result)))
20424 (define-primop 'rsha
20426 (emit-shift-operation as $ex.rsha $r.result x $r.result)))
20430 ; FIXME: for symmetry with shifts there should be rotl and rotr (?)
20431 ; or perhaps rot should only ever rotate one way.
20432 ; FIXME: implement.
20434 (define-primop 'rot
20436 (asm-error "Sparcasm: ROT primop is not implemented.")))
20438 (define-primop 'null?
20440 (sparc.cmpi as $r.result $imm.null)
20441 (emit-set-boolean! as)))
20443 (define-primop 'pair?
20445 (emit-single-tagcheck->bool! as $tag.pair-tag)))
20447 (define-primop 'eof-object?
20449 (sparc.cmpi as $r.result $imm.eof)
20450 (emit-set-boolean! as)))
20452 ; Tests the specific representation, not 'flonum or compnum with 0i'.
20454 (define-primop 'flonum?
20456 (emit-double-tagcheck->bool! as $tag.bytevector-tag
20457 (+ $imm.bytevector-header
20458 $tag.flonum-typetag))))
20460 (define-primop 'compnum?
20462 (emit-double-tagcheck->bool! as $tag.bytevector-tag
20463 (+ $imm.bytevector-header
20464 $tag.compnum-typetag))))
20466 (define-primop 'symbol?
20468 (emit-double-tagcheck->bool! as $tag.vector-tag
20469 (+ $imm.vector-header
20470 $tag.symbol-typetag))))
20472 (define-primop 'port?
20474 (emit-double-tagcheck->bool! as $tag.vector-tag
20475 (+ $imm.vector-header
20476 $tag.port-typetag))))
20478 (define-primop 'structure?
20480 (emit-double-tagcheck->bool! as $tag.vector-tag
20481 (+ $imm.vector-header
20482 $tag.structure-typetag))))
20484 (define-primop 'char?
20486 (sparc.andi as $r.result #xFF $r.tmp0)
20487 (sparc.cmpi as $r.tmp0 $imm.character)
20488 (emit-set-boolean! as)))
20490 (define-primop 'string?
20492 (emit-double-tagcheck->bool! as
20493 $tag.bytevector-tag
20494 (+ $imm.bytevector-header
20495 $tag.string-typetag))))
20497 (define-primop 'bytevector?
20499 (emit-double-tagcheck->bool! as
20500 $tag.bytevector-tag
20501 (+ $imm.bytevector-header
20502 $tag.bytevector-typetag))))
20504 (define-primop 'bytevector-like?
20506 (emit-single-tagcheck->bool! as $tag.bytevector-tag)))
20508 (define-primop 'vector?
20510 (emit-double-tagcheck->bool! as
20512 (+ $imm.vector-header
20513 $tag.vector-typetag))))
20515 (define-primop 'vector-like?
20517 (emit-single-tagcheck->bool! as $tag.vector-tag)))
20519 (define-primop 'procedure?
20521 (emit-single-tagcheck->bool! as $tag.procedure-tag)))
20523 (define-primop 'cons
20525 (emit-primop.4arg! as 'internal:cons $r.result r $r.result)))
20527 (define-primop 'car
20529 (emit-primop.3arg! as 'internal:car $r.result $r.result)))
20531 (define-primop 'cdr
20533 (emit-primop.3arg! as 'internal:cdr $r.result $r.result)))
20535 (define-primop 'car:pair
20537 (sparc.ldi as $r.result (- $tag.pair-tag) $r.result)))
20539 (define-primop 'cdr:pair
20541 (sparc.ldi as $r.result (- 4 $tag.pair-tag) $r.result)))
20543 (define-primop 'set-car!
20545 (if (not (unsafe-code))
20546 (emit-single-tagcheck-assert! as $tag.pair-tag $ex.car #f))
20547 (emit-setcar/setcdr! as $r.result x 0)))
20549 (define-primop 'set-cdr!
20551 (if (not (unsafe-code))
20552 (emit-single-tagcheck-assert! as $tag.pair-tag $ex.cdr #f))
20553 (emit-setcar/setcdr! as $r.result x 4)))
20555 ; Cells are internal data structures, represented using pairs.
20556 ; No error checking is done on cell references.
20558 (define-primop 'make-cell
20560 (emit-primop.4arg! as 'internal:cons $r.result $r.g0 $r.result)))
20562 (define-primop 'cell-ref
20564 (emit-primop.3arg! as 'internal:cell-ref $r.result $r.result)))
20566 (define-primop 'cell-set!
20568 (emit-setcar/setcdr! as $r.result r 0)))
20570 (define-primop 'syscall
20572 (millicode-call/0arg as $m.syscall)))
20574 (define-primop 'break
20576 (millicode-call/0arg as $m.break)))
20578 (define-primop 'creg
20580 (millicode-call/0arg as $m.creg)))
20582 (define-primop 'creg-set!
20584 (millicode-call/0arg as $m.creg-set!)))
20586 (define-primop 'typetag
20588 (millicode-call/0arg as $m.typetag)))
20590 (define-primop 'typetag-set!
20592 (millicode-call/1arg as $m.typetag-set r)))
20594 (define-primop 'exact->inexact
20596 (millicode-call/0arg as $m.exact->inexact)))
20598 (define-primop 'inexact->exact
20600 (millicode-call/0arg as $m.inexact->exact)))
20602 (define-primop 'real-part
20604 (millicode-call/0arg as $m.real-part)))
20606 (define-primop 'imag-part
20608 (millicode-call/0arg as $m.imag-part)))
20610 (define-primop 'char->integer
20612 (if (not (unsafe-code))
20613 (emit-assert-char! as $ex.char2int #f))
20614 (sparc.srli as $r.result 14 $r.result)))
20616 (define-primop 'integer->char
20618 (if (not (unsafe-code))
20619 (emit-assert-fixnum! as $r.result $ex.int2char))
20620 (sparc.andi as $r.result #x3FF $r.result)
20621 (sparc.slli as $r.result 14 $r.result)
20622 (sparc.ori as $r.result $imm.character $r.result)))
20624 (define-primop 'not
20626 (sparc.cmpi as $r.result $imm.false)
20627 (emit-set-boolean! as)))
20629 (define-primop 'eq?
20631 (emit-primop.4arg! as 'internal:eq? $r.result x $r.result)))
20633 (define-primop 'eqv?
20635 (let ((tmp (force-hwreg! as x $r.tmp0))
20637 (sparc.cmpr as $r.result tmp)
20639 (sparc.set as $imm.true $r.result)
20640 (millicode-call/1arg as $m.eqv tmp)
20641 (sparc.label as L1))))
20643 (define-primop 'make-bytevector
20645 (if (not (unsafe-code))
20646 (emit-assert-positive-fixnum! as $r.result $ex.mkbvl))
20647 (emit-allocate-bytevector as
20648 (+ $imm.bytevector-header
20649 $tag.bytevector-typetag)
20651 (sparc.addi as $r.result $tag.bytevector-tag $r.result)))
20653 (define-primop 'bytevector-fill!
20655 (let* ((fault (emit-double-tagcheck-assert! as
20656 $tag.bytevector-tag
20657 (+ $imm.bytevector-header
20658 $tag.bytevector-typetag)
20661 (rs2 (force-hwreg! as rs2 $r.argreg2)))
20662 (sparc.btsti as rs2 3)
20663 (sparc.bne as fault)
20664 (sparc.srai as rs2 2 $r.tmp2)
20665 (sparc.ldi as $r.result (- $tag.bytevector-tag) $r.tmp0)
20666 (sparc.addi as $r.result (- 4 $tag.bytevector-tag) $r.tmp1)
20667 (sparc.srai as $r.tmp0 8 $r.tmp0)
20668 (emit-bytevector-fill as $r.tmp0 $r.tmp1 $r.tmp2))))
20670 (define-primop 'bytevector-length
20672 (emit-get-length! as
20673 $tag.bytevector-tag
20674 (+ $imm.bytevector-header $tag.bytevector-typetag)
20679 (define-primop 'bytevector-like-length
20681 (emit-get-length! as
20682 $tag.bytevector-tag
20688 (define-primop 'bytevector-ref
20690 (let ((fault (if (not (unsafe-code))
20691 (emit-double-tagcheck-assert!
20693 $tag.bytevector-tag
20694 (+ $imm.bytevector-header $tag.bytevector-typetag)
20698 (emit-bytevector-like-ref! as $r.result r $r.result fault #f #t))))
20700 (define-primop 'bytevector-like-ref
20702 (let ((fault (if (not (unsafe-code))
20703 (emit-single-tagcheck-assert! as
20704 $tag.bytevector-tag
20708 (emit-bytevector-like-ref! as $r.result r $r.result fault #f #f))))
20710 (define-primop 'bytevector-set!
20712 (let ((fault (if (not (unsafe-code))
20713 (emit-double-tagcheck-assert!
20715 $tag.bytevector-tag
20716 (+ $imm.bytevector-header $tag.bytevector-typetag)
20720 (emit-bytevector-like-set! as r1 r2 fault #t))))
20722 (define-primop 'bytevector-like-set!
20724 (let ((fault (if (not (unsafe-code))
20725 (emit-single-tagcheck-assert! as
20726 $tag.bytevector-tag
20730 (emit-bytevector-like-set! as r1 r2 fault #f))))
20732 (define-primop 'sys$bvlcmp
20734 (millicode-call/1arg as $m.bvlcmp x)))
20738 ; RESULT must have nonnegative fixnum.
20739 ; RS2 must have character.
20741 (define-primop 'make-string
20743 (let ((FAULT (new-label))
20744 (START (new-label)))
20745 (sparc.label as START)
20746 (let ((rs2 (force-hwreg! as rs2 $r.argreg2)))
20747 (if (not (unsafe-code))
20748 (let ((L1 (new-label))
20750 (sparc.tsubrcc as $r.result $r.g0 $r.g0)
20751 (sparc.bvc.a as L1)
20752 (sparc.andi as rs2 255 $r.tmp0)
20753 (sparc.label as FAULT)
20754 (if (not (= rs2 $r.argreg2))
20755 (sparc.move as rs2 $r.argreg2))
20756 (sparc.set as (thefixnum $ex.mkbvl) $r.tmp0) ; Wrong code.
20757 (millicode-call/ret as $m.exception START)
20758 (sparc.label as L1)
20759 (sparc.bl as FAULT)
20760 (sparc.cmpi as $r.tmp0 $imm.character)
20761 (sparc.bne as FAULT)
20762 (sparc.move as $r.result $r.argreg3))
20764 (sparc.move as $r.result $r.argreg3)))
20765 (emit-allocate-bytevector as
20766 (+ $imm.bytevector-header
20767 $tag.string-typetag)
20769 (sparc.srai as rs2 16 $r.tmp1)
20770 (sparc.addi as $r.result 4 $r.result)
20771 (sparc.srai as $r.argreg3 2 $r.tmp0)
20772 (emit-bytevector-fill as $r.tmp0 $r.result $r.tmp1)
20773 (sparc.addi as $r.result (- $tag.bytevector-tag 4) $r.result)))))
20775 (define-primop 'string-length
20777 (emit-primop.3arg! as 'internal:string-length $r.result $r.result)))
20779 (define-primop 'string-ref
20781 (emit-primop.4arg! as 'internal:string-ref $r.result r $r.result)))
20783 (define-primop 'string-set!
20785 (emit-string-set! as $r.result r1 r2)))
20787 (define-primop 'sys$partial-list->vector
20789 (millicode-call/1arg as $m.partial-list->vector r)))
20791 (define-primop 'make-procedure
20793 (emit-make-vector-like! as
20795 $imm.procedure-header
20796 $tag.procedure-tag)))
20798 (define-primop 'make-vector
20800 (emit-make-vector-like! as
20802 (+ $imm.vector-header $tag.vector-typetag)
20805 (define-primop 'make-vector:0
20806 (lambda (as r) (make-vector-n as 0 r)))
20808 (define-primop 'make-vector:1
20809 (lambda (as r) (make-vector-n as 1 r)))
20811 (define-primop 'make-vector:2
20812 (lambda (as r) (make-vector-n as 2 r)))
20814 (define-primop 'make-vector:3
20815 (lambda (as r) (make-vector-n as 3 r)))
20817 (define-primop 'make-vector:4
20818 (lambda (as r) (make-vector-n as 4 r)))
20820 (define-primop 'make-vector:5
20821 (lambda (as r) (make-vector-n as 5 r)))
20823 (define-primop 'make-vector:6
20824 (lambda (as r) (make-vector-n as 6 r)))
20826 (define-primop 'make-vector:7
20827 (lambda (as r) (make-vector-n as 7 r)))
20829 (define-primop 'make-vector:8
20830 (lambda (as r) (make-vector-n as 8 r)))
20832 (define-primop 'make-vector:9
20833 (lambda (as r) (make-vector-n as 9 r)))
20835 (define-primop 'vector-length
20837 (emit-primop.3arg! as 'internal:vector-length $r.result $r.result)))
20839 (define-primop 'vector-like-length
20841 (emit-get-length! as $tag.vector-tag #f $ex.vllen $r.result $r.result)))
20843 (define-primop 'vector-length:vec
20845 (emit-get-length-trusted! as $tag.vector-tag $r.result $r.result)))
20847 (define-primop 'procedure-length
20849 (emit-get-length! as $tag.procedure-tag #f $ex.plen $r.result $r.result)))
20851 (define-primop 'vector-ref
20853 (emit-primop.4arg! as 'internal:vector-ref $r.result r $r.result)))
20855 (define-primop 'vector-like-ref
20857 (let ((fault (if (not (unsafe-code))
20858 (emit-single-tagcheck-assert! as
20863 (emit-vector-like-ref!
20864 as $r.result r $r.result fault $tag.vector-tag #f))))
20866 (define-primop 'vector-ref:trusted
20868 (emit-vector-like-ref-trusted!
20869 as $r.result rs2 $r.result $tag.vector-tag)))
20871 (define-primop 'procedure-ref
20873 (let ((fault (if (not (unsafe-code))
20874 (emit-single-tagcheck-assert! as
20879 (emit-vector-like-ref!
20880 as $r.result r $r.result fault $tag.procedure-tag #f))))
20882 (define-primop 'vector-set!
20884 (emit-primop.4arg! as 'internal:vector-set! $r.result r1 r2)))
20886 (define-primop 'vector-like-set!
20888 (let ((fault (if (not (unsafe-code))
20889 (emit-single-tagcheck-assert! as
20894 (emit-vector-like-set! as $r.result r1 r2 fault $tag.vector-tag #f))))
20896 (define-primop 'vector-set!:trusted
20897 (lambda (as rs2 rs3)
20898 (emit-vector-like-set-trusted! as $r.result rs2 rs3 $tag.vector-tag)))
20900 (define-primop 'procedure-set!
20902 (let ((fault (if (not (unsafe-code))
20903 (emit-single-tagcheck-assert! as
20908 (emit-vector-like-set! as $r.result r1 r2 fault $tag.procedure-tag #f))))
20910 (define-primop 'char<?
20912 (emit-char-cmp as x sparc.bl.a $ex.char<?)))
20914 (define-primop 'char<=?
20916 (emit-char-cmp as x sparc.ble.a $ex.char<=?)))
20918 (define-primop 'char=?
20920 (emit-char-cmp as x sparc.be.a $ex.char=?)))
20922 (define-primop 'char>?
20924 (emit-char-cmp as x sparc.bg.a $ex.char>?)))
20926 (define-primop 'char>=?
20928 (emit-char-cmp as x sparc.bge.a $ex.char>=?)))
20930 ; Experimental (for performance).
20931 ; This makes massive assumptions about the layout of the port structure:
20932 ; A port is a vector-like where
20937 ; See Lib/iosys.sch for more information.
20939 (define-primop 'sys$read-char
20941 (let ((Lfinish (new-label))
20942 (Lend (new-label)))
20943 (if (not (unsafe-code))
20945 (sparc.andi as $r.result $tag.tagmask $r.tmp0) ; mask argument tag
20946 (sparc.cmpi as $r.tmp0 $tag.vector-tag); vector-like?
20947 (sparc.bne as Lfinish) ; skip if not vector-like
20949 (sparc.ldbi as $r.RESULT 0 $r.tmp1))) ; header byte
20950 (sparc.ldi as $r.RESULT 1 $r.tmp2) ; port.input? or garbage
20951 (if (not (unsafe-code))
20953 (sparc.cmpi as $r.tmp1 $hdr.port) ; port?
20954 (sparc.bne as Lfinish))) ; skip if not port
20955 (sparc.cmpi as $r.tmp2 $imm.false) ; [slot] input port?
20956 (sparc.be as Lfinish) ; skip if not active port
20957 (sparc.ldi as $r.RESULT (+ 1 32) $r.tmp1) ; [slot] port.rd-ptr
20958 (sparc.ldi as $r.RESULT (+ 1 28) $r.tmp2) ; port.rd-lim
20959 (sparc.ldi as $r.RESULT (+ 1 16) $r.tmp0) ; port.buffer
20960 (sparc.cmpr as $r.tmp1 $r.tmp2) ; rd-ptr < rd-lim?
20961 (sparc.bge as Lfinish) ; skip if rd-ptr >= rd-lim
20962 (sparc.subi as $r.tmp0 1 $r.tmp0) ; [slot] addr of string@0
20963 (sparc.srai as $r.tmp1 2 $r.tmp2) ; rd-ptr as native int
20964 (sparc.ldbr as $r.tmp0 $r.tmp2 $r.tmp2) ; get byte from string
20965 (sparc.addi as $r.tmp1 4 $r.tmp1) ; bump rd-ptr
20966 (sparc.sti as $r.tmp1 (+ 1 32) $r.RESULT) ; store rd-ptr in port
20967 (sparc.slli as $r.tmp2 16 $r.tmp2) ; convert to char #1
20969 (sparc.ori as $r.tmp2 $imm.character $r.RESULT) ; [slot] convert to char
20970 (sparc.label as Lfinish)
20971 (sparc.set as $imm.false $r.RESULT) ; failed
20972 (sparc.label as Lend))))
20976 ; Copyright 1998 Lars T Hansen.
20978 ; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
20982 ; SPARC code generation macros for primitives, part 2:
20983 ; primitives introduced by peephole optimization.
20985 (define-primop 'internal:car
20986 (lambda (as src1 dest)
20987 (internal-primop-invariant2 'internal:car src1 dest)
20988 (if (not (unsafe-code))
20989 (emit-single-tagcheck-assert-reg! as
20990 $tag.pair-tag src1 #f $ex.car))
20991 (sparc.ldi as src1 (- $tag.pair-tag) dest)))
20993 (define-primop 'internal:cdr
20994 (lambda (as src1 dest)
20995 (internal-primop-invariant2 'internal:cdr src1 dest)
20996 (if (not (unsafe-code))
20997 (emit-single-tagcheck-assert-reg! as
20998 $tag.pair-tag src1 #f $ex.cdr))
20999 (sparc.ldi as src1 (- 4 $tag.pair-tag) dest)))
21001 (define-primop 'internal:cell-ref
21002 (lambda (as src1 dest)
21003 (internal-primop-invariant2 'internal:cell-ref src1 dest)
21004 (sparc.ldi as src1 (- $tag.pair-tag) dest)))
21006 (define-primop 'internal:set-car!
21007 (lambda (as rs1 rs2 dest-ignored)
21008 (internal-primop-invariant2 'internal:set-car! rs1 dest-ignored)
21009 (if (not (unsafe-code))
21010 (emit-single-tagcheck-assert-reg! as $tag.pair-tag rs1 rs2 $ex.car))
21011 (emit-setcar/setcdr! as rs1 rs2 0)))
21013 (define-primop 'internal:set-cdr!
21014 (lambda (as rs1 rs2 dest-ignored)
21015 (internal-primop-invariant2 'internal:set-cdr! rs1 dest-ignored)
21016 (if (not (unsafe-code))
21017 (emit-single-tagcheck-assert-reg! as $tag.pair-tag rs1 rs2 $ex.cdr))
21018 (emit-setcar/setcdr! as rs1 rs2 4)))
21020 (define-primop 'internal:cell-set!
21021 (lambda (as rs1 rs2 dest-ignored)
21022 (internal-primop-invariant2 'internal:cell-set! rs1 dest-ignored)
21023 (emit-setcar/setcdr! as rs1 rs2 0)))
21027 ; One instruction reduced here translates into about 2.5KB reduction in the
21028 ; size of the basic heap image. :-)
21030 ; In the out-of-line case, if rd != RESULT then a garbage value is left
21031 ; in RESULT, but it always looks like a fixnum, so it's OK.
21033 (define-primop 'internal:cons
21034 (lambda (as rs1 rs2 rd)
21035 (if (inline-allocation)
21036 (let ((ENOUGH-MEMORY (new-label))
21037 (START (new-label)))
21038 (sparc.label as START)
21039 (sparc.addi as $r.e-top 8 $r.e-top)
21040 (sparc.cmpr as $r.e-top $r.e-limit)
21041 (sparc.ble.a as ENOUGH-MEMORY)
21042 (sparc.sti as rs1 -8 $r.e-top)
21043 (millicode-call/ret as $m.gc START)
21044 (sparc.label as ENOUGH-MEMORY)
21045 (sparc.sti as (force-hwreg! as rs2 $r.tmp0) -4 $r.e-top)
21046 (sparc.subi as $r.e-top (- 8 $tag.pair-tag) rd))
21048 (if (= rs1 $r.result)
21049 (sparc.move as $r.result $r.argreg2))
21050 (millicode-call/numarg-in-result as $m.alloc 8)
21051 (if (= rs1 $r.result)
21052 (sparc.sti as $r.argreg2 0 $r.result)
21053 (sparc.sti as rs1 0 $r.result))
21054 (sparc.sti as (force-hwreg! as rs2 $r.tmp1) 4 $r.result)
21055 (sparc.addi as $r.result $tag.pair-tag rd)))))
21057 (define-primop 'internal:car:pair
21058 (lambda (as src1 dest)
21059 (internal-primop-invariant2 'internal:car src1 dest)
21060 (sparc.ldi as src1 (- $tag.pair-tag) dest)))
21062 (define-primop 'internal:cdr:pair
21063 (lambda (as src1 dest)
21064 (internal-primop-invariant2 'internal:cdr src1 dest)
21065 (sparc.ldi as src1 (- 4 $tag.pair-tag) dest)))
21067 ; Vector operations.
21069 (define-primop 'internal:vector-length
21071 (internal-primop-invariant2 'internal:vector-length rs rd)
21072 (emit-get-length! as
21074 (+ $imm.vector-header $tag.vector-typetag)
21079 (define-primop 'internal:vector-ref
21080 (lambda (as rs1 rs2 rd)
21081 (internal-primop-invariant2 'internal:vector-ref rs1 rd)
21082 (let ((fault (if (not (unsafe-code))
21083 (emit-double-tagcheck-assert-reg/reg!
21086 (+ $imm.vector-header $tag.vector-typetag)
21090 (emit-vector-like-ref! as rs1 rs2 rd fault $tag.vector-tag #t))))
21092 (define-primop 'internal:vector-ref/imm
21093 (lambda (as rs1 imm rd)
21094 (internal-primop-invariant2 'internal:vector-ref/imm rs1 rd)
21095 (let ((fault (if (not (unsafe-code))
21096 (emit-double-tagcheck-assert-reg/imm!
21099 (+ $imm.vector-header $tag.vector-typetag)
21103 (emit-vector-like-ref/imm! as rs1 imm rd fault $tag.vector-tag #t))))
21105 (define-primop 'internal:vector-set!
21106 (lambda (as rs1 rs2 rs3)
21107 (internal-primop-invariant1 'internal:vector-set! rs1)
21108 (let ((fault (if (not (unsafe-code))
21109 (emit-double-tagcheck-assert-reg/reg!
21112 (+ $imm.vector-header $tag.vector-typetag)
21116 (emit-vector-like-set! as rs1 rs2 rs3 fault $tag.vector-tag #t))))
21118 (define-primop 'internal:vector-length:vec
21119 (lambda (as rs1 dst)
21120 (internal-primop-invariant2 'internal:vector-length:vec rs1 dst)
21121 (emit-get-length-trusted! as $tag.vector-tag rs1 dst)))
21123 (define-primop 'internal:vector-ref:trusted
21124 (lambda (as rs1 rs2 dst)
21125 (emit-vector-like-ref-trusted! as rs1 rs2 dst $tag.vector-tag)))
21127 (define-primop 'internal:vector-set!:trusted
21128 (lambda (as rs1 rs2 rs3)
21129 (emit-vector-like-ref-trusted! as rs1 rs2 rs3 $tag.vector-tag)))
21133 (define-primop 'internal:string-length
21135 (internal-primop-invariant2 'internal:string-length rs rd)
21136 (emit-get-length! as
21137 $tag.bytevector-tag
21138 (+ $imm.bytevector-header $tag.string-typetag)
21143 (define-primop 'internal:string-ref
21144 (lambda (as rs1 rs2 rd)
21145 (internal-primop-invariant2 'internal:string-ref rs1 rd)
21146 (let ((fault (if (not (unsafe-code))
21147 (emit-double-tagcheck-assert-reg/reg!
21149 $tag.bytevector-tag
21150 (+ $imm.bytevector-header $tag.string-typetag)
21154 (emit-bytevector-like-ref! as rs1 rs2 rd fault #t #t))))
21156 (define-primop 'internal:string-ref/imm
21157 (lambda (as rs1 imm rd)
21158 (internal-primop-invariant2 'internal:string-ref/imm rs1 rd)
21159 (let ((fault (if (not (unsafe-code))
21160 (emit-double-tagcheck-assert-reg/imm!
21162 $tag.bytevector-tag
21163 (+ $imm.bytevector-header $tag.string-typetag)
21167 (emit-bytevector-like-ref/imm! as rs1 imm rd fault #t #t))))
21169 (define-primop 'internal:string-set!
21170 (lambda (as rs1 rs2 rs3)
21171 (internal-primop-invariant1 'internal:string-set! rs1)
21172 (emit-string-set! as rs1 rs2 rs3)))
21174 (define-primop 'internal:+
21175 (lambda (as src1 src2 dest)
21176 (internal-primop-invariant2 'internal:+ src1 dest)
21177 (emit-arith-primop! as sparc.taddrcc sparc.subr $m.add src1 src2 dest #t)))
21179 (define-primop 'internal:+/imm
21180 (lambda (as src1 imm dest)
21181 (internal-primop-invariant2 'internal:+/imm src1 dest)
21182 (emit-arith-primop! as sparc.taddicc sparc.subi $m.add src1 imm dest #f)))
21184 (define-primop 'internal:-
21185 (lambda (as src1 src2 dest)
21186 (internal-primop-invariant2 'internal:- src1 dest)
21187 (emit-arith-primop! as sparc.tsubrcc sparc.addr $m.subtract
21188 src1 src2 dest #t)))
21190 (define-primop 'internal:-/imm
21191 (lambda (as src1 imm dest)
21192 (internal-primop-invariant2 'internal:-/imm src1 dest)
21193 (emit-arith-primop! as sparc.tsubicc sparc.addi $m.subtract
21194 src1 imm dest #f)))
21196 (define-primop 'internal:--
21198 (internal-primop-invariant2 'internal:-- rs rd)
21199 (emit-negate as rs rd)))
21201 (define-primop 'internal:branchf-null?
21202 (lambda (as reg label)
21203 (internal-primop-invariant1 'internal:branchf-null? reg)
21204 (sparc.cmpi as reg $imm.null)
21205 (sparc.bne.a as label)
21208 (define-primop 'internal:branchf-pair?
21209 (lambda (as reg label)
21210 (internal-primop-invariant1 'internal:branchf-pair? reg)
21211 (sparc.andi as reg $tag.tagmask $r.tmp0)
21212 (sparc.cmpi as $r.tmp0 $tag.pair-tag)
21213 (sparc.bne.a as label)
21216 (define-primop 'internal:branchf-zero?
21217 (lambda (as reg label)
21218 (internal-primop-invariant1 'internal:brancf-zero? reg)
21219 (emit-bcmp-primop! as sparc.bne.a reg $r.g0 label $m.zerop #t)))
21221 (define-primop 'internal:branchf-eof-object?
21222 (lambda (as rs label)
21223 (internal-primop-invariant1 'internal:branchf-eof-object? rs)
21224 (sparc.cmpi as rs $imm.eof)
21225 (sparc.bne.a as label)
21228 (define-primop 'internal:branchf-fixnum?
21229 (lambda (as rs label)
21230 (internal-primop-invariant1 'internal:branchf-fixnum? rs)
21231 (sparc.btsti as rs 3)
21232 (sparc.bne.a as label)
21235 (define-primop 'internal:branchf-char?
21236 (lambda (as rs label)
21237 (internal-primop-invariant1 'internal:branchf-char? rs)
21238 (sparc.andi as rs 255 $r.tmp0)
21239 (sparc.cmpi as $r.tmp0 $imm.character)
21240 (sparc.bne.a as label)
21243 (define-primop 'internal:branchf-=
21244 (lambda (as src1 src2 label)
21245 (internal-primop-invariant1 'internal:branchf-= src1)
21246 (emit-bcmp-primop! as sparc.bne.a src1 src2 label $m.numeq #t)))
21248 (define-primop 'internal:branchf-<
21249 (lambda (as src1 src2 label)
21250 (internal-primop-invariant1 'internal:branchf-< src1)
21251 (emit-bcmp-primop! as sparc.bge.a src1 src2 label $m.numlt #t)))
21253 (define-primop 'internal:branchf-<=
21254 (lambda (as src1 src2 label)
21255 (internal-primop-invariant1 'internal:branchf-<= src1)
21256 (emit-bcmp-primop! as sparc.bg.a src1 src2 label $m.numle #t)))
21258 (define-primop 'internal:branchf->
21259 (lambda (as src1 src2 label)
21260 (internal-primop-invariant1 'internal:branchf-> src1)
21261 (emit-bcmp-primop! as sparc.ble.a src1 src2 label $m.numgt #t)))
21263 (define-primop 'internal:branchf->=
21264 (lambda (as src1 src2 label)
21265 (internal-primop-invariant1 'internal:branchf->= src1)
21266 (emit-bcmp-primop! as sparc.bl.a src1 src2 label $m.numge #t)))
21268 (define-primop 'internal:branchf-=/imm
21269 (lambda (as src1 imm label)
21270 (internal-primop-invariant1 'internal:branchf-=/imm src1)
21271 (emit-bcmp-primop! as sparc.bne.a src1 imm label $m.numeq #f)))
21273 (define-primop 'internal:branchf-</imm
21274 (lambda (as src1 imm label)
21275 (internal-primop-invariant1 'internal:branchf-</imm src1)
21276 (emit-bcmp-primop! as sparc.bge.a src1 imm label $m.numlt #f)))
21278 (define-primop 'internal:branchf-<=/imm
21279 (lambda (as src1 imm label)
21280 (internal-primop-invariant1 'internal:branchf-<=/imm src1)
21281 (emit-bcmp-primop! as sparc.bg.a src1 imm label $m.numle #f)))
21283 (define-primop 'internal:branchf->/imm
21284 (lambda (as src1 imm label)
21285 (internal-primop-invariant1 'internal:branchf->/imm src1)
21286 (emit-bcmp-primop! as sparc.ble.a src1 imm label $m.numgt #f)))
21288 (define-primop 'internal:branchf->=/imm
21289 (lambda (as src1 imm label)
21290 (internal-primop-invariant1 'internal:branchf->=/imm src1)
21291 (emit-bcmp-primop! as sparc.bl.a src1 imm label $m.numge #f)))
21293 (define-primop 'internal:branchf-char=?
21294 (lambda (as src1 src2 label)
21295 (internal-primop-invariant1 'internal:branchf-char=? src1)
21296 (emit-char-bcmp-primop! as sparc.bne.a src1 src2 label $ex.char=?)))
21298 (define-primop 'internal:branchf-char<=?
21299 (lambda (as src1 src2 label)
21300 (internal-primop-invariant1 'internal:branchf-char<=? src1)
21301 (emit-char-bcmp-primop! as sparc.bg.a src1 src2 label $ex.char<=?)))
21303 (define-primop 'internal:branchf-char<?
21304 (lambda (as src1 src2 label)
21305 (internal-primop-invariant1 'internal:branchf-char<? src1)
21306 (emit-char-bcmp-primop! as sparc.bge.a src1 src2 label $ex.char<?)))
21308 (define-primop 'internal:branchf-char>=?
21309 (lambda (as src1 src2 label)
21310 (internal-primop-invariant1 'internal:branchf-char>=? src1)
21311 (emit-char-bcmp-primop! as sparc.bl.a src1 src2 label $ex.char>=?)))
21313 (define-primop 'internal:branchf-char>?
21314 (lambda (as src1 src2 label)
21315 (internal-primop-invariant1 'internal:branchf-char>=? src1)
21316 (emit-char-bcmp-primop! as sparc.ble.a src1 src2 label $ex.char>?)))
21318 (define-primop 'internal:branchf-char=?/imm
21319 (lambda (as src imm label)
21320 (internal-primop-invariant1 'internal:branchf-char=?/imm src)
21321 (emit-char-bcmp-primop! as sparc.bne.a src imm label $ex.char=?)))
21323 (define-primop 'internal:branchf-char>=?/imm
21324 (lambda (as src imm label)
21325 (internal-primop-invariant1 'internal:branchf-char>=?/imm src)
21326 (emit-char-bcmp-primop! as sparc.bl.a src imm label $ex.char>=?)))
21328 (define-primop 'internal:branchf-char>?/imm
21329 (lambda (as src imm label)
21330 (internal-primop-invariant1 'internal:branchf-char>?/imm src)
21331 (emit-char-bcmp-primop! as sparc.ble.a src imm label $ex.char>?)))
21333 (define-primop 'internal:branchf-char<=?/imm
21334 (lambda (as src imm label)
21335 (internal-primop-invariant1 'internal:branchf-char<=?/imm src)
21336 (emit-char-bcmp-primop! as sparc.bg.a src imm label $ex.char<=?)))
21338 (define-primop 'internal:branchf-char<?/imm
21339 (lambda (as src imm label)
21340 (internal-primop-invariant1 'internal:branchf-char<?/imm src)
21341 (emit-char-bcmp-primop! as sparc.bge.a src imm label $ex.char<?)))
21343 (define-primop 'internal:eq?
21344 (lambda (as src1 src2 dest)
21345 (internal-primop-invariant2 'internal:eq? src1 dest)
21346 (let ((tmp (force-hwreg! as src2 $r.tmp0)))
21347 (sparc.cmpr as src1 tmp)
21348 (emit-set-boolean-reg! as dest))))
21350 (define-primop 'internal:eq?/imm
21351 (lambda (as rs imm rd)
21352 (internal-primop-invariant2 'internal:eq?/imm rs rd)
21353 (cond ((fixnum? imm) (sparc.cmpi as rs (thefixnum imm)))
21354 ((eq? imm #t) (sparc.cmpi as rs $imm.true))
21355 ((eq? imm #f) (sparc.cmpi as rs $imm.false))
21356 ((null? imm) (sparc.cmpi as rs $imm.null))
21358 (emit-set-boolean-reg! as rd)))
21360 (define-primop 'internal:branchf-eq?
21361 (lambda (as src1 src2 label)
21362 (internal-primop-invariant1 'internal:branchf-eq? src1)
21363 (let ((src2 (force-hwreg! as src2 $r.tmp0)))
21364 (sparc.cmpr as src1 src2)
21365 (sparc.bne.a as label)
21368 (define-primop 'internal:branchf-eq?/imm
21369 (lambda (as rs imm label)
21370 (internal-primop-invariant1 'internal:branchf-eq?/imm rs)
21371 (cond ((fixnum? imm) (sparc.cmpi as rs (thefixnum imm)))
21372 ((eq? imm #t) (sparc.cmpi as rs $imm.true))
21373 ((eq? imm #f) (sparc.cmpi as rs $imm.false))
21374 ((null? imm) (sparc.cmpi as rs $imm.null))
21376 (sparc.bne.a as label)
21379 ; Unary predicates followed by a check.
21381 (define-primop 'internal:check-fixnum?
21382 (lambda (as src L1 liveregs)
21383 (sparc.btsti as src 3)
21384 (emit-checkcc! as sparc.bne L1 liveregs)))
21386 (define-primop 'internal:check-pair?
21387 (lambda (as src L1 liveregs)
21388 (sparc.andi as src $tag.tagmask $r.tmp0)
21389 (sparc.cmpi as $r.tmp0 $tag.pair-tag)
21390 (emit-checkcc! as sparc.bne L1 liveregs)))
21392 (define-primop 'internal:check-vector?
21393 (lambda (as src L1 liveregs)
21394 (sparc.andi as src $tag.tagmask $r.tmp0)
21395 (sparc.cmpi as $r.tmp0 $tag.vector-tag)
21398 (sparc.ldi as src (- $tag.vector-tag) $r.tmp0)
21399 (sparc.andi as $r.tmp0 255 $r.tmp1)
21400 (sparc.cmpi as $r.tmp1 $imm.vector-header)
21401 (emit-checkcc! as sparc.bne L1 liveregs)))
21403 (define-primop 'internal:check-vector?/vector-length:vec
21404 (lambda (as src dst L1 liveregs)
21405 (sparc.andi as src $tag.tagmask $r.tmp0)
21406 (sparc.cmpi as $r.tmp0 $tag.vector-tag)
21409 (sparc.ldi as src (- $tag.vector-tag) $r.tmp0)
21410 (sparc.andi as $r.tmp0 255 $r.tmp1)
21411 (sparc.cmpi as $r.tmp1 $imm.vector-header)
21413 (apply sparc.slot2 as liveregs)
21414 (sparc.srli as $r.tmp0 8 dst)))
21416 (define (internal-primop-invariant2 name a b)
21417 (if (not (and (hardware-mapped? a) (hardware-mapped? b)))
21418 (asm-error "SPARC assembler internal invariant violated by " name
21419 " on operands " a " and " b)))
21421 (define (internal-primop-invariant1 name a)
21422 (if (not (hardware-mapped? a))
21423 (asm-error "SPARC assembler internal invariant violated by " name
21424 " on operand " a)))
21427 ; Copyright 1998 Lars T Hansen.
21429 ; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
21431 ; SPARC code generation macros for primitives, part 3a:
21432 ; helper procedures for scalars.
21435 ; LOGAND, LOGIOR, LOGXOR: logical operations on fixnums.
21437 ; Input: Registers rs1 and rs2, both of which can be general registers.
21438 ; In addition, rs1 can be RESULT, and rs2 can be ARGREG2.
21439 ; Output: Register dest, which can be a general register or RESULT.
21441 (define (logical-op as rs1 rs2 dest op excode)
21443 (define (fail rs1 rs2 L0)
21444 (if (not (= rs1 $r.result)) (sparc.move as rs1 $r.result))
21445 (if (not (= rs2 $r.argreg2)) (sparc.move as rs2 $r.argreg2))
21446 (sparc.set as (thefixnum excode) $r.tmp0)
21447 (millicode-call/ret as $m.exception L0))
21449 (let ((L0 (new-label))
21451 (sparc.label as L0)
21452 (let ((rs1 (force-hwreg! as rs1 $r.result))
21453 (rs2 (force-hwreg! as rs2 $r.argreg2))
21455 (d (hardware-mapped? dest)))
21457 (op as rs1 rs2 dest))
21459 (op as rs1 rs2 $r.tmp0)
21460 (emit-store-reg! as $r.tmp0 dest))
21462 (sparc.orr as rs1 rs2 $r.tmp0)
21463 (sparc.btsti as $r.tmp0 3)
21465 (op as rs1 rs2 dest)
21467 (sparc.label as L1))
21469 (sparc.orr as rs1 rs2 $r.tmp0)
21470 (sparc.btsti as $r.tmp0 3)
21472 (op as rs1 rs2 $r.tmp0)
21474 (sparc.label as L1)
21475 (emit-store-reg! as $r.tmp0 dest))))))
21478 ; LSH, RSHA, RSHL: Bitwise shifts on fixnums.
21480 ; Notes for future contemplation:
21481 ; - The semantics do not match those of MIT Scheme or MacScheme: only
21482 ; positive shifts are allowed.
21483 ; - The names do not match the fixnum-specific procedures of Chez Scheme
21484 ; that have the same semantics: fxsll, fxsra, fxsrl.
21485 ; - This code checks that the second argument is in range; if it did
21486 ; not, then we could get a MOD for free. Probably too hardware-dependent
21488 ; - The range 0..31 for the shift count is curious given that the fixnum
21491 (define (emit-shift-operation as exn rs1 rs2 rd)
21492 (let ((rs2 (force-hwreg! as rs2 $r.argreg2)))
21493 (if (not (unsafe-code))
21494 (let ((L0 (new-label))
21495 (FAULT (new-label))
21496 (START (new-label)))
21497 (sparc.label as START)
21498 (sparc.btsti as rs1 3) ; RS1 fixnum?
21500 (sparc.andi as rs2 #x7c $r.g0) ; RS2 fixnum and 0 <= RS2 < 32?
21501 (sparc.label as FAULT)
21502 (if (not (= rs1 $r.result))
21503 (sparc.move as rs1 $r.result))
21504 (if (not (= rs2 $r.argreg2))
21505 (emit-move2hwreg! as rs2 $r.argreg2))
21506 (sparc.set as (thefixnum exn) $r.tmp0)
21507 (millicode-call/ret as $m.exception START)
21508 (sparc.label as L0)
21509 (sparc.bne as FAULT)
21510 (sparc.srai as rs2 2 $r.tmp1))
21512 (sparc.srai as rs2 2 $r.tmp1)))
21513 (cond ((= exn $ex.lsh)
21514 (sparc.sllr as rs1 $r.tmp1 rd))
21516 (sparc.srlr as rs1 $r.tmp1 rd)
21517 (sparc.andni as rd 3 rd))
21519 (sparc.srar as rs1 $r.tmp1 rd)
21520 (sparc.andni as rd 3 rd))
21524 ; Set result on condition code.
21526 ; The processor's zero bit has been affected by a previous instruction.
21527 ; If the bit is set, store #t in RESULT, otherwise store #f in RESULT.
21529 (define (emit-set-boolean! as)
21530 (emit-set-boolean-reg! as $r.result))
21533 ; Set on condition code.
21535 ; The processor's zero bit has been affected by a previous instruction.
21536 ; If the bit is set, store #t in the processor register 'dest', otherwise
21537 ; store #f in 'dest'.
21539 (define (emit-set-boolean-reg! as dest)
21540 (let ((L1 (new-label)))
21541 (sparc.set as $imm.true dest)
21542 (sparc.bne.a as L1)
21543 (sparc.set as $imm.false dest)
21544 (sparc.label as L1)))
21547 ; Representation predicate.
21549 (define (emit-single-tagcheck->bool! as tag)
21550 (sparc.andi as $r.result $tag.tagmask $r.tmp0)
21551 (sparc.cmpi as $r.tmp0 tag)
21552 (emit-set-boolean! as))
21554 (define (emit-single-tagcheck-assert! as tag1 excode reg2)
21555 (emit-single-tagcheck-assert-reg! as tag1 $r.result reg2 excode))
21557 (define (emit-single-tagcheck-assert-reg! as tag1 reg reg2 excode)
21558 (let ((L0 (new-label))
21560 (FAULT (new-label)))
21561 (sparc.label as L0)
21562 (sparc.andi as reg $tag.tagmask $r.tmp0)
21563 (sparc.cmpi as $r.tmp0 tag1)
21564 (fault-if-ne as excode #f #f reg reg2 L0)))
21566 ; Assert that a machine register has a fixnum in it.
21567 ; Returns the label of the fault code.
21569 (define (emit-assert-fixnum! as reg excode)
21570 (let ((L0 (new-label))
21572 (FAULT (new-label)))
21573 (sparc.label as L0)
21574 (sparc.btsti as reg 3)
21575 (fault-if-ne as excode #f #f reg #f L0)))
21577 ; Assert that RESULT has a character in it.
21578 ; Returns the label of the fault code.
21580 (define (emit-assert-char! as excode fault-label)
21581 (let ((L0 (new-label))
21583 (FAULT (new-label)))
21584 (sparc.label as L0)
21585 (sparc.andi as $r.result #xFF $r.tmp0)
21586 (sparc.cmpi as $r.tmp0 $imm.character)
21587 (fault-if-ne as excode #f fault-label #f #f L0)))
21589 ; Generate code for fault handling if the zero flag is not set.
21590 ; - excode is the nativeint exception code.
21591 ; - cont-label, if not #f, is the label to go to if there is no fault.
21592 ; - fault-label, if not #f, is the label of an existing fault handler.
21593 ; - reg1, if not #f, is the number of a register which must be
21594 ; moved into RESULT before the fault handler is called.
21595 ; - reg2, if not #f, is the number of a register which must be moved
21596 ; into ARGREG2 before the fault handler is called.
21597 ; - ret-label, if not #f, is the return address to be set up before calling
21598 ; the fault handler.
21600 ; Ret-label and fault-label cannot simultaneously be non-#f; in this case
21601 ; the ret-label is ignored (since the existing fault handler most likely
21602 ; sets up the return in the desired manner).
21604 (define (fault-if-ne as excode cont-label fault-label reg1 reg2 ret-label)
21607 (if (and reg2 (not (= reg2 $r.argreg2)))
21608 (emit-move2hwreg! as reg2 $r.argreg2))
21609 (sparc.bne as fault-label)
21610 (if (and reg1 (not (= reg1 $r.result)))
21611 (sparc.move as reg1 $r.result)
21614 (let ((FAULT (new-label))
21616 (sparc.be.a as (or cont-label L1))
21618 (sparc.label as FAULT)
21619 (if (and reg1 (not (= reg1 $r.result)))
21620 (sparc.move as reg1 $r.result))
21621 (if (and reg2 (not (= reg2 $r.argreg2)))
21622 (emit-move2hwreg! as reg2 $r.argreg2))
21623 (sparc.set as (thefixnum excode) $r.tmp0)
21624 (millicode-call/ret as $m.exception (or ret-label L1))
21625 (if (or (not cont-label) (not ret-label))
21626 (sparc.label as L1))
21629 ; This is more expensive than what is good for it (5 cycles in the usual case),
21630 ; but there does not seem to be a better way.
21632 (define (emit-assert-positive-fixnum! as reg excode)
21633 (let ((L1 (new-label))
21636 (sparc.label as L2)
21637 (sparc.tsubrcc as reg $r.g0 $r.g0)
21640 (sparc.label as L3)
21641 (if (not (= reg $r.result))
21642 (sparc.move as reg $r.result))
21643 (sparc.set as (thefixnum excode) $r.tmp0)
21644 (millicode-call/ret as $m.exception l2)
21645 (sparc.label as L1)
21651 ; Arithmetic comparison with boolean result.
21653 (define (emit-cmp-primop! as branch_t.a generic r)
21654 (let ((Ltagok (new-label))
21655 (Lcont (new-label))
21656 (r (force-hwreg! as r $r.argreg2)))
21657 (sparc.tsubrcc as $r.result r $r.g0)
21658 (sparc.bvc.a as Ltagok)
21659 (sparc.set as $imm.false $r.result)
21660 (if (not (= r $r.argreg2))
21661 (sparc.move as r $r.argreg2))
21662 (millicode-call/ret as generic Lcont)
21663 (sparc.label as Ltagok)
21664 (branch_t.a as Lcont)
21665 (sparc.set as $imm.true $r.result)
21666 (sparc.label as Lcont)))
21669 ; Arithmetic comparison and branch.
21671 ; This code does not use the chained branch trick (DCTI) that was documented
21672 ; in the Sparc v8 manual and deprecated in the v9 manual. This code executes
21673 ; _much_ faster on the Ultra than the code using DCTI, even though it executes
21674 ; the same instructions.
21676 ; Parameters and preconditions.
21677 ; Src1 is a general register, RESULT, ARGREG2, or ARGREG3.
21678 ; Src2 is a general register, RESULT, ARGREG2, ARGREG3, or an immediate.
21679 ; Src2 is an immediate iff src2isreg = #f.
21680 ; Branch_f.a is a branch on condition code that branches if the condition
21682 ; Generic is the millicode table offset of the generic procedure.
21684 (define (emit-bcmp-primop! as branch_f.a src1 src2 Lfalse generic src2isreg)
21685 (let ((Ltagok (new-label))
21686 (Ltrue (new-label))
21688 (force-hwreg! as src2 $r.tmp1)
21690 (sub (if src2isreg sparc.tsubrcc sparc.tsubicc))
21691 (mov (if src2isreg sparc.move sparc.set)))
21692 (sub as src1 op2 $r.g0)
21693 (sparc.bvc.a as Ltagok)
21696 ; Not both fixnums.
21697 ; Must move src1 to result if src1 is not result.
21698 ; Must move src2 to argreg2 if src2 is not argreg2.
21700 (let ((move-res (not (= src1 $r.result)))
21701 (move-arg2 (or (not src2isreg) (not (= op2 $r.argreg2)))))
21702 (if (and move-arg2 move-res)
21703 (mov as op2 $r.argreg2))
21704 (sparc.jmpli as $r.millicode generic $r.o7)
21705 (cond (move-res (sparc.move as src1 $r.result))
21706 (move-arg2 (mov as op2 $r.argreg2))
21707 (else (sparc.nop as)))
21708 (sparc.cmpi as $r.result $imm.false)
21709 (sparc.bne.a as Ltrue)
21711 (sparc.b as Lfalse)
21714 (sparc.label as Ltagok)
21715 (branch_f.a as Lfalse)
21717 (sparc.label as Ltrue)))
21720 ; Generic arithmetic for + and -.
21722 ; We have two HW registers src1 and dest.
21723 ; If src2isreg is #t then src2 may be a HW reg or a SW reg
21724 ; If src2isreg is #f then src2 is an immediate fixnum, not shifted.
21725 ; Src1 and dest may be RESULT, but src2 may not.
21726 ; Src2 may be ARGREG2, the others may not.
21728 ; FIXME! This is incomprehensible.
21732 '(define (emit-arith-primop! as op invop generic src1 src2 dest src2isreg)
21733 (let ((L1 (new-label))
21735 (force-hwreg! as src2 $r.tmp1)
21736 (thefixnum src2))))
21737 (if (and src2isreg (= op2 dest))
21738 (begin (op as src1 op2 $r.tmp0)
21739 (sparc.bvc.a as L1)
21740 (sparc.move as $r.tmp0 dest))
21741 (begin (op as src1 op2 dest)
21742 (sparc.bvc.a as L1)
21744 (invop as dest op2 dest)))
21745 (let ((n (+ (if (not (= src1 $r.result)) 1 0)
21746 (if (or (not src2isreg) (not (= op2 $r.argreg2))) 1 0)))
21747 (mov2 (if src2isreg sparc.move sparc.set)))
21749 (mov2 as op2 $r.argreg2))
21750 (sparc.jmpli as $r.millicode generic $r.o7)
21751 (cond ((= n 0) (sparc.nop as))
21752 ((= n 1) (mov2 as op2 $r.argreg2))
21753 (else (sparc.move as src1 $r.result)))
21754 ; Generic arithmetic leaves stuff in RESULT, must move to dest if
21755 ; dest is not RESULT.
21756 (if (not (= dest $r.result))
21757 (sparc.move as $r.result dest))
21758 (sparc.label as L1))))
21760 ; Comprehensible, but longer.
21762 ; Important to be careful not to clobber arguments, and not to leave garbage
21763 ; in rd, if millicode is called.
21765 ; op is the appropriate operation.
21766 ; invop is the appropriate inverse operation.
21767 ; RS1 can be any general hw register or RESULT.
21768 ; RS2/IMM can be any general register or ARGREG2 (op2isreg=#t), or
21769 ; an immediate (op2isreg=#f)
21770 ; RD can be any general hw register or RESULT.
21772 ; FIXME: split this into two procedures.
21774 (define (emit-arith-primop! as op invop generic rs1 rs2/imm rd op2isreg)
21775 (let ((L1 (new-label)))
21777 (let ((rs2 (force-hwreg! as rs2/imm $r.argreg2)))
21778 (cond ((or (= rs1 rs2 rd)
21780 (= generic $m.subtract)))
21781 (op as rs1 rs2 $r.tmp0)
21782 (sparc.bvc.a as L1)
21783 (sparc.move as $r.tmp0 rd))
21785 (op as rs1 rs2 rs1)
21786 (sparc.bvc.a as L1)
21788 (invop as rs1 rs2 rs1))
21790 (op as rs1 rs2 rs2)
21791 (sparc.bvc.a as L1)
21793 (invop as rs2 rs1 rs2))
21796 (sparc.bvc.a as L1)
21798 (if (and (not (= rd $r.result)) (not (= rd $r.argreg2)))
21799 (sparc.clr as rd))))
21800 (cond ((and (= rs1 $r.result) (= rs2 $r.argreg2))
21801 ;; Could peephole the INVOP or CLR into the slot here.
21802 (millicode-call/0arg as generic))
21804 (millicode-call/1arg as generic rs2))
21805 ((= rs2 $r.argreg2)
21806 (millicode-call/1arg-in-result as generic rs1))
21808 (sparc.move as rs2 $r.argreg2)
21809 (millicode-call/1arg-in-result as generic rs1))))
21810 (let ((imm (thefixnum rs2/imm)))
21812 (sparc.bvc.a as L1)
21814 (invop as rd imm rd)
21815 (if (not (= rs1 $r.result))
21816 (sparc.move as rs1 $r.result))
21817 (millicode-call/numarg-in-reg as generic imm $r.argreg2)))
21818 (if (not (= rd $r.result))
21819 (sparc.move as $r.result rd))
21820 (sparc.label as L1)))
21823 ; Important to be careful not to leave garbage in rd if millicode is called.
21825 (define (emit-negate as rs rd)
21826 (let ((L1 (new-label)))
21828 (sparc.tsubrcc as $r.g0 rs rs)
21829 (sparc.bvc.a as L1)
21831 (if (= rs $r.result)
21833 (sparc.jmpli as $r.millicode $m.negate $r.o7)
21834 (sparc.subr as $r.g0 $r.result $r.result))
21836 (sparc.subr as $r.g0 rs rs)
21837 (sparc.jmpli as $r.millicode $m.negate $r.o7)
21838 (sparc.move as rs $r.result))))
21840 (sparc.tsubrcc as $r.g0 rs rd)
21841 (sparc.bvc.a as L1)
21843 (cond ((= rs $r.result)
21844 (sparc.jmpli as $r.millicode $m.negate $r.o7)
21847 (sparc.jmpli as $r.millicode $m.negate $r.o7)
21848 (sparc.move as rs $r.result))
21851 (sparc.jmpli as $r.millicode $m.negate $r.o7)
21852 (sparc.move as rs $r.result)))))
21853 (if (not (= rd $r.result))
21854 (sparc.move as $r.result rd))
21855 (sparc.label as L1)))
21857 ; Character comparison.
21859 ; r is a register or a character constant.
21861 (define (emit-char-cmp as r btrue.a excode)
21862 (emit-charcmp! as (lambda ()
21863 (let ((l2 (new-label)))
21864 (sparc.set as $imm.false $r.result)
21866 (sparc.set as $imm.true $r.result)
21867 (sparc.label as L2)))
21872 ; op1 is a hw register
21873 ; op2 is a register or a character constant
21875 (define (emit-char-bcmp-primop! as bfalse.a op1 op2 L0 excode)
21876 (emit-charcmp! as (lambda ()
21883 ; We check the tags of both by xoring them and seeing if the low byte is 0.
21884 ; If so, then we can subtract one from the other (tag and all) and check the
21887 ; The branch-on-true instruction must have the annull bit set. (???)
21889 ; op1 is a hw register
21890 ; op2 is a register or a character constant.
21892 (define (emit-charcmp! as tail op1 op2 excode)
21893 (let ((op2 (if (char? op2)
21895 (force-hwreg! as op2 $r.argreg2))))
21896 (cond ((not (unsafe-code))
21897 (let ((L0 (new-label))
21899 (FAULT (new-label)))
21900 (sparc.label as L0)
21902 (sparc.xori as op1 $imm.character $r.tmp0)
21903 (sparc.btsti as $r.tmp0 #xFF)
21904 (sparc.srli as op1 16 $r.tmp0)
21906 (sparc.cmpi as $r.tmp0 (char->integer op2)))
21908 (sparc.andi as op1 #xFF $r.tmp0)
21909 (sparc.andi as op2 #xFF $r.tmp1)
21910 (sparc.cmpr as $r.tmp0 $r.tmp1)
21911 (sparc.bne as FAULT)
21912 (sparc.cmpi as $r.tmp0 $imm.character)
21914 (sparc.cmpr as op1 op2)))
21915 (sparc.label as FAULT)
21916 (if (not (eqv? op1 $r.result))
21917 (sparc.move as op1 $r.result))
21919 (emit-immediate->register! as
21920 (char->immediate op2)
21922 ((not (eqv? op2 $r.argreg2))
21923 (sparc.move as op2 $r.argreg2)))
21924 (sparc.set as (thefixnum excode) $r.tmp0)
21925 (millicode-call/ret as $m.exception L0)
21926 (sparc.label as L1)))
21928 (sparc.cmpr as op1 op2))
21930 (sparc.srli as op1 16 $r.tmp0)
21931 (sparc.cmpi as $r.tmp0 (char->integer op2))))
21935 ; Copyright 1998 Lars T Hansen.
21937 ; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
21939 ; SPARC code generation macros for primitives, part 3b:
21940 ; helper procedures for data structures.
21943 ; SET-CAR!, SET-CDR!, CELL-SET!
21945 ; Input: RS1: a hardware register; has pair pointer (tag check must be
21946 ; performed by the caller).
21947 ; RS2: any register; has value to store.
21950 ; Having rs1 != RESULT is pretty silly with the current write barrier
21951 ; but will be less silly with the new barrier.
21953 (define (emit-setcar/setcdr! as rs1 rs2 offs)
21954 (cond ((and (write-barrier) (hardware-mapped? rs2))
21955 (sparc.sti as rs2 (- offs $tag.pair-tag) rs1)
21956 (if (not (= rs1 $r.result))
21957 (sparc.move as rs1 $r.result))
21958 (millicode-call/1arg as $m.addtrans rs2))
21960 (emit-move2hwreg! as rs2 $r.argreg2)
21961 (sparc.sti as $r.argreg2 (- offs $tag.pair-tag) rs1)
21962 (millicode-call/1arg-in-result as $m.addtrans rs1))
21963 ((hardware-mapped? rs2)
21964 (sparc.sti as rs2 (- offs $tag.pair-tag) rs1))
21966 (emit-move2hwreg! as rs2 $r.argreg2)
21967 (sparc.sti as $r.argreg2 (- offs $tag.pair-tag) rs1))))
21972 ; Representation predicate.
21974 ; RESULT has an object. If the tag of RESULT is 'tag1' and the
21975 ; header byte of the object is 'tag2' then set RESULT to #t, else
21978 (define (emit-double-tagcheck->bool! as tag1 tag2)
21979 (let ((L1 (new-label)))
21980 (sparc.andi as $r.result $tag.tagmask $r.tmp0)
21981 (sparc.cmpi as $r.tmp0 tag1)
21982 (sparc.bne.a as L1)
21983 (sparc.set as $imm.false $r.result)
21984 (sparc.ldbi as $r.result (+ (- tag1) 3) $r.tmp0)
21985 (sparc.set as $imm.true $r.result)
21986 (sparc.cmpi as $r.tmp0 tag2)
21987 (sparc.bne.a as L1)
21988 (sparc.set as $imm.false $r.result)
21989 (sparc.label as L1)))
21992 ; Check structure tag.
21994 ; RS1 has an object. If the tag of RS1 is not 'tag1', or if the tag is
21995 ; 'tag1' but the header byte of the object header is not 'tag2', then an
21996 ; exception with code 'excode' is signalled. The exception call is set
21997 ; up to return to the first instruction of the emitted code.
21999 ; If RS1 is not RESULT then it is moved to RESULT before the exception
22002 ; If RS2/IMM is not #f, then it is a register or immediate that is moved
22003 ; to ARGREG2 before the exception is signalled; it is an immediate iff
22006 ; RS1 must be a hardware register.
22007 ; RS2/IMM is a general register, ARGREG2, an immediate, or #f.
22008 ; RS3 is a general register, ARGREG3, or #f.
22010 ; The procedure returns the label of the fault address. If the execution
22011 ; falls off the end of the emitted instruction sequence, then the following
22013 ; - the tag of the object in RS1 was 'tag1' and its header byte was 'tag2'
22014 ; - the object header word is in TMP0.
22016 (define (double-tagcheck-assert as tag1 tag2 rs1 rs2/imm rs3 excode imm?)
22017 (let ((L0 (new-label))
22019 (FAULT (new-label)))
22020 (sparc.label as L0)
22021 (sparc.andi as rs1 $tag.tagmask $r.tmp0)
22022 (sparc.cmpi as $r.tmp0 tag1)
22024 (sparc.ldi as rs1 (- tag1) $r.tmp0)
22025 (sparc.label as FAULT)
22026 (if (not (= rs1 $r.result))
22027 (sparc.move as rs1 $r.result))
22030 (sparc.set as (thefixnum rs2/imm) $r.argreg2))
22031 ((= rs2/imm $r.argreg2))
22033 (emit-move2hwreg! as rs2/imm $r.argreg2))))
22034 (if (and rs3 (not (= rs3 $r.argreg3)))
22035 (emit-move2hwreg! as rs3 $r.argreg3))
22036 (sparc.set as (thefixnum excode) $r.tmp0)
22037 (millicode-call/ret as $m.exception L0)
22038 (sparc.label as L1)
22039 (sparc.andi as $r.tmp0 255 $r.tmp1)
22040 (sparc.cmpi as $r.tmp1 tag2)
22041 (sparc.bne.a as FAULT)
22045 (define (emit-double-tagcheck-assert! as tag1 tag2 excode reg2)
22046 (double-tagcheck-assert as tag1 tag2 $r.result reg2 #f excode #f))
22048 (define (emit-double-tagcheck-assert-reg/reg! as tag1 tag2 rs1 rs2 excode)
22049 (double-tagcheck-assert as tag1 tag2 rs1 rs2 #f excode #f))
22051 (define (emit-double-tagcheck-assert-reg/imm! as tag1 tag2 rs1 imm excode)
22052 (double-tagcheck-assert as tag1 tag2 rs1 imm #f excode #t))
22057 ; Get the length of a vector or bytevector structure, with tag checking
22060 ; Input: RS and RD are both hardware registers.
22062 (define (emit-get-length! as tag1 tag2 excode rs rd)
22063 (if (not (unsafe-code))
22065 (emit-double-tagcheck-assert-reg/reg! as tag1 tag2 rs rd excode)
22066 (emit-single-tagcheck-assert-reg! as tag1 rs rd excode)))
22067 (emit-get-length-trusted! as tag1 rs rd))
22069 ; Get the length of a vector or bytevector structure, without tag checking.
22071 ; Input: RS and RD are both hardware registers.
22073 (define (emit-get-length-trusted! as tag1 rs rd)
22074 (sparc.ldi as rs (- tag1) $r.tmp0)
22075 (sparc.srli as $r.tmp0 8 rd)
22076 (if (= tag1 $tag.bytevector-tag)
22077 (sparc.slli as rd 2 rd)))
22080 ; Allocate a bytevector, leave untagged pointer in RESULT.
22082 (define (emit-allocate-bytevector as hdr preserved-result)
22084 ; Preserve the length field, then calculate the number of words
22085 ; to allocate. The value `28' is an adjustment of 3 (for rounding
22086 ; up) plus another 4 bytes for the header, all represented as a fixnum.
22088 (if (not preserved-result)
22089 (sparc.move as $r.result $r.argreg2))
22090 (sparc.addi as $r.result 28 $r.result)
22091 (sparc.andi as $r.result (asm:signed #xFFFFFFF0) $r.result)
22095 (sparc.jmpli as $r.millicode $m.alloc-bv $r.o7)
22096 (sparc.srai as $r.result 2 $r.result)
22098 ; Setup the header.
22100 (if (not preserved-result)
22101 (sparc.slli as $r.argreg2 6 $r.tmp0)
22102 (sparc.slli as preserved-result 6 $r.tmp0))
22103 (sparc.addi as $r.tmp0 hdr $r.tmp0)
22104 (sparc.sti as $r.tmp0 0 $r.result))
22107 ; Given a nativeint count, a pointer to the first element of a
22108 ; bytevector-like structure, and a byte value, fill the bytevector
22109 ; with the byte value.
22111 (define (emit-bytevector-fill as r-bytecount r-pointer r-value)
22112 (let ((L2 (new-label))
22114 (sparc.label as L2)
22115 (sparc.deccc as r-bytecount)
22116 (sparc.bge.a as L2)
22117 (sparc.stbr as r-value r-bytecount r-pointer)
22118 (sparc.label as L1)))
22121 ; BYTEVECTOR-REF, BYTEVECTOR-LIKE-REF, STRING-REF.
22123 ; The pointer in RS1 is known to be bytevector-like. RS2 is the fixnum
22124 ; index into the structure. Get the RS2'th element and place it in RD.
22126 ; RS1 and RD are hardware registers.
22127 ; RS2 is a general register or ARGREG2.
22128 ; 'fault' is defined iff (unsafe-code) = #f
22129 ; header is in TMP0 iff (unsafe-code) = #f and 'header-loaded?' = #t
22130 ; if 'charize?' is #t then store result as char, otherwise as fixnum.
22132 (define (emit-bytevector-like-ref! as rs1 rs2 rd fault charize? header-loaded?)
22133 (let ((rs2 (force-hwreg! as rs2 $r.argreg2)))
22134 (if (not (unsafe-code))
22136 ; check that index is fixnum
22137 (sparc.btsti as rs2 3)
22138 (sparc.bne as fault)
22139 (if (not header-loaded?)
22140 (sparc.ldi as rs1 (- $tag.bytevector-tag) $r.tmp0))
22142 (sparc.srai as rs2 2 $r.tmp1)
22143 (sparc.srli as $r.tmp0 8 $r.tmp0)
22144 (sparc.cmpr as $r.tmp0 $r.tmp1)
22145 (sparc.bleu as fault)
22146 ; No NOP or SLOT -- the SUBI below goes into the slot.
22149 (sparc.srai as rs2 2 $r.tmp1)))
22150 ; Pointer is in RS1.
22151 ; Shifted index is in TMP1.
22152 (sparc.addi as rs1 (- 4 $tag.bytevector-tag) $r.tmp0)
22153 (sparc.ldbr as $r.tmp0 $r.tmp1 $r.tmp0)
22155 (sparc.slli as $r.tmp0 2 rd)
22156 (begin (sparc.slli as $r.tmp0 16 rd)
22157 (sparc.ori as rd $imm.character rd)))))
22159 ; As above, but RS2 is replaced by an immediate, IMM.
22161 ; The immediate, represented as a fixnum, is guaranteed fit in the
22162 ; instruction's immediate field.
22164 (define (emit-bytevector-like-ref/imm! as rs1 imm rd fault charize?
22166 (if (not (unsafe-code))
22168 (if (not header-loaded?)
22169 (sparc.ldi as rs1 (- $tag.bytevector-tag) $r.tmp0))
22171 (sparc.srli as $r.tmp0 8 $r.tmp0)
22172 (sparc.cmpi as $r.tmp0 imm)
22173 (sparc.bleu.a as fault)
22176 ; Pointer is in RS1.
22178 (let ((adjusted-offset (+ (- 4 $tag.bytevector-tag) imm)))
22179 (if (immediate-literal? adjusted-offset)
22181 (sparc.ldbi as rs1 adjusted-offset $r.tmp0))
22183 (sparc.addi as rs1 (- 4 $tag.bytevector-tag) $r.tmp0)
22184 (sparc.ldbr as $r.tmp0 imm $r.tmp0)))
22186 (sparc.slli as $r.tmp0 2 rd)
22187 (begin (sparc.slli as $r.tmp0 16 rd)
22188 (sparc.ori as rd $imm.character rd)))))
22191 ; BYTEVECTOR-SET!, BYTEVECTOR-LIKE-SET!
22193 ; Input: RESULT -- a pointer to a bytevector-like structure.
22194 ; TMP0 -- the header iff (unsafe-code) = #f and header-loaded? = #t
22195 ; IDX -- a register that holds the second argument
22196 ; BYTE -- a register that holds the third argument
22199 ; 'Fault' is the address of the error code iff (unsafe-code) = #f
22202 ; - Argument values passed to error handler appear to be bogus
22203 ; (error message is very strange).
22204 ; - There's no check that the value actually fits in a byte.
22205 ; - Uses ARGREG3 and and TMP2.
22207 (define (emit-bytevector-like-set! as idx byte fault header-loaded?)
22208 (let ((r1 (force-hwreg! as idx $r.tmp1))
22209 (r2 (force-hwreg! as byte $r.argreg3)))
22210 (if (not (unsafe-code))
22212 (if (not header-loaded?)
22213 (sparc.ldi as $r.result (- $tag.bytevector-tag) $r.tmp0))
22214 ; Both index and byte must be fixnums.
22215 ; Can't use tsubcc because the computation may really overflow.
22216 (sparc.orr as r1 r2 $r.tmp2)
22217 (sparc.btsti as $r.tmp2 3)
22218 (sparc.bnz as fault)
22219 ; No NOP -- next instruction is OK in slot.
22220 ; Index must be in range.
22221 (sparc.srli as $r.tmp0 8 $r.tmp0) ; limit - in slot
22222 (sparc.srai as r1 2 $r.tmp1) ; index
22223 (sparc.cmpr as $r.tmp1 $r.tmp0)
22224 (sparc.bgeu as fault)
22225 ; No NOP -- next instruction is OK in slot.
22228 (sparc.srai as r1 2 $r.tmp1)))
22229 (sparc.srli as r2 2 $r.tmp0)
22230 ; Using ARGREG2 as the destination is OK because the resulting pointer
22231 ; value always looks like a fixnum. By doing so, we avoid needing TMP2.
22232 (sparc.addi as $r.result (- 4 $tag.bytevector-tag) $r.argreg2)
22233 (sparc.stbr as $r.tmp0 $r.tmp1 $r.argreg2)))
22238 (define (emit-string-set! as rs1 rs2 rs3)
22239 (let* ((rs2 (force-hwreg! as rs2 $r.argreg2))
22240 (rs3 (force-hwreg! as rs3 $r.argreg3))
22241 (FAULT (if (not (unsafe-code))
22242 (double-tagcheck-assert
22244 $tag.bytevector-tag
22245 (+ $imm.bytevector-header $tag.string-typetag)
22249 ; Header is in TMP0; TMP1 and TMP2 are free.
22250 (if (not (unsafe-code))
22252 ; RS2 must be a fixnum.
22253 (sparc.btsti as rs2 3)
22254 (sparc.bne as FAULT)
22255 ; Index (in RS2) must be valid; header is in tmp0.
22256 (sparc.srli as $r.tmp0 8 $r.tmp0) ; limit
22257 (sparc.srai as rs2 2 $r.tmp1) ; index
22258 (sparc.cmpr as $r.tmp1 $r.tmp0)
22259 (sparc.bgeu as FAULT)
22260 ; RS3 must be a character.
22261 (sparc.andi as rs3 #xFF $r.tmp0)
22262 (sparc.cmpi as $r.tmp0 $imm.character)
22263 (sparc.bne as FAULT)
22264 ; No NOP -- the SRLI below goes in the slot
22267 (sparc.srai as rs2 2 $r.tmp1)))
22268 ; tmp1 has nativeint index.
22269 ; rs3/argreg3 has character.
22271 (sparc.subi as $r.tmp1 (- $tag.bytevector-tag 4) $r.tmp1)
22272 (sparc.srli as rs3 16 $r.tmp0)
22273 (sparc.stbr as $r.tmp0 rs1 $r.tmp1)))
22276 ; VECTORS and PROCEDURES
22278 ; Allocate short vectors of known length; faster than the general case.
22279 ; FIXME: can also allocate in-line.
22281 (define (make-vector-n as length r)
22282 (sparc.jmpli as $r.millicode $m.alloc $r.o7)
22283 (sparc.set as (thefixnum (+ length 1)) $r.result)
22284 (emit-immediate->register! as (+ (* 256 (thefixnum length))
22286 $tag.vector-typetag)
22288 (sparc.sti as $r.tmp0 0 $r.result)
22289 (let ((dest (force-hwreg! as r $r.argreg2)))
22290 (do ((i 0 (+ i 1)))
22292 (sparc.sti as dest (* (+ i 1) 4) $r.result)))
22293 (sparc.addi as $r.result $tag.vector-tag $r.result))
22296 ; emit-make-vector-like! assumes argreg3 is not destroyed by alloci.
22297 ; FIXME: bug: $ex.mkvl is not right if the operation is make-procedure
22300 (define (emit-make-vector-like! as r hdr ptrtag)
22301 (let ((FAULT (emit-assert-positive-fixnum! as $r.result $ex.mkvl)))
22302 (sparc.move as $r.result $r.argreg3)
22303 (sparc.addi as $r.result 4 $r.result)
22304 (sparc.jmpli as $r.millicode $m.alloci $r.o7)
22306 (sparc.set as $imm.null $r.argreg2)
22307 (emit-move2hwreg! as r $r.argreg2))
22308 (sparc.slli as $r.argreg3 8 $r.tmp0)
22309 (sparc.addi as $r.tmp0 hdr $r.tmp0)
22310 (sparc.sti as $r.tmp0 0 $r.result)
22311 (sparc.addi as $r.result ptrtag $r.result)))
22314 ; VECTOR-REF, VECTOR-LIKE-REF, PROCEDURE-REF
22316 ; FAULT is valid iff (unsafe-code) = #f
22317 ; Header is in TMP0 iff (unsafe-code) = #f and header-loaded? = #t.
22319 (define (emit-vector-like-ref! as rs1 rs2 rd FAULT tag header-loaded?)
22320 (let ((index (force-hwreg! as rs2 $r.argreg2)))
22321 (if (not (unsafe-code))
22323 (if (not header-loaded?)
22324 (sparc.ldi as rs1 (- tag) $r.tmp0))
22325 ; Index must be fixnum.
22326 (sparc.btsti as index 3)
22327 (sparc.bne as FAULT)
22328 ; Index must be within bounds.
22329 (sparc.srai as $r.tmp0 8 $r.tmp0)
22330 (sparc.cmpr as $r.tmp0 index)
22331 (sparc.bleu as FAULT)
22332 ; No NOP; the following instruction is valid in the slot.
22334 (emit-vector-like-ref-trusted! as rs1 index rd tag)))
22336 (define (emit-vector-like-ref-trusted! as rs1 rs2 rd tag)
22337 (let ((index (force-hwreg! as rs2 $r.argreg2)))
22338 (sparc.addi as rs1 (- 4 tag) $r.tmp0)
22339 (sparc.ldr as $r.tmp0 index rd)))
22342 ; VECTOR-REF/IMM, VECTOR-LIKE-REF/IMM, PROCEDURE-REF/IMM
22344 ; 'rs1' is a hardware register containing a vectorish pointer (to a
22345 ; vector-like or procedure).
22346 ; 'imm' is a fixnum s.t. (immediate-literal? imm) => #t.
22347 ; 'rd' is a hardware register.
22348 ; 'FAULT' is the label of the error code iff (unsafe-code) => #f
22349 ; 'tag' is the tag of the pointer in rs1.
22350 ; 'header-loaded?' is #t iff the structure header word is in $r.tmp0.
22352 (define (emit-vector-like-ref/imm! as rs1 imm rd FAULT tag header-loaded?)
22353 (if (not (unsafe-code))
22355 (if (not header-loaded?) (sparc.ldi as rs1 (- tag) $r.tmp0))
22357 (sparc.srai as $r.tmp0 10 $r.tmp0)
22358 (sparc.cmpi as $r.tmp0 imm)
22359 (sparc.bleu as FAULT)
22361 (emit-vector-like-ref/imm-trusted! as rs1 imm rd tag))
22363 ; 'rs1' is a hardware register containing a vectorish pointer (to a
22364 ; vector-like or procedure).
22365 ; 'imm' is a fixnum s.t. (immediate-literal? imm) => #t.
22366 ; 'rd' is a hardware register.
22367 ; 'tag' is the tag of the pointer in rs1.
22369 (define (emit-vector-like-ref/imm-trusted! as rs1 imm rd tag)
22370 (let* ((offset (* imm 4)) ; words->bytes
22371 (adjusted-offset (+ (- 4 tag) offset)))
22372 (if (immediate-literal? adjusted-offset)
22374 (sparc.ldi as rs1 adjusted-offset rd))
22376 (sparc.addi as rs1 (- 4 tag) $r.tmp0)
22377 (sparc.ldi as $r.tmp0 offset rd)))))
22381 ; VECTOR-SET!, VECTOR-LIKE-SET!, PROCEDURE-SET!
22383 ; It is assumed that the pointer in RESULT is valid. We must check the index
22384 ; in register x for validity and then perform the side effect (by calling
22385 ; millicode). The tag is the pointer tag to be adjusted for.
22387 ; The use of vector-set is ok even if it is a procedure.
22389 ; fault is valid iff (unsafe-code) = #f
22390 ; header is in tmp0 iff (unsafe-code) = #f and header-loaded? = #t
22392 (define (emit-vector-like-set! as rs1 rs2 rs3 fault tag header-loaded?)
22393 (let ((rs2 (force-hwreg! as rs2 $r.tmp1))
22394 (rs3 (force-hwreg! as rs3 $r.argreg2)))
22395 (if (not (unsafe-code))
22397 (if (not header-loaded?)
22398 (sparc.ldi as $r.result (- tag) $r.tmp0))
22399 (sparc.btsti as rs2 3)
22400 (sparc.bne as fault)
22401 (sparc.srai as $r.tmp0 8 $r.tmp0)
22402 (sparc.cmpr as $r.tmp0 rs2)
22403 (sparc.bleu as fault)))
22404 (emit-vector-like-set-trusted! as rs1 rs2 rs3 tag)))
22406 ; rs1 must be a hardware register.
22407 ; tag is the pointer tag to be adjusted for.
22409 (define (emit-vector-like-set-trusted! as rs1 rs2 rs3 tag)
22410 (let ((rs2 (force-hwreg! as rs2 $r.tmp1))
22411 (rs3 (force-hwreg! as rs3 $r.argreg2)))
22412 ;; The ADDR can go in the delay slot of a preceding BLEU.
22413 (sparc.addr as rs1 rs2 $r.tmp0)
22414 (cond ((not (write-barrier))
22415 (sparc.sti as rs3 (- 4 tag) $r.tmp0))
22417 (cond ((= rs3 $r.argreg2)
22418 (sparc.jmpli as $r.millicode $m.addtrans $r.o7)
22419 (sparc.sti as rs3 (- 4 tag) $r.tmp0))
22421 (sparc.sti as rs3 (- 4 tag) $r.tmp0)
22422 (millicode-call/1arg as $m.addtrans rs3))))
22424 (cond ((= rs3 $r.argreg2)
22425 (sparc.sti as rs3 (- 4 tag) $r.tmp0)
22426 (millicode-call/1arg-in-result as $m.addtrans rs1))
22428 (sparc.sti as rs3 (- 4 tag) $r.tmp0)
22429 (sparc.move as rs1 $r.result)
22430 (millicode-call/1arg as $m.addtrans rs3)))))))
22433 ; Copyright 1998 Lars T Hansen.
22435 ; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
22439 ; SPARC code generation macros for primitives, part 3:
22440 ; fixnum-specific operations.
22442 ; Constraints for all the primops.
22444 ; RS1 is a general hardware register or RESULT.
22445 ; RS2 is a general register or ARGREG2.
22446 ; IMM is an exact integer in the range -1024 .. 1023.
22447 ; RD is a general hardware register or RESULT.
22450 ; Missing fxquotient, fxremainder
22451 ; When new pass1 in place:
22452 ; Must add code to pass1 to allow n-ary calls to be rewritten as binary
22453 ; Must add compiler macro for fxabs.
22456 ; most-negative-fixnum, most-positive-fixnum.
22458 (define-primop 'most-negative-fixnum
22460 (emit-immediate->register! as (asm:signed #x80000000) $r.result)))
22462 (define-primop 'most-positive-fixnum
22464 (emit-immediate->register! as (asm:signed #x7FFFFFFC) $r.result)))
22467 ; fx+, fx- w/o immediates
22469 (define-primop 'fx+
22471 (emit-fixnum-arithmetic as sparc.taddrcc sparc.addr $r.result rs2 $r.result
22474 (define-primop 'internal:fx+
22475 (lambda (as rs1 rs2 rd)
22476 (emit-fixnum-arithmetic as sparc.taddrcc sparc.addr rs1 rs2 rd $ex.fx+)))
22478 (define-primop 'fx-
22480 (emit-fixnum-arithmetic as sparc.tsubrcc sparc.subr $r.result rs2 $r.result
22483 (define-primop 'internal:fx-
22484 (lambda (as rs1 rs2 rd)
22485 (emit-fixnum-arithmetic as sparc.tsubrcc sparc.subr rs1 rs2 rd $ex.fx-)))
22487 (define-primop 'fx--
22489 (emit-fixnum-arithmetic as sparc.tsubrcc sparc.subr
22490 $r.g0 $r.result $r.result $ex.fx--)))
22492 (define-primop 'internal:fx--
22494 (emit-fixnum-arithmetic as sparc.tsubrcc sparc.subr $r.g0 rs rd $ex.fx--)))
22496 (define (emit-fixnum-arithmetic as op-check op-nocheck rs1 rs2 rd exn)
22498 (let ((rs2 (force-hwreg! as rs2 $r.argreg2)))
22499 (op-nocheck as rs1 rs2 rd))
22500 (let ((rs2 (force-hwreg! as rs2 $r.argreg2))
22503 (sparc.label as L0)
22504 (op-check as rs1 rs2 $r.tmp0)
22505 (sparc.bvc.a as L1)
22506 (sparc.move as $r.tmp0 rd)
22507 (if (not (= exn $ex.fx--))
22509 (if (not (= rs1 $r.result)) (sparc.move as rs1 $r.result))
22510 (if (not (= rs2 $r.argreg2)) (sparc.move as rs2 $r.argreg2)))
22512 (if (not (= rs2 $r.result)) (sparc.move as rs2 $r.result))))
22513 (sparc.set as (thefixnum exn) $r.tmp0)
22514 (millicode-call/ret as $m.exception L0)
22515 (sparc.label as L1))))
22517 ; fx* w/o immediate
22519 (define-primop 'fx*
22521 (emit-multiply-code as rs2 #t)))
22523 ; fx+, fx- w/immediates
22525 (define-primop 'internal:fx+/imm
22526 (lambda (as rs imm rd)
22527 (emit-fixnum-arithmetic/imm as sparc.taddicc sparc.addi
22528 rs imm rd $ex.fx+)))
22530 (define-primop 'internal:fx-/imm
22531 (lambda (as rs imm rd)
22532 (emit-fixnum-arithmetic/imm as sparc.tsubicc sparc.subi
22533 rs imm rd $ex.fx-)))
22535 (define (emit-fixnum-arithmetic/imm as op-check op-nocheck rs imm rd exn)
22537 (op-nocheck as rs (thefixnum imm) rd)
22538 (let ((L0 (new-label))
22540 (sparc.label as L0)
22541 (op-check as rs (thefixnum imm) $r.tmp0)
22542 (sparc.bvc.a as L1)
22543 (sparc.move as $r.tmp0 rd)
22544 (if (not (= rs $r.result)) (sparc.move as rs $r.result))
22545 (sparc.set as (thefixnum imm) $r.argreg2)
22546 (sparc.set as (thefixnum exn) $r.tmp0)
22547 (millicode-call/ret as $m.exception L0)
22548 (sparc.label as L1))))
22551 ; fx=, fx<, fx<=, fx>, fx>=, fxpositive?, fxnegative?, fxzero? w/o immediates
22553 (define-primop 'fx=
22555 (emit-fixnum-compare as sparc.bne.a $r.result rs2 $r.result $ex.fx= #f)))
22557 (define-primop 'fx<
22559 (emit-fixnum-compare as sparc.bge.a $r.result rs2 $r.result $ex.fx< #f)))
22561 (define-primop 'fx<=
22563 (emit-fixnum-compare as sparc.bg.a $r.result rs2 $r.result $ex.fx<= #f)))
22565 (define-primop 'fx>
22567 (emit-fixnum-compare as sparc.ble.a $r.result rs2 $r.result $ex.fx> #f)))
22569 (define-primop 'fx>=
22571 (emit-fixnum-compare as sparc.bl.a $r.result rs2 $r.result $ex.fx>= #f)))
22573 (define-primop 'internal:fx=
22574 (lambda (as rs1 rs2 rd)
22575 (emit-fixnum-compare as sparc.bne.a rs1 rs2 rd $ex.fx= #f)))
22577 (define-primop 'internal:fx<
22578 (lambda (as rs1 rs2 rd)
22579 (emit-fixnum-compare as sparc.bge.a rs1 rs2 rd $ex.fx< #f)))
22581 (define-primop 'internal:fx<=
22582 (lambda (as rs1 rs2 rd)
22583 (emit-fixnum-compare as sparc.bg.a rs1 rs2 rd $ex.fx<= #f)))
22585 (define-primop 'internal:fx>
22586 (lambda (as rs1 rs2 rd)
22587 (emit-fixnum-compare as sparc.ble.a rs1 rs2 rd $ex.fx> #f)))
22589 (define-primop 'internal:fx>=
22590 (lambda (as rs1 rs2 rd)
22591 (emit-fixnum-compare as sparc.bl.a rs1 rs2 rd $ex.fx>= #f)))
22594 ; Use '/imm' code for these because the generated code is better.
22596 (define-primop 'fxpositive?
22598 (emit-fixnum-compare/imm as sparc.ble.a $r.result 0 $r.result
22599 $ex.fxpositive? #f)))
22601 (define-primop 'fxnegative?
22603 (emit-fixnum-compare/imm as sparc.bge.a $r.result 0 $r.result
22604 $ex.fxnegative? #f)))
22606 (define-primop 'fxzero?
22608 (emit-fixnum-compare/imm as sparc.bne.a $r.result 0 $r.result
22611 (define-primop 'internal:fxpositive?
22613 (emit-fixnum-compare/imm as sparc.ble.a rs 0 rd $ex.fxpositive? #f)))
22615 (define-primop 'internal:fxnegative?
22617 (emit-fixnum-compare/imm as sparc.bge.a rs 0 rd $ex.fxnegative? #f)))
22619 (define-primop 'internal:fxzero?
22621 (emit-fixnum-compare/imm as sparc.bne.a rs 0 rd $ex.fxzero? #f)))
22624 ; fx=, fx<, fx<=, fx>, fx>= w/immediates
22626 (define-primop 'internal:fx=/imm
22627 (lambda (as rs imm rd)
22628 (emit-fixnum-compare/imm as sparc.bne.a rs imm rd $ex.fx= #f)))
22630 (define-primop 'internal:fx</imm
22631 (lambda (as rs imm rd)
22632 (emit-fixnum-compare/imm as sparc.bge.a rs imm rd $ex.fx< #f)))
22634 (define-primop 'internal:fx<=/imm
22635 (lambda (as rs imm rd)
22636 (emit-fixnum-compare/imm as sparc.bg.a rs imm rd $ex.fx<= #f)))
22638 (define-primop 'internal:fx>/imm
22639 (lambda (as rs imm rd)
22640 (emit-fixnum-compare/imm as sparc.ble.a rs imm rd $ex.fx> #f)))
22642 (define-primop 'internal:fx>=/imm
22643 (lambda (as rs imm rd)
22644 (emit-fixnum-compare/imm as sparc.bl.a rs imm rd $ex.fx>= #f)))
22646 ; fx=, fx<, fx<=, fx>, fx>=, fxpositive?, fxnegative?, fxzero? w/o immediates
22649 (define-primop 'internal:branchf-fx=
22650 (lambda (as rs1 rs2 L)
22651 (emit-fixnum-compare as sparc.bne.a rs1 rs2 #f $ex.fx= L)))
22653 (define-primop 'internal:branchf-fx<
22654 (lambda (as rs1 rs2 L)
22655 (emit-fixnum-compare as sparc.bge.a rs1 rs2 #f $ex.fx< L)))
22657 (define-primop 'internal:branchf-fx<=
22658 (lambda (as rs1 rs2 L)
22659 (emit-fixnum-compare as sparc.bg.a rs1 rs2 #f $ex.fx<= L)))
22661 (define-primop 'internal:branchf-fx>
22662 (lambda (as rs1 rs2 L)
22663 (emit-fixnum-compare as sparc.ble.a rs1 rs2 #f $ex.fx> L)))
22665 (define-primop 'internal:branchf-fx>=
22666 (lambda (as rs1 rs2 L)
22667 (emit-fixnum-compare as sparc.bl.a rs1 rs2 #f $ex.fx>= L)))
22669 (define-primop 'internal:branchf-fxpositive?
22671 (emit-fixnum-compare/imm as sparc.ble.a rs1 0 #f $ex.fxpositive? L)))
22673 (define-primop 'internal:branchf-fxnegative?
22675 (emit-fixnum-compare/imm as sparc.bge.a rs1 0 #f $ex.fxnegative? L)))
22677 (define-primop 'internal:branchf-fxzero?
22679 (emit-fixnum-compare/imm as sparc.bne.a rs1 0 #f $ex.fxzero? L)))
22682 ; fx=, fx<, fx<=, fx>, fx>= w/immediates for control.
22684 (define-primop 'internal:branchf-fx=/imm
22685 (lambda (as rs imm L)
22686 (emit-fixnum-compare/imm as sparc.bne.a rs imm #f $ex.fx= L)))
22688 (define-primop 'internal:branchf-fx</imm
22689 (lambda (as rs imm L)
22690 (emit-fixnum-compare/imm as sparc.bge.a rs imm #f $ex.fx< L)))
22692 (define-primop 'internal:branchf-fx<=/imm
22693 (lambda (as rs imm L)
22694 (emit-fixnum-compare/imm as sparc.bg.a rs imm #f $ex.fx<= L)))
22696 (define-primop 'internal:branchf-fx>/imm
22697 (lambda (as rs imm L)
22698 (emit-fixnum-compare/imm as sparc.ble.a rs imm #f $ex.fx> L)))
22700 (define-primop 'internal:branchf-fx>=/imm
22701 (lambda (as rs imm L)
22702 (emit-fixnum-compare/imm as sparc.bl.a rs imm #f $ex.fx>= L)))
22705 ; Trusted fixnum comparisons.
22707 (define-primop '=:fix:fix
22709 (emit-fixnum-compare-trusted as sparc.bne.a $r.result rs2 $r.result #f)))
22711 (define-primop '<:fix:fix
22713 (emit-fixnum-compare-trusted as sparc.bge.a $r.result rs2 $r.result #f)))
22715 (define-primop '<=:fix:fix
22717 (emit-fixnum-compare-trusted as sparc.bg.a $r.result rs2 $r.result #f)))
22719 (define-primop '>:fix:fix
22721 (emit-fixnum-compare-trusted as sparc.ble.a $r.result rs2 $r.result #f)))
22723 (define-primop '>=:fix:fix
22725 (emit-fixnum-compare-trusted as sparc.bl.a $r.result rs2 $r.result #f)))
22727 (define-primop 'internal:=:fix:fix
22728 (lambda (as rs1 rs2 rd)
22729 (emit-fixnum-compare-trusted as sparc.bne.a rs1 rs2 rd #f)))
22731 (define-primop 'internal:<:fix:fix
22732 (lambda (as rs1 rs2 rd)
22733 (emit-fixnum-compare-trusted as sparc.bge.a rs1 rs2 rd #f)))
22735 (define-primop 'internal:<=:fix:fix
22736 (lambda (as rs1 rs2 rd)
22737 (emit-fixnum-compare-trusted as sparc.bg.a rs1 rs2 rd #f)))
22739 (define-primop 'internal:>:fix:fix
22740 (lambda (as rs1 rs2 rd)
22741 (emit-fixnum-compare-trusted as sparc.ble.a rs1 rs2 rd #f)))
22743 (define-primop 'internal:>=:fix:fix
22744 (lambda (as rs1 rs2 rd)
22745 (emit-fixnum-compare-trusted as sparc.bl.a rs1 rs2 rd #f)))
22749 (define-primop 'internal:=:fix:fix/imm
22750 (lambda (as rs imm rd)
22751 (emit-fixnum-compare/imm-trusted as sparc.bne.a rs imm rd #f)))
22753 (define-primop 'internal:<:fix:fix/imm
22754 (lambda (as rs imm rd)
22755 (emit-fixnum-compare/imm-trusted as sparc.bge.a rs imm rd #f)))
22757 (define-primop 'internal:<=:fix:fix/imm
22758 (lambda (as rs imm rd)
22759 (emit-fixnum-compare/imm-trusted as sparc.bg.a rs imm rd #f)))
22761 (define-primop 'internal:>:fix:fix/imm
22762 (lambda (as rs imm rd)
22763 (emit-fixnum-compare/imm-trusted as sparc.ble.a rs imm rd #f)))
22765 (define-primop 'internal:>=:fix:fix/imm
22766 (lambda (as rs imm rd)
22767 (emit-fixnum-compare/imm-trusted as sparc.bl.a rs imm rd #f)))
22769 ; Without immediates, for control.
22771 (define-primop 'internal:branchf-=:fix:fix
22772 (lambda (as rs1 rs2 L)
22773 (emit-fixnum-compare-trusted as sparc.bne.a rs1 rs2 #f L)))
22775 (define-primop 'internal:branchf-<:fix:fix
22776 (lambda (as rs1 rs2 L)
22777 (emit-fixnum-compare-trusted as sparc.bge.a rs1 rs2 #f L)))
22779 (define-primop 'internal:branchf-<=:fix:fix
22780 (lambda (as rs1 rs2 L)
22781 (emit-fixnum-compare-trusted as sparc.bg.a rs1 rs2 #f L)))
22783 (define-primop 'internal:branchf->:fix:fix
22784 (lambda (as rs1 rs2 L)
22785 (emit-fixnum-compare-trusted as sparc.ble.a rs1 rs2 #f L)))
22787 (define-primop 'internal:branchf->=:fix:fix
22788 (lambda (as rs1 rs2 L)
22789 (emit-fixnum-compare-trusted as sparc.bl.a rs1 rs2 #f L)))
22791 ; With immediates, for control.
22793 (define-primop 'internal:branchf-=:fix:fix/imm
22794 (lambda (as rs imm L)
22795 (emit-fixnum-compare/imm-trusted as sparc.bne.a rs imm #f L)))
22797 (define-primop 'internal:branchf-<:fix:fix/imm
22798 (lambda (as rs imm L)
22799 (emit-fixnum-compare/imm-trusted as sparc.bge.a rs imm #f L)))
22801 (define-primop 'internal:branchf-<=:fix:fix/imm
22802 (lambda (as rs imm L)
22803 (emit-fixnum-compare/imm-trusted as sparc.bg.a rs imm #f L)))
22805 (define-primop 'internal:branchf->:fix:fix/imm
22806 (lambda (as rs imm L)
22807 (emit-fixnum-compare/imm-trusted as sparc.ble.a rs imm #f L)))
22809 (define-primop 'internal:branchf->=:fix:fix/imm
22810 (lambda (as rs imm L)
22811 (emit-fixnum-compare/imm-trusted as sparc.bl.a rs imm #f L)))
22813 ; Range check: 0 <= src1 < src2
22815 (define-primop 'internal:check-range
22816 (lambda (as src1 src2 L1 livregs)
22817 (let ((src2 (force-hwreg! as src2 $r.argreg2)))
22818 (emit-fixnum-compare-check
22819 as src2 src1 sparc.bleu L1 livregs))))
22821 ; Trusted fixnum comparisons followed by a check.
22823 (define-primop 'internal:check-=:fix:fix
22824 (lambda (as src1 src2 L1 liveregs)
22825 (emit-fixnum-compare-check
22826 as src1 src2 sparc.bne L1 liveregs)))
22828 (define-primop 'internal:check-<:fix:fix
22829 (lambda (as src1 src2 L1 liveregs)
22830 (emit-fixnum-compare-check
22831 as src1 src2 sparc.bge L1 liveregs)))
22833 (define-primop 'internal:check-<=:fix:fix
22834 (lambda (as src1 src2 L1 liveregs)
22835 (emit-fixnum-compare-check
22836 as src1 src2 sparc.bg L1 liveregs)))
22838 (define-primop 'internal:check->:fix:fix
22839 (lambda (as src1 src2 L1 liveregs)
22840 (emit-fixnum-compare-check
22841 as src1 src2 sparc.ble L1 liveregs)))
22843 (define-primop 'internal:check->=:fix:fix
22844 (lambda (as src1 src2 L1 liveregs)
22845 (emit-fixnum-compare-check
22846 as src1 src2 sparc.bl L1 liveregs)))
22848 (define-primop 'internal:check-=:fix:fix/imm
22849 (lambda (as src1 imm L1 liveregs)
22850 (emit-fixnum-compare/imm-check
22851 as src1 imm sparc.bne L1 liveregs)))
22853 (define-primop 'internal:check-<:fix:fix/imm
22854 (lambda (as src1 imm L1 liveregs)
22855 (emit-fixnum-compare/imm-check
22856 as src1 imm sparc.bge L1 liveregs)))
22858 (define-primop 'internal:check-<=:fix:fix/imm
22859 (lambda (as src1 imm L1 liveregs)
22860 (emit-fixnum-compare/imm-check
22861 as src1 imm sparc.bg L1 liveregs)))
22863 (define-primop 'internal:check->:fix:fix/imm
22864 (lambda (as src1 imm L1 liveregs)
22865 (emit-fixnum-compare/imm-check
22866 as src1 imm sparc.ble L1 liveregs)))
22868 (define-primop 'internal:check->=:fix:fix/imm
22869 (lambda (as src1 imm L1 liveregs)
22870 (emit-fixnum-compare/imm-check
22871 as src1 imm sparc.bl L1 liveregs)))
22873 ; Below, 'target' is a label or #f. If #f, RD must be a general hardware
22874 ; register or RESULT, and a boolean result is generated in RD.
22876 (define (emit-fixnum-compare as branchf.a rs1 rs2 rd exn target)
22878 (emit-fixnum-compare-trusted as branchf.a rs1 rs2 rd target)
22879 (let ((rs2 (force-hwreg! as rs2 $r.argreg2))
22882 (sparc.label as L0)
22883 (sparc.orr as rs1 rs2 $r.tmp0)
22884 (sparc.btsti as $r.tmp0 3)
22886 (sparc.cmpr as rs1 rs2)
22887 (if (not (= rs1 $r.result)) (sparc.move as rs1 $r.result))
22888 (if (not (= rs2 $r.argreg2)) (sparc.move as rs2 $r.argreg2))
22889 (sparc.set as (thefixnum exn) $r.tmp0)
22890 (millicode-call/ret as $m.exception L0)
22891 (sparc.label as L1)
22892 (emit-evaluate-cc! as branchf.a rd target))))
22894 ; Below, 'target' is a label or #f. If #f, RD must be a general hardware
22895 ; register or RESULT, and a boolean result is generated in RD.
22897 (define (emit-fixnum-compare-trusted as branchf.a rs1 rs2 rd target)
22898 (let ((rs2 (force-hwreg! as rs2 $r.argreg2)))
22899 (sparc.cmpr as rs1 rs2)
22900 (emit-evaluate-cc! as branchf.a rd target)))
22902 ; rs must be a hardware register.
22904 (define (emit-fixnum-compare/imm as branchf.a rs imm rd exn target)
22906 (emit-fixnum-compare/imm-trusted as branchf.a rs imm rd target)
22907 (let ((L0 (new-label))
22909 (sparc.label as L0)
22910 (sparc.btsti as rs 3)
22912 (sparc.cmpi as rs (thefixnum imm))
22913 (if (not (= rs $r.result)) (sparc.move as rs $r.result))
22914 (sparc.set as (thefixnum imm) $r.argreg2)
22915 (sparc.set as (thefixnum exn) $r.tmp0)
22916 (millicode-call/ret as $m.exception L0)
22917 (sparc.label as L1)))
22918 (emit-evaluate-cc! as branchf.a rd target))
22920 ; rs must be a hardware register.
22922 (define (emit-fixnum-compare/imm-trusted as branchf.a rs imm rd target)
22923 (sparc.cmpi as rs (thefixnum imm))
22924 (emit-evaluate-cc! as branchf.a rd target))
22928 (define (emit-fixnum-compare-check
22929 as src1 src2 branch-bad L1 liveregs)
22930 (internal-primop-invariant1 'emit-fixnum-compare-check src1)
22931 (let ((src2 (force-hwreg! as src2 $r.argreg2)))
22932 (sparc.cmpr as src1 src2)
22933 (emit-checkcc! as branch-bad L1 liveregs)))
22935 (define (emit-fixnum-compare/imm-check
22936 as src1 imm branch-bad L1 liveregs)
22937 (internal-primop-invariant1 'emit-fixnum-compare/imm-check src1)
22938 (sparc.cmpi as src1 imm)
22939 (emit-checkcc! as branch-bad L1 liveregs))
22942 ; Copyright 1998 Lars T Hansen.
22944 ; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
22946 ; SPARC machine assembler flags.
22952 (define short-effective-addresses
22953 (make-twobit-flag 'short-effective-addresses))
22955 (define runtime-safety-checking
22956 (make-twobit-flag 'runtime-safety-checking))
22958 (define catch-undefined-globals
22959 (make-twobit-flag 'catch-undefined-globals))
22961 (define inline-allocation
22962 (make-twobit-flag 'inline-allocation))
22964 ;(define inline-assignment
22965 ; (make-twobit-flag 'inline-assignment))
22967 (define write-barrier
22968 (make-twobit-flag 'write-barrier))
22970 (define peephole-optimization
22971 (make-twobit-flag 'peephole-optimization))
22973 (define single-stepping
22974 (make-twobit-flag 'single-stepping))
22976 (define fill-delay-slots
22977 (make-twobit-flag 'fill-delay-slots))
22979 ; For backward compatibility.
22981 ;(define unsafe-code
22982 ; (make-twobit-flag 'unsafe-code))
22984 (define (unsafe-code . args)
22986 (not (runtime-safety-checking))
22987 (runtime-safety-checking (not (car args)))))
22989 (define (display-assembler-flags which)
22992 (display-twobit-flag single-stepping))
22994 (display-twobit-flag write-barrier)
22995 ;(display-twobit-flag unsafe-code)
22996 (display-twobit-flag runtime-safety-checking)
22997 (if (runtime-safety-checking)
22998 (begin (display " ")
22999 (display-twobit-flag catch-undefined-globals))))
23001 (display-twobit-flag peephole-optimization)
23002 (display-twobit-flag inline-allocation)
23003 ; (display-twobit-flag inline-assignment)
23004 (display-twobit-flag fill-delay-slots))
23007 (define (set-assembler-flags! mode)
23010 (set-assembler-flags! 'standard)
23011 (peephole-optimization #f)
23012 (fill-delay-slots #f))
23014 (short-effective-addresses #t)
23015 (catch-undefined-globals #t)
23016 (inline-allocation #f)
23017 ; (inline-assignment #f)
23018 (peephole-optimization #t)
23019 (runtime-safety-checking #t)
23021 (single-stepping #f)
23022 (fill-delay-slots #t))
23023 ((fast-safe default)
23024 (set-assembler-flags! 'standard)
23025 ; (inline-assignment #t)
23026 (inline-allocation #t))
23028 (set-assembler-flags! 'fast-safe)
23029 (catch-undefined-globals #f)
23030 (runtime-safety-checking #f))
23032 (error "set-assembler-flags!: unknown mode " mode))))
23034 (set-assembler-flags! 'default)
23037 ; Copyright 1998 Lars T Hansen.
23039 ; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
23041 ; SPARC disassembler.
23043 ; (disassemble-instruction instruction address)
23044 ; => decoded-instruction
23046 ; (disassemble-codevector codevector)
23047 ; => decoded-instruction-list
23049 ; (print-instructions decoded-instruction-list)
23051 ; Also takes an optional port and optionally the symbol "native-names".
23053 ; (format-instruction decoded-instruction address larceny-names?)
23056 ; A `decoded-instruction' is a list where the car is a mnemonic and
23057 ; the operands are appropriate for that mnemonic.
23059 ; A `mnemonic' is an exact nonnegative integer. It encodes the name of
23060 ; the instruction as well as its attributes (operand pattern and instruction
23061 ; type). See below for specific operations on mnemonics.
23063 (define (disassemble-codevector cv)
23064 (define (loop addr ilist)
23068 (cons (disassemble-instruction (bytevector-word-ref cv addr)
23071 (loop (- (bytevector-length cv) 4) '()))
23073 (define disassemble-instruction) ; Defined below.
23077 (define *asm-annul* 1)
23078 (define *asm-immed* 2)
23079 (define *asm-store* 4)
23080 (define *asm-load* 8)
23081 (define *asm-branch* 16)
23082 (define *asm-freg* 32)
23083 (define *asm-fpop* 64)
23084 (define *asm-no-op2* 128)
23085 (define *asm-no-op3* 256)
23088 `((a . ,*asm-annul*) (i . ,*asm-immed*) (s . ,*asm-store*)
23089 (l . ,*asm-load*) (b . ,*asm-branch*) (f . ,*asm-freg*)
23090 (fpop . ,*asm-fpop*) (no-op2 . ,*asm-no-op2*) (no-op3 . ,*asm-no-op3*)))
23092 (define *asm-mnemonic-table* '())
23096 (lambda (name . rest)
23097 (let* ((probe (assq name *asm-mnemonic-table*))
23103 (set! *asm-mnemonic-table*
23104 (cons (cons name code)
23105 *asm-mnemonic-table*))
23107 (for-each (lambda (x)
23108 (set! code (+ code (cdr (assq x *asm-bits*)))))
23112 (define (mnemonic:name mnemonic)
23113 (let ((mnemonic (quotient mnemonic 1024)))
23114 (let loop ((t *asm-mnemonic-table*))
23115 (cond ((null? t) #f)
23116 ((= (cdar t) mnemonic) (caar t))
23117 (else (loop (cdr t)))))))
23119 (define (mnemonic=? m name)
23120 (= (quotient m 1024) (quotient (mnemonic name) 1024)))
23122 (define (mnemonic:test bit)
23124 (not (zero? (logand mnemonic bit)))))
23126 (define (mnemonic:test-not bit)
23128 (zero? (logand mnemonic bit))))
23130 (define mnemonic:annul? (mnemonic:test *asm-annul*))
23131 (define mnemonic:immediate? (mnemonic:test *asm-immed*))
23132 (define mnemonic:store? (mnemonic:test *asm-store*))
23133 (define mnemonic:load? (mnemonic:test *asm-load*))
23134 (define mnemonic:branch? (mnemonic:test *asm-branch*))
23135 (define mnemonic:freg? (mnemonic:test *asm-freg*))
23136 (define mnemonic:fpop? (mnemonic:test *asm-fpop*))
23137 (define mnemonic:op2? (mnemonic:test-not *asm-no-op2*))
23138 (define mnemonic:op3? (mnemonic:test-not *asm-no-op3*))
23140 \f; Instruction disassembler.
23144 ;; Useful constants
23146 (define two^3 (expt 2 3))
23147 (define two^5 (expt 2 5))
23148 (define two^6 (expt 2 6))
23149 (define two^8 (expt 2 8))
23150 (define two^9 (expt 2 9))
23151 (define two^12 (expt 2 12))
23152 (define two^13 (expt 2 13))
23153 (define two^14 (expt 2 14))
23154 (define two^16 (expt 2 16))
23155 (define two^19 (expt 2 19))
23156 (define two^21 (expt 2 21))
23157 (define two^22 (expt 2 22))
23158 (define two^24 (expt 2 24))
23159 (define two^25 (expt 2 25))
23160 (define two^29 (expt 2 29))
23161 (define two^30 (expt 2 30))
23162 (define two^32 (expt 2 32))
23164 ;; Class 0 has branches and weirdness, like sethi and nop.
23165 ;; We dispatch first on the op2 field and then on the op3 field.
23169 (vector (mnemonic 'bn 'b)
23173 (mnemonic 'bleu 'b)
23175 (mnemonic 'bneg 'b)
23183 (mnemonic 'bpos 'b)
23185 (mnemonic 'bn 'a 'b)
23186 (mnemonic 'be 'a 'b)
23187 (mnemonic 'ble 'a 'b)
23188 (mnemonic 'bl 'a 'b)
23189 (mnemonic 'bleu 'a 'b)
23190 (mnemonic 'bcs 'a 'b)
23191 (mnemonic 'bneg 'a 'b)
23192 (mnemonic 'bvs 'a 'b)
23193 (mnemonic 'ba 'a 'b)
23194 (mnemonic 'bne 'a 'b)
23195 (mnemonic 'bg 'a 'b)
23196 (mnemonic 'bge 'a 'b)
23197 (mnemonic 'bgu 'a 'b)
23198 (mnemonic 'bcc 'a 'b)
23199 (mnemonic 'bpos 'a 'b)
23200 (mnemonic 'bvc 'a 'b)))
23202 (vector (mnemonic 'fbn 'b)
23203 (mnemonic 'fbne 'b)
23204 (mnemonic 'fblg 'b)
23205 (mnemonic 'fbul 'b)
23207 (mnemonic 'fbug 'b)
23212 (mnemonic 'fbue 'b)
23213 (mnemonic 'fbge 'b)
23214 (mnemonic 'fbuge 'b)
23215 (mnemonic 'fble 'b)
23216 (mnemonic 'fbule 'b)
23218 (mnemonic 'fbn 'a 'b)
23219 (mnemonic 'fbne 'a 'b)
23220 (mnemonic 'fblg 'a 'b)
23221 (mnemonic 'fbul 'a 'b)
23222 (mnemonic 'fbl 'a 'b)
23223 (mnemonic 'fbug 'a 'b)
23224 (mnemonic 'fbg 'a 'b)
23225 (mnemonic 'fbu 'a 'b)
23226 (mnemonic 'fba 'a 'b)
23227 (mnemonic 'fbe 'a 'b)
23228 (mnemonic 'fbue 'a 'b)
23229 (mnemonic 'fbge 'a 'b)
23230 (mnemonic 'fbuge 'a 'b)
23231 (mnemonic 'fble 'a 'b)
23232 (mnemonic 'fbule 'a 'b)
23233 (mnemonic 'fbo 'a 'b)))
23234 (nop (mnemonic 'nop))
23235 (sethi (mnemonic 'sethi)))
23238 (let ((op2 (op2field instr)))
23239 (cond ((= op2 #b100)
23240 (if (zero? (rdfield instr))
23242 `(,sethi ,(imm22field instr) ,(rdfield instr))))
23244 `(,(vector-ref b-table (rdfield instr))
23245 ,(* 4 (imm22field instr))))
23247 `(,(vector-ref fb-table (rdfield instr))
23248 ,(* 4 (imm22field instr))))
23250 (disasm-error "Can't disassemble " (number->string instr 16)
23252 " with op2=" op2)))))))
23254 ;; Class 1 is the call instruction; there's no choice.
23256 (define (class01 ip instr)
23257 `(,(mnemonic 'call) ,(* 4 (imm30field instr))))
23259 ;; Class 2 is for the ALU. Dispatch on op3 field.
23263 `#((,(mnemonic 'add) ,(mnemonic 'add 'i))
23264 (,(mnemonic 'and) ,(mnemonic 'and 'i))
23265 (,(mnemonic 'or) ,(mnemonic 'or 'i))
23266 (,(mnemonic 'xor) ,(mnemonic 'xor 'i))
23267 (,(mnemonic 'sub) ,(mnemonic 'sub 'i))
23268 (,(mnemonic 'andn) ,(mnemonic 'andn 'i))
23269 (,(mnemonic 'orn) ,(mnemonic 'orn 'i))
23270 (,(mnemonic 'xnor) ,(mnemonic 'xnor 'i))
23274 (,(mnemonic 'smul) ,(mnemonic 'smul 'i))
23278 (,(mnemonic 'sdiv) ,(mnemonic 'sdiv 'i))
23279 (,(mnemonic 'addcc) ,(mnemonic 'addcc 'i))
23280 (,(mnemonic 'andcc) ,(mnemonic 'andcc 'i))
23281 (,(mnemonic 'orcc) ,(mnemonic 'orcc 'i))
23282 (,(mnemonic 'xorcc) ,(mnemonic 'xorcc 'i))
23283 (,(mnemonic 'subcc) ,(mnemonic 'subcc 'i)) ; 20
23290 (,(mnemonic 'smulcc) ,(mnemonic 'smulcc 'i))
23294 (,(mnemonic 'sdivcc) ,(mnemonic 'sdivcc 'i))
23295 (,(mnemonic 'taddcc) ,(mnemonic 'taddcc 'i))
23296 (,(mnemonic 'tsubcc) ,(mnemonic 'tsubcc 'i))
23300 (,(mnemonic 'sll) ,(mnemonic 'sll 'i))
23301 (,(mnemonic 'srl) ,(mnemonic 'srl 'i))
23302 (,(mnemonic 'sra) ,(mnemonic 'sra 'i))
23303 (,(mnemonic 'rd) 0) ; 40
23311 (,(mnemonic 'wr) ,(mnemonic 'wr 'i))
23319 (,(mnemonic 'jmpl) ,(mnemonic 'jmpl 'i))
23323 (,(mnemonic 'save) ,(mnemonic 'save 'i)) ; 60
23324 (,(mnemonic 'restore) ,(mnemonic 'restore 'i))
23329 (let ((op3 (op3field instr)))
23330 (if (or (= op3 #b110100) (= op3 #b110101))
23331 (fpop-instruction ip instr)
23332 (nice-instruction op3-table ip instr))))))
23335 ;; Class 3 is memory stuff.
23339 `#((,(mnemonic 'ld 'l) ,(mnemonic 'ld 'i 'l))
23340 (,(mnemonic 'ldb 'l) ,(mnemonic 'ldb 'i 'l))
23341 (,(mnemonic 'ldh 'l) ,(mnemonic 'ldh 'i 'l))
23342 (,(mnemonic 'ldd 'l) ,(mnemonic 'ldd 'i 'l))
23343 (,(mnemonic 'st 's) ,(mnemonic 'st 'i 's))
23344 (,(mnemonic 'stb 's) ,(mnemonic 'stb 'i 's))
23345 (,(mnemonic 'sth 's) ,(mnemonic 'sth 'i 's))
23346 (,(mnemonic 'std 's) ,(mnemonic 'std 'i 's))
23371 (,(mnemonic 'ldf 'f 'l) ,(mnemonic 'ldf 'i 'f 'l))
23374 (,(mnemonic 'lddf 'f 'l) ,(mnemonic 'lddf 'i 'f 'l))
23375 (,(mnemonic 'stf 'f 's) ,(mnemonic 'stf 'i 'f 's))
23378 (,(mnemonic 'stdf 'f 's) ,(mnemonic 'stdf 'i 'f 's))
23405 (nice-instruction op3-table ip instr))))
23407 ;; For classes 2 and 3
23409 (define (nice-instruction op3-table ip instr)
23410 (let* ((op3 (op3field instr))
23411 (imm (ifield instr))
23412 (rd (rdfield instr))
23413 (rs1 (rs1field instr))
23414 (src2 (if (zero? imm)
23416 (imm13field instr))))
23417 (let ((op ((if (zero? imm) car cadr) (vector-ref op3-table op3))))
23418 `(,op ,rs1 ,src2 ,rd))))
23420 ;; Floating-point operate instructions
23422 (define (fpop-instruction ip instr)
23423 (let ((rd (rdfield instr))
23424 (rs1 (rs1field instr))
23425 (rs2 (rs2field instr))
23426 (fpop (fpop-field instr)))
23427 `(,(cdr (assv fpop fpop-names)) ,rs1 ,rs2 ,rd)))
23430 `((#b000000001 . ,(mnemonic 'fmovs 'fpop 'no-op2))
23431 (#b000000101 . ,(mnemonic 'fnegs 'fpop 'no-op2))
23432 (#b000001001 . ,(mnemonic 'fabss 'fpop 'no-op2))
23433 (#b001000010 . ,(mnemonic 'faddd 'fpop))
23434 (#b001000110 . ,(mnemonic 'fsubd 'fpop))
23435 (#b001001010 . ,(mnemonic 'fmuld 'fpop))
23436 (#b001001110 . ,(mnemonic 'fdivd 'fpop))
23437 (#b001010010 . ,(mnemonic 'fcmpd 'fpop 'no-op3))))
23440 ;; The following procedures pick apart an instruction
23442 (define (op2field instr)
23443 (remainder (quotient instr two^22) two^3))
23445 (define (op3field instr)
23446 (remainder (quotient instr two^19) two^6))
23448 (define (ifield instr)
23449 (remainder (quotient instr two^13) 2))
23451 (define (rs2field instr)
23452 (remainder instr two^5))
23454 (define (rs1field instr)
23455 (remainder (quotient instr two^14) two^5))
23457 (define (rdfield instr)
23458 (remainder (quotient instr two^25) two^5))
23460 (define (imm13field instr)
23461 (let ((x (remainder instr two^13)))
23462 (if (not (zero? (quotient x two^12)))
23466 (define (imm22field instr)
23467 (let ((x (remainder instr two^22)))
23468 (if (not (zero? (quotient x two^21)))
23472 (define (imm30field instr)
23473 (let ((x (remainder instr two^30)))
23474 (if (not (zero? (quotient x two^29)))
23478 (define (fpop-field instr)
23479 (remainder (quotient instr two^5) two^9))
23481 (set! disassemble-instruction
23482 (let ((class-table (vector class00 class01 class10 class11)))
23483 (lambda (instr addr)
23484 ((vector-ref class-table (quotient instr two^30)) addr instr))))
23486 'disassemble-instruction)
23489 \f; Instruction printer
23491 ; It assumes that the first instruction comes from address 0, and prints
23492 ; addresses (and relative addresses) based on that assumption.
23494 ; If the optional symbol native-names is supplied, then SPARC register
23495 ; names is used, and millicode calls are not annotated with millicode names.
23497 (define (print-instructions ilist . rest)
23499 (define port (current-output-port))
23500 (define larceny-names? #t)
23502 (define (print-ilist ilist a)
23505 (begin (display (format-instruction (car ilist) a larceny-names?)
23508 (print-ilist (cdr ilist) (+ a 4)))))
23510 (do ((rest rest (cdr rest)))
23512 (cond ((port? (car rest))
23513 (set! port (car rest)))
23514 ((eq? (car rest) 'native-names)
23515 (set! larceny-names? #f))))
23517 (print-ilist ilist 0))
23519 (define format-instruction) ; Defined below
23521 (define *format-instructions-pretty* #t)
23523 ; Instruction formatter.
23527 (define use-larceny-registers #t)
23529 (define sparc-register-table
23530 (vector "%g0" "%g1" "%g2" "%g3" "%g4" "%g5" "%g6" "%g7"
23531 "%o0" "%o1" "%o2" "%o3" "%o4" "%o5" "%o6" "%o7"
23532 "%l0" "%l1" "%l2" "%l3" "%l4" "%l5" "%l6" "%l7"
23533 "%i0" "%i1" "%i2" "%i3" "%i4" "%i5" "%i6" "%i7"))
23535 (define larceny-register-table
23536 (make-vector 32 #f))
23538 (define (larceny-register-name reg . rest)
23540 (or (and use-larceny-registers
23541 (vector-ref larceny-register-table reg))
23542 (vector-ref sparc-register-table reg))
23543 (vector-set! larceny-register-table reg (car rest))))
23545 (define millicode-procs '())
23547 (define (float-register-name reg)
23548 (string-append "%f" (number->string reg)))
23553 (define op3 cadddr)
23554 (define tabstring (string #\tab))
23558 (string-append tabstring "! 0x" (number->string n 16))
23561 (define (millicode-name offset . rest)
23563 (let ((probe (assv offset millicode-procs)))
23567 (set! millicode-procs
23568 (cons (cons offset (car rest)) millicode-procs))))
23570 (define (millicode-call offset)
23571 (string-append tabstring "! " (millicode-name offset)))
23573 (define (plus/minus n)
23575 (string-append " - " (number->string (abs n))))
23576 ((and (= n 0) *format-instructions-pretty*) "")
23578 (string-append " + " (number->string n)))))
23580 (define (srcreg instr extractor)
23581 (if (mnemonic:freg? (op instr))
23582 (float-register-name (extractor instr))
23583 (larceny-register-name (extractor instr))))
23585 (define (sethi instr)
23586 (string-append (number->string (* (op1 instr) 1024)) ", "
23587 (larceny-register-name (op2 instr))
23588 (heximm (* (op1 instr) 1024))))
23590 (define (rrr instr)
23591 (string-append (larceny-register-name (op1 instr)) ", "
23592 (larceny-register-name (op2 instr)) ", "
23593 (larceny-register-name (op3 instr))))
23595 (define (rir instr)
23596 (string-append (larceny-register-name (op1 instr)) ", "
23597 (number->string (op2 instr)) ", "
23598 (larceny-register-name (op3 instr))
23599 (heximm (op2 instr))))
23601 (define (sir instr)
23602 (string-append (srcreg instr op3) ", [ "
23603 (larceny-register-name (op1 instr))
23604 (plus/minus (op2 instr)) " ]"))
23606 (define (srr instr)
23607 (string-append (srcreg instr op3) ", [ "
23608 (larceny-register-name (op1 instr)) "+"
23609 (larceny-register-name (op2 instr)) " ]"))
23611 (define (lir instr)
23612 (string-append "[ " (larceny-register-name (op1 instr))
23613 (plus/minus (op2 instr)) " ], "
23614 (srcreg instr op3)))
23616 (define (lrr instr)
23617 (string-append "[ " (larceny-register-name (op1 instr)) "+"
23618 (larceny-register-name (op2 instr)) " ], "
23619 (srcreg instr op3)))
23621 (define (bimm instr addr)
23622 (string-append "#" (number->string (+ (op1 instr) addr))))
23624 (define (jmpli instr)
23625 (string-append (larceny-register-name (op1 instr))
23626 (plus/minus (op2 instr)) ", "
23627 (larceny-register-name (op3 instr))
23628 (if (and (= (op1 instr) $r.globals)
23629 use-larceny-registers)
23630 (millicode-call (op2 instr))
23631 (heximm (op2 instr)))))
23633 (define (jmplr instr)
23634 (string-append (larceny-register-name (op1 instr)) "+"
23635 (larceny-register-name (op2 instr)) ", "
23636 (larceny-register-name (op3 instr))))
23638 (define (call instr addr)
23639 (string-append "#" (number->string (+ (op1 instr) addr))))
23642 (string-append "%y, " (srcreg instr op3)))
23644 (define (wr instr imm?)
23646 (string-append (larceny-register-name (op1 instr)) ", "
23647 (number->string (op2 instr)) ", %y"
23648 (larceny-register-name (op3 instr)))
23649 (string-append (larceny-register-name (op1 instr)) ", "
23650 (larceny-register-name (op2 instr)) ", %y")))
23652 (define (fpop instr op2-used? op3-used?)
23653 (string-append (float-register-name (op1 instr)) ", "
23654 (cond ((and op2-used? op3-used?)
23656 (float-register-name (op2 instr)) ", "
23657 (float-register-name (op3 instr))))
23659 (float-register-name (op2 instr)))
23661 (float-register-name (op3 instr))))))
23663 ;; If we want to handle instruction aliases (clr, mov, etc) then
23664 ;; the structure of this procedure must change, because as it is,
23665 ;; the printing of the name is independent of the operand values.
23667 (define (format-instr i a larceny-names?)
23668 (set! use-larceny-registers larceny-names?)
23670 (string-append (number->string a)
23672 (symbol->string (mnemonic:name m))
23673 (if (mnemonic:annul? m) ",a" "")
23675 (cond ((mnemonic:store? m)
23676 (if (mnemonic:immediate? m) (sir i) (srr i)))
23677 ((mnemonic:load? m)
23678 (if (mnemonic:immediate? m) (lir i) (lrr i)))
23679 ((mnemonic:fpop? m)
23680 (fpop i (mnemonic:op2? m) (mnemonic:op3? m)))
23681 ((mnemonic:branch? m) (bimm i a))
23682 ((mnemonic=? m 'sethi) (sethi i))
23683 ((mnemonic=? m 'nop) "")
23684 ((mnemonic=? m 'jmpl)
23685 (if (mnemonic:immediate? m) (jmpli i) (jmplr i)))
23686 ((mnemonic=? m 'call) (call i a))
23687 ((mnemonic=? m 'rd) (rd i))
23688 ((mnemonic=? m 'wr) (wr i (mnemonic:immediate? m)))
23689 ((mnemonic:immediate? m) (rir i))
23692 (larceny-register-name $r.tmp0 "%tmp0")
23693 (larceny-register-name $r.result "%result")
23694 (larceny-register-name $r.argreg2 "%argreg2")
23695 (larceny-register-name $r.argreg3 "%argreg3")
23696 (larceny-register-name $r.tmp1 "%tmp1")
23697 (larceny-register-name $r.tmp2 "%tmp2")
23698 (larceny-register-name $r.reg0 "%r0")
23699 (larceny-register-name $r.reg1 "%r1")
23700 (larceny-register-name $r.reg2 "%r2")
23701 (larceny-register-name $r.reg3 "%r3")
23702 (larceny-register-name $r.reg4 "%r4")
23703 (larceny-register-name $r.reg5 "%r5")
23704 (larceny-register-name $r.reg6 "%r6")
23705 (larceny-register-name $r.reg7 "%r7")
23706 (larceny-register-name $r.e-top "%etop")
23707 (larceny-register-name $r.e-limit "%elim")
23708 (larceny-register-name $r.timer "%timer")
23709 (larceny-register-name $r.millicode "%millicode")
23710 (larceny-register-name $r.globals "%globals")
23711 (larceny-register-name $r.stkp "%stkp") ; note: after elim
23713 (millicode-name $m.alloc "alloc")
23714 (millicode-name $m.alloci "alloci")
23715 (millicode-name $m.gc "gc")
23716 (millicode-name $m.addtrans "addtrans")
23717 (millicode-name $m.stkoflow "stkoflow")
23718 (millicode-name $m.stkuflow "stkuflow")
23719 (millicode-name $m.creg "creg")
23720 (millicode-name $m.creg-set! "creg-set!")
23721 (millicode-name $m.add "+")
23722 (millicode-name $m.subtract "- (binary)")
23723 (millicode-name $m.multiply "*")
23724 (millicode-name $m.quotient "quotient")
23725 (millicode-name $m.remainder "remainder")
23726 (millicode-name $m.divide "/")
23727 (millicode-name $m.modulo "modulo")
23728 (millicode-name $m.negate "- (unary)")
23729 (millicode-name $m.numeq "=")
23730 (millicode-name $m.numlt "<")
23731 (millicode-name $m.numle "<=")
23732 (millicode-name $m.numgt ">")
23733 (millicode-name $m.numge ">=")
23734 (millicode-name $m.zerop "zero?")
23735 (millicode-name $m.complexp "complex?")
23736 (millicode-name $m.realp "real?")
23737 (millicode-name $m.rationalp "rational?")
23738 (millicode-name $m.integerp "integer?")
23739 (millicode-name $m.exactp "exact?")
23740 (millicode-name $m.inexactp "inexact?")
23741 (millicode-name $m.exact->inexact "exact->inexact")
23742 (millicode-name $m.inexact->exact "inexact->exact")
23743 (millicode-name $m.make-rectangular "make-rectangular")
23744 (millicode-name $m.real-part "real-part")
23745 (millicode-name $m.imag-part "imag-part")
23746 (millicode-name $m.sqrt "sqrt")
23747 (millicode-name $m.round "round")
23748 (millicode-name $m.truncate "truncate")
23749 (millicode-name $m.apply "apply")
23750 (millicode-name $m.varargs "varargs")
23751 (millicode-name $m.typetag "typetag")
23752 (millicode-name $m.typetag-set "typetag-set")
23753 (millicode-name $m.break "break")
23754 (millicode-name $m.eqv "eqv?")
23755 (millicode-name $m.partial-list->vector "partial-list->vector")
23756 (millicode-name $m.timer-exception "timer-exception")
23757 (millicode-name $m.exception "exception")
23758 (millicode-name $m.singlestep "singlestep")
23759 (millicode-name $m.syscall "syscall")
23760 (millicode-name $m.bvlcmp "bvlcmp")
23761 (millicode-name $m.enable-interrupts "enable-interrupts")
23762 (millicode-name $m.disable-interrupts "disable-interrupts")
23763 (millicode-name $m.alloc-bv "alloc-bv")
23764 (millicode-name $m.global-ex "global-exception")
23765 (millicode-name $m.invoke-ex "invoke-exception")
23766 (millicode-name $m.global-invoke-ex "global-invoke-exception")
23767 (millicode-name $m.argc-ex "argc-exception")
23769 (set! format-instruction format-instr)
23770 'format-instruction)
23776 ; ----------------------------------------------------------------------
23778 (define (twobit-benchmark type . rest)
23779 (let ((k (if (null? rest) 1 (car rest))))
23786 (compiler-switches 'fast-safe)
23787 (benchmark-block-mode #f)
23788 (compile-file "benchmarks/twobit-input-long.sch"))
23790 (compiler-switches 'fast-safe)
23791 (benchmark-block-mode #t)
23792 (compile-file "benchmarks/twobit-input-short.sch"))
23794 (error "Benchmark type must be `long' or `short': " type))))