;;; This is a -*-Lisp-*- file.
;;; %%% Need to merge in Jim's stuff,
;;; %%% Make lots of set-nulls reduce to NPOP-NSIC
;;; %%% Make (SET-NULL STACK) (BIND (CONSTANT foo)) => (BIND-NULL (CONSTANT foo))
;;; **********************************************************************
;;; This code was written as part of the Spice Lisp project at
;;; Carnegie-Mellon University, and has been placed in the public domain.
;;; Spice Lisp is currently incomplete and under active development.
;;; If you want to use this code or any part of Spice Lisp, please contact
;;; Scott Fahlman (FAHLMAN@CMUC).
;;; **********************************************************************
;;; Peephole optimizer for the Common Lisp Compiler.
;;; Written by Scott Fahlman and Skef Wholey.
;;; Based on an earlier version by Joe Ginder.
;;; Called from within Compile-One-Lambda, which sets up certain special
;;; variables, particularly Lap-Code. Destructively modifies Lap-Code
;;; and returns the logically equivalent, but more compact, result.
;;; Makes a pass through the Lap code, examining each instruction by itself
;;; and together with the two preceding instructions. Unreferenced tags
;;; are flushed, sequences are replaced by equivalent but shorter ones, some
;;; branches are reorganized to be more efficient. In some cases a change
;;; might create opportunities for further optimization that cannot be done
;;; during the current scan. In these cases a flag is set that will cause
;;; the scan to repeat after the current pass is completed.
;;; For a description of Spice Lap format, look in the file LAP.TXT in the
;;; compiler directory.
;;; For compilation and loading instructions, see COMPILE-CLC and BUILD-CLC.
;;; *******************************************************************
;;; MACROS FOR ACCESSING SPICE LAP FORMAT CODE.
;;; The following are called on top-level elements of the code list:
(defmacro tagp (inst) `(atom ,inst))
(defmacro opcode (inst) `(car ,inst))
(defmacro operand (inst) `(cadr ,inst))
(defmacro branchp (inst) `(and (listp ,inst)
(memq (car ,inst)
'(branch
branch-null
branch-not-null
branch-save-not-null))))
;;; Called on the operand of a macro instruction.
(defmacro short-constantp (operand)
`(and (listp ,operand)
(eq (car ,operand) 'short-const)))
;;; Called on a branch instruction.
(defmacro branch-tag (inst) `(cadr ,inst))
;;; Given a branch instruction INST, find the first instruction after
;;; the tag, skipping over other tags. ICODE is the whole lap-list
;;; starting with (CODE-START).
(defun branch-target (inst icode)
(do ((l (memq (branch-tag inst) icode) (cdr l)))
((null l)
(error "Compiler bug. Bad destination for ~S." inst))
(or (atom (car l)) (return (car l)))))
;;; Useful tables.
(defparameter cond-branch-inverses
'((branch-null branch-not-null)
(branch-not-null branch-null)))
(defparameter simple-setting-ops
'(set-null set-t set-0))
(defparameter cumulative-ops
'(unbind list*))
;;; Peephole-optimize is the top-level function for peephole optimization.
;;; The variable "icode" is initialized to point to the LAP-CODE
;;; starting with the (CODE-START) flag. A quick pre-pass is done to
;;; record which tags have been referenced. Tags not on this list are flushed.
;;; Keep calling PEEP1 until it returns (), then we are done.
(defun peephole-optimize ()
(let* ((ctags (tags-in-constants-list))
(length-before (if *peep-statistics* (length lap-code))))
(do ((repeat t)
(referenced-tags nil))
((not repeat)
(if *peep-statistics*
(clc-mumble
"~%Optimization of ~S: ~S instructions in, ~S instructions out."
function-name length-before (length lap-code))))
(setq referenced-tags (reftags lap-code ctags))
(setq repeat (peep1 lap-code referenced-tags)))))
;;; List all the tags appearing in the constants list of this function.
;;; Also, all of the entry point tags. This never changes, so only do it
;;; once. The special THROW-TAG tag is always treated as being referenced.
(defun tags-in-constants-list ()
(do ((cl constants-list (cdr cl))
(tags (mapcar #'cadr entry-points)))
((null cl) (cons 'throw-tag tags))
(if (and (not (atom (car cl))) (eq (caar cl) '**tag**))
(push (cadr (car cl)) tags))))
;;; List all tags referenced by branch instructions in CODE, which is the
;;; LAP-CODE list starting with (CODE-START). These are consed
;;; onto the CTAGS list.
(defun reftags (code ctags)
(do ((cl (cdr code) (cdr cl))
(tags ctags))
((null cl) tags)
(if (branchp (car cl))
(push (branch-tag (car cl)) tags))))
;;; PEEP1 does the actual work. REFTAGS is the list of tags referenced
;;; by branches in the code. Modifies the code by destructively altering
;;; top-level cells of the LAP-CODE list. Returns NIL if optimization is
;;; complete, T if it might help to go around again.
;;; Moves a three-instruction window through the code list. Each
;;; instruction must sit in position INST first, then it shifts to PREV,
;;; and finally to PREV2 as new instructions move into the window.
;;; INST-PTR, PREV-PTR, and PREV2-PTR are the portions of the ICODE list
;;; whose CAR is the instruction in question. PREV2 and PREV2-PTR may
;;; sometimes be NIL, indicating that the instruction in that position
;;; does not exist or cannot be part of an optimization.
(defun peep1 (icode reftags)
(prog (inst prev prev2 inst-ptr prev-ptr prev2-ptr
repeat new-inst temp)
(setq prev-ptr icode
prev (car icode)
inst-ptr (cdr icode)
inst (cadr icode))
LOOP
(cond ((null inst-ptr) (return repeat)))
(cond ((tagp inst)
(cond ((not (memq inst reftags))
;; Tag is unreferenced, flush it.
(go flush-inst))
;; Flush branches to immediately following tag.
((and (branchp prev)
(eq (branch-tag prev) inst))
(setq new-inst inst)
(go collapse))
;; (BRANCH-COND tag1) (BRANCH tag2) tag1
;; => (BRANCH-INVERSE-COND tag2) tag1
((and (listp prev)
(eq (opcode prev) 'branch)
(listp prev2)
(setq temp (assq (opcode prev2) cond-branch-inverses))
(eq (branch-tag prev2) inst))
(setq prev2 `(,(cadr temp) ,(branch-tag prev)))
(rplaca prev2-ptr prev2)
(setq new-inst inst)
(go collapse))))
;; Flush comments.
((eq (opcode inst) 'comment) (go flush-inst))
;; (PUSH STACK NIL) and (POP STACK NIL) are no-ops.
((and (or (eq (opcode inst) 'push) (eq (opcode inst) 'pop))
(eq (operand inst) 'stack))
(go flush-inst))
;; NPOP and UNBIND are no-ops if arg is 0.
((and (or (eq (opcode inst) 'npop) (eq (opcode inst) 'unbind))
(equal (operand inst) '(short-const 0)))
(go flush-inst))
;; If target of an unconditional branch is a return, go direct.
((and (eq (opcode inst) 'branch)
(eq (opcode (setq temp (branch-target inst icode))) 'return))
(rplaca inst-ptr temp)
(setq inst temp)
(setq repeat t)
(go loop))
;; If target of any branch is an unconditional branch, go direct.
;; Note: modifies the tag of the branch instruction directly.
;; All branches are constructed lists, so this is OK.
((and (branchp inst)
(eq (opcode (setq temp (branch-target inst icode))) 'branch))
(when (eql (branch-tag inst) (branch-tag temp))
(clc-warning "Bodyless infinite loop encountered by peeper.")
(return nil))
(rplaca (cdr inst) (cadr temp))
(setq repeat t)
(go loop))
;; Turn (NPOP (SHORT-CONST -1)) into (SET-NULL STACK).
((equal inst '(npop (short-const -1)))
(rplaca inst-ptr (list 'set-null 'stack))
(setq inst (car inst-ptr))
(go loop))
;; If PREV tag or empty, cannot win beyond here.
((atom prev) (go step))
;; If PREV is an unconditional branch, throw, or return, code up to
;; the next referenced tag is unreachable. Flush it.
((and (not (tagp inst))
(or (eq (opcode prev) 'branch)
(eq (opcode prev) 'return)
(eq (opcode prev) 'throw)))
(go flush-inst))
;; (PUSH src) (op STACK . notes) => (op src . notes)
((and (eq (opcode prev) 'push)
(eq (operand inst) 'stack)
(eq (get (opcode inst) '%instruction-type) 'read))
(setq new-inst `(,(opcode inst) ,(operand prev) ,@(cddr inst)))
(go collapse))
;; (op STACK . notes) (POP dest) => (op dest . notes)
((and (eq (opcode inst) 'pop)
(eq (operand prev) 'stack)
(eq (get (opcode inst) '%instruction-type) 'write))
(setq new-inst `(,(opcode prev) ,(operand inst) ,@(cddr prev)))
(go collapse))
;; (POP op) (PUSH op) => (COPY op)
((and (eq (opcode prev) 'pop)
(eq (opcode inst) 'push)
(equal (operand prev) (operand inst)))
(setq new-inst (list 'copy (operand prev)))
(go collapse))
;; (COPY op) (POP IGNORE) => (POP op)
((and (eq (opcode inst) 'pop)
(eq (operand inst) 'ignore)
(eq (opcode prev) 'copy))
(setq new-inst (list 'pop (operand prev)))
(go collapse))
;; Condense repeated setting ops of same operand.
((and (memq (opcode inst) simple-setting-ops)
(memq (opcode prev) simple-setting-ops)
(not (eq (operand inst) 'stack))
(equal (operand inst) (operand prev)))
(setq new-inst inst)
(go collapse))
;; (SET-CDR op) (SET-CDR op) => (SET-CDDR op)
;; If both are NO-CHECK, result is too.
((and (eq (opcode inst) 'set-cdr)
(eq (opcode prev) 'set-cdr)
(equal (operand inst) (operand prev)))
(setq new-inst (list* 'set-cddr (operand inst)
(if (and (equal (caddr inst) '(no-check))
(equal (caddr prev) '(no-check)))
'((no-check))
nil)))
(go collapse))
;; (NOT-PREDICATE op) (NOT-PREDICATE op) => (MAKE-PREDICATE op)
((and (eq (opcode inst) 'not-predicate)
(equal inst prev))
(setq new-inst (list 'make-predicate (operand inst)))
(go collapse))
;; (PUSH op) (POP op) => no-op
((and (eq (opcode prev) 'push)
(eq (opcode inst) 'pop)
(equal (operand prev) (operand inst)))
(setq new-inst nil)
(go collapse))
;; (op i) (op j) => (op i+j) where I and J are short constants.
((and (eq (opcode prev) (opcode inst))
(memq (opcode inst) cumulative-ops)
(short-constantp (operand inst))
(short-constantp (operand prev))
(<= (setq temp (+ (cadr (operand inst))
(cadr (operand prev))))
most-positive-short-constant)
(>= temp most-negative-short-constant))
(setq new-inst `(,(opcode inst) (short-const ,temp)))
(go collapse))
;; (LIST i) (LIST* j) => (LIST i+j) for short-const I and J.
((and (eq (opcode prev) 'list)
(eq (opcode prev) 'list*)
(short-constantp (operand inst))
(short-constantp (operand prev))
(<= (setq temp (+ (cadr (operand inst))
(cadr (operand prev))))
most-positive-short-constant)
(>= temp most-negative-short-constant))
(setq new-inst `(list (short-const ,temp)))
(go collapse))
;; (CDR op . notes) (POP op) => (SET-CDR op . notes)
((and (eq (opcode prev) 'cdr)
(eq (opcode inst) 'pop)
(equal (operand prev) (operand inst)))
(setq new-inst `(set-cdr ,(operand inst) ,@(cddr prev)))
(go collapse))
;; (CDDR op . notes) (POP op) => (SET-CDDR op . notes)
((and (eq (opcode prev) 'cddr)
(eq (opcode inst) 'pop)
(equal (operand prev) (operand inst)))
(setq new-inst `(set-cddr ,(operand inst) ,@(cddr prev)))
(go collapse))
;; If PREV2 tag or empty, cannot win beyond here.
((atom prev2) (go step))
;; (PUSH op) (modify STACK . notes) (POP op) => (modify op . notes)
((and (eq (opcode prev2) 'push)
(eq (opcode inst) 'pop)
(eq (operand prev) 'stack)
(equal (operand prev2) (operand inst))
(eq (get (opcode prev) '%instruction-type) 'read-modify-write))
(rplaca prev2-ptr nil)
(setq prev2 nil)
(setq new-inst `(,(opcode prev) ,(operand inst) ,@(cddr prev)))
(go collapse))
;; (PUSH op) (modify STACK) (COPY op) => (modify op) (PUSH op)
((and (eq (opcode prev2) 'push)
(eq (opcode inst) 'copy)
(eq (operand prev) 'stack)
(equal (operand prev2) (operand inst))
(eq (get (opcode prev) '%instruction-type) 'read-modify-write))
(rplaca prev2-ptr `(,(opcode prev) ,(operand inst) ,@(cddr prev)))
(setq prev2 (car prev2-ptr))
(setq new-inst (list 'push (operand inst)))
(go collapse))
)
STEP
;; No optimization occurred, move window ahead.
(setq prev2-ptr prev-ptr prev2 prev
prev-ptr inst-ptr prev inst
inst-ptr (cdr inst-ptr) inst (car inst-ptr))
(go loop)
COLLAPSE
;; Replace PREV and INST with NEW-INST, get next inst.
;; Sets REPEAT flag.
(rplaca prev-ptr new-inst)
(setq prev new-inst)
(setq repeat t)
FLUSH-INST
;; Remove the current INST from the code list.
(rplacd prev-ptr (cdr inst-ptr))
(setq inst-ptr (cdr inst-ptr) inst (car inst-ptr))
(go loop)))