+;;; Components are connected pieces of the control flow graph of
+;;; basic blocks with some additional information. Components have
+;;; well-defined entry and exit nodes. It is the toplevel
+;;; organizational entity in the compiler. The IR translation result
+;;; is accumulated into components incrementally.
+(defstruct (component (:print-object generic-printer))
+ (id (generate-id 'component))
+ name
+ entry
+ exit
+ functions
+ ;; TODO: Replace with a flags slot for indicate what
+ ;; analysis/transformations have been carried out.
+ reverse-post-order-p
+ blocks)
+
+;;; The current component.
+(defvar *component*)
+
+;;; 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)))
+ (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 (or (component-exit-p block) (find block seen))
+ (push block seen)
+ (dolist (successor (block-succ block))
+ (unless (component-exit-p block)
+ (compute-from successor)))
+ (funcall function block))))
+ (compute-from (unlist (block-succ (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 (singlep (block-succ block))
+ (error "Cannot delete a basic block with multiple successors."))
+ (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)))
+