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 ,(concatenate 'string (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 (defun generic-printer (x stream)
  39   (print-unreadable-object (x stream :type t :identity t)))
  40
  41 ;;; A generic counter mechanism. IDs are used generally for debugging
  42 ;;; purposes. You can bind *counter-alist* to NIL to reset the
  43 ;;; counters in a dynamic extent.
  44 (defvar *counter-alist* nil)
  45 (defun generate-id (class)
  46   (let ((e (assoc class *counter-alist*)))
  47     (if e
  48         (incf (cdr e))
  49         (prog1 1
  50           (push (cons class 1) *counter-alist*)))))
  51
  52
  53 ;;;; Intermediate representation structures
  54 ;;;;
  55 ;;;; This intermediate representation (IR) is a simplified version of
  56 ;;;; the first intermediate representation what you will find if you
  57 ;;;; have a look to the source code of SBCL. Some terminology is also
  58 ;;;; used, but other is changed, so be careful if you assume you know
  59 ;;;; what it is because you know the name.
  60 ;;;;
  61 ;;;; Computations are represented by `node'.  Nodes are grouped
  62 ;;;; sequencially into `basic-block'. It is a plain representation
  63 ;;;; rather than a nested one. Computations take data and produce a
  64 ;;;; value. Both data transfer are represented by `lvar'.
  65
  66 (defstruct leaf)
  67
  68 ;;; A (lexical) variable. Special variables has not a special
  69 ;;; representation in the IR. They are handled by the primitive
  70 ;;; functions `%symbol-function' and `%symbol-value'.
  71 (defstruct (var (:include leaf))
  72   ;; The symbol which names this variable in the source code.
  73   name)
  74
  75 ;;; A literal Lisp object. It usually comes from a quoted expression.
  76 (defstruct (constant (:include leaf))
  77   ;; The object itself.
  78   value)
  79
  80 ;;; A lambda expression. Why do we name it `functional'? Well,
  81 ;;; function is reserved by the ANSI, isn't it?
  82 (defstruct (functional (:include leaf) (:print-object generic-printer))
  83   ;; The symbol which names this function in the source code or null
  84   ;; if we do not know or it is an anonymous function.
  85   name
  86   arguments
  87   return-lvar
  88   component)
  89
  90 ;;; An abstract place where the result of a computation is stored and
  91 ;;; it can be referenced from other nodes, so lvars are responsible
  92 ;;; for keeping the necessary information of the nested structure of
  93 ;;; the code in this plain representation.
  94 (defstruct lvar
  95   (id (generate-id 'lvar)))
  96
  97 ;;; A base structure for every single computation. Most of the
  98 ;;; computations are valued.
  99 (defstruct (node (:print-object generic-printer))
 100   ;; The next and the prev slots are the next nodes and the previous
 101   ;; node in the basic block sequence respectively.
 102   next prev
 103   ;; Lvar which stands for the result of the computation of this node.
 104   lvar)
 105
 106 ;;; Sentinel nodes in the basic block sequence of nodes.
 107 (defstruct (block-entry (:include node)))
 108 (defstruct (block-exit (:include node)))
 109
 110 ;;; A reference to a leaf (variable, constant and functions). The
 111 ;;; meaning of this node is leaving the leaf into the lvar of the
 112 ;;; node.
 113 (defstruct (ref (:include node))
 114   leaf)
 115
 116 ;;; An assignation of the LVAR VALUE into the var VARIABLE.
 117 (defstruct (assignment (:include node))
 118   variable
 119   value)
 120
 121 ;;; A base node to function calls with a list of lvar as ARGUMENTS.
 122 (defstruct (combination (:include node) (:constructor))
 123   arguments)
 124
 125 ;;; A function call to the ordinary Lisp function in the lvar FUNCTION.
 126 (defstruct (call (:include combination))
 127   function)
 128
 129 ;;; A function call to the primitive FUNCTION.
 130 (defstruct (primitive-call (:include combination))
 131   function)
 132
 133
 134 ;;; A conditional branch. If the LVAR is not NIL, then we will jump to
 135 ;;; the basic block CONSEQUENT, jumping to ALTERNATIVE otherwise. By
 136 ;;; definition, a conditional must appear at the end of a basic block.
 137 (defstruct (conditional (:include node))
 138   test
 139   consequent
 140   alternative)
 141
 142
 143
 144 ;;; Blocks are `basic block`. Basic blocks are organized as a control
 145 ;;; flow graph with some more information in omponents.
 146 (defstruct (basic-block
 147              (:conc-name "BLOCK-")
 148              (:constructor make-block)
 149              (:predicate block-p)
 150              (:print-object generic-printer))
 151   (id (generate-id 'basic-block))
 152   ;; List of successors and predecessors of this basic block. They are
 153   ;; null only for deleted blocks and component's entry and exit.
 154   succ pred
 155   ;; The sentinel nodes of the sequence.
 156   entry exit
 157   ;; The component where the basic block belongs to.
 158   component
 159   ;; The order in the reverse post ordering of the blocks.
 160   order
 161   ;; A bit-vector representing the set of dominators. See the function
 162   ;; `compute-dominators' to know how to use it properly.
 163   dominators%
 164   ;; Arbitrary data which could be necessary to keep during IR
 165   ;; processing.
 166   data)
 167
 168 ;;; Sentinel nodes in the control flow graph of basic blocks.
 169 (defstruct (component-entry (:include basic-block)))
 170 (defstruct (component-exit (:include basic-block)))
 171
 172 ;;; Return T if B is an empty basic block and NIL otherwise.
 173 (defun empty-block-p (b)
 174   (block-exit-p (node-next (block-entry b))))
 175
 176 (defun boundary-block-p (block)
 177   (or (component-entry-p block)
 178       (component-exit-p block)))
 179
 180 ;;; Iterate across the nodes in a basic block forward.
 181 (defmacro do-nodes
 182     ((node block &optional result &key include-sentinel-p) &body body)
 183   `(do ((,node ,(if include-sentinel-p
 184                     `(block-entry ,block)
 185                     `(node-next (block-entry ,block)))
 186                (node-next ,node)))
 187        (,(if include-sentinel-p
 188              `(null ,node)
 189              `(block-exit-p ,node))
 190         ,result)
 191      ,@body))
 192
 193 ;;; Iterate across the nodes in a basic block backward.
 194 (defmacro do-nodes-backward
 195     ((node block &optional result &key include-sentinel-p) &body body)
 196   `(do ((,node ,(if include-sentinel-p
 197                     `(block-exit ,block)
 198                     `(node-prev (block-entry ,block)))
 199                (node-prev ,node)))
 200        (,(if include-sentinel-p
 201              `(null ,node)
 202              `(block-entry-p ,node))
 203         ,result)
 204      ,@body))
 205
 206 ;;; Link FROM and TO nodes together. FROM and TO must belong to the
 207 ;;; same basic block and appear in such order. The nodes between FROM
 208 ;;; and TO are discarded.
 209 (defun link-nodes (from to)
 210   (setf (node-next from) to
 211         (node-prev to) from)
 212   (values))
 213
 214
 215 ;;; Components are connected pieces of the control flow graph of
 216 ;;; basic blocks with some additional information. Components have
 217 ;;; well-defined entry and exit nodes. It is the toplevel
 218 ;;; organizational entity in the compiler. The IR translation result
 219 ;;; is accumulated into components incrementally.
 220 (defstruct (component (:print-object generic-printer))
 221   (id (generate-id 'component))
 222   name
 223   entry
 224   exit
 225   functions
 226   ;; TODO: Replace with a flags slot for indicate what
 227   ;; analysis/transformations have been carried out.
 228   reverse-post-order-p
 229   blocks)
 230
 231 ;;; The current component.
 232 (defvar *component*)
 233
 234 ;;; Create a new fresh empty basic block in the current component.
 235 (defun make-empty-block ()
 236   (let ((entry (make-block-entry))
 237         (exit (make-block-exit)))
 238     (link-nodes entry exit)
 239     (let ((block (make-block :entry entry :exit exit :component *component*)))
 240       (push block (component-blocks *component*))
 241       block)))
 242
 243 ;;; Create a new component with an empty basic block, ready to start
 244 ;;; conversion to IR. It returns the component and the basic block as
 245 ;;; multiple values.
 246 (defun make-empty-component (&optional name)
 247   (let ((*component* (make-component :name name)))
 248     (let ((entry (make-component-entry :component *component*))
 249           (exit (make-component-exit :component *component*))
 250           (block (make-empty-block)))
 251       (setf (block-succ entry) (list block)
 252             (block-pred exit)  (list block)
 253             (block-succ block) (list exit)
 254             (block-pred block) (list entry)
 255             (component-entry *component*) entry
 256             (component-exit  *component*) exit)
 257       (values *component* block))))
 258
 259 ;;; A few consistency checks in the IR useful for catching bugs.
 260 (defun check-ir-consistency (&optional (component *component*))
 261   (with-simple-restart (continue "Continue execution")
 262     (dolist (block (component-blocks component))
 263       (dolist (succ (block-succ block))
 264         (unless (find block (block-pred succ))
 265           (error "The block `~S' does not belong to the predecessors list of the its successor `~S'"
 266                  block succ))
 267         (unless (or (boundary-block-p succ) (find succ (component-blocks component)))
 268           (error "Block `~S' is reachable from its predecessor `~S' but it is not in the component `~S'"
 269                  succ block component)))
 270       (dolist (pred (block-pred block))
 271         (unless (find block (block-succ pred))
 272           (error "The block `~S' does not belong to the successors' list of its predecessor `~S'"
 273                  block pred))
 274         (unless (or (boundary-block-p pred) (find pred (component-blocks component)))
 275           (error "Block `~S' is reachable from its sucessor `~S' but it is not in the component `~S'"
 276                  pred block component))))))
 277
 278 ;;; Prepare a new component with a current empty block ready to start
 279 ;;; IR conversion bound in the current cursor. BODY is evaluated and
 280 ;;; the value of the last form is returned.
 281 (defmacro with-component-compilation ((&optional name) &body body)
 282   (with-gensyms (block)
 283     `(multiple-value-bind (*component* ,block)
 284          (make-empty-component ,name)
 285        (let ((*cursor* (cursor :block ,block)))
 286          ,@body))))
 287
 288 ;;; Call function for each reachable block in component in
 289 ;;; post-order. The consequences are unspecified if a block is
 290 ;;; FUNCTION modifies a block which has not been processed yet.
 291 (defun map-postorder-blocks (function component)
 292   (let ((seen nil))
 293     (labels ((compute-from (block)
 294                (unless (or (component-exit-p block) (find block seen))
 295                  (push block seen)
 296                  (dolist (successor (block-succ block))
 297                    (unless (component-exit-p block)
 298                      (compute-from successor)))
 299                  (funcall function block))))
 300       (compute-from (unlist (block-succ (component-entry component))))
 301       nil)))
 302
 303 ;;; Change all the predecessors of BLOCK to precede NEW-BLOCK
 304 ;;; instead. As consequence, BLOCK becomes unreachable.
 305 (defun replace-block (block new-block)
 306   (let ((predecessors (block-pred block)))
 307     (setf (block-pred block) nil)
 308     (dolist (pred predecessors)
 309       (pushnew pred (block-pred new-block))
 310       (setf (block-succ pred) (substitute new-block block (block-succ pred)))
 311       (unless (component-entry-p pred)
 312         (let ((last-node (node-prev (block-exit pred))))
 313           (when (conditional-p last-node)
 314             (macrolet ((replacef (place)
 315                          `(setf ,place (if (eq block ,place) new-block ,place))))
 316               (replacef (conditional-consequent last-node))
 317               (replacef (conditional-alternative last-node)))))))))
 318
 319 (defun delete-block (block)
 320   (when (boundary-block-p block)
 321     (error "Cannot delete entry or exit basic blocks."))
 322   (unless (null (cdr (block-succ block)))
 323     (error "Cannot delete a basic block with multiple successors."))
 324   ;; If the block has not successors, then it is already deleted. So
 325   ;; just skip it.
 326   (when (block-succ block)
 327     (let ((successor (unlist (block-succ block))))
 328       (replace-block block successor)
 329       ;; At this point, block is unreachable, however we could have
 330       ;; backreferences to it from its successors. Let's get rid of
 331       ;; them.
 332       (setf (block-pred successor) (remove block (block-pred successor)))
 333       (setf (block-succ block) nil))))
 334
 335
 336 ;;;; Cursors
 337 ;;;;
 338 ;;;; A cursor is a point between two nodes in some basic block in the
 339 ;;;; IR representation where manipulations can take place, similarly
 340 ;;;; to the cursors in text editing.
 341 ;;;;
 342 ;;;; Cursors cannot point to special component's entry and exit basic
 343 ;;;; blocks or after a conditional node. Conveniently, the `cursor'
 344 ;;;; function will signal an error if the cursor is not positioned
 345 ;;;; correctly, so the rest of the code does not need to check once
 346 ;;;; and again.
 347
 348 (defstruct cursor
 349   block next)
 350
 351 ;;; The current cursor. It is the default cursor for many functions
 352 ;;; which work on cursors.
 353 (defvar *cursor*)
 354
 355 ;;; Return the current basic block. It is to say, the basic block
 356 ;;; where the current cursor is pointint.
 357 (defun current-block ()
 358   (cursor-block *cursor*))
 359
 360 ;;; Create a cursor which points to the basic block BLOCK. If omitted,
 361 ;;; then the current block is used.
 362 ;;;
 363 ;;; The keywords AFTER and BEFORE specify the cursor will point after (or
 364 ;;; before) that node respectively. If none is specified, the cursor is
 365 ;;; created before the exit node in BLOCK. An error is signaled if both
 366 ;;; keywords are specified inconsistently, or if the nodes do not belong
 367 ;;; to BLOCK.
 368 ;;;
 369 ;;; AFTER and BEFORE could also be the special values :ENTRY and :EXIT,
 370 ;;; which stand for the entry and exit nodes of the block respectively.
 371 (defun cursor (&key (block (current-block))
 372                  (before nil before-p)
 373                  (after nil after-p))
 374   (when (boundary-block-p block)
 375     (error "Invalid cursor on special entry/exit basic block."))
 376   ;; Handle special values :ENTRY and :EXIT.
 377   (flet ((node-designator (x)
 378            (case x
 379              (:entry (block-entry block))
 380              (:exit  (block-exit block))
 381              (t x))))
 382     (setq before (node-designator before))
 383     (setq after  (node-designator after)))
 384   (let* ((next (or before (and after (node-next after)) (block-exit block)))
 385          (cursor (make-cursor :block block :next next)))
 386     (flet ((out-of-range-cursor ()
 387              (error "Out of range cursor."))
 388            (ambiguous-cursor ()
 389              (error "Ambiguous cursor specified between two non-adjacent nodes.")))
 390       (when (conditional-p (node-prev next))
 391         (error "Invalid cursor after conditional node."))
 392       (when (or (null next) (block-entry-p next))
 393         (out-of-range-cursor))
 394       (when (and before-p after-p (not (eq after before)))
 395         (ambiguous-cursor))
 396       (do-nodes-backward (node block (out-of-range-cursor) :include-sentinel-p t)
 397         (when (eq next node) (return))))
 398     cursor))
 399
 400 ;;; Accept a cursor specification just as described in `cursor'
 401 ;;; describing a position in the IR and modify destructively the
 402 ;;; current cursor to point there.
 403 (defun set-cursor (&rest cursor-spec)
 404   (let ((newcursor (apply #'cursor cursor-spec)))
 405     (setf (cursor-block *cursor*) (cursor-block newcursor))
 406     (setf (cursor-next *cursor*) (cursor-next newcursor))
 407     *cursor*))
 408
 409 ;;; Insert NODE at cursor.
 410 (defun insert-node (node &optional (cursor *cursor*))
 411   (link-nodes (node-prev (cursor-next cursor)) node)
 412   (link-nodes node (cursor-next cursor))
 413   t)
 414
 415 ;;; Split the block at CURSOR. The cursor will point to the end of the
 416 ;;; first basic block. Return the three basic blocks as multiple
 417 ;;; values.
 418 (defun split-block (&optional (cursor *cursor*))
 419   ;; <aaaaa|zzzzz>  ==>  <aaaaa|>--<zzzzz>
 420   (let* ((block (cursor-block cursor))
 421          (newexit (make-block-exit))
 422          (newentry (make-block-entry))
 423          (exit (block-exit block))
 424          (newblock (make-block :entry newentry
 425                                :exit exit
 426                                :pred (list block)
 427                                :succ (block-succ block)
 428                                :component *component*)))
 429     (insert-node newexit)
 430     (insert-node newentry)
 431     (setf (node-next newexit)  nil)
 432     (setf (node-prev newentry) nil)
 433     (setf (block-exit block) newexit)
 434     (setf (block-succ block) (list newblock))
 435     (dolist (succ (block-succ newblock))
 436       (setf (block-pred succ) (substitute newblock block (block-pred succ))))
 437     (set-cursor :block block :before newexit)
 438     (push newblock (component-blocks *component*))
 439     newblock))
 440
 441 ;;; Split the block at CURSOR if it is in the middle of it. The cursor
 442 ;;; will point to the end of the first basic block. Return the three
 443 ;;; basic blocks as multiple values.
 444 (defun maybe-split-block (&optional (cursor *cursor*))
 445   ;; If we are converting IR into the end of the basic block, it's
 446   ;; fine, we don't need to do anything.
 447   (unless (block-exit-p (cursor-next cursor))
 448     (split-block cursor)))
 449
 450
 451 ;;;; Lexical environment
 452 ;;;;
 453 ;;;; It keeps an association between names and the IR entities. It is
 454 ;;;; used to guide the translation from the Lisp source code to the
 455 ;;;; intermediate representation.
 456
 457 (defstruct binding
 458   name namespace type value)
 459
 460 (defvar *lexenv* nil)
 461
 462 (defun find-binding (name namespace)
 463   (find-if (lambda (b)
 464              (and (eq (binding-name b) name)
 465                   (eq (binding-namespace b) namespace)))
 466            *lexenv*))
 467
 468 (defun push-binding (name namespace value &optional type)
 469   (push (make-binding :name name
 470                       :namespace namespace
 471                       :type type
 472                       :value value)
 473         *lexenv*))
 474
 475
 476 ;;;; IR Translation
 477 ;;;;
 478 ;;;; This code covers the translation from Lisp source code to the
 479 ;;;; intermediate representation. The main entry point function to do
 480 ;;;; that is the `ir-convert' function, which dispatches to IR
 481 ;;;; translators. This function ss intended to do the initial
 482 ;;;; conversion as well as insert new IR code during optimizations.
 483
 484 ;;; A alist of IR translator functions.
 485 (defvar *ir-translator* nil)
 486
 487 ;;; Define a IR translator for NAME. LAMBDA-LIST is used to
 488 ;;; destructure the arguments of the form. Calling the local function
 489 ;;; `result-lvar' you can get the LVAR where the compilation of the
 490 ;;; expression should store the result of the evaluation.
 491 ;;;
 492 ;;; The cursor is granted to be at the end of a basic block with a
 493 ;;; unique successor, and so it should be when the translator returns.
 494 (defmacro define-ir-translator (name lambda-list &body body)
 495   (check-type name symbol)
 496   (let ((fname (intern (format nil "IR-CONVERT-~a" (string name)))))
 497     (with-gensyms (result form)
 498       `(progn
 499          (defun ,fname (,form ,result)
 500            (flet ((result-lvar () ,result))
 501              (declare (ignorable (function result-lvar)))
 502              (destructuring-bind ,lambda-list ,form
 503                ,@body)))
 504          (push (cons ',name #',fname) *ir-translator*)))))
 505
 506 ;;; Return the unique successor of the current block. If it is not
 507 ;;; unique signal an error.
 508 (defun next-block ()
 509   (unlist (block-succ (current-block))))
 510
 511 ;;; Set the next block of the current one.
 512 (defun (setf next-block) (new-value)
 513   (let ((block (current-block)))
 514     (dolist (succ (block-succ block))
 515       (setf (block-pred succ) (remove block (block-pred succ))))
 516     (setf (block-succ block) (list new-value))
 517     (push block (block-pred new-value))
 518     new-value))
 519
 520 (defun ir-convert-constant (form result)
 521   (let* ((leaf (make-constant :value form)))
 522     (insert-node (make-ref :leaf leaf :lvar result))))
 523
 524 (define-ir-translator quote (form)
 525   (ir-convert-constant form (result-lvar)))
 526
 527 (define-ir-translator setq (variable value)
 528   (let ((b (find-binding variable 'variable)))
 529     (cond
 530       (b
 531        (let ((var (make-var :name variable))
 532              (value-lvar (make-lvar)))
 533          (ir-convert value value-lvar)
 534          (let ((assign (make-assignment :variable var :value value-lvar :lvar (result-lvar))))
 535            (insert-node assign))))
 536       (t
 537        (ir-convert `(set ',variable ,value) (result-lvar))))))
 538
 539 (define-ir-translator progn (&body body)
 540   (mapc #'ir-convert (butlast body))
 541   (ir-convert (car (last body)) (result-lvar)))
 542
 543 (define-ir-translator if (test then &optional else)
 544   ;; It is the schema of how the basic blocks will look like
 545   ;;
 546   ;;              / ..then.. \
 547   ;;  <aaaaXX> --<            >-- <|> -- <zzzz>
 548   ;;              \ ..else.. /
 549   ;;
 550   ;; Note that is important to leave the cursor in an empty basic
 551   ;; block, as zzz could be the exit basic block of the component,
 552   ;; which is an invalid position for a cursor.
 553   (let ((test-lvar (make-lvar))
 554         (then-block (make-empty-block))
 555         (else-block (make-empty-block))
 556         (join-block (make-empty-block)))
 557     (ir-convert test test-lvar)
 558     (insert-node (make-conditional :test test-lvar :consequent then-block :alternative else-block))
 559     (let* ((block (current-block))
 560            (tail-block (next-block)))
 561       ;; Link together the different created basic blocks.
 562       (setf (block-succ block)      (list else-block then-block)
 563             (block-pred else-block) (list block)
 564             (block-pred then-block) (list block)
 565             (block-succ then-block) (list join-block)
 566             (block-succ else-block) (list join-block)
 567             (block-pred join-block) (list else-block then-block)
 568             (block-succ join-block) (list tail-block)
 569             (block-pred tail-block) (substitute join-block block (block-pred tail-block))))
 570     ;; Convert he consequent and alternative forms and update cursor.
 571     (ir-convert then (result-lvar) (cursor :block then-block))
 572     (ir-convert else (result-lvar) (cursor :block else-block))
 573     (set-cursor :block join-block)))
 574
 575 (define-ir-translator block (name &body body)
 576   (let ((new (split-block)))
 577     (push-binding name 'block (cons (next-block) (result-lvar)))
 578     (ir-convert `(progn ,@body) (result-lvar))
 579     (set-cursor :block new)))
 580
 581 (define-ir-translator return-from (name &optional value)
 582   (let ((binding
 583          (or (find-binding name 'block)
 584              (error "Tried to return from unknown block `~S' name" name))))
 585     (destructuring-bind (jump-block . lvar)
 586         (binding-value binding)
 587       (ir-convert value lvar)
 588       (setf (next-block) jump-block)
 589       ;; This block is really unreachable, even if the following code
 590       ;; is labelled in a tagbody, as tagbody will create a new block
 591       ;; for each label. However, we have to leave the cursor
 592       ;; somewhere to convert new input.
 593       (let ((dummy (make-empty-block)))
 594         (set-cursor :block dummy)))))
 595
 596 (define-ir-translator tagbody (&rest statements)
 597   (flet ((go-tag-p (x)
 598            (or (integerp x) (symbolp x))))
 599     (let* ((tags (remove-if-not #'go-tag-p statements))
 600            (tag-blocks nil))
 601       ;; Create a chain of basic blocks for the tags, recording each
 602       ;; block in a alist in TAG-BLOCKS.
 603       (let ((*cursor* *cursor*))
 604         (dolist (tag tags)
 605           (setq *cursor* (cursor :block (split-block)))
 606           (push-binding tag 'tag (current-block))
 607           (if (assoc tag tag-blocks)
 608               (error "Duplicated tag `~S' in tagbody." tag)
 609               (push (cons tag (current-block)) tag-blocks))))
 610       ;; Convert the statements into the correct block.
 611       (dolist (stmt statements)
 612         (if (go-tag-p stmt)
 613             (set-cursor :block (cdr (assoc stmt tag-blocks)))
 614             (ir-convert stmt))))))
 615
 616 (define-ir-translator go (label)
 617   (let ((tag-binding
 618          (or (find-binding label 'tag)
 619              (error "Unable to jump to the label `~S'" label))))
 620     (setf (next-block) (binding-value tag-binding))
 621     ;; Unreachable block.
 622     (let ((dummy (make-empty-block)))
 623       (set-cursor :block dummy))))
 624
 625
 626 (defun ir-convert-functoid (result name arguments &rest body)
 627   (let ((component)
 628         (return-lvar (make-lvar)))
 629     (with-component-compilation (name)
 630       (ir-convert `(progn ,@body) return-lvar)
 631       (ir-normalize)
 632       (setq component *component*))
 633     (let ((functional
 634            (make-functional
 635             :name name
 636             :arguments arguments
 637             :component component
 638             :return-lvar return-lvar)))
 639       (push functional (component-functions *component*))
 640       (insert-node (make-ref :leaf functional :lvar result)))))
 641
 642 (define-ir-translator function (name)
 643   (if (atom name)
 644       (ir-convert `(symbol-function ,name) (result-lvar))
 645       (ecase (car name)
 646         ((lambda named-lambda)
 647          (let ((desc (cdr name)))
 648            (when (eq 'lambda (car name))
 649              (push nil desc))
 650            (apply #'ir-convert-functoid (result-lvar) desc)))
 651         (setf))))
 652
 653 (defun ir-convert-var (form result)
 654   (let ((binds (find-binding form 'variable)))
 655     (if binds
 656         (insert-node (make-ref :leaf (binding-value binds) :lvar result))
 657         (ir-convert `(symbol-value ',form) result))))
 658
 659 (defun ir-convert-call (form result)
 660   (destructuring-bind (function &rest args) form
 661     (let ((func-lvar (make-lvar))
 662           (args-lvars nil))
 663       ;; Argument list
 664       (dolist (arg args)
 665         (let ((arg-lvar (make-lvar)))
 666           (push arg-lvar args-lvars)
 667           (ir-convert arg arg-lvar)))
 668       (setq args-lvars (reverse args-lvars))
 669       ;; Funcall
 670       (if (find-primitive function)
 671           (insert-node (make-primitive-call
 672                         :function (find-primitive function)
 673                         :arguments args-lvars
 674                         :lvar result))
 675           (progn
 676             (ir-convert `(symbol-function ,function) func-lvar)
 677             (insert-node (make-call :function func-lvar
 678                                     :arguments args-lvars
 679                                     :lvar result)))))))
 680
 681 ;;; Convert the Lisp expression FORM, it may create new basic
 682 ;;; blocks. RESULT is the lvar representing the result of the
 683 ;;; computation or null if the value should be discarded. The IR is
 684 ;;; inserted at *CURSOR*.
 685 (defun ir-convert (form &optional result (*cursor* *cursor*))
 686   ;; Rebinding the lexical environment here we make sure that the
 687   ;; lexical information introduced by FORM is just available for
 688   ;; subforms.
 689   (let ((*lexenv* *lexenv*))
 690     ;; Possibly create additional blocks in order to make sure the
 691     ;; cursor is at end the end of a basic block.
 692     (maybe-split-block)
 693     (cond
 694       ((atom form)
 695        (cond
 696          ((symbolp form)
 697           (ir-convert-var form result))
 698          (t
 699           (ir-convert-constant form result))))
 700       (t
 701        (destructuring-bind (op &rest args) form
 702          (let ((translator (cdr (assoc op *ir-translator*))))
 703            (if translator
 704                (funcall translator args result)
 705                (ir-convert-call form result))))))
 706     (values)))
 707
 708
 709 ;;;; IR Normalization
 710 ;;;;
 711 ;;;; IR as generated by `ir-convert' or after some transformations is
 712 ;;;; not appropiated. Here, we remove unreachable and empty blocks and
 713 ;;;; coallesce blocks when it is possible.
 714
 715 ;;; Try to coalesce BLOCK with the successor if it is unique and block
 716 ;;; is its unique predecessor.
 717 (defun maybe-coalesce-block (block)
 718   (when (singlep (block-succ block))
 719     (let ((succ (first (block-succ block))))
 720       (when (and (not (component-exit-p succ)) (singlep (block-pred succ)))
 721         (link-nodes (node-prev (block-exit block))
 722                     (node-next (block-entry succ)))
 723         (setf (block-exit block) (block-exit succ))
 724         (setf (block-succ block) (block-succ succ))
 725         (dolist (next (block-succ succ))
 726           (setf (block-pred next) (substitute block succ (block-pred next))))
 727         (setf (block-succ succ) nil
 728               (block-pred succ) nil)
 729         t))))
 730
 731 ;;; Normalize a component. This function must be called after a batch
 732 ;;; of modifications to the flowgraph of the component to make sure it
 733 ;;; is a valid input for the possible optimizations and the backend.
 734 (defun ir-normalize (&optional (component *component*))
 735   ;; Initialize blocks as unreachables and remove empty basic blocks.
 736   (dolist (block (component-blocks component))
 737     (setf (block-data block) 'unreachable))
 738   ;; Coalesce and mark blocks as reachable.
 739   (map-postorder-blocks
 740    (lambda (block)
 741      (maybe-coalesce-block block)
 742      (setf (block-data block) 'reachable))
 743    component)
 744   (let ((block-list nil))
 745     (dolist (block (component-blocks component))
 746       (cond
 747         ;; If the block is unreachable, but it is predeces a reachable
 748         ;; one, then break the link between them. So we discard it
 749         ;; from the flowgraph.
 750         ((eq (block-data block) 'unreachable)
 751          (setf (block-succ block) nil)
 752          (dolist (succ (block-succ block))
 753            (when (eq (block-data succ) 'reachable)
 754              (remove block (block-pred succ)))))
 755         ;; Delete empty blocks
 756         ((empty-block-p block)
 757          (delete-block block))
 758         ;; The rest of blocks remain in the component.
 759         (t
 760          (push block block-list))))
 761     (setf (component-blocks component) block-list))
 762   (check-ir-consistency))
 763
 764
 765 ;;;; IR Analysis
 766 ;;;;
 767 ;;;; Once IR conversion has been finished. We do some analysis of the
 768 ;;;; component to produce information which is useful for both
 769 ;;;; optimizations and code generation. Indeed, we provide some
 770 ;;;; abstractions to use this information.
 771
 772 (defun compute-reverse-post-order (component)
 773   (let ((output nil)
 774         (count 0))
 775     (flet ((add-block-to-list (block)
 776              (push block output)
 777              (setf (block-order block) (incf count))))
 778       (map-postorder-blocks #'add-block-to-list component))
 779     (setf (component-reverse-post-order-p component) t)
 780     (setf (component-blocks component) output)))
 781
 782 ;;; Iterate across blocks in COMPONENT in reverse post order.
 783 (defmacro do-blocks-forward ((block component &optional result) &body body)
 784   (with-gensyms (g!component)
 785     `(let ((,g!component ,component))
 786        (dolist (,block (if (component-reverse-post-order-p ,g!component)
 787                            (component-blocks ,g!component)
 788                            (error "reverse post order was not computed yet."))
 789                  ,result)
 790          ,@body))))
 791
 792 ;;; Iterate across blocks in COMPONENT in post order.
 793 (defmacro do-blocks-backward ((block component &optional result) &body body)
 794   (with-gensyms (g!component)
 795     `(let ((,g!component ,component))
 796        (dolist (,block (if (component-reverse-post-order-p ,g!component)
 797                            (reverse (component-blocks ,g!component))
 798                            (error "reverse post order was not computed yet."))
 799                  ,result)
 800          ,@body))))
 801
 802 (defun compute-dominators (component)
 803   ;; Initialize the dominators of the entry to the component to be
 804   ;; empty and the power set of the set of blocks for proper basic
 805   ;; blocks in the component.
 806   (let ((n (length (component-blocks component))))
 807     ;; The component entry special block has not predecessors in the
 808     ;; set of (proper) basic blocks.
 809     (setf (block-dominators% (component-entry component))
 810           (make-array n :element-type 'bit :initial-element 0))
 811     (dolist (block (component-blocks component))
 812       (setf (block-dominators% block) (make-array n :element-type 'bit :initial-element 1))))
 813   ;; Iterate across the blocks in the component removing non domintors
 814   ;; until it reaches a fixed point.
 815   (do ((i 0 0)
 816        (iteration 0 (1+ iteration))
 817        (changes t))
 818       ((not changes))
 819     (setf changes nil)
 820     (do-blocks-forward (block component)
 821       (let* ((predecessors (block-pred block)))
 822         (bit-and (block-dominators% block) (block-dominators% (first predecessors)) t)
 823         (dolist (pred (rest predecessors))
 824           (bit-and (block-dominators% block) (block-dominators% pred) t))
 825         (setf (aref (block-dominators% block) i) 1)
 826         (setf changes (or changes (not (equal (block-dominators% block) (block-dominators% block)))))
 827         (incf i)))))
 828
 829 ;;; Return T if BLOCK1 dominates BLOCK2, else return NIL.
 830 (defun dominate-p (block1 block2)
 831   (let ((order (block-order block1)))
 832     (= 1 (aref (block-dominators% block2) order))))
 833
 834
 835 ;;;; IR Debugging
 836 ;;;;
 837 ;;;; This section provides a function `/print' which write a textual
 838 ;;;; representation of a component to the standard output. Also, a
 839 ;;;; `/ir' macro is provided, which takes a form, convert it to IR and
 840 ;;;; then print the component as above.  They are useful commands if
 841 ;;;; you are hacking the front-end of the compiler.
 842 ;;;;
 843
 844 (defun format-block-name (block)
 845   (cond
 846     ((eq block (unlist (block-succ (component-entry (block-component block)))))
 847      (format nil "ENTRY-~a" (component-id (block-component block))))
 848     ((component-exit-p block)
 849      (format nil "EXIT-~a" (component-id (block-component block))))
 850     (t
 851      (format nil "BLOCK ~a" (block-id block)))))
 852
 853
 854 (defun print-node (node)
 855   (when (node-lvar node)
 856     (format t "$~a = " (lvar-id (node-lvar node))))
 857   (cond
 858     ((ref-p node)
 859      (let ((leaf (ref-leaf node)))
 860        (cond
 861          ((var-p leaf)
 862           (format t "~a" (var-name leaf)))
 863          ((constant-p leaf)
 864           (format t "'~s" (constant-value leaf)))
 865          ((functional-p leaf)
 866           (format t "#<function ~a>" (functional-name leaf))))))
 867     ((assignment-p node)
 868      (format t "set ~a $~a"
 869              (var-name (assignment-variable node))
 870              (lvar-id (assignment-value node))))
 871     ((primitive-call-p node)
 872      (format t "primitive ~a" (primitive-name (primitive-call-function node)))
 873      (dolist (arg (primitive-call-arguments node))
 874        (format t " $~a" (lvar-id arg))))
 875     ((call-p node)
 876      (format t "call $~a" (lvar-id (call-function node)))
 877      (dolist (arg (call-arguments node))
 878        (format t " $~a" (lvar-id arg))))
 879     ((conditional-p node)
 880      (format t "if $~a then ~a else ~a~%"
 881              (lvar-id (conditional-test node))
 882              (format-block-name (conditional-consequent node))
 883              (format-block-name (conditional-alternative node))))
 884     (t
 885      (error "`print-node' does not support printing ~S as a node." node)))
 886   (terpri))
 887
 888 (defun print-block (block)
 889   (write-line (format-block-name block))
 890   (do-nodes (node block)
 891     (print-node node))
 892   (when (singlep (block-succ block))
 893     (format t "GO ~a~%~%" (format-block-name (unlist (block-succ block))))))
 894
 895 (defun /print (component &optional (stream *standard-output*))
 896   (format t ";;; COMPONENT ~a (~a) ~%~%" (component-name component) (component-id component))
 897   (let ((*standard-output* stream))
 898     (do-blocks-forward (block component)
 899       (print-block block)))
 900   (format t ";;; END COMPONENT ~a ~%~%" (component-name component))
 901   (let ((*standard-output* stream))
 902     (dolist (func (component-functions component))
 903       (/print (functional-component func)))))
 904
 905 ;;; Translate FORM into IR and print a textual repreresentation of the
 906 ;;; component.
 907 (defun convert-toplevel-and-print (form)
 908   (let ((*counter-alist* nil))
 909     (with-component-compilation ('toplevel)
 910       (ir-convert form (make-lvar :id "out"))
 911       (ir-normalize)
 912       (compute-reverse-post-order *component*)
 913       (/print *component*)
 914       *component*)))
 915
 916 (defmacro /ir (form)
 917   `(convert-toplevel-and-print ',form))
 918
 919
 920
 921 ;;;; Primitives
 922 ;;;;
 923 ;;;; Primitive functions are a set of functions provided by the
 924 ;;;; compiler. They cannot usually be written in terms of other
 925 ;;;; functions. When the compiler tries to compile a function call, it
 926 ;;;; looks for a primitive function firstly, and if it is found and
 927 ;;;; the declarations allow it, a primitive call is inserted in the
 928 ;;;; IR. The back-end of the compiler knows how to compile primitive
 929 ;;;; calls.
 930 ;;;;
 931
 932 (defvar *primitive-function-table* nil)
 933
 934 (defstruct primitive
 935   name)
 936
 937 (defmacro define-primitive (name args &body body)
 938   (declare (ignore args body))
 939   `(push (make-primitive :name ',name)
 940          *primitive-function-table*))
 941
 942 (defun find-primitive (name)
 943   (find name *primitive-function-table* :key #'primitive-name))
 944
 945 (define-primitive symbol-function (symbol))
 946 (define-primitive symbol-value (symbol))
 947 (define-primitive set (symbol value))
 948 (define-primitive fset (symbol value))
 949
 950 (define-primitive + (&rest numbers))
 951 (define-primitive - (number &rest other-numbers))
 952
 953 (define-primitive consp (x))
 954 (define-primitive cons (x y))
 955 (define-primitive car (x))
 956 (define-primitive cdr (x))
 957
 958
 959 ;;; compiler.lisp ends here