96 lines
3.9 KiB
Common Lisp
96 lines
3.9 KiB
Common Lisp
(in-package #:user-side-compiler)
|
|
|
|
(defclass ir-inline (ir-inst) ())
|
|
|
|
(defclass ir-inline-bitand (ir-inline ir-operation) ())
|
|
(defclass ir-inline-bitxor (ir-inline ir-operation) ())
|
|
|
|
(defparameter *inline-functions*
|
|
'(("bitand" . ir-inline-bitand)
|
|
("bitxor" . ir-inline-bitxor)))
|
|
|
|
(defun optim-inline (start-iblock)
|
|
(do-iblocks (iblock start-iblock)
|
|
(do-instructions (inst iblock)
|
|
(when (typep inst 'ir-call)
|
|
(let ((inline-equivalent (cdr (assoc (name (callee inst))
|
|
*inline-functions*
|
|
:test #'string-equal))))
|
|
(unless (null inline-equivalent)
|
|
(let* ((inputs (inputs inst))
|
|
(output (output inst)))
|
|
(setf (inputs inst) '()
|
|
(output inst) nil)
|
|
(let ((new (make-instance inline-equivalent
|
|
:source (source inst)
|
|
:inputs inputs
|
|
:output output)))
|
|
(insert-instruction-above new inst)
|
|
(delete-instruction inst)
|
|
(setf inst new))))))))
|
|
(print-iblocks start-iblock))
|
|
|
|
(defun optim-reuse-temporary-slots (start-iblock allocations)
|
|
(let ((free '()))
|
|
(do-iblocks (iblock start-iblock)
|
|
(do-instructions (inst iblock)
|
|
(let ((ending (find inst allocations
|
|
:key (alexandria:compose #'last-use
|
|
#'data)))
|
|
(beginning (find (output inst) allocations :key #'data)))
|
|
(cond ((and ending
|
|
(eql (strategy ending) :temporary-variable)
|
|
(not (null (varvec-index ending))))
|
|
(pushnew (varvec-index ending) free))
|
|
((and beginning
|
|
(eql (strategy beginning) :temporary-variable)
|
|
(not (null (varvec-index beginning)))
|
|
(not (null free)))
|
|
(setf (varvec-index beginning) (pop free)))))))))
|
|
|
|
(defun optim-prepare-direct-instructions (iblock)
|
|
(do-instructions (inst iblock)
|
|
(when (typep inst 'ir-operation)
|
|
(assert (= (length (inputs inst)) 2))
|
|
(destructuring-bind (accumulator operand)
|
|
(inputs inst)
|
|
(when (typep (definition accumulator) '(or ir-fetchvar ir-getconst))
|
|
(move-instruction-above (definition accumulator) inst))
|
|
(when (typep (definition operand) '(or ir-fetchvar ir-getconst))
|
|
(when (typep (definition operand) 'ir-fetchvar)
|
|
(setf (inputs inst)
|
|
(substitute (input (definition operand)) operand
|
|
(inputs inst))))
|
|
(delete-instruction (definition operand)))))))
|
|
|
|
(defparameter *operation-routines*
|
|
'((ir-mult . "mult")
|
|
(ir-div . "div")))
|
|
|
|
(defun pre-assembly-software-operations (start-iblock)
|
|
(do-iblocks (ib start-iblock)
|
|
(do-instructions (inst ib)
|
|
(when (member (type-of inst) *operation-routines* :key #'car)
|
|
(let ((inputs (inputs inst))
|
|
(output (output inst))
|
|
(implementation (get-asm-function
|
|
(cdr (assoc (type-of inst)
|
|
*operation-routines*)))))
|
|
(setf (inputs inst) '()
|
|
(output inst) nil)
|
|
(let ((new (make-instance 'ir-call
|
|
:callee implementation
|
|
:inputs inputs :output output)))
|
|
(insert-instruction-above new inst)
|
|
(delete-instruction inst)
|
|
;; To ensure that the code walking continues correctly
|
|
(setf inst new)))))))
|
|
|
|
(defun pre-assembly (iblock)
|
|
(pre-assembly-software-operations iblock)
|
|
(optim-inline iblock)
|
|
(do-iblocks (ib iblock)
|
|
(optim-prepare-direct-instructions ib))
|
|
(let ((allocs (allocate-values iblock)))
|
|
(optim-reuse-temporary-slots iblock allocs)
|
|
allocs))
|