[Wisp-cvs] wisp/tools worth,1.20,1.21
Status: Alpha
Brought to you by:
digg
Menu
▾
▴
[Wisp-cvs] wisp/tools worth,1.20,1.21
|
From: <di...@us...> - 2002-08-31 14:29:25
|
Update of /cvsroot/wisp/wisp/tools
In directory usw-pr-cvs1:/tmp/cvs-serv4879/tools
Modified Files:
worth
Log Message:
Implemented the beginnings of Worth's delay-optimization.
Index: worth
===================================================================
RCS file: /cvsroot/wisp/wisp/tools/worth,v
retrieving revision 1.20
retrieving revision 1.21
diff -u -d -r1.20 -r1.21
--- worth 26 Aug 2002 16:18:24 -0000 1.20
+++ worth 31 Aug 2002 14:29:22 -0000 1.21
@@ -15,7 +15,9 @@
(gimme syscalls)
-(define builtin-words '(if else then begin until))
+(define builtin-words
+ '(< <= <> = > >= begin else if then u< u<= u> u>= until))
+
(define macro-box (make-box '()))
(define def-box (make-box #f))
(define known-procedure-box (make-box '()))
@@ -152,30 +154,41 @@
(emit `(mov ,new ,old))
(set! (cdr (assq new regref#)) (cdr (assq old regref#)))
(set! (cdr (assq old regref#)) 0)
- (set! regstack
- (map (lambda (object)
- (if (eq? object old)
- new
- object))
- regstack)))
- ((free-register reg)
+ (let (loop (tree regstack))
+ (if (cons? tree)
+ (begin
+ (if (eq? (car tree) old)
+ (set! (car tree) new)
+ (loop (car tree)))
+ (if (eq? (cdr tree) old)
+ (set! (cdr tree) new)
+ (loop (cdr tree)))))))
+ ((get-regref reg)
(my c (assq reg regref#)
(if (not c)
(raise 'cpu-register? reg))
- (if (zero? (cdr c))
- reg
- (and (pick-register) -> subst
- (begin
- (reassign subst reg)
- reg)))))
+ c))
+ ((free-register reg) ; reg specifies the register to be freed
+ ; Returns the register or #f in case of failure
+ (if (zero? (cdr (get-regref reg)))
+ reg
+ (and (pick-register) -> subst
+ (begin
+ (reassign subst reg)
+ reg))))
((pick-register (reg #f))
+ ; reg may be either #f (meaning 'any register will
+ ; do'), a register, or a list of registers.
+ ; Returns the chosen register or #f in case of failure
(cond
((not reg)
(and (rassv 0 regref#) -> c
(begin
(incr! (cdr c))
(car c))))
- ((assq reg regref#)
+ ((cons? reg)
+ (any pick-register reg))
+ ((get-regref reg)
=> (lambda (c)
(if (zero? (cdr c))
(begin
@@ -184,15 +197,19 @@
(and (free-register reg)
(begin
(incr! (cdr c))
- reg)))))
- (else
- (raise 'cpu-register? reg))))
+ reg)))))))
+ ; In |use--| and |use++|, we intentionally ignore
+ ; those items that aren't registers.
((use-- reg)
- (and (assq reg regref#) -> c
- (decr! (cdr c))))
+ (if (cons? reg)
+ (for-each use-- reg)
+ (and (assq reg regref#) -> c
+ (decr! (cdr c)))))
((use++ reg)
- (and (assq reg regref#) -> c
- (incr! (cdr c))))
+ (if (cons? reg)
+ (for-each use++ reg)
+ (and (assq reg regref#) -> c
+ (incr! (cdr c)))))
((enstack) ; error if regstack is empty
(my rrs (reverse regstack)
(my item (car rrs)
@@ -206,7 +223,7 @@
(emit `(push ,item))
(use-- item))
(reverse regstack))
- (set! regstack '()))
+ (set! regstack '()))
((stack>=! c)
(while (< (length regstack) c)
(my r (pick-register)
@@ -222,16 +239,48 @@
(stack<=! c)
(stack>=! c))
((->register i (reg #f))
- (if reg (type cpu-register reg))
- (stack>=! i)
+ ; reg may be either #f (meaning 'any register will
+ ; do'), a register, or a list of registers.
+ ; Returns the chosen register or #f in case of failure
(stack>=! (+ i 1))
(let (loop)
(my object (list-ref regstack i)
+ (if (cons? object) ; need reducing?
+ (my sl (length regstack) ; for checking
+ (case (car object) operator
+ ((= <> < <= > >= u< u<= u> u>=)
+ (my word (cdr (assq operator
+ '((= . \=?v)
+ (<> . \<>?v)
+ (< . \<?v)
+ (<= . \<=?v)
+ (> . \>?v)
+ (>= . \>=?v)
+ (u< . \u<?v)
+ (u<= . \u<=?v)
+ (u> . \u>?v)
+ (u>= . \u>=?v))))
+ (my (a b) (cdr object)
+ (cons! regstack a)
+ (use++ a)
+ (cons! regstack b)
+ (use++ b)
+ (process-word word #t)
+ (if (/= (length regstack) (+ sl 1))
+ (raise 'improper word))
+ (use-- object)
+ (set! object (car regstack))
+ (cdr! regstack)
+ (set! (list-ref regstack i) object)
+ (if (cons? object)
+ (raise 'improper word))))))))
(cond
; has the desired situation been achieved already?
((and (cpu-register? object)
(or (not reg)
- (eq? object reg))))
+ (if (cons? reg)
+ (memq object reg)
+ (eq? object reg)))))
; can we just allocate a suitable register?
((pick-register reg)
=> (lambda (r)
@@ -244,6 +293,10 @@
(reassign r reg)
(loop)))
((> (length regstack (+ i 1)))
+ (if (cons? (last regstack))
+ ; We've run out of registers and the bottom
+ ; register is an expression. This is bad.
+ (raise 'deadlock regstack))
(enstack) ; push one item to the machine stack
(loop)) ; and try again
(else
@@ -287,6 +340,14 @@
(add-string name word)
(cons! regstack name)
(cons! regstack (string-length word))))
+ ((= <> < <= > >= u< u<= u> u>=)
+ ; make an expression
+ (stack>=! 2)
+ (my b (car regstack)
+ (cdr! regstack)
+ (my a (car regstack)
+ (cdr! regstack)
+ (cons! regstack (list word a b)))))
((if) (stack=! 1)
(->register 0)
(my l (gen-label)
@@ -352,20 +413,19 @@
((flush) (if (not (null? (cdr word)))
(raise 'worth-word? word))
(flush))
- ((register) (cond
- ((or (null? (cdr word))
- (null? (cddr word)))
- (let (loop)
- (my r (pick-register
- (and (cons? (cdr word))
- (cadr word)))
- (if r
- (cons! regstack r)
- (begin
- (enstack)
- (loop))))))
- (else
- (raise 'worth-word? word))))
+ ((register) (let (loop)
+ (my r (pick-register
+ (and (cons? (cdr word))
+ (cdr word)))
+ (if r
+ (cons! regstack r)
+ (begin
+ (if (cons? (last regstack))
+ ; We've run out of registers and the bottom
+ ; register is an expression. This is bad.
+ (raise 'deadlock regstack))
+ (enstack)
+ (loop))))))
((copy) (if (not (and (cons? (cdr word))
(null? (cddr word))))
(raise 'worth-word? word))
@@ -375,9 +435,10 @@
(raise 'worth-word? word))
(delete (second word)))
((->reg) (case (length word)
+ ((1) (raise 'worth-word? word))
((2) (->register (second word)))
((3) (->register (second word)
- (third word)))
+ (cddr word)))
(else (raise 'worth-word? word))))
((->ureg) (if (not (and (cons? (cdr word))
(null? (cddr word))))
|
