1 ; Complete source for Twobit and Sparc assembler in one file.
2 ; $Id: twobit-smaller.sch,v 1.1 1999/09/09 22:13:42 lth Exp $
4 ; See 'twobit-benchmark', at end.
6 ; Copyright 1998 Lars T Hansen.
8 ; $Id: twobit-smaller.sch,v 1.1 1999/09/09 22:13:42 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-smaller.sch,v 1.1 1999/09/09 22:13:42 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-smaller.sch,v 1.1 1999/09/09 22:13:42 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-smaller.sch,v 1.1 1999/09/09 22:13:42 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-smaller.sch,v 1.1 1999/09/09 22:13:42 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-smaller.sch,v 1.1 1999/09/09 22:13:42 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-smaller.sch,v 1.1 1999/09/09 22:13:42 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-smaller.sch,v 1.1 1999/09/09 22:13:42 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-smaller.sch,v 1.1 1999/09/09 22:13:42 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-smaller.sch,v 1.1 1999/09/09 22:13:42 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-smaller.sch,v 1.1 1999/09/09 22:13:42 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-smaller.sch,v 1.1 1999/09/09 22:13:42 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-smaller.sch,v 1.1 1999/09/09 22:13:42 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-smaller.sch,v 1.1 1999/09/09 22:13:42 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-smaller.sch,v 1.1 1999/09/09 22:13:42 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-smaller.sch,v 1.1 1999/09/09 22:13:42 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-smaller.sch,v 1.1 1999/09/09 22:13:42 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-smaller.sch,v 1.1 1999/09/09 22:13:42 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-smaller.sch,v 1.1 1999/09/09 22:13:42 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-smaller.sch,v 1.1 1999/09/09 22:13:42 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-smaller.sch,v 1.1 1999/09/09 22:13:42 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-smaller.sch,v 1.1 1999/09/09 22:13:42 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-smaller.sch,v 1.1 1999/09/09 22:13:42 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-smaller.sch,v 1.1 1999/09/09 22:13:42 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 ; ----------------------------------------------------------------------
15397 (define (twobit-benchmark . rest)
15398 (let ((k (if (null? rest) 1 (car rest))))
15399 (compiler-switches 'fast-safe)
15400 (benchmark-block-mode #t)
15404 (lambda () (compile-file "twobit-input.sch"))