-;;; Components are connected pieces of the control flow graph with
-;;; some additional information. Components have well-defined entry
-;;; and exit nodes. They also track what basic blocks we have and
-;;; other useful information. It is the toplevel organizational entity
-;;; in the compiler. The IR translation result is accumulated into
-;;; components incrementally.
-(defstruct (component #-jscl (:print-object print-component))
- entry
- exit)
-
-;;; Create a new component with sentinel nodes and 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 ()
- (let ((entry (make-component-entry))
- (block (make-empty-block))
- (exit (make-component-exit)))
- (setf (block-succ entry) (list block)
- (block-pred exit) (list block)
- (block-succ block) (list exit)
- (block-pred block) (list entry))
- (values (make-component :entry entry :exit exit) block)))
-
-;;; Return the list of blocks in COMPONENT.
-(defun component-blocks (component)
- (let ((output nil))
- (labels ((compute-rdfo-from (block)
- (unless (or (component-exit-p block) (find block output))
- (dolist (successor (block-succ block))
- (unless (component-exit-p block)
- (compute-rdfo-from successor)))
- (push block output))))
- (compute-rdfo-from (unlist (block-succ (component-entry component))))
- output)))
-
-;;; Iterate across different blocks in COMPONENT.
-(defmacro do-blocks ((block component &optional result) &body body)
- `(dolist (,block (component-blocks ,component) ,result)
- ,@body))
-
-;;; A few consistency checks in the IR useful for catching bugs.
-(defun check-ir-consistency (&optional (component *component*))
- (with-simple-restart (continue "Continue execution")
- (do-blocks (block 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-id block)
- (block-id succ))))
- (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-id block)
- (block-id pred)))))))
-
-(defun delete-empty-block (block)
- (when (or (component-entry-p block) (component-exit-p block))
- (error "Cannot delete entry or exit basic blocks."))
- (unless (empty-block-p block)
- (error "Block `~S' is not empty!" (block-id block)))
- (let ((succ (unlist (block-succ block))))
- (setf (block-pred succ) (remove block (block-pred succ)))
- (dolist (pred (block-pred block))
- (setf (block-succ pred) (substitute succ block (block-succ pred)))
- (pushnew pred (block-pred succ)))))
-
-;;; Try to coalesce BLOCK with the successor if it is unique and block
-;;; is its unique predecessor.
-(defun maybe-coalesce-block (block)
- (when (singlep (block-succ block))
- (let ((succ (first (block-succ block))))
- (when (and (singlep (block-pred succ)) (not (component-exit-p succ)))
- (link-nodes (node-prev (block-exit block)) (node-next (block-entry succ)))
- (setf (block-succ block) (block-succ succ))
- (dolist (next (block-succ succ))
- (setf (block-pred next) (substitute block succ (block-pred next))))
- t))))
-
-(defun finish-component (component)
- (do-blocks (block component)
- (if (empty-block-p block)
- (delete-empty-block block)
- (maybe-coalesce-block block))))