;;; 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)))