573 lines
17 KiB
Common Lisp
573 lines
17 KiB
Common Lisp
|
||
; -*- Mode: Lisp -*- Filename: ppeep.s
|
||
|
||
; Last Revision: 1-Oct-85 1630ct
|
||
|
||
;--------------------------------------------------------------------------;
|
||
; ;
|
||
; TI SCHEME -- PCS Compiler ;
|
||
; Copyright 1985 (c) Texas Instruments ;
|
||
; ;
|
||
; David Bartley ;
|
||
; ;
|
||
; Post-Codegen Optimization ;
|
||
; ;
|
||
;--------------------------------------------------------------------------;
|
||
; ;
|
||
; Note: The optimization TEST+JUMP-NULL? ==> JUMP-NOT-TEST has not been ;
|
||
; implemented because peep2 can't reliably tell when TEST is dead. ;
|
||
; ;
|
||
; ;
|
||
; Revisions : ;
|
||
; 6/1/87 rb - Modified p2-substitute, so as not to monkey with %xesc ;
|
||
; 6/3/87 tc - Modified p1 register substitution to understand %xesc ;
|
||
; ;
|
||
; ;
|
||
;--------------------------------------------------------------------------;
|
||
|
||
|
||
(define pcs-postgen
|
||
(lambda (code)
|
||
(letrec
|
||
(
|
||
;----!
|
||
|
||
(peep1
|
||
(lambda (code)
|
||
(cond (pcs-permit-peep-1 (p1 code '()))
|
||
(pcs-permit-peep-2 (reverse! code))
|
||
(t code))))
|
||
|
||
(p1
|
||
(lambda (next acc)
|
||
(if (null? next)
|
||
(begin
|
||
(p1-forget-all)
|
||
acc)
|
||
(let ((rest (cdr next))
|
||
(instr (car next)))
|
||
(cond ((or (atom? instr) ; label
|
||
(number? (car instr))) ; label
|
||
(when (and acc
|
||
(cdr acc)
|
||
(not (atom? (car acc)))
|
||
(eq? (caar acc) 'JUMP)
|
||
(equal? (cadar acc) instr))
|
||
(set! acc (cdr acc))) ; delete "JUMP $+1"
|
||
(p1-forget-all))
|
||
((memq (car instr) '(JUMP CALL LIVE))
|
||
(p1-forget-all))
|
||
((eq? (car instr) 'LOAD)
|
||
(p1-propagate (cddr instr)) ; src reg
|
||
(p1-forget (cdr instr)) ; dest reg
|
||
(p1-remember (cadr instr) ; dest <== src
|
||
(caddr instr))
|
||
)
|
||
((eq? (car instr) '%XESC)
|
||
; %xesc assumes the dest reg will be equal tc - 6/3/87
|
||
; to the third operand (cadddr instr)
|
||
(let ((dest (cadr instr)))
|
||
(p1-propagate-all (cdr instr))
|
||
(p1-forget (cdr instr)) ; dest reg
|
||
(p1-forget dest) ; old dest reg
|
||
(p1-remember (cadr instr) ; dest <== src
|
||
(cadddr instr))
|
||
(p1-remember dest ; old dest <== src
|
||
(cadddr instr))
|
||
)
|
||
)
|
||
((not (atom? (cdr instr)))
|
||
(p1-propagate-all (cddr instr)) ; src regs
|
||
(p1-forget (cdr instr))) ; dest reg
|
||
(t '()))
|
||
(set-cdr! next acc)
|
||
(p1 rest next)))))
|
||
|
||
(p1-propagate
|
||
(lambda (s*) ; (src ...)
|
||
(when (not (atom? s*))
|
||
(let ((s (car s*)))
|
||
(when (number? s)
|
||
(let ((sub (vector-ref reg-table s)))
|
||
(when sub ; any sub
|
||
(set-car! s* sub))))))))
|
||
|
||
(p1-propagate-all
|
||
(lambda (s*) ; (src ...)
|
||
(when (not (atom? s*))
|
||
(let ((s (car s*)))
|
||
(when (number? s)
|
||
(let ((sub (vector-ref reg-table s)))
|
||
(when (number? sub) ; regs only
|
||
(set-car! s* sub)))))
|
||
(p1-propagate-all (cdr s*))))) ; cdr down
|
||
|
||
(p1-remember
|
||
(lambda (dest src)
|
||
(when (or (number? src) ; reg?
|
||
(and (not (atom? src)) ; constant
|
||
(eq? (car src) 'quote)))
|
||
(vector-set! reg-table dest src)
|
||
(set! reg-table-max
|
||
(max reg-table-max
|
||
(if (and (number? src)(> src dest))
|
||
src
|
||
dest))))))
|
||
|
||
(p1-forget
|
||
(lambda (d*) ; (dest ...)
|
||
(when (not (atom? d*))
|
||
(let ((d (car d*)))
|
||
(when (number? d) ; reg
|
||
(vector-set! reg-table d #!false)
|
||
(p1-forget-uses d))))))
|
||
|
||
(p1-forget-uses
|
||
(lambda (reg)
|
||
(letrec ((loop (lambda (v i reg)
|
||
(when (not (negative? i))
|
||
(if (equal? (vector-ref v i) reg)
|
||
(vector-set! v i #!false))
|
||
(loop v (sub1 i) reg)))))
|
||
(loop reg-table reg-table-max reg))))
|
||
|
||
(p1-forget-all
|
||
(lambda ()
|
||
(vector-fill! reg-table #!false)))
|
||
|
||
|
||
;;; p2 -- peephole optimizer pass 2
|
||
|
||
;;; Purposes:
|
||
;;;
|
||
;;; 1. Destructively reverse the code list (previously reversed by the
|
||
;;; first pass), returning it to forward order.
|
||
;;;
|
||
;;; 2. Eliminate dead code
|
||
;;;
|
||
;;; Delete instructions whenever the destination register is dead and
|
||
;;; there are no side effects.
|
||
;;;
|
||
;;; Maintain live/dead info: destination registers are dead prior to
|
||
;;; assignment, source registers become live. LIVE directives and
|
||
;;; arguments to CALLs also control liveness.
|
||
;;;
|
||
;;; Assumption: every JUMP is immediately preceded by a LIVE.
|
||
;;;
|
||
;;; 3. Target registers
|
||
;;;
|
||
;;; Delay register moves (only), such as (LOAD A B). Mark register A
|
||
;;; as dead, register B as live.
|
||
;;;
|
||
;;; Force delayed loads whenever register A is used or a label, CALL,
|
||
;;; or JUMP occurs.
|
||
;;;
|
||
;;; Substitute register A for register B and remove the (LOAD A B)
|
||
;;; from the delayed list whenever register B is the destination of
|
||
;;; an instruction.
|
||
;;;
|
||
;;; 4. Other optimizations
|
||
;;;
|
||
;;; Eliminate no-ops: (LOAD A A)
|
||
;;;
|
||
;;; Commute operands: (+ A B A) ==> (+ A A B)
|
||
;;;
|
||
;;;
|
||
;;; Data Structures:
|
||
;;;
|
||
;;; REG-TABLE [0..63]
|
||
;;;
|
||
;;; Entry I is #!FALSE iff register I is "live"
|
||
;;;
|
||
;;; DELAY-LIST
|
||
;;;
|
||
;;; "Delayed" register moves are maintained in the form:
|
||
;;;
|
||
;;; ((LOAD Ai Bi) ...)
|
||
;;;
|
||
;;; where each Ai and Bi is a register number, no Ai=Aj, no Ai=Bj,
|
||
;;; and no Bi=Bj. The P2-DELAY routine decides whether to delay a
|
||
;;; given (LOAD A B), based on the following considerations:
|
||
;;;
|
||
;;; (= A B) : Can't happen, because P2 previously deletes these
|
||
;;; no-ops [p2-dead].
|
||
;;;
|
||
;;; (= A Ai) : Can't happen, because Ai is "dead" and P2 would have
|
||
;;; deleted this operation [p2-dead].
|
||
;;;
|
||
;;; (= A Bi) : Can't happen, because P2 would previously have
|
||
;;; substituted the corresponding Ai for A [p2-substitute], making
|
||
;;; this (LOAD Ai B), and no Ai=Bj. (???)
|
||
;;;
|
||
;;; (= B Ai) : Can't happen, because P2 would have forced out any
|
||
;;; delayed (LOAD Ai Bi) [p2-sources].
|
||
;;;
|
||
;;; (= B Bi) : CAN happen. We modify the current instruction so we
|
||
;;; can continue to delay the previous (LOAD Ai Bi), as follows.
|
||
;;;
|
||
;;; Example: (load 3 5) ... (load 4 5)
|
||
;;;
|
||
;;; When we see the (LOAD 3 5), we have already delayed the
|
||
;;; (LOAD 4 5). Thus, we change (LOAD 3 5) into (LOAD 3 4),
|
||
;;; make register 4 "live", and continue to delay (LOAD 4 5).
|
||
;;;
|
||
;;; B is live : CAN happen. Don't delay the load, since the values
|
||
;;; of both A and B are needed.
|
||
;;;
|
||
;;; otherwise : delay the (LOAD A B).
|
||
;;;
|
||
|
||
(peep2
|
||
(lambda (code)
|
||
(cond (pcs-permit-peep-2 (p2 code '()))
|
||
(pcs-permit-peep-1 (reverse! code))
|
||
(t code))))
|
||
|
||
(p2
|
||
(lambda (next acc)
|
||
(if (null? next)
|
||
acc
|
||
(let ((rest (cdr next))
|
||
(instr (car next)))
|
||
(begin
|
||
(set-cdr! next acc) ; assume we will keep it
|
||
;; don't use ACC past here
|
||
(if (or (atom? instr)
|
||
(number? (car instr)))
|
||
(p2 rest (p2-force-all next)) ; label
|
||
(let ((op (car instr)))
|
||
(cond
|
||
((eq? op 'JUMP) ; JUMP
|
||
(p2-jump instr rest next))
|
||
|
||
((eq? op 'CALL) ; CALL
|
||
(p2-call instr rest next))
|
||
|
||
((eq? op 'LIVE) ; LIVE
|
||
(p2-live instr rest next))
|
||
|
||
((p2-dead? instr) ; result not needed
|
||
(p2 rest (cdr next))) ; delete it
|
||
|
||
(t
|
||
(p2-substitute instr)
|
||
(if (eq? op 'LOAD)
|
||
(p2-load instr rest next)
|
||
(begin
|
||
(let ((dest (cadr instr)))
|
||
(when (number? dest)
|
||
(p2-force dest next delay-list '())
|
||
(p2-kill dest)))
|
||
(p2-sources ; make the src regs live
|
||
(cddr instr) next)
|
||
(p2-keep rest instr next))))))))))))
|
||
|
||
|
||
;;; p2-jump -- Process JUMP instructions.
|
||
|
||
(p2-jump
|
||
(lambda (instr rest next)
|
||
(p2 rest
|
||
(p2-sources (cdddr instr)
|
||
(p2-force-all next)))))
|
||
|
||
|
||
;;; p2-call -- Process CALL instructions.
|
||
|
||
(p2-call
|
||
(lambda (instr rest next)
|
||
(vector-fill! reg-table #!true) ; make all regs dead
|
||
(let ((next (p2-sources (cddr instr)
|
||
(p2-force-all next)))) ; make src regs live
|
||
(if (not (atom? (caddr instr)))
|
||
(p2-make-live 1 (car (caddr instr)))) ; number of args
|
||
(p2 rest next))))
|
||
|
||
;;; p2-live -- Process LIVE directives.
|
||
|
||
(p2-live
|
||
(lambda (instr rest next)
|
||
(vector-fill! reg-table #!true) ; make all regs dead
|
||
(let ((range (cadr instr))) ; then make some live
|
||
(when (not (null? range))
|
||
(p2-make-live (car range)(cdr range))))
|
||
(p2 rest next)))
|
||
|
||
(p2-make-live
|
||
(lambda (lo hi)
|
||
(when ( >= hi lo)
|
||
(vector-set! reg-table hi #!false) ; make reg live
|
||
(p2-make-live lo (sub1 hi)))))
|
||
|
||
;;; p2-load -- Process LOAD instructions.
|
||
|
||
(p2-load
|
||
(lambda (instr rest next)
|
||
(let ((dest (cadr instr))
|
||
(src (caddr instr)))
|
||
(if (equal? dest src) ; no-op?
|
||
(p2 rest (cdr next)) ; delete it
|
||
(let ((live-src? (and (number? src)
|
||
(null? (vector-ref reg-table src)))))
|
||
(p2-force dest next delay-list '())
|
||
(p2-kill dest)
|
||
(p2-sources (cddr instr) next)
|
||
(let ((acc (cdr next)))
|
||
(if (and (not live-src?)
|
||
(p2-delay next)) ; does (set-cdr! next ...)
|
||
(p2 rest acc)
|
||
(p2-keep rest instr next))))))))
|
||
|
||
;;; p2-substitute -- Attempt to substitute a delayed register for the
|
||
;;; destination of INSTR. If the destination of INSTR is B and a
|
||
;;; (LOAD A B) instruction has been delayed, then the destination is
|
||
;;; changed to A and the (LOAD A B) is forgotten.
|
||
;;;
|
||
;;; This substitution cannot be performed on %XESC instructions because
|
||
;;; %XESC assumes the destination is the same as the third operand
|
||
|
||
(p2-substitute
|
||
(lambda (instr)
|
||
(letrec ((loop
|
||
(lambda (reg old new)
|
||
(if (null? old)
|
||
new
|
||
(let ((next (cdr old))
|
||
(src (caddr (car old))))
|
||
(if (and (= reg src)
|
||
; don't substitute for %xesc rb - 6/1/87
|
||
(not (eq? (car instr) '%xesc)))
|
||
(begin ; replace the dest opd
|
||
(p2-kill (cadr instr)) ; kill old dest reg
|
||
(set-car! (cdr instr) ; subst new dest reg
|
||
(cadr (car old)))
|
||
(append! next new)) ; forget it
|
||
(begin
|
||
(set-cdr! old new)
|
||
(loop reg next old))))))))
|
||
(if delay-list
|
||
(let ((dest (cadr instr)))
|
||
(if (number? dest)
|
||
(set! delay-list
|
||
(loop dest delay-list '()))))))))
|
||
|
||
|
||
;;; p2-kill -- Mark the register DEST as "dead".
|
||
|
||
(p2-kill
|
||
(lambda (dest)
|
||
(if (number? dest)
|
||
(vector-set! reg-table dest #!true))))
|
||
|
||
|
||
;;; p2-sources -- Process the source registers (SS) of an instruction:
|
||
;;; 1. Mark each source register as "live".
|
||
;;; 2. For each source operand OPD which is a register for which there is
|
||
;;; a delayed assignment, force out the load, since this is the last
|
||
;;; use of a previous value.
|
||
;;; 3. Return the updated code list, NEXT.
|
||
|
||
(p2-sources
|
||
(lambda (ss next)
|
||
(if (null? ss)
|
||
next
|
||
(let ((opd (car ss)))
|
||
(if (number? opd) ; register
|
||
(begin
|
||
(vector-set! reg-table opd #!false) ; make it live
|
||
(p2-sources (cdr ss)
|
||
(p2-force opd next delay-list '())))
|
||
(p2-sources (cdr ss) next))))))
|
||
|
||
|
||
;;; p2-force -- REG is a register which is being used as a source operand
|
||
;;; of the instruction which is at the head of CODE-LIST. Thus, we must
|
||
;;; force out any delayed load which defines or uses REG, since the source
|
||
;;; operand must refer to the old value before reassignment (defines) and
|
||
;;; we can't eliminate registers with multiple uses. Returns the updated
|
||
;;; CODE-LIST.
|
||
|
||
(p2-force
|
||
(lambda (reg code-list old new)
|
||
(if (null? old)
|
||
(begin
|
||
(set! delay-list new)
|
||
code-list)
|
||
(let ((this (cdr old))
|
||
(dest (cadr (car old)))
|
||
(src (caddr (car old))))
|
||
(if (or (= reg dest)
|
||
(= reg src))
|
||
(begin
|
||
(set-cdr! old (cdr code-list))
|
||
(set-cdr! code-list old)
|
||
(set! delay-list (append! this new))
|
||
code-list)
|
||
(begin
|
||
(set-cdr! old new)
|
||
(p2-force reg code-list this old)))))))
|
||
|
||
|
||
;;; p2-force-all -- Force all delayed register assignments out. This is
|
||
;;; necessary at all jumps, calls, labels, etc.
|
||
|
||
(p2-force-all
|
||
(lambda (code-list)
|
||
(when delay-list
|
||
(set-cdr! code-list
|
||
(append! delay-list (cdr code-list)))
|
||
(set! delay-list '()))
|
||
code-list))
|
||
|
||
|
||
;;; p2-delay -- Delay instructions of the form (LOAD reg-A reg-B)
|
||
|
||
(p2-delay
|
||
(lambda (next)
|
||
(let ((instr (car next)))
|
||
(let ((dest (cadr instr))
|
||
(src (caddr instr)))
|
||
(if (number? src)
|
||
(let ((delayed-load (p2-lookup src delay-list)))
|
||
(if delayed-load
|
||
(let ((delayed-dest (cadr delayed-load)))
|
||
(set-car! (cddr instr)
|
||
delayed-dest) ; fix this one
|
||
(p2-make-live delayed-dest
|
||
delayed-dest) ; keep the other delayed
|
||
'())
|
||
(begin ; delay this one
|
||
(set-cdr! next delay-list)
|
||
(set! delay-list next)
|
||
't)))
|
||
'()))))) ; not a reg-reg move
|
||
|
||
(p2-lookup
|
||
(lambda (src dl)
|
||
(cond ((null? dl) '())
|
||
((= src (caddr (car dl))) (car dl))
|
||
(t (p2-lookup src (cdr dl))))))
|
||
|
||
|
||
;;; p2-dead? -- Determine whether instruction INSTR may be considered
|
||
;;; redundant and thus deleted. If the destination operand is "dead" and
|
||
;;; the instruction has no side effects, then the instruction is "dead".
|
||
|
||
(p2-dead?
|
||
(lambda (instr)
|
||
(and (eq? (car instr) 'LOAD) ; no side effects
|
||
(number? (cadr instr)) ; dest reg
|
||
(or (equal? (cadr instr)(caddr instr))
|
||
(not (null? (vector-ref reg-table (cadr instr))))))))
|
||
|
||
|
||
;;; p2-keep -- Keep the current instruction, INSTR (which is also the first
|
||
;;; item in NEXT). If INSTR is a primitive that requires the first source
|
||
;;; operand to be the same as the destination register, add an appropriate
|
||
;;; LOAD in front and modify the instruction.
|
||
|
||
(p2-keep
|
||
(lambda (rest instr next)
|
||
(let ((dest (cadr instr))
|
||
(src (and (cddr instr)(caddr instr))))
|
||
(cond ((or (not (number? dest))
|
||
(not (number? src))
|
||
(= dest src)
|
||
(memq (car instr) funny-primitives))
|
||
(p2 rest next))
|
||
((member dest (cdddr instr))
|
||
(if (and (memq (car instr) commutative-primops)
|
||
(equal? dest (cadddr instr)))
|
||
(begin ; swap source operands
|
||
(set-car! (cddr instr) dest)
|
||
(set-car! (cdddr instr) src)
|
||
(p2 rest next))
|
||
(begin
|
||
(set-cdr! next (cons (list 'LOAD dest 63)
|
||
(cdr next)))
|
||
(set-car! (cdr instr) 63)
|
||
(set-car! (cddr instr) 63)
|
||
(p2 rest (cons (list 'LOAD 63 src) next)))))
|
||
(t
|
||
(set-car! (cddr instr) dest)
|
||
(p2 rest (cons (list 'LOAD dest src) next)))))))
|
||
|
||
|
||
;;; data
|
||
|
||
(funny-primitives '(LOAD cons car cdr caar cadr cdar cddr caaar caadr
|
||
cadar caddr cdaar cdadr cddar cdddr cadddr))
|
||
|
||
(commutative-primops '(+ * = eq? eqv? equal? max min))
|
||
|
||
(delay-list '())
|
||
(reg-table-max 0)
|
||
(reg-table (make-vector 64 #!false))
|
||
|
||
;----!
|
||
)
|
||
(begin
|
||
(when pcs-verbose-flag
|
||
(writeln "Codegen results:")
|
||
(pcs-princode code)
|
||
(newline))
|
||
(let ((code1 (peep1 code)))
|
||
(when pcs-verbose-flag
|
||
(writeln "Pass 1 optimization results:")
|
||
(set! code1 (reverse! code1))
|
||
(pcs-princode code1)
|
||
(set! code1 (reverse! code1))
|
||
(newline))
|
||
(let ((code2 (peep2 code1)))
|
||
(when pcs-verbose-flag
|
||
(writeln "Pass 2 optimization results:")
|
||
(pcs-princode code2)
|
||
(newline))
|
||
code2))))))
|
||
|
||
|
||
(define pcs-princode ; PCS-PRINCODE
|
||
(lambda (code)
|
||
(letrec
|
||
(
|
||
;----!
|
||
|
||
(tab " ")
|
||
(tab2 " ")
|
||
(nlabels 0)
|
||
(ninstrs 0)
|
||
(nfields 0)
|
||
|
||
(pcl
|
||
(lambda (cl)
|
||
(newline)
|
||
(when cl
|
||
(let ((x (car cl)))
|
||
(if (or (atom? x) ; label?
|
||
(number? (car x)))
|
||
(begin
|
||
(set! nlabels (add1 nlabels))
|
||
(princ tab)
|
||
(princ x)) ; label
|
||
(begin
|
||
(set! ninstrs (add1 ninstrs))
|
||
(princ tab2)
|
||
(pc x tab))) ; instruction
|
||
(pcl (cdr cl))))))
|
||
|
||
(pc
|
||
(lambda (x spacer)
|
||
(set! nfields (add1 nfields))
|
||
(princ (car x))
|
||
(when (cdr x)
|
||
(princ spacer)
|
||
(pc (cdr x) ", "))))
|
||
|
||
;----!
|
||
)
|
||
(pcl code)
|
||
(writeln " There are " nlabels " labels, "
|
||
ninstrs " instructions, and "
|
||
nfields " fields.")
|
||
)))
|
||
|