John Lorentzson
7aff9db800
It replaces the IR-FETCHVAR's result with the variable being fetched. This only works when the only use is in an operation that does not require a separate fetch be performed, such as those implemented as CPU instructions.
202 lines
9.1 KiB
Common Lisp
202 lines
9.1 KiB
Common Lisp
(in-package #:user-side-compiler)
|
|
|
|
;;;; This is by far the messiest part and is probably not anywhere near ready.
|
|
;;;; Some optimizations work fine, others should be replaced. All are correct.
|
|
;;;; (unless I made a mistake I didn't catch somewhere)
|
|
|
|
(defun flatten-operation-inputs (inst)
|
|
(loop :for input :in (inputs inst)
|
|
:for definition := (definition input)
|
|
:if (typep definition (type-of inst))
|
|
:append (flatten-operation-inputs definition)
|
|
:else
|
|
:collect input))
|
|
|
|
(defun fold-instruction (inst to-remove value)
|
|
(let ((output (make-instance 'ir-constant))
|
|
(add-post (null (member (first (inputs inst)) to-remove))))
|
|
(insert-instruction-above
|
|
(make-instance 'ir-getconst
|
|
:input value
|
|
:output output)
|
|
inst)
|
|
(setf (inputs inst)
|
|
(append
|
|
(when (not add-post)
|
|
(list output))
|
|
(remove-if (lambda (i) (member i to-remove))
|
|
(inputs inst))
|
|
(when add-post
|
|
(list output))))))
|
|
|
|
(defun optim-commutative-constant-folding (iblock)
|
|
"Attempts to replace operations with compile-time computed constants."
|
|
(do-instructions (inst iblock)
|
|
(when (or (typep inst '(or ir-plus ir-mult)))
|
|
(let ((new-inputs (flatten-operation-inputs inst)))
|
|
(unless (equal new-inputs (inputs inst))
|
|
(dolist (i (remove-if (lambda (d) (typep d 'ir-reusable)) new-inputs))
|
|
(unless (or (null (user i)) (eql (user i) inst))
|
|
(delete-instruction (user i))))
|
|
(setf (inputs inst) new-inputs)))
|
|
(let* ((to-fold (remove-if-not #'ir-constant-p (inputs inst)))
|
|
(values (mapcar #'ir-constant-value to-fold)))
|
|
(typecase inst
|
|
(ir-plus
|
|
(fold-instruction inst to-fold (mod (reduce #'+ values) 256))
|
|
;; Adding zero has no effect, so remove any zeroes
|
|
(setf (inputs inst)
|
|
(remove-if (lambda (i)
|
|
(and (ir-constant-p i)
|
|
(zerop (ir-constant-value i))))
|
|
(inputs inst))))
|
|
(ir-mult
|
|
;; Multiplication gets an extra check in case a multiplication by
|
|
;; zero occurs and we need to zero out the result.
|
|
(fold-instruction inst to-fold (mod (reduce #'* values) 256))
|
|
(let ((zero (find 0 (remove-if-not #'ir-constant-p (inputs inst))
|
|
:key #'ir-constant-value)))
|
|
(unless (null zero)
|
|
(setf (inputs inst)
|
|
(remove-if-not (lambda (i)
|
|
(or (typep (definition i) 'ir-call)
|
|
(eql i zero)))
|
|
(inputs inst)))))))
|
|
(when (= 1 (length (inputs inst)))
|
|
(let ((new (first (inputs inst)))
|
|
(old (output inst)))
|
|
(setf (inputs inst) '())
|
|
(loop :for user :in (users (output inst))
|
|
:do (setf (inputs user)
|
|
(substitute new old (inputs user))))))))))
|
|
|
|
(defun optim-non-commutative-constant-folding (iblock)
|
|
;; BROKEN!!
|
|
"Attempts to replace operations with compile-time computed constants.
|
|
No guarantees of success are made, I just hope it's not incorrect."
|
|
(do-instructions (inst iblock)
|
|
(when (and (typep inst 'ir-operation)
|
|
(not (typep inst 'ir-call))
|
|
(or (every #'ir-constant-p (inputs inst))
|
|
;; Division and subtraction can only be properly folded
|
|
;; here if it's only constants being used. That sucks but
|
|
;; I guess that's what we'll have to live with for now.
|
|
(and (not (typep inst 'ir-div))
|
|
(not (typep inst 'ir-minus)))))
|
|
;; Collect a new flattened list of inputs, combining other instructions
|
|
;; of the same type. This is used to enable constant folding in
|
|
;; situations where there's a variable in the middle.
|
|
(let ((new-inputs (flatten-operation-inputs inst)))
|
|
(unless (equal new-inputs (inputs inst))
|
|
(dolist (i (remove-if (lambda (d) (typep d 'ir-reusable)) new-inputs))
|
|
(unless (or (null (user i)) (eql (user i) inst))
|
|
(delete-instruction (user i))))
|
|
(setf (inputs inst) new-inputs)))
|
|
;; Perform the pre-calculation and actual folding.
|
|
(let* ((to-fold (remove-if-not #'ir-constant-p (inputs inst)))
|
|
(values (mapcar #'ir-constant-value to-fold)))
|
|
(typecase inst
|
|
|
|
(ir-minus
|
|
(setf values (mapcar (lambda (v)
|
|
(if (>= v 128)
|
|
(dpb v (byte 8 0) -1)
|
|
v))
|
|
values))
|
|
(fold-instruction inst to-fold (mod (- (first values)
|
|
(reduce #'+ (rest values)))
|
|
256)))
|
|
|
|
(ir-div
|
|
(fold-instruction inst to-fold (reduce #'/ values)))))
|
|
(when (= 1 (length (inputs inst)))
|
|
(let ((new (first (inputs inst)))
|
|
(old (output inst)))
|
|
(setf (inputs inst) '())
|
|
(loop :for user :in (users (output inst))
|
|
:do (setf (inputs user)
|
|
(substitute new old (inputs user)))))))))
|
|
|
|
(defun optim-reorder-arguments (iblock)
|
|
"Puts the simpler non-operation arguments right above the operation that
|
|
uses them to assist in generating more direct 6502 code."
|
|
(do-instructions (inst iblock)
|
|
(when (typep inst 'ir-operation)
|
|
(loop :for input :in (inputs inst)
|
|
:when (and (not (typep (definition input) 'ir-operation))
|
|
(not (typep input 'ir-reusable)))
|
|
:do (move-instruction-above (definition input) inst)))))
|
|
|
|
(defparameter +optim-remove-unused-max-passes+ 25
|
|
"The maximum number of passes the Remove Unused optimization may run
|
|
before being cut off. This ensures that it can't get stuck forever, even
|
|
though I'm pretty sure it can't anyway.")
|
|
|
|
(defun optim-remove-unused (iblock)
|
|
(let ((to-delete '()))
|
|
(loop :repeat +optim-remove-unused-max-passes+ ; this many times or fewer
|
|
:do (setf to-delete '())
|
|
(do-iblocks (ib iblock)
|
|
(do-instructions (inst ib)
|
|
(when (and (not (typep inst 'ir-terminator))
|
|
(not (effect-used-p inst))
|
|
(null (users (output inst))))
|
|
(push inst to-delete))))
|
|
(mapc 'delete-instruction to-delete)
|
|
:until (null to-delete))))
|
|
|
|
(defun optim-call-duplicate-args (iblock)
|
|
"Attempts to deduplicate call arguments."
|
|
(let ((calls '()))
|
|
(do-instructions (inst iblock)
|
|
(when (typep inst 'ir-call)
|
|
(push inst calls)))
|
|
(flet ((arg-duplicates-p (a b)
|
|
(or (and (ir-constant-p a) (ir-constant-p b)
|
|
(eql (ir-constant-value a) (ir-constant-value b)))
|
|
(and (typep a 'ir-fetchvar) (typep b 'ir-fetchvar)
|
|
(eql (input (definition a)) (input (definition b)))))))
|
|
(dolist (call calls)
|
|
(let ((arguments '())
|
|
(replacements '()))
|
|
(dolist (input (inputs call))
|
|
(let ((duplicate (find-if (lambda (i)
|
|
(arg-duplicates-p i input))
|
|
arguments)))
|
|
(if duplicate
|
|
(push (cons duplicate input) replacements)
|
|
(push input arguments))))
|
|
(loop :for (new . old) :in replacements
|
|
:do (setf (inputs call) (substitute new old (inputs call)))))))))
|
|
|
|
(defun optim-direct-variable-use (iblock)
|
|
"Removes unnecessary uses of IR-FETCHVAR.
|
|
Some operations do not require their operands to be copied before use. CPU
|
|
instructions, for example. This optimization pass goes through and removes
|
|
IR-FETCHVAR instructions that would serve no purpose in compiled code."
|
|
;; TODO: Add more instructions to the candidates
|
|
(let ((candidates-type '(or ir-test-equal ir-plus ir-minus))
|
|
(to-remove '()))
|
|
(do-instructions (inst iblock)
|
|
#+(or)
|
|
(when (equalp (name iblock) "else")
|
|
(break "~A ~A" inst
|
|
(if (typep inst 'ir-fetchvar)
|
|
(format nil "~A ~A ~A" (input inst) (output inst) (users (output inst)))
|
|
"")))
|
|
(when (typep inst 'ir-fetchvar)
|
|
(let ((result (output inst))
|
|
(src (input inst)))
|
|
(when (and (not (typep (output inst) 'ir-reusable))
|
|
(typep (user result) candidates-type))
|
|
(let ((user (user (output inst))))
|
|
(setf (inputs user) (substitute src result (inputs user)))
|
|
(push inst to-remove))))))
|
|
(mapc #'delete-instruction to-remove)))
|
|
|
|
(defun compute-lifetime-knowledge (start-iblock)
|
|
(do-iblocks (iblock start-iblock)
|
|
(do-instructions (inst iblock)
|
|
(loop :for data :in (inputs inst)
|
|
:when (typep data 'ir-data)
|
|
:do (setf (last-use data) inst)))))
|