John Lorentzson
9e643e6c6d
The compiler middle stage takes high level nodes and produces code in an intermediate representation more closely resembling assembly code. Optimizations and the tools for making those are also included. It's significantly easier to optimize IR than syntax trees or assembly. Several things need cleaning up, in particular there are things in jigs.lisp that really should be documented tools, not jigs (specifically the compilation setup and finalization).
170 lines
7.7 KiB
Common Lisp
170 lines
7.7 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)))))))))
|