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