93 lines
3.3 KiB
Common Lisp
93 lines
3.3 KiB
Common Lisp
(in-package #:user-side-compiler)
|
|
|
|
(defclass builder ()
|
|
((%iblock :accessor iblock :initarg :iblock)
|
|
(%insertion-point :accessor insertion-point :initarg :insertion-point)))
|
|
|
|
(defun insert-instruction-below (new target)
|
|
(check-type target (and ir-inst (not ir-terminator)))
|
|
(let ((next-inst (next target)))
|
|
(setf (next new) next-inst
|
|
(previous next-inst) new
|
|
(previous new) target
|
|
(next target) new
|
|
(iblock new) (iblock target))))
|
|
|
|
(defun insert-instruction-above (new target)
|
|
(let ((prev-inst (previous target))
|
|
(ib (iblock target)))
|
|
(setf (next new) target
|
|
(previous new) prev-inst
|
|
(previous target) new
|
|
(iblock new) ib)
|
|
(if (null prev-inst)
|
|
(setf (start ib) new)
|
|
(setf (next prev-inst) new))))
|
|
|
|
(defun yank-instruction (instruction)
|
|
"Removes INSTRUCTIONS without cleaning up, allowing it to be put back in."
|
|
(check-type instruction (and ir-inst (not ir-terminator)))
|
|
;; TODO: integrity checks
|
|
(let ((iblock (iblock instruction))
|
|
(before (previous instruction))
|
|
(after (next instruction)))
|
|
(setf (previous after) before)
|
|
(unless (null before)
|
|
(setf (next before) after))
|
|
(when (eql (start iblock) instruction)
|
|
(setf (start iblock) after)))
|
|
(setf (next instruction) nil
|
|
(previous instruction) nil))
|
|
|
|
(defun move-instruction-above (moving target)
|
|
(yank-instruction moving)
|
|
(insert-instruction-above moving target))
|
|
|
|
(defun move-instruction-below (moving target)
|
|
(yank-instruction moving)
|
|
(insert-instruction-below moving target))
|
|
|
|
(defun delete-instruction (instruction)
|
|
"Removes an instruction with the expectation that it's not coming back."
|
|
(dolist (input (inputs instruction))
|
|
(when (typep input 'ir-data)
|
|
(remove-user input instruction)))
|
|
(yank-instruction instruction))
|
|
|
|
(defun build-begin (builder iblock)
|
|
"Start BUILDER on a fresh IBLOCK."
|
|
(when (slot-boundp builder '%iblock)
|
|
(setf (program iblock) (program (iblock builder))))
|
|
(setf (insertion-point builder) nil
|
|
(iblock builder) iblock))
|
|
|
|
(defun %build-insert (builder inst)
|
|
(setf (iblock inst) (iblock builder))
|
|
(if (null (insertion-point builder))
|
|
(setf (start (iblock builder)) inst
|
|
(next inst) nil
|
|
(previous inst) nil)
|
|
(setf (next (insertion-point builder)) inst
|
|
(previous inst) (insertion-point builder)))
|
|
(setf (insertion-point builder) inst))
|
|
|
|
(declaim (ftype (function ((and ir-inst (not ir-terminator)) builder) t) build-insert))
|
|
(defun build-insert (instruction builder)
|
|
"Insert INSTRUCTION into the place being build by BUILDER."
|
|
(%build-insert builder instruction))
|
|
|
|
(declaim (ftype (function (ir-terminator builder) t) build-insert-end))
|
|
(defun build-insert-end (instruction builder)
|
|
"Insert a terminator INSTRUCTION with BUILDER, ending its current iblock."
|
|
(%build-insert builder instruction)
|
|
(setf (end (iblock builder)) instruction))
|
|
|
|
(defmacro do-iblocks ((iblock start-block) &body body)
|
|
`(loop :for ,iblock := ,start-block :then (next ,iblock)
|
|
:until (null ,iblock)
|
|
:do (progn ,@body)))
|
|
|
|
(defmacro do-instructions ((instruction iblock) &body body)
|
|
`(loop :for ,instruction := (start ,iblock) :then (next ,instruction)
|
|
:until (null ,instruction)
|
|
:do (progn ,@body)))
|