+;;; Create a new fresh empty basic block in the current component.
+(defun make-empty-block ()
+ (let ((entry (make-block-entry))
+ (exit (make-block-exit)))
+ (link-nodes entry exit)
+ (let ((block (make-block :entry entry :exit exit :component *component*)))
+ (push block (component-blocks *component*))
+ block)))
+
+;;; Create a new component with an empty basic block, ready to start
+;;; conversion to IR. It returns the component and the basic block as
+;;; multiple values.
+(defun make-empty-component (&optional name)
+ (let ((*component* (make-component :name name)))
+ (let ((entry (make-component-entry :component *component*))
+ (exit (make-component-exit :component *component*))
+ (block (make-empty-block)))
+ (push entry (component-blocks *component*))
+ (push exit (component-blocks *component*))
+ (setf (block-succ entry) (list block)
+ (block-pred exit) (list block)
+ (block-succ block) (list exit)
+ (block-pred block) (list entry)
+ (component-entry *component*) entry
+ (component-exit *component*) exit)
+ (values *component* block))))
+
+;;; A few consistency checks in the IR useful for catching bugs.
+(defun check-ir-consistency (&optional (component *component*))
+ (with-simple-restart (continue "Continue execution")
+ (dolist (block (component-blocks component))
+ (dolist (succ (block-succ block))
+ (unless (find block (block-pred succ))
+ (error "The block `~S' does not belong to the predecessors list of the its successor `~S'"
+ block succ))
+ (unless (or (boundary-block-p succ) (find succ (component-blocks component)))
+ (error "Block `~S' is reachable from its predecessor `~S' but it is not in the component `~S'"
+ succ block component)))
+ (dolist (pred (block-pred block))
+ (unless (find block (block-succ pred))
+ (error "The block `~S' does not belong to the successors' list of its predecessor `~S'"
+ block pred))
+ (unless (or (boundary-block-p pred) (find pred (component-blocks component)))
+ (error "Block `~S' is reachable from its sucessor `~S' but it is not in the component `~S'"
+ pred block component))))))
+
+;;; Prepare a new component with a current empty block ready to start
+;;; IR conversion bound in the current cursor. BODY is evaluated and
+;;; the value of the last form is returned.
+(defmacro with-component-compilation ((&optional name) &body body)
+ (with-gensyms (block)
+ `(multiple-value-bind (*component* ,block)
+ (make-empty-component ,name)
+ (let ((*cursor* (cursor :block ,block)))
+ ,@body))))
+
+;;; Call function for each reachable block in component in
+;;; post-order. The consequences are unspecified if a block is
+;;; FUNCTION modifies a block which has not been processed yet.
+(defun map-postorder-blocks (function component)
+ (let ((seen nil))
+ (labels ((compute-from (block)
+ (unless (find block seen)
+ (push block seen)
+ (dolist (successor (block-succ block))
+ (unless (component-exit-p block)
+ (compute-from successor)))
+ (funcall function block))))
+ (compute-from (component-entry component))
+ nil)))
+
+;;; Change all the predecessors of BLOCK to precede NEW-BLOCK
+;;; instead. As consequence, BLOCK becomes unreachable.
+(defun replace-block (block new-block)
+ (let ((predecessors (block-pred block)))
+ (setf (block-pred block) nil)
+ (dolist (pred predecessors)
+ (pushnew pred (block-pred new-block))
+ (setf (block-succ pred) (substitute new-block block (block-succ pred)))
+ (unless (component-entry-p pred)
+ (let ((last-node (node-prev (block-exit pred))))
+ (when (conditional-p last-node)
+ (macrolet ((replacef (place)
+ `(setf ,place (if (eq block ,place) new-block ,place))))
+ (replacef (conditional-consequent last-node))
+ (replacef (conditional-alternative last-node)))))))))
+
+(defun delete-block (block)
+ (when (boundary-block-p block)
+ (error "Cannot delete entry or exit basic blocks."))
+ (unless (null (cdr (block-succ block)))
+ (error "Cannot delete a basic block with multiple successors."))
+ ;; If the block has not successors, then it is already deleted. So
+ ;; just skip it.
+ (when (block-succ block)
+ (let ((successor (unlist (block-succ block))))
+ (replace-block block successor)
+ ;; At this point, block is unreachable, however we could have
+ ;; backreferences to it from its successors. Let's get rid of
+ ;; them.
+ (setf (block-pred successor) (remove block (block-pred successor)))
+ (setf (block-succ block) nil))))
+
+
+;;;; Cursors
+;;;;
+;;;; A cursor is a point between two nodes in some basic block in the
+;;;; IR representation where manipulations can take place, similarly
+;;;; to the cursors in text editing.
+;;;;
+;;;; Cursors cannot point to special component's entry and exit basic
+;;;; blocks or after a conditional node. Conveniently, the `cursor'
+;;;; function will signal an error if the cursor is not positioned
+;;;; correctly, so the rest of the code does not need to check once
+;;;; and again.
+
+(defstruct cursor
+ block next)
+
+;;; The current cursor. It is the default cursor for many functions
+;;; which work on cursors.
+(defvar *cursor*)
+
+;;; Return the current basic block. It is to say, the basic block
+;;; where the current cursor is pointint.
+(defun current-block ()
+ (cursor-block *cursor*))
+
+;;; Create a cursor which points to the basic block BLOCK. If omitted,
+;;; then the current block is used.
+;;;
+;;; The keywords AFTER and BEFORE specify the cursor will point after (or
+;;; before) that node respectively. If none is specified, the cursor is
+;;; created before the exit node in BLOCK. An error is signaled if both
+;;; keywords are specified inconsistently, or if the nodes do not belong
+;;; to BLOCK.
+;;;
+;;; AFTER and BEFORE could also be the special values :ENTRY and :EXIT,
+;;; which stand for the entry and exit nodes of the block respectively.
+(defun cursor (&key (block (current-block))
+ (before nil before-p)
+ (after nil after-p))
+ (when (boundary-block-p block)
+ (error "Invalid cursor on special entry/exit basic block."))
+ ;; Handle special values :ENTRY and :EXIT.
+ (flet ((node-designator (x)
+ (case x
+ (:entry (block-entry block))
+ (:exit (block-exit block))
+ (t x))))
+ (setq before (node-designator before))
+ (setq after (node-designator after)))
+ (let* ((next (or before (and after (node-next after)) (block-exit block)))
+ (cursor (make-cursor :block block :next next)))
+ (flet ((out-of-range-cursor ()
+ (error "Out of range cursor."))
+ (ambiguous-cursor ()
+ (error "Ambiguous cursor specified between two non-adjacent nodes.")))
+ (when (conditional-p (node-prev next))
+ (error "Invalid cursor after conditional node."))
+ (when (or (null next) (block-entry-p next))
+ (out-of-range-cursor))
+ (when (and before-p after-p (not (eq after before)))
+ (ambiguous-cursor))
+ (do-nodes-backward (node block (out-of-range-cursor) :include-sentinel-p t)
+ (when (eq next node) (return))))
+ cursor))
+
+;;; Accept a cursor specification just as described in `cursor'
+;;; describing a position in the IR and modify destructively the
+;;; current cursor to point there.
+(defun set-cursor (&rest cursor-spec)
+ (let ((newcursor (apply #'cursor cursor-spec)))
+ (setf (cursor-block *cursor*) (cursor-block newcursor))
+ (setf (cursor-next *cursor*) (cursor-next newcursor))
+ *cursor*))
+
+;;; Insert NODE at cursor.
+(defun insert-node (node &optional (cursor *cursor*))
+ (link-nodes (node-prev (cursor-next cursor)) node)
+ (link-nodes node (cursor-next cursor))
+ t)
+
+;;; Split the block at CURSOR. The cursor will point to the end of the
+;;; first basic block. Return the three basic blocks as multiple
+;;; values.
+(defun split-block (&optional (cursor *cursor*))
+ ;; <aaaaa|zzzzz> ==> <aaaaa|>--<zzzzz>
+ (let* ((block (cursor-block cursor))
+ (newexit (make-block-exit))
+ (newentry (make-block-entry))
+ (exit (block-exit block))
+ (newblock (make-block :entry newentry
+ :exit exit
+ :pred (list block)
+ :succ (block-succ block)
+ :component *component*)))
+ (insert-node newexit)
+ (insert-node newentry)
+ (setf (node-next newexit) nil)
+ (setf (node-prev newentry) nil)
+ (setf (block-exit block) newexit)
+ (setf (block-succ block) (list newblock))
+ (dolist (succ (block-succ newblock))
+ (setf (block-pred succ) (substitute newblock block (block-pred succ))))
+ (set-cursor :block block :before newexit)
+ (push newblock (component-blocks *component*))
+ newblock))
+
+;;; Split the block at CURSOR if it is in the middle of it. The cursor
+;;; will point to the end of the first basic block. Return the three
+;;; basic blocks as multiple values.
+(defun maybe-split-block (&optional (cursor *cursor*))
+ ;; If we are converting IR into the end of the basic block, it's
+ ;; fine, we don't need to do anything.
+ (unless (block-exit-p (cursor-next cursor))
+ (split-block cursor)))
+
+
+;;;; Lexical environment
+;;;;
+;;;; It keeps an association between names and the IR entities. It is
+;;;; used to guide the translation from the Lisp source code to the
+;;;; intermediate representation.