experimental/compiler.lisp

   1 ;;; compiler.lisp ---
   2
   3 ;; Copyright (C) 2013 David Vazquez
   4
   5 ;; JSCL is free software: you can redistribute it and/or
   6 ;; modify it under the terms of the GNU General Public License as
   7 ;; published by the Free Software Foundation, either version 3 of the
   8 ;; License, or (at your option) any later version.
   9 ;;
  10 ;; JSCL is distributed in the hope that it will be useful, but
  11 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;; General Public License for more details.
  14 ;;
  15 ;; You should have received a copy of the GNU General Public License
  16 ;; along with JSCL.  If not, see <http://www.gnu.org/licenses/>.
  17
  18 (defpackage :jscl
  19   (:use :cl))
  20
  21 (in-package :jscl)
  22
  23 ;;;; Utilities
  24 ;;;;
  25 ;;;; Random Common Lisp code useful to use here and there.
  26
  27 (defmacro with-gensyms ((&rest vars) &body body)
  28   `(let ,(mapcar (lambda (var) `(,var (gensym ,(string var)))) vars)
  29      ,@body))
  30
  31 (defun singlep (x)
  32   (and (consp x) (null (cdr x))))
  33
  34 (defun unlist (x)
  35   (assert (singlep x))
  36   (first x))
  37
  38
  39 ;;;; Intermediate representation structures
  40 ;;;;
  41 ;;;; This intermediate representation (IR) is a simplified version of
  42 ;;;; the first intermediate representation what you will find if you
  43 ;;;; have a look to the source code of SBCL. Some terminology is also
  44 ;;;; used, but other is changed, so be careful if you assume you know
  45 ;;;; what it is because you know the name.
  46 ;;;;
  47 ;;;; Computations are represented by `node'.  Nodes are grouped
  48 ;;;; sequencially into `basic-block'. It is a plain representation
  49 ;;;; rather than a nested one. Computations take data and produce a
  50 ;;;; value. Both data transfer are represented by `lvar'.
  51
  52 (defstruct leaf)
  53
  54 ;;; A (lexical) variable. Special variables has not a special
  55 ;;; representation in the IR. They are handled by the primitive
  56 ;;; functions `%symbol-function' and `%symbol-value'.
  57 (defstruct (var (:include leaf))
  58   ;; The symbol which names this variable in the source code.
  59   name)
  60
  61 ;;; A literal Lisp object. It usually comes from a quoted expression.
  62 (defstruct (constant (:include leaf))
  63   ;; The object itself.
  64   value)
  65
  66 ;;; A lambda expression. Why do we name it `functional'? Well,
  67 ;;; function is reserved by the ANSI, isn't it?
  68 (defstruct (functional (:include leaf))
  69   ;; The symbol which names this function in the source code or null
  70   ;; if we do not know or it is an anonymous function.
  71   name
  72   arguments
  73   return-lvar
  74   entry-point)
  75
  76 ;;; An abstract place where the result of a computation is stored and
  77 ;;; it can be referenced from other nodes, so lvars are responsible
  78 ;;; for keeping the necessary information of the nested structure of
  79 ;;; the code in this plain representation.
  80 (defstruct lvar
  81   (id (gensym "$")))
  82
  83 ;;; A base structure for every single computation. Most of the
  84 ;;; computations are valued.
  85 (defstruct node
  86   ;; The next and the prev slots are the next nodes and the previous
  87   ;; node in the basic block sequence respectively.
  88   next prev
  89   ;; Lvar which stands for the result of the computation of this node.
  90   lvar)
  91
  92 ;;; Sentinel nodes in the basic block sequence of nodes.
  93 (defstruct (block-entry (:include node)))
  94 (defstruct (block-exit (:include node)))
  95
  96 ;;; A reference to a leaf (variable, constant and functions). The
  97 ;;; meaning of this node is leaving the leaf into the lvar of the
  98 ;;; node.
  99 (defstruct (ref (:include node))
 100   leaf)
 101
 102 ;;; An assignation of the LVAR VALUE into the var VARIABLE.
 103 (defstruct (assignment (:include node))
 104   variable
 105   value)
 106
 107 ;;; Call the lvar FUNCTION with a list of lvars as ARGUMENTS.
 108 (defstruct (call (:include node))
 109   function
 110   arguments)
 111
 112 ;;; A conditional branch. If the LVAR is not NIL, then we will jump to
 113 ;;; the basic block CONSEQUENT, jumping to ALTERNATIVE otherwise. By
 114 ;;; definition, a conditional must appear at the end of a basic block.
 115 (defstruct (conditional (:include node))
 116   test
 117   consequent
 118   alternative)
 119
 120
 121 ;;; Blocks are `basic block`. Basic blocks are organized as a control
 122 ;;; flow graph with some more information in omponents.
 123 (defstruct (basic-block
 124              (:conc-name "BLOCK-")
 125              (:constructor make-block)
 126              (:predicate block-p))
 127   (id (gensym "L"))
 128   ;; List of successors and predecessors of this basic block.
 129   succ pred
 130   ;; The sentinel nodes of the sequence.
 131   entry exit)
 132
 133 ;;; Sentinel nodes in the control flow graph of basic blocks.
 134 (defstruct (component-entry (:include basic-block)))
 135 (defstruct (component-exit (:include basic-block)))
 136
 137 ;;; Return a fresh empty basic block.
 138 (defun make-empty-block ()
 139   (let ((entry (make-block-entry))
 140         (exit (make-block-exit)))
 141     (setf (node-next entry) exit
 142           (node-prev exit) entry)
 143     (make-block :entry entry :exit exit)))
 144
 145 ;;; Return T if B is an empty basic block and NIL otherwise.
 146 (defun empty-block-p (b)
 147   (block-exit-p (node-next (block-entry b))))
 148
 149 ;;; Iterate across the nodes in a basic block forward.
 150 (defmacro do-nodes
 151     ((node block &optional result &key include-sentinel-p) &body body)
 152   `(do ((,node ,(if include-sentinel-p
 153                     `(block-entry ,block)
 154                     `(node-next (block-entry ,block)))
 155                (node-next ,node)))
 156        (,(if include-sentinel-p
 157              `(null ,node)
 158              `(block-exit-p ,node))
 159         ,result)
 160      ,@body))
 161
 162 ;;; Iterate across the nodes in a basic block backward.
 163 (defmacro do-nodes-backward
 164     ((node block &optional result &key include-sentinel-p) &body body)
 165   `(do ((,node ,(if include-sentinel-p
 166                     `(block-exit ,block)
 167                     `(node-prev (block-entry ,block)))
 168                (node-prev ,node)))
 169        (,(if include-sentinel-p
 170              `(null ,node)
 171              `(block-entry-p ,node))
 172         ,result)
 173      ,@body))
 174
 175 ;;; Link FROM and TO nodes together. FROM and TO must belong to the
 176 ;;; same basic block and appear in such order. The nodes between FROM
 177 ;;; and TO are discarded.
 178 (defun link-nodes (from to)
 179   (setf (node-next from) to
 180         (node-prev to) from)
 181   (values))
 182
 183
 184
 185 ;;;; Cursors
 186 ;;;;
 187 ;;;; A cursor is a point between two nodes in some basic block in the
 188 ;;;; IR representation where manipulations can take place, similarly
 189 ;;;; to the cursors in text editing.
 190 ;;;;
 191 ;;;; Cursors cannot point to special component's entry and exit basic
 192 ;;;; blocks or after a conditional node. Conveniently, the `cursor'
 193 ;;;; function will signal an error if the cursor is not positioned
 194 ;;;; correctly, so the rest of the code does not need to check once
 195 ;;;; and again.
 196
 197 (defstruct cursor
 198   block next)
 199
 200 ;;; The current cursor. It is the default cursor for many functions
 201 ;;; which work on cursors.
 202 (defvar *cursor*)
 203
 204 ;;; Return the current basic block. It is to say, the basic block
 205 ;;; where the current cursor is pointint.
 206 (defun current-block ()
 207   (cursor-block *cursor*))
 208
 209 ;;; Create a cursor which points to the basic block BLOCK. If omitted,
 210 ;;; then the current block is used.
 211 ;;;
 212 ;;; The keywords AFTER and BEFORE specify the cursor will point after (or
 213 ;;; before) that node respectively. If none is specified, the cursor is
 214 ;;; created before the exit node in BLOCK. An error is signaled if both
 215 ;;; keywords are specified inconsistently, or if the nodes do not belong
 216 ;;; to BLOCK.
 217 ;;;
 218 ;;; AFTER and BEFORE could also be the special values :ENTRY and :EXIT,
 219 ;;; which stand for the entry and exit nodes of the block respectively.
 220 (defun cursor (&key (block (current-block))
 221                  (before nil before-p)
 222                  (after nil after-p))
 223   (when (or (component-entry-p block) (component-exit-p block))
 224     (error "Invalid cursor on special entry/exit basic block."))
 225   ;; Handle special values :ENTRY and :EXIT.
 226   (flet ((node-designator (x)
 227            (case x
 228              (:entry (block-entry block))
 229              (:exit  (block-exit block))
 230              (t x))))
 231     (setq before (node-designator before))
 232     (setq after  (node-designator after)))
 233   (let* ((next (or before (and after (node-next after)) (block-exit block)))
 234          (cursor (make-cursor :block block :next next)))
 235     (flet ((out-of-range-cursor ()
 236              (error "Out of range cursor."))
 237            (ambiguous-cursor ()
 238              (error "Ambiguous cursor specified between two non-adjacent nodes.")))
 239       (when (conditional-p (node-prev next))
 240         (error "Invalid cursor after conditional node."))
 241       (when (or (null next) (block-entry-p next))
 242         (out-of-range-cursor))
 243       (when (and before-p after-p (not (eq after before)))
 244         (ambiguous-cursor))
 245       (do-nodes-backward (node block (out-of-range-cursor) :include-sentinel-p t)
 246         (when (eq next node) (return))))
 247     cursor))
 248
 249 ;;; Accept a cursor specification just as described in `cursor'
 250 ;;; describing a position in the IR and modify destructively the
 251 ;;; current cursor to point there.
 252 (defun set-cursor (&rest cursor-spec)
 253   (let ((newcursor (apply #'cursor cursor-spec)))
 254     (setf (cursor-block *cursor*) (cursor-block newcursor))
 255     (setf (cursor-next *cursor*) (cursor-next newcursor))
 256     *cursor*))
 257
 258 ;;; Insert NODE at cursor.
 259 (defun insert-node (node &optional (cursor *cursor*))
 260   ;; After if? wrong!
 261   (link-nodes (node-prev (cursor-next cursor)) node)
 262   (link-nodes node (cursor-next cursor))
 263   t)
 264
 265 ;;; Split the block at CURSOR. The cursor will point to the end of the
 266 ;;; first basic block. Return the three basic blocks as multiple
 267 ;;; values.
 268 (defun split-block (&optional (cursor *cursor*))
 269   ;; <aaaaa|zzzzz>  ==>  <aaaaa|>--<zzzzz>
 270   (let* ((block (cursor-block cursor))
 271          (newexit (make-block-exit))
 272          (newentry (make-block-entry))
 273          (exit (block-exit block))
 274          (newblock (make-block :entry newentry
 275                                :exit exit
 276                                :pred (list block)
 277                                :succ (block-succ block))))
 278     (insert-node newexit)
 279     (insert-node newentry)
 280     (setf (node-next newexit)  nil)
 281     (setf (node-prev newentry) nil)
 282     (setf (block-exit block) newexit)
 283     (setf (block-succ block) (list newblock))
 284     (dolist (succ (block-succ newblock))
 285       (setf (block-pred succ) (substitute newblock block (block-pred succ))))
 286     (set-cursor :block block :before newexit)
 287     newblock))
 288
 289 ;;; Split the block at CURSOR if it is in the middle of it. The cursor
 290 ;;; will point to the end of the first basic block. Return the three
 291 ;;; basic blocks as multiple values.
 292 (defun maybe-split-block (&optional (cursor *cursor*))
 293   ;; If we are converting IR into the end of the basic block, it's
 294   ;; fine, we don't need to do anything.
 295   (unless (block-exit-p (cursor-next cursor))
 296     (split-block cursor)))
 297
 298
 299 ;;;; Components
 300 ;;;;
 301 ;;;; Components are connected pieces of the control flow graph of
 302 ;;;; basic blocks with some additional information. Components have
 303 ;;;; well-defined entry and exit nodes. It is the toplevel
 304 ;;;; organizational entity in the compiler. The IR translation result
 305 ;;;; is accumulated into components incrementally.
 306 (defstruct (component #-jscl (:print-object print-component))
 307   entry
 308   exit)
 309
 310 ;;; Create a new component with an empty basic block, ready to start
 311 ;;; conversion to IR. It returns the component and the basic block as
 312 ;;; multiple values.
 313 (defun make-empty-component ()
 314   (let ((entry (make-component-entry))
 315         (block (make-empty-block))
 316         (exit (make-component-exit)))
 317     (setf (block-succ entry)  (list block)
 318           (block-pred exit)   (list block)
 319           (block-succ block) (list exit)
 320           (block-pred block) (list entry))
 321     (values (make-component :entry entry :exit exit) block)))
 322
 323 ;;; Return the list of blocks in COMPONENT, conveniently sorted.
 324 (defun component-blocks (component)
 325   (let ((output nil))
 326     (labels ((compute-rdfo-from (block)
 327                (unless (or (component-exit-p block) (find block output))
 328                  (dolist (successor (block-succ block))
 329                    (unless (component-exit-p block)
 330                      (compute-rdfo-from successor)))
 331                  (push block output))))
 332       (compute-rdfo-from (unlist (block-succ (component-entry component))))
 333       output)))
 334
 335 ;;; Iterate across different blocks in COMPONENT.
 336 (defmacro do-blocks ((block component &optional result) &body body)
 337   `(dolist (,block (component-blocks ,component) ,result)
 338      ,@body))
 339
 340 ;;; A few consistency checks in the IR useful for catching bugs.
 341 (defun check-ir-consistency (component)
 342   (with-simple-restart (continue "Continue execution")
 343     (do-blocks (block component)
 344       (dolist (succ (block-succ block))
 345         (unless (find block (block-pred succ))
 346           (error "The block `~S' does not belong to the predecessors list of the its successor `~S'"
 347                  (block-id block)
 348                  (block-id succ))))
 349       (dolist (pred (block-pred block))
 350         (unless (find block (block-succ pred))
 351           (error "The block `~S' does not belong to the successors' list of its predecessor `~S'"
 352                  (block-id block)
 353                  (block-id pred)))))))
 354
 355
 356 ;;;; Lexical environment
 357 ;;;;
 358 ;;;; It keeps an association between names and the IR entities. It is
 359 ;;;; used to guide the translation from the Lisp source code to the
 360 ;;;; intermediate representation.
 361
 362 (defstruct binding
 363   name namespace type value)
 364
 365 (defvar *lexenv*)
 366
 367 (defun find-binding (name namespace)
 368   (find-if (lambda (b)
 369              (and (eq (binding-name b) name)
 370                   (eq (binding-namespace b) namespace)))
 371            *lexenv*))
 372
 373 (defun push-binding (name namespace value &optional type)
 374   (push (make-binding :name name
 375                       :namespace namespace
 376                       :type type
 377                       :value value)
 378         *lexenv*))
 379
 380
 381 ;;;; IR Translation
 382 ;;;;
 383 ;;;; This code covers the translation from Lisp source code to the
 384 ;;;; intermediate representation. The main entry point function to do
 385 ;;;; that is the `ir-convert' function, which dispatches to IR
 386 ;;;; translators. This function ss intended to do the initial
 387 ;;;; conversion as well as insert new IR code during optimizations.
 388 ;;;;
 389 ;;;; The function `ir-complete' will coalesce basic blocks in a
 390 ;;;; component to generate proper maximal basic blocks.
 391
 392 ;;; The current component. We accumulate the results of the IR
 393 ;;; conversion in this component.
 394 (defvar *component*)
 395
 396 ;;; A alist of IR translator functions.
 397 (defvar *ir-translator* nil)
 398
 399 ;;; Define a IR translator for NAME. LAMBDA-LIST is used to
 400 ;;; destructure the arguments of the form. Calling the local function
 401 ;;; `result-lvar' you can get the LVAR where the compilation of the
 402 ;;; expression should store the result of the evaluation.
 403 ;;;
 404 ;;; The cursor is granted to be at the end of a basic block with a
 405 ;;; unique successor, and so it should be when the translator returns.
 406 (defmacro define-ir-translator (name lambda-list &body body)
 407   (check-type name symbol)
 408   (let ((fname (intern (format nil "IR-CONVERT-~a" (string name))))
 409         (result (gensym))
 410         (form (gensym)))
 411     `(progn
 412        (defun ,fname (,form ,result)
 413          (flet ((result-lvar () ,result))
 414            (declare (ignorable (function result-lvar)))
 415            (destructuring-bind ,lambda-list ,form
 416              ,@body)))
 417        (push (cons ',name #',fname) *ir-translator*))))
 418
 419 ;;; Return the unique successor of the current block. If it is not
 420 ;;; unique signal an error.
 421 (defun next-block ()
 422   (unlist (block-succ (current-block))))
 423
 424 ;;; Set the next block of the current one.
 425 (defun (setf next-block) (new-value)
 426   (let ((block (current-block))
 427         (next (next-block)))
 428     (setf (block-pred next) (remove block (block-pred next)))
 429     (setf (block-succ block) (list new-value))
 430     (push block (block-pred new-value))
 431     new-value))
 432
 433
 434 (defun ir-convert-constant (form result)
 435   (let* ((leaf (make-constant :value form)))
 436     (insert-node (make-ref :leaf leaf :lvar result))))
 437
 438 (define-ir-translator quote (form)
 439   (ir-convert-constant form (result-lvar)))
 440
 441 (define-ir-translator setq (variable value)
 442   (let ((var (make-var :name variable))
 443         (value-lvar (make-lvar)))
 444     (ir-convert value value-lvar)
 445     (let ((assign (make-assignment :variable var :value value-lvar :lvar (result-lvar))))
 446       (insert-node assign))))
 447
 448 (define-ir-translator progn (&body body)
 449   (mapc #'ir-convert (butlast body))
 450   (ir-convert (car (last body)) (result-lvar)))
 451
 452 (define-ir-translator if (test then &optional else)
 453   ;; It is the schema of how the basic blocks will look like
 454   ;;
 455   ;;                              / ..then.. \
 456   ;;  <aaaa|> --  =>  <aaaaXX> --<            >-- <|> --<zzzz>
 457   ;;                              \ ..else.. /
 458   ;;
 459   ;; Note that is important to leave the cursor in an empty basic
 460   ;; block, as zzz could be the exit basic block of the component,
 461   ;; which is an invalid position for a cursor.
 462   (let ((test-lvar (make-lvar))
 463         (then-block (make-empty-block))
 464         (else-block (make-empty-block))
 465         (join-block (make-empty-block)))
 466     (ir-convert test test-lvar)
 467     (insert-node (make-conditional :test test-lvar :consequent then-block :alternative else-block))
 468     (let* ((block (current-block))
 469            (tail-block (next-block)))
 470       ;; Link together the different created basic blocks.
 471       (setf (block-succ block)      (list else-block then-block)
 472             (block-pred else-block) (list block)
 473             (block-pred then-block) (list block)
 474             (block-succ then-block) (list join-block)
 475             (block-succ else-block) (list join-block)
 476             (block-pred join-block) (list else-block then-block)
 477             (block-succ join-block) (list tail-block)
 478             (block-pred tail-block) (substitute join-block block (block-pred tail-block))))
 479     ;; Convert he consequent and alternative forms and update cursor.
 480     (ir-convert then (result-lvar) (cursor :block then-block))
 481     (ir-convert else (result-lvar) (cursor :block else-block))
 482     (set-cursor :block join-block)))
 483
 484 (define-ir-translator block (name &body body)
 485   (push-binding name 'block (cons (next-block) (result-lvar)))
 486   (ir-convert `(progn ,@body) (result-lvar)))
 487
 488 (define-ir-translator return-from (name &optional value)
 489   (let ((binding
 490          (or (find-binding name 'block)
 491              (error "Tried to return from unknown block `~S' name" name))))
 492     (destructuring-bind (jump-block . lvar)
 493         (binding-value binding)
 494       (ir-convert value lvar)
 495       (let ((new (split-block)))
 496         (setf (next-block) jump-block)
 497         (set-cursor :block new)))))
 498
 499 (defun ir-convert-var (form result)
 500   (let* ((leaf (make-var :name form)))
 501     (insert-node (make-ref :leaf leaf :lvar result))))
 502
 503 (defun ir-convert-call (form result)
 504   (destructuring-bind (function &rest args) form
 505     (let ((func-lvar (make-lvar))
 506           (args-lvars nil))
 507       (when (symbolp function)
 508         (ir-convert `(%symbol-function ,function) func-lvar))
 509       (dolist (arg args)
 510         (let ((arg-lvar (make-lvar)))
 511           (push arg-lvar args-lvars)
 512           (ir-convert arg arg-lvar)))
 513       (setq args-lvars (reverse args-lvars))
 514       (let ((call (make-call :function func-lvar :arguments args-lvars :lvar result)))
 515         (insert-node call)))))
 516
 517 ;;; Convert the Lisp expression FORM into IR before the NEXT node, it
 518 ;;; may create new basic blocks into the current component. RESULT is
 519 ;;; the lvar representing the result of the computation or null if the
 520 ;;; value should be discarded. The IR is inserted at *CURSOR*.
 521 (defun ir-convert (form &optional result (*cursor* *cursor*))
 522   ;; Rebinding the lexical environment here we make sure that the
 523   ;; lexical information introduced by FORM is just available for
 524   ;; subforms.
 525   (let ((*lexenv* *lexenv*))
 526     ;; Possibly create additional blocks in order to make sure the
 527     ;; cursor is at end the end of a basic block.
 528     (maybe-split-block)
 529     (cond
 530       ((atom form)
 531        (cond
 532          ((symbolp form)
 533           (ir-convert-var form result))
 534          (t
 535           (ir-convert-constant form result))))
 536       (t
 537        (destructuring-bind (op &rest args) form
 538          (let ((translator (cdr (assoc op *ir-translator*))))
 539            (if translator
 540                (funcall translator args result)
 541                (ir-convert-call form result))))))
 542     (values)))
 543
 544
 545 ;;; Prepare a new component with a current empty block ready to start
 546 ;;; IR conversion bound in the current cursor. BODY is evaluated and
 547 ;;; the value of the last form is returned.
 548 (defmacro with-component-compilation (&body body)
 549   (let ((block (gensym)))
 550     `(multiple-value-bind (*component* ,block)
 551          (make-empty-component)
 552        (let ((*cursor* (cursor :block ,block))
 553              (*lexenv* nil))
 554          ,@body))))
 555
 556 (defun delete-empty-block (block)
 557   (when (or (component-entry-p block) (component-exit-p block))
 558     (error "Cannot delete entry or exit basic blocks."))
 559   (unless (empty-block-p block)
 560     (error "Block `~S' is not empty!" (block-id block)))
 561   (let ((succ (unlist (block-succ block))))
 562     (setf (block-pred succ) (remove block (block-pred succ)))
 563     (dolist (pred (block-pred block))
 564       (setf (block-succ pred) (substitute succ block (block-succ pred)))
 565       (pushnew pred (block-pred succ)))))
 566
 567 ;;; Try to coalesce BLOCK with the successor if it is unique and block
 568 ;;; is its unique predecessor.
 569 (defun maybe-coalesce-block (block)
 570   (when (singlep (block-succ block))
 571     (let ((succ (first (block-succ block))))
 572       (when (and (singlep (block-pred succ))
 573                  (not (component-exit-p succ)))
 574         (link-nodes (node-prev (block-exit block))
 575                     (node-next (block-entry succ)))
 576         (setf (block-succ block) (block-succ succ))
 577         (dolist (next (block-succ succ))
 578           (setf (block-pred next) (substitute block succ (block-pred next))))
 579         t))))
 580
 581 (defun ir-complete (&optional (component *component*))
 582   (do-blocks (block component)
 583     (if (empty-block-p block)
 584         (delete-empty-block block)
 585         (maybe-coalesce-block block))))
 586
 587
 588 ;;; IR Debugging
 589
 590 (defun print-node (node)
 591   (when (node-lvar node)
 592     (format t "~a = " (lvar-id (node-lvar node))))
 593   (cond
 594     ((ref-p node)
 595      (let ((leaf (ref-leaf node)))
 596        (cond
 597          ((var-p leaf)
 598           (format t "~a" (var-name leaf)))
 599          ((constant-p leaf)
 600           (format t "'~a" (constant-value leaf)))
 601          ((functional-p leaf)
 602           (format t "#<function ~a at ~a>"
 603                   (functional-name leaf)
 604                   (functional-entry-point leaf))))))
 605     ((assignment-p node)
 606      (format t "set ~a ~a"
 607              (var-name (assignment-variable node))
 608              (lvar-id (assignment-value node))))
 609     ((call-p node)
 610      (format t "call ~a" (lvar-id (call-function node)))
 611      (dolist (arg (call-arguments node))
 612        (format t " ~a" (lvar-id arg))))
 613     ((conditional-p node)
 614      (format t "if ~a ~a ~a"
 615              (lvar-id (conditional-test node))
 616              (block-id (conditional-consequent node))
 617              (block-id (conditional-alternative node))))
 618     (t
 619      (error "`print-node' does not support printing ~S as a node." node)))
 620   (terpri))
 621
 622 (defun print-block (block)
 623   (flet ((block-name (block)
 624            (cond
 625              ((and (singlep (block-pred block))
 626                    (component-entry-p (unlist (block-pred block))))
 627               "ENTRY")
 628              ((component-exit-p block)
 629               "EXIT")
 630              (t (string (block-id block))))))
 631     (format t "BLOCK ~a:~%" (block-name block))
 632     (do-nodes (node block)
 633       (print-node node))
 634     (when (singlep (block-succ block))
 635       (format t "GO ~a~%" (block-name (first (block-succ block)))))
 636     (terpri)))
 637
 638 (defun print-component (component &optional (stream *standard-output*))
 639   (let ((*standard-output* stream))
 640     (do-blocks (block component)
 641       (print-block block))))
 642
 643 ;;; Translate FORM into IR and print a textual repreresentation of the
 644 ;;; component.
 645 (defun describe-ir (form)
 646   (with-component-compilation
 647     (ir-convert form (make-lvar :id "$out"))
 648     (ir-complete)
 649     (check-ir-consistency *component*)
 650     (print-component *component*)))
 651
 652
 653 ;;; compiler.lisp ends here