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