+ ;; Rebinding the lexical environment here we make sure that the
+ ;; lexical information introduced by FORM is just available for
+ ;; subforms.
+ (let ((*lexenv* *lexenv*))
+ ;; Possibly create additional blocks in order to make sure the
+ ;; cursor is at end the end of a basic block.
+ (maybe-split-block)
+ (cond
+ ((atom form)
+ (cond
+ ((symbolp form)
+ (ir-convert-var form result))
+ (t
+ (ir-convert-constant form result))))
+ (t
+ (destructuring-bind (op &rest args) form
+ (let ((translator (cdr (assoc op *ir-translator*))))
+ (if translator
+ (funcall translator args result)
+ (ir-convert-call form result))))))
+ (values)))
+
+
+;;;; IR Normalization
+;;;;
+;;;; IR as generated by `ir-convert' or after some transformations is
+;;;; not appropiated. Here, we remove unreachable and empty blocks and
+;;;; coallesce blocks when it is possible.
+
+;;; Try to coalesce BLOCK with the successor if it is unique and block
+;;; is its unique predecessor.
+(defun maybe-coalesce-block (block)
+ (when (and (singlep (block-succ block)) (not (component-entry-p block)))
+ (let ((succ (first (block-succ block))))
+ (when (and (not (component-exit-p succ)) (singlep (block-pred succ)))
+ (link-nodes (node-prev (block-exit block))
+ (node-next (block-entry succ)))
+ (setf (block-exit block) (block-exit succ))
+ (setf (block-succ block) (block-succ succ))
+ (dolist (next (block-succ succ))
+ (setf (block-pred next) (substitute block succ (block-pred next))))
+ (setf (block-succ succ) nil
+ (block-pred succ) nil)
+ t))))
+
+;;; Normalize a component. This function must be called after a batch
+;;; of modifications to the flowgraph of the component to make sure it
+;;; is a valid input for the possible optimizations and the backend.
+(defun ir-normalize (&optional (component *component*))
+ ;; Initialize blocks as unreachables and remove empty basic blocks.
+ (dolist (block (component-blocks component))
+ (setf (block-data block) 'unreachable))
+ ;; Coalesce and mark blocks as reachable.
+ (map-postorder-blocks #'maybe-coalesce-block component)
+ (map-postorder-blocks (lambda (block)
+ (setf (block-data block) 'reachable))
+ component)
+ (let ((block-list nil))
+ (dolist (block (component-blocks component))
+ (cond
+ ;; If the block is unreachable, but it is predeces a reachable
+ ;; one, then break the link between them. So we discard it
+ ;; from the flowgraph.
+ ((eq (block-data block) 'unreachable)
+ (dolist (succ (block-succ block))
+ (when (eq (block-data succ) 'reachable)
+ (setf (block-pred succ) (remove block (block-pred succ)))))
+ (setf (block-succ block) nil))
+ ;; Delete empty blocks
+ ((and (empty-block-p block)
+ (not (boundary-block-p block))
+ ;; We cannot delete a block if it is its own successor,
+ ;; even thought it is empty.
+ (not (member block (block-succ block))))
+ (delete-block block))
+ ;; The rest of blocks remain in the component.
+ (t
+ (push block block-list))))
+ (setf (component-blocks component) block-list))
+ (check-ir-consistency))
+
+
+;;;; IR Analysis
+;;;;
+;;;; Once IR conversion has been finished. We do some analysis of the
+;;;; component to produce information which is useful for both
+;;;; optimizations and code generation. Indeed, we provide some
+;;;; abstractions to use this information.
+
+(defun compute-reverse-post-order (component)
+ (let ((output nil)
+ (index (length (component-blocks component))))
+ (flet ((add-block-to-list (block)
+ (push block output)
+ (setf (block-order block) (decf index))))
+ (map-postorder-blocks #'add-block-to-list component))
+ (setf (component-reverse-post-order-p component) t)
+ (setf (component-blocks component) output)))
+
+
+(defmacro do-blocks% ((block component &optional reverse ends result) &body body)
+ (with-gensyms (g!component g!blocks)
+ `(let* ((,g!component ,component)
+ (,g!blocks ,(if reverse
+ `(reverse (component-blocks ,g!component))
+ `(component-blocks ,g!component))))
+ ;; Do we have the information available?
+ (unless (component-reverse-post-order-p ,g!component)
+ (error "Reverse post order was not computed yet."))
+ (dolist (,block ,(if (member ends '(:head :both))
+ `,g!blocks
+ `(cdr ,g!blocks))
+ ,result)
+ ,@(if (member ends '(:tail :both))
+ nil
+ `((if (component-exit-p ,block) (return))))
+ ,@body))))
+
+;;; Iterate across blocks in COMPONENT in reverse post order.
+(defmacro do-blocks-forward ((block component &optional ends result) &body body)
+ `(do-blocks% (,block ,component nil ,ends ,result)
+ ,@body))
+
+;;; Iterate across blocks in COMPONENT in reverse post order.
+(defmacro do-blocks-backward ((block component &optional ends result) &body body)
+ `(do-blocks% (,block (reverse ,component) t ,ends ,result)
+ ,@body))
+
+
+(defun compute-dominators (component)
+ ;; Initialize the dominators of the entry to the component to be
+ ;; empty and the power set of the set of blocks for proper basic
+ ;; blocks in the component.
+ (let ((n (length (component-blocks component))))
+ ;; The component entry special block has not predecessors in the
+ ;; set of (proper) basic blocks.
+ (setf (block-dominators% (component-entry component))
+ (make-array n :element-type 'bit :initial-element 0))
+ (setf (aref (block-dominators% (component-entry component)) 0) 1)
+ (do-blocks-forward (block component :tail)
+ (setf (block-dominators% block) (make-array n :element-type 'bit :initial-element 1))))
+ ;; Iterate across the blocks in the component removing non domintors
+ ;; until it reaches a fixed point.
+ (do ((i 1 1)
+ (changes t))
+ ((not changes))
+ (setf changes nil)
+ (do-blocks-forward (block component :tail)
+ ;; We compute the new set of dominators for this iteration in a
+ ;; fresh set NEW-DOMINATORS. So we do NOT modify the old
+ ;; dominators. It is important because the block could predeces
+ ;; itself. Indeed, it allows us to check if the set of
+ ;; dominators changed.
+ (let* ((predecessors (block-pred block))
+ (new-dominators (copy-seq (block-dominators% (first predecessors)))))
+ (dolist (pred (rest predecessors))
+ (bit-and new-dominators (block-dominators% pred) t))
+ (setf (aref new-dominators i) 1)
+ (unless changes
+ (setq changes (not (equal (block-dominators% block) new-dominators))))
+ (setf (block-dominators% block) new-dominators)
+ (incf i)))))
+
+;;; Return T if BLOCK1 dominates BLOCK2, else return NIL.
+(defun dominate-p (block1 block2)
+ (let ((order (block-order block1)))
+ (= 1 (aref (block-dominators% block2) order))))
+
+;;; Check if BLOCK is a loop header. It is to say if it dominates one
+;;; of its predecessors.
+(defun loop-header-p (block)
+ (some (lambda (pred) (dominate-p block pred))
+ (block-pred block)))
+
+;;; This function duplicates the block in component for each input
+;;; edge. A technique useful to make a general flowgraph reducible.
+(defun node-splitting (block)
+ (let ((predecessors (block-pred block)))
+ (when predecessors
+ (setf (block-pred block) (list (car predecessors)))
+ (dolist (pred (cdr predecessors))
+ (let ((newblock (copy-basic-block block)))
+ (setf (block-id newblock) (generate-id 'basic-block))
+ (push newblock (component-blocks (block-component block)))
+ (setf (block-pred newblock) (list pred))
+ (setf (block-succ pred) (substitute newblock block (block-succ pred))))))))
+
+
+
+;;;; IR Debugging
+;;;;
+;;;; This section provides a function `/print' which write a textual
+;;;; representation of a component to the standard output. Also, a
+;;;; `/ir' macro is provided, which takes a form, convert it to IR and
+;;;; then print the component as above. They are useful commands if
+;;;; you are hacking the front-end of the compiler.
+;;;;
+
+(defun format-block-name (block)