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 (defmacro while (condition &body body)
  53   `(do nil ((not ,condition)) ,@body))
  54
  55 ;;;; Intermediate representation structures
  56 ;;;;
  57 ;;;; This intermediate representation (IR) is a simplified version of
  58 ;;;; the first intermediate representation what you will find if you
  59 ;;;; have a look to the source code of SBCL. Some terminology is also
  60 ;;;; used, but other is changed, so be careful if you assume you know
  61 ;;;; what it is because you know the name.
  62 ;;;;
  63 ;;;; Computations are represented by `node'.  Nodes are grouped
  64 ;;;; sequencially into `basic-block'. It is a plain representation
  65 ;;;; rather than a nested one. Computations take data and produce a
  66 ;;;; value. Both data transfer are represented by `lvar'.
  67
  68 (defstruct leaf)
  69
  70 ;;; A (lexical) variable. Special variables has not a special
  71 ;;; representation in the IR. They are handled by the primitive
  72 ;;; functions `%symbol-function' and `%symbol-value'.
  73 (defstruct (var (:include leaf))
  74   ;; The symbol which names this variable in the source code.
  75   name)
  76
  77 ;;; A literal Lisp object. It usually comes from a quoted expression.
  78 (defstruct (constant (:include leaf))
  79   ;; The object itself.
  80   value)
  81
  82 ;;; A lambda expression. Why do we name it `functional'? Well,
  83 ;;; function is reserved by ANSI, isn't it?
  84 (defstruct (functional (:include leaf) (:print-object generic-printer))
  85   ;; The symbol which names this function in the source code or null
  86   ;; if we do not know or it is an anonymous function.
  87   name
  88   arguments
  89   return-lvar
  90   component)
  91
  92 ;;; An abstract place where the result of a computation is stored and
  93 ;;; it can be referenced from other nodes, so lvars are responsible
  94 ;;; for keeping the necessary information of the nested structure of
  95 ;;; the code in this plain representation.
  96 (defstruct lvar
  97   (id (generate-id 'lvar)))
  98
  99 ;;; A base structure for every single computation. Most of the
 100 ;;; computations are valued.
 101 (defstruct (node (:print-object generic-printer))
 102   ;; The next and the prev slots are the next nodes and the previous
 103   ;; node in the basic block sequence respectively.
 104   next prev
 105   ;; Lvar which stands for the result of the computation of this node.
 106   lvar)
 107
 108 ;;; Sentinel nodes in the basic block sequence of nodes.
 109 (defstruct (block-entry (:include node)))
 110 (defstruct (block-exit (:include node)))
 111
 112 ;;; A reference to a leaf (variable, constant and functions). The
 113 ;;; meaning of this node is leaving the leaf into the lvar of the
 114 ;;; node.
 115 (defstruct (ref (:include node))
 116   leaf)
 117
 118 ;;; An assignation of the LVAR VALUE into the var VARIABLE.
 119 (defstruct (assignment (:include node))
 120   variable
 121   value)
 122
 123 ;;; A base node to function calls with a list of lvar as ARGUMENTS.
 124 (defstruct (combination (:include node) (:constructor))
 125   arguments)
 126
 127 ;;; A function call to the ordinary Lisp function in the lvar FUNCTION.
 128 (defstruct (call (:include combination))
 129   function)
 130
 131 ;;; A function call to the primitive FUNCTION.
 132 (defstruct (primitive-call (:include combination))
 133   function)
 134
 135 ;;; A conditional branch. If the LVAR is not NIL, then we will jump to
 136 ;;; the basic block CONSEQUENT, jumping to ALTERNATIVE otherwise. By
 137 ;;; definition, a conditional must appear at the end of a basic block.
 138 (defstruct (conditional (:include node))
 139   test
 140   consequent
 141   alternative)
 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   ;; List of successors and predecessors of this basic block. They are
 152   ;; null only for deleted blocks and component's entry and exit.
 153   succ pred
 154   ;; The sentinel nodes of the sequence.
 155   entry exit
 156   ;; The component where the basic block belongs to.
 157   component
 158   ;; The order in the reverse post ordering of the blocks.
 159   order
 160   ;; The innermost loop this block belongs to.
 161   loop
 162   ;; A bit-vector representing the set of dominators. See the function
 163   ;; `compute-dominators' to know how to use it properly.
 164   dominators%
 165   ;; Arbitrary data which could be necessary to keep during IR
 166   ;; processing.
 167   data)
 168
 169 ;;; Sentinel nodes in the control flow graph of basic blocks.
 170 (defstruct (component-entry (:include basic-block)))
 171 (defstruct (component-exit (:include basic-block)))
 172
 173 ;;; Return T if B is an empty basic block and NIL otherwise.
 174 (defun empty-block-p (b)
 175   (or (boundary-block-p b)
 176       (block-exit-p (node-next (block-entry b)))))
 177
 178 (defun boundary-block-p (block)
 179   (or (component-entry-p block)
 180       (component-exit-p block)))
 181
 182 ;;; Iterate across the nodes in a basic block forward.
 183 (defmacro do-nodes
 184     ((node block &optional result &key include-sentinel-p) &body body)
 185   `(do ((,node ,(if include-sentinel-p
 186                     `(block-entry ,block)
 187                     `(node-next (block-entry ,block)))
 188                (node-next ,node)))
 189        (,(if include-sentinel-p
 190              `(null ,node)
 191              `(block-exit-p ,node))
 192         ,result)
 193      ,@body))
 194
 195 ;;; Iterate across the nodes in a basic block backward.
 196 (defmacro do-nodes-backward
 197     ((node block &optional result &key include-sentinel-p) &body body)
 198   `(do ((,node ,(if include-sentinel-p
 199                     `(block-exit ,block)
 200                     `(node-prev (block-entry ,block)))
 201                (node-prev ,node)))
 202        (,(if include-sentinel-p
 203              `(null ,node)
 204              `(block-entry-p ,node))
 205         ,result)
 206      ,@body))
 207
 208 ;;; Link FROM and TO nodes together. FROM and TO must belong to the
 209 ;;; same basic block and appear in such order. The nodes between FROM
 210 ;;; and TO are discarded.
 211 (defun link-nodes (from to)
 212   (setf (node-next from) to
 213         (node-prev to) from)
 214   (values))
 215
 216
 217 ;;; Components are connected pieces of the control flow graph of
 218 ;;; basic blocks with some additional information. Components have
 219 ;;; well-defined entry and exit nodes. It is the toplevel
 220 ;;; organizational entity in the compiler. The IR translation result
 221 ;;; is accumulated into components incrementally.
 222 (defstruct (component (:print-object generic-printer))
 223   (id (generate-id 'component))
 224   name
 225   entry
 226   exit
 227   functions
 228   ;; TODO: Replace with a flags slot for indicate what
 229   ;; analysis/transformations have been carried out.
 230   reverse-post-order-p
 231   ;; List of natural loops in this component.
 232   loops
 233   blocks)
 234
 235 ;;; The current component.
 236 (defvar *component*)
 237
 238 ;;; Create a new fresh empty basic block in the current component.
 239 (defun make-empty-block ()
 240   (let ((entry (make-block-entry))
 241         (exit (make-block-exit)))
 242     (link-nodes entry exit)
 243     (let ((block (make-block :entry entry :exit exit :component *component*)))
 244       (push block (component-blocks *component*))
 245       block)))
 246
 247 ;;; Create a new component with an empty basic block, ready to start
 248 ;;; conversion to IR. It returns the component and the basic block as
 249 ;;; multiple values.
 250 (defun make-empty-component (&optional name)
 251   (let ((*component* (make-component :name name)))
 252     (let ((entry (make-component-entry :component *component*))
 253           (exit (make-component-exit :component *component*))
 254           (block (make-empty-block)))
 255       (push entry (component-blocks *component*))
 256       (push exit (component-blocks *component*))
 257       (setf (block-succ entry) (list block)
 258             (block-pred exit)  (list block)
 259             (block-succ block) (list exit)
 260             (block-pred block) (list entry)
 261             (component-entry *component*) entry
 262             (component-exit  *component*) exit)
 263       (values *component* block))))
 264
 265 ;;; A few consistency checks in the IR useful for catching bugs.
 266 (defun check-ir-consistency (&optional (component *component*))
 267   (with-simple-restart (continue "Continue execution")
 268     (dolist (block (component-blocks component))
 269       (dolist (succ (block-succ block))
 270         (unless (find block (block-pred succ))
 271           (error "The block `~S' does not belong to the predecessors list of the its successor `~S'"
 272                  block succ))
 273         (unless (or (boundary-block-p succ) (find succ (component-blocks component)))
 274           (error "Block `~S' is reachable from its predecessor `~S' but it is not in the component `~S'"
 275                  succ block component)))
 276       (dolist (pred (block-pred block))
 277         (unless (find block (block-succ pred))
 278           (error "The block `~S' does not belong to the successors' list of its predecessor `~S'"
 279                  block pred))
 280         (unless (or (boundary-block-p pred) (find pred (component-blocks component)))
 281           (error "Block `~S' is reachable from its sucessor `~S' but it is not in the component `~S'"
 282                  pred block component))))))
 283
 284 ;;; Prepare a new component with a current empty block ready to start
 285 ;;; IR conversion bound in the current cursor. BODY is evaluated and
 286 ;;; the value of the last form is returned.
 287 (defmacro with-component-compilation ((&optional name) &body body)
 288   (with-gensyms (block)
 289     `(multiple-value-bind (*component* ,block)
 290          (make-empty-component ,name)
 291        (let ((*cursor* (cursor :block ,block)))
 292          ,@body))))
 293
 294 ;;; Call function for each reachable block in component in
 295 ;;; post-order. The consequences are unspecified if a block is
 296 ;;; FUNCTION modifies a block which has not been processed yet.
 297 (defun map-postorder-blocks (function component)
 298   (let ((seen nil))
 299     (labels ((compute-from (block)
 300                (unless (find block seen)
 301                  (push block seen)
 302                  (dolist (successor (block-succ block))
 303                    (unless (component-exit-p block)
 304                      (compute-from successor)))
 305                  (funcall function block))))
 306       (compute-from (component-entry component))
 307       nil)))
 308
 309 ;;; Change all the predecessors of BLOCK to precede NEW-BLOCK
 310 ;;; instead. As consequence, BLOCK becomes unreachable.
 311 (defun replace-block (block new-block)
 312   (let ((predecessors (block-pred block)))
 313     (setf (block-pred block) nil)
 314     (dolist (pred predecessors)
 315       (pushnew pred (block-pred new-block))
 316       (setf (block-succ pred) (remove block (block-succ pred)))
 317       (pushnew new-block (block-succ pred))
 318       (unless (component-entry-p pred)
 319         (let ((last-node (node-prev (block-exit pred))))
 320           (when (conditional-p last-node)
 321             (macrolet ((replacef (place)
 322                          `(setf ,place (if (eq block ,place) new-block ,place))))
 323               (replacef (conditional-consequent last-node))
 324               (replacef (conditional-alternative last-node)))))))))
 325
 326 (defun delete-block (block)
 327   (when (boundary-block-p block)
 328     (error "Cannot delete entry or exit basic blocks."))
 329   (unless (null (cdr (block-succ block)))
 330     (error "Cannot delete a basic block with multiple successors."))
 331   ;; If the block has not successors, then it is already deleted. So
 332   ;; just skip it.
 333   (when (block-succ block)
 334     (let ((successor (unlist (block-succ block))))
 335       (replace-block block successor)
 336       ;; At this point, block is unreachable, however we could have
 337       ;; backreferences to it from its successors. Let's get rid of
 338       ;; them.
 339       (setf (block-pred successor) (remove block (block-pred successor)))
 340       (setf (block-succ block) nil))))
 341
 342
 343 ;;;; Cursors
 344 ;;;;
 345 ;;;; A cursor is a point between two nodes in some basic block in the
 346 ;;;; IR representation where manipulations can take place, similarly
 347 ;;;; to the cursors in text editing.
 348 ;;;;
 349 ;;;; Cursors cannot point to special component's entry and exit basic
 350 ;;;; blocks or after a conditional node. Conveniently, the `cursor'
 351 ;;;; function will signal an error if the cursor is not positioned
 352 ;;;; correctly, so the rest of the code does not need to check once
 353 ;;;; and again.
 354
 355 (defstruct cursor
 356   block next)
 357
 358 ;;; The current cursor. It is the default cursor for many functions
 359 ;;; which work on cursors.
 360 (defvar *cursor*)
 361
 362 ;;; Return the current basic block. It is to say, the basic block
 363 ;;; where the current cursor is pointint.
 364 (defun current-block ()
 365   (cursor-block *cursor*))
 366
 367 ;;; Create a cursor which points to the basic block BLOCK. If omitted,
 368 ;;; then the current block is used.
 369 ;;;
 370 ;;; The keywords AFTER and BEFORE specify the cursor will point after (or
 371 ;;; before) that node respectively. If none is specified, the cursor is
 372 ;;; created before the exit node in BLOCK. An error is signaled if both
 373 ;;; keywords are specified inconsistently, or if the nodes do not belong
 374 ;;; to BLOCK.
 375 ;;;
 376 ;;; AFTER and BEFORE could also be the special values :ENTRY and :EXIT,
 377 ;;; which stand for the entry and exit nodes of the block respectively.
 378 (defun cursor (&key (block (current-block))
 379                  (before nil before-p)
 380                  (after nil after-p))
 381   (when (boundary-block-p block)
 382     (error "Invalid cursor on special entry/exit basic block."))
 383   ;; Handle special values :ENTRY and :EXIT.
 384   (flet ((node-designator (x)
 385            (case x
 386              (:entry (block-entry block))
 387              (:exit  (block-exit block))
 388              (t x))))
 389     (setq before (node-designator before))
 390     (setq after  (node-designator after)))
 391   (let* ((next (or before (and after (node-next after)) (block-exit block)))
 392          (cursor (make-cursor :block block :next next)))
 393     (flet ((out-of-range-cursor ()
 394              (error "Out of range cursor."))
 395            (ambiguous-cursor ()
 396              (error "Ambiguous cursor specified between two non-adjacent nodes.")))
 397       (when (conditional-p (node-prev next))
 398         (error "Invalid cursor after conditional node."))
 399       (when (or (null next) (block-entry-p next))
 400         (out-of-range-cursor))
 401       (when (and before-p after-p (not (eq after before)))
 402         (ambiguous-cursor))
 403       (do-nodes-backward (node block (out-of-range-cursor) :include-sentinel-p t)
 404         (when (eq next node) (return))))
 405     cursor))
 406
 407 ;;; Accept a cursor specification just as described in `cursor'
 408 ;;; describing a position in the IR and modify destructively the
 409 ;;; current cursor to point there.
 410 (defun set-cursor (&rest cursor-spec)
 411   (let ((newcursor (apply #'cursor cursor-spec)))
 412     (setf (cursor-block *cursor*) (cursor-block newcursor))
 413     (setf (cursor-next *cursor*) (cursor-next newcursor))
 414     *cursor*))
 415
 416 ;;; Insert NODE at cursor.
 417 (defun insert-node (node &optional (cursor *cursor*))
 418   (link-nodes (node-prev (cursor-next cursor)) node)
 419   (link-nodes node (cursor-next cursor))
 420   t)
 421
 422 ;;; Split the block at CURSOR. The cursor will point to the end of the
 423 ;;; first basic block. Return the three basic blocks as multiple
 424 ;;; values.
 425 (defun split-block (&optional (cursor *cursor*))
 426   ;; <aaaaa|zzzzz>  ==>  <aaaaa|>--<zzzzz>
 427   (let* ((block (cursor-block cursor))
 428          (newexit (make-block-exit))
 429          (newentry (make-block-entry))
 430          (exit (block-exit block))
 431          (newblock (make-block :entry newentry
 432                                :exit exit
 433                                :pred (list block)
 434                                :succ (block-succ block)
 435                                :component *component*)))
 436     (insert-node newexit)
 437     (insert-node newentry)
 438     (setf (node-next newexit)  nil)
 439     (setf (node-prev newentry) nil)
 440     (setf (block-exit block) newexit)
 441     (setf (block-succ block) (list newblock))
 442     (dolist (succ (block-succ newblock))
 443       (setf (block-pred succ) (substitute newblock block (block-pred succ))))
 444     (set-cursor :block block :before newexit)
 445     (push newblock (component-blocks *component*))
 446     newblock))
 447
 448 ;;; Split the block at CURSOR if it is in the middle of it. The cursor
 449 ;;; will point to the end of the first basic block. Return the three
 450 ;;; basic blocks as multiple values.
 451 (defun maybe-split-block (&optional (cursor *cursor*))
 452   ;; If we are converting IR into the end of the basic block, it's
 453   ;; fine, we don't need to do anything.
 454   (unless (block-exit-p (cursor-next cursor))
 455     (split-block cursor)))
 456
 457
 458 ;;;; Lexical environment
 459 ;;;;
 460 ;;;; It keeps an association between names and the IR entities. It is
 461 ;;;; used to guide the translation from the Lisp source code to the
 462 ;;;; intermediate representation.
 463
 464 (defstruct binding
 465   name namespace type value)
 466
 467 (defvar *lexenv* nil)
 468
 469 (defun find-binding (name namespace)
 470   (find-if (lambda (b)
 471              (and (eq (binding-name b) name)
 472                   (eq (binding-namespace b) namespace)))
 473            *lexenv*))
 474
 475 (defun push-binding (name namespace value &optional type)
 476   (push (make-binding :name name
 477                       :namespace namespace
 478                       :type type
 479                       :value value)
 480         *lexenv*))
 481
 482
 483 ;;;; IR Translation
 484 ;;;;
 485 ;;;; This code covers the translation from Lisp source code to the
 486 ;;;; intermediate representation. The main entry point function to do
 487 ;;;; that is the `ir-convert' function, which dispatches to IR
 488 ;;;; translators. This function ss intended to do the initial
 489 ;;;; conversion as well as insert new IR code during optimizations.
 490
 491 ;;; A alist of IR translator functions.
 492 (defvar *ir-translator* nil)
 493
 494 ;;; Define a IR translator for NAME. LAMBDA-LIST is used to
 495 ;;; destructure the arguments of the form. Calling the local function
 496 ;;; `result-lvar' you can get the LVAR where the compilation of the
 497 ;;; expression should store the result of the evaluation.
 498 ;;;
 499 ;;; The cursor is granted to be at the end of a basic block with a
 500 ;;; unique successor, and so it should be when the translator returns.
 501 (defmacro define-ir-translator (name lambda-list &body body)
 502   (check-type name symbol)
 503   (let ((fname (intern (format nil "IR-CONVERT-~a" (string name)))))
 504     (with-gensyms (result form)
 505       `(progn
 506          (defun ,fname (,form ,result)
 507            (flet ((result-lvar () ,result))
 508              (declare (ignorable (function result-lvar)))
 509              (destructuring-bind ,lambda-list ,form
 510                ,@body)))
 511          (push (cons ',name #',fname) *ir-translator*)))))
 512
 513 ;;; Return the unique successor of the current block. If it is not
 514 ;;; unique signal an error.
 515 (defun next-block ()
 516   (unlist (block-succ (current-block))))
 517
 518 ;;; Set the next block of the current one.
 519 (defun (setf next-block) (new-value)
 520   (let ((block (current-block)))
 521     (dolist (succ (block-succ block))
 522       (setf (block-pred succ) (remove block (block-pred succ))))
 523     (setf (block-succ block) (list new-value))
 524     (push block (block-pred new-value))
 525     new-value))
 526
 527 (defun ir-convert-constant (form result)
 528   (let* ((leaf (make-constant :value form)))
 529     (insert-node (make-ref :leaf leaf :lvar result))))
 530
 531 (define-ir-translator quote (form)
 532   (ir-convert-constant form (result-lvar)))
 533
 534 (define-ir-translator setq (variable value)
 535   (let ((b (find-binding variable 'variable)))
 536     (cond
 537       (b
 538        (let ((var (make-var :name variable))
 539              (value-lvar (make-lvar)))
 540          (ir-convert value value-lvar)
 541          (let ((assign (make-assignment :variable var :value value-lvar :lvar (result-lvar))))
 542            (insert-node assign))))
 543       (t
 544        (ir-convert `(set ',variable ,value) (result-lvar))))))
 545
 546 (define-ir-translator progn (&body body)
 547   (mapc #'ir-convert (butlast body))
 548   (ir-convert (car (last body)) (result-lvar)))
 549
 550 (define-ir-translator if (test then &optional else)
 551   ;; It is the schema of how the basic blocks will look like
 552   ;;
 553   ;;              / ..then.. \
 554   ;;  <aaaaXX> --<            >-- <|> -- <zzzz>
 555   ;;              \ ..else.. /
 556   ;;
 557   ;; Note that is important to leave the cursor in an empty basic
 558   ;; block, as zzz could be the exit basic block of the component,
 559   ;; which is an invalid position for a cursor.
 560   (let ((test-lvar (make-lvar))
 561         (then-block (make-empty-block))
 562         (else-block (make-empty-block))
 563         (join-block (make-empty-block)))
 564     (ir-convert test test-lvar)
 565     (insert-node (make-conditional :test test-lvar :consequent then-block :alternative else-block))
 566     (let* ((block (current-block))
 567            (tail-block (next-block)))
 568       ;; Link together the different created basic blocks.
 569       (setf (block-succ block)      (list else-block then-block)
 570             (block-pred else-block) (list block)
 571             (block-pred then-block) (list block)
 572             (block-succ then-block) (list join-block)
 573             (block-succ else-block) (list join-block)
 574             (block-pred join-block) (list else-block then-block)
 575             (block-succ join-block) (list tail-block)
 576             (block-pred tail-block) (substitute join-block block (block-pred tail-block))))
 577     ;; Convert he consequent and alternative forms and update cursor.
 578     (ir-convert then (result-lvar) (cursor :block then-block))
 579     (ir-convert else (result-lvar) (cursor :block else-block))
 580     (set-cursor :block join-block)))
 581
 582 (define-ir-translator block (name &body body)
 583   (let ((new (split-block)))
 584     (push-binding name 'block (cons (next-block) (result-lvar)))
 585     (ir-convert `(progn ,@body) (result-lvar))
 586     (set-cursor :block new)))
 587
 588 (define-ir-translator return-from (name &optional value)
 589   (let ((binding
 590          (or (find-binding name 'block)
 591              (error "Tried to return from unknown block `~S' name" name))))
 592     (destructuring-bind (jump-block . lvar)
 593         (binding-value binding)
 594       (ir-convert value lvar)
 595       (setf (next-block) jump-block)
 596       ;; This block is really unreachable, even if the following code
 597       ;; is labelled in a tagbody, as tagbody will create a new block
 598       ;; for each label. However, we have to leave the cursor
 599       ;; somewhere to convert new input.
 600       (let ((dummy (make-empty-block)))
 601         (set-cursor :block dummy)))))
 602
 603 (define-ir-translator tagbody (&rest statements)
 604   (flet ((go-tag-p (x)
 605            (or (integerp x) (symbolp x))))
 606     (let* ((tags (remove-if-not #'go-tag-p statements))
 607            (tag-blocks nil))
 608       ;; Create a chain of basic blocks for the tags, recording each
 609       ;; block in a alist in TAG-BLOCKS.
 610       (let ((*cursor* *cursor*))
 611         (dolist (tag tags)
 612           (setq *cursor* (cursor :block (split-block)))
 613           (push-binding tag 'tag (current-block))
 614           (if (assoc tag tag-blocks)
 615               (error "Duplicated tag `~S' in tagbody." tag)
 616               (push (cons tag (current-block)) tag-blocks))))
 617       ;; Convert the statements into the correct block.
 618       (dolist (stmt statements)
 619         (cond
 620           ((go-tag-p stmt)
 621            (set-cursor :block (cdr (assoc stmt tag-blocks))))
 622           ((atom stmt)
 623            (error "Invalid tag `~S'" stmt))
 624           (t
 625            (ir-convert stmt)))))))
 626
 627 (define-ir-translator go (label)
 628   (let ((tag-binding
 629          (or (find-binding label 'tag)
 630              (error "Unable to jump to the label `~S'" label))))
 631     (setf (next-block) (binding-value tag-binding))
 632     ;; Unreachable block.
 633     (let ((dummy (make-empty-block)))
 634       (set-cursor :block dummy))))
 635
 636
 637 (defun convert-functional (result name arguments &rest body)
 638   (let ((component)
 639         (return-lvar (make-lvar)))
 640     (with-component-compilation (name)
 641       (ir-convert `(progn ,@body) return-lvar)
 642       (ir-normalize)
 643       (setq component *component*))
 644     (let ((functional
 645            (make-functional
 646             :name name
 647             :arguments arguments
 648             :component component
 649             :return-lvar return-lvar)))
 650       (push functional (component-functions *component*))
 651       (insert-node (make-ref :leaf functional :lvar result)))))
 652
 653 (define-ir-translator function (name)
 654   (if (atom name)
 655       (ir-convert `(symbol-function ,name) (result-lvar))
 656       (ecase (car name)
 657         ((lambda named-lambda)
 658          (let ((desc (cdr name)))
 659            (when (eq 'lambda (car name))
 660              (push nil desc))
 661            (apply #'convert-functional (result-lvar) desc)))
 662         (setf))))
 663
 664 (defun ir-convert-var (form result)
 665   (let ((binds (find-binding form 'variable)))
 666     (if binds
 667         (insert-node (make-ref :leaf (binding-value binds) :lvar result))
 668         (ir-convert `(symbol-value ',form) result))))
 669
 670 (defun ir-convert-call (form result)
 671   (destructuring-bind (function &rest args) form
 672     (let ((func-lvar (make-lvar))
 673           (args-lvars nil))
 674       ;; Argument list
 675       (dolist (arg args)
 676         (let ((arg-lvar (make-lvar)))
 677           (push arg-lvar args-lvars)
 678           (ir-convert arg arg-lvar)))
 679       (setq args-lvars (reverse args-lvars))
 680       ;; Funcall
 681       (if (find-primitive function)
 682           (insert-node (make-primitive-call
 683                         :function (find-primitive function)
 684                         :arguments args-lvars
 685                         :lvar result))
 686           (progn
 687             (ir-convert `(symbol-function ',function) func-lvar)
 688             (insert-node (make-call :function func-lvar
 689                                     :arguments args-lvars
 690                                     :lvar result)))))))
 691
 692 ;;; Convert the Lisp expression FORM, it may create new basic
 693 ;;; blocks. RESULT is the lvar representing the result of the
 694 ;;; computation or null if the value should be discarded. The IR is
 695 ;;; inserted at *CURSOR*.
 696 (defun ir-convert (form &optional result (*cursor* *cursor*))
 697   ;; Rebinding the lexical environment here we make sure that the
 698   ;; lexical information introduced by FORM is just available for
 699   ;; subforms.
 700   (let ((*lexenv* *lexenv*))
 701     ;; Possibly create additional blocks in order to make sure the
 702     ;; cursor is at end the end of a basic block.
 703     (maybe-split-block)
 704     (cond
 705       ((atom form)
 706        (cond
 707          ((symbolp form)
 708           (ir-convert-var form result))
 709          (t
 710           (ir-convert-constant form result))))
 711       (t
 712        (destructuring-bind (op &rest args) form
 713          (let ((translator (cdr (assoc op *ir-translator*))))
 714            (if translator
 715                (funcall translator args result)
 716                (ir-convert-call form result))))))
 717     (values)))
 718
 719
 720 ;;;; IR Normalization
 721 ;;;;
 722 ;;;; IR as generated by `ir-convert' or after some transformations is
 723 ;;;; not appropiated. Here, we remove unreachable and empty blocks and
 724 ;;;; coallesce blocks when it is possible.
 725
 726 ;;; Try to coalesce BLOCK with the successor if it is unique and block
 727 ;;; is its unique predecessor.
 728 (defun maybe-coalesce-block (block)
 729   (when (and (singlep (block-succ block)) (not (component-entry-p block)))
 730     (let ((succ (first (block-succ block))))
 731       (when (and (not (component-exit-p succ)) (singlep (block-pred succ)))
 732         (link-nodes (node-prev (block-exit block))
 733                     (node-next (block-entry succ)))
 734         (setf (block-exit block) (block-exit succ))
 735         (setf (block-succ block) (block-succ succ))
 736         (dolist (next (block-succ succ))
 737           (setf (block-pred next) (remove succ (block-pred next)))
 738           (pushnew block (block-pred next)))
 739         (setf (block-succ succ) nil
 740               (block-pred succ) nil)
 741         t))))
 742
 743 ;;; Normalize a component. This function must be called after a batch
 744 ;;; of modifications to the flowgraph of the component to make sure it
 745 ;;; is a valid input for the possible optimizations and the backend.
 746 (defun ir-normalize (&optional (component *component*))
 747   ;; Initialize blocks as unreachables and remove empty basic blocks.
 748   (dolist (block (component-blocks component))
 749     (setf (block-data block) 'unreachable))
 750   ;; Coalesce and mark blocks as reachable.
 751   (map-postorder-blocks #'maybe-coalesce-block component)
 752   (map-postorder-blocks (lambda (block)
 753                           (setf (block-data block) 'reachable))
 754                         component)
 755   (let ((block-list nil))
 756     (dolist (block (component-blocks component))
 757       (cond
 758         ;; If the block is unreachable, but it is predeces a reachable
 759         ;; one, then break the link between them. So we discard it
 760         ;; from the flowgraph.
 761         ((eq (block-data block) 'unreachable)
 762          (dolist (succ (block-succ block))
 763            (when (eq (block-data succ) 'reachable)
 764              (setf (block-pred succ) (remove block (block-pred succ)))))
 765          (setf (block-succ block) nil))
 766         ;; Delete empty blocks
 767         ((and (empty-block-p block)
 768               (not (boundary-block-p block))
 769               ;; We cannot delete a block if it is its own successor,
 770               ;; even thought it is empty.
 771               (not (member block (block-succ block))))
 772          (delete-block block))
 773         ;; The rest of blocks remain in the component.
 774         (t
 775          (push block block-list))))
 776     (setf (component-blocks component) block-list))
 777   (check-ir-consistency))
 778
 779
 780 ;;;; IR Analysis
 781 ;;;;
 782 ;;;; Once IR conversion has been finished. We do some analysis of the
 783 ;;;; component to produce information which is useful for both
 784 ;;;; optimizations and code generation. Indeed, we provide some
 785 ;;;; abstractions to use this information.
 786
 787 (defun compute-reverse-post-order (&optional (component *component*))
 788   (let ((output nil)
 789         (index (length (component-blocks component))))
 790     (flet ((add-block-to-list (block)
 791              (push block output)
 792              (setf (block-order block) (decf index))))
 793       (map-postorder-blocks #'add-block-to-list component))
 794     (setf (component-reverse-post-order-p component) t)
 795     (setf (component-blocks component) output)))
 796
 797
 798 (defmacro do-blocks% ((block component &optional reverse ends result) &body body)
 799   (with-gensyms (g!component g!blocks)
 800     `(let* ((,g!component ,component)
 801             (,g!blocks ,(if reverse
 802                             `(reverse (component-blocks ,g!component))
 803                             `(component-blocks ,g!component))))
 804        ;; Do we have the information available?
 805        (unless (component-reverse-post-order-p ,g!component)
 806          (error "Reverse post order was not computed yet."))
 807        (dolist (,block  ,(if (member ends '(:head :both))
 808                              `,g!blocks
 809                              `(cdr ,g!blocks))
 810                  ,result)
 811          ,@(if (member ends '(:tail :both))
 812                nil
 813                `((if (component-exit-p ,block) (return))))
 814          ,@body))))
 815
 816 ;;; Iterate across blocks in COMPONENT in reverse post order.
 817 (defmacro do-blocks-forward ((block component &optional ends result) &body body)
 818   `(do-blocks% (,block ,component nil ,ends ,result)
 819      ,@body))
 820
 821 ;;; Iterate across blocks in COMPONENT in post order.
 822 (defmacro do-blocks-backward ((block component &optional ends result) &body body)
 823   `(do-blocks% (,block (reverse ,component) t ,ends ,result)
 824      ,@body))
 825
 826 (defun compute-dominators (&optional (component *component*))
 827   ;; Initialize the dominators of the entry to the component to be
 828   ;; empty and the power set of the set of blocks for proper basic
 829   ;; blocks in the component.
 830   (let ((n (length (component-blocks component))))
 831     ;; The component entry special block has not predecessors in the
 832     ;; set of (proper) basic blocks.
 833     (setf (block-dominators% (component-entry component))
 834           (make-array n :element-type 'bit :initial-element 0))
 835     (setf (aref (block-dominators% (component-entry component)) 0) 1)
 836     (do-blocks-forward (block component :tail)
 837       (setf (block-dominators% block) (make-array n :element-type 'bit :initial-element 1))))
 838   ;; Iterate across the blocks in the component removing non domintors
 839   ;; until it reaches a fixed point.
 840   (do ((i 1 1)
 841        (changes t))
 842       ((not changes))
 843     (setf changes nil)
 844     (do-blocks-forward (block component :tail)
 845       ;; We compute the new set of dominators for this iteration in a
 846       ;; fresh set NEW-DOMINATORS. So we do NOT modify the old
 847       ;; dominators. It is important because the block could predeces
 848       ;; itself. Indeed, it allows us to check if the set of
 849       ;; dominators changed.
 850       (let* ((predecessors (block-pred block))
 851              (new-dominators (copy-seq (block-dominators% (first predecessors)))))
 852         (dolist (pred (rest predecessors))
 853           (bit-and new-dominators (block-dominators% pred) t))
 854         (setf (aref new-dominators i) 1)
 855         (unless changes
 856           (setq changes (not (equal (block-dominators% block) new-dominators))))
 857         (setf (block-dominators% block) new-dominators)
 858         (incf i)))))
 859
 860 ;;; Return T if BLOCK1 dominates BLOCK2, else return NIL.
 861 (defun dominate-p (block1 block2)
 862   (let ((order (block-order block1)))
 863     (= 1 (aref (block-dominators% block2) order))))
 864
 865
 866
 867 ;;;; Natural Loops
 868
 869 (defstruct natural-loop
 870   parent
 871   header
 872   body)
 873
 874 (defun find-natural-loops (&optional (component *component*))
 875   (let ((size (length (component-blocks component))))
 876     ;; We look for loop headers in reverse post order, so we will find
 877     ;; outermost loop first. It makes sure we can fill the LOOP slot
 878     ;; of the blocks and it will not be rewritten by an outer loop.
 879     (do-blocks-forward (header component)
 880       (dolist (block (block-pred header))
 881         (when (dominate-p header block) ; Back edge
 882           (let* ((loop
 883                     ;; If header is already the header of a loop, then
 884                     ;; just merge the natural loop for this back edge
 885                     ;; into the same loop.
 886                     (if (loop-header-p header)
 887                         (block-loop header)
 888                         (make-natural-loop
 889                          :parent (block-loop header)
 890                          :header header
 891                          :body (make-array size :element-type 'bit :initial-element 0))))
 892                  ;; The set of nodes which belongs to this loop.
 893                  (body (natural-loop-body loop)))
 894             (unless (loop-header-p header)
 895               (push loop (component-loops component)))
 896             ;; The header belongs to the loop
 897             (setf (aref body (block-order header)) 1
 898                   (block-loop header) loop)
 899             ;; Add to the loop all the blocks which can reach the tail
 900             ;; without going throught the header.
 901             (labels ((explore-backward (block)
 902                        (unless (= 1 (aref body (block-order block)))
 903                          (setf (aref body (block-order block)) 1
 904                                (block-loop block) loop)
 905                          (dolist (pred (block-pred block))
 906                            (explore-backward pred)))))
 907               (explore-backward block))))))))
 908
 909 ;;; Check if BLOCK is a loop header.
 910 (defun loop-header-p (block)
 911   (let ((loop (block-loop block)))
 912     (and loop (eq (natural-loop-header loop) block))))
 913
 914
 915
 916
 917 ;;; Save the edges of the flow graph of the current component. Then,
 918 ;;; execute BODY as an implicit progn and restore the edges even if
 919 ;;; BODY exists with an abnormal exit.
 920 (defmacro save-component-edges (&body body)
 921   (with-gensyms (edges)
 922     `(let (,edges)
 923        ;; Save edges
 924        (dolist (block (component-blocks *component*))
 925          (push (list block (block-succ block) (block-pred block)) ,edges))
 926        (unwind-protect (progn ,@body)
 927          ;; Restore edges
 928          (dolist (entry ,edges)
 929            (destructuring-bind (block succ pred) entry
 930              (setf (block-succ block) succ
 931                    (block-pred block) pred)))))))
 932
 933 (defun reduce-component (&optional (component *component*))
 934   (let* ((*component* component)
 935          (list-blocks (component-blocks component))
 936          ;; A vector of the blocks in the component. Blocks are added
 937          ;; and deleted always at the fill pointer of the vector.
 938          (vector-blocks
 939           (make-array (length list-blocks)
 940                       :initial-contents (component-blocks component)
 941                       :adjustable t
 942                       :fill-pointer t))
 943          ;; A list of nodes which have been splitted during the
 944          ;; reduction of the component. We apply
 945          (nodes-to-split '()))
 946     (flet (;; Remove an edge from a block to itself
 947            (T1 (block)
 948              (when (member block (block-succ block))
 949                (setf (block-succ block) (remove block (block-succ block)))
 950                (setf (block-pred block) (remove block (block-pred block)))
 951                t))
 952            ;; Collapse a block back into its predecessor if it is unique
 953            (T2 (block)
 954              (when (singlep (block-pred block))
 955                (let ((pred (unlist (block-pred block))))
 956                  (setf (block-succ pred) (remove block (block-succ pred)))
 957                  (dolist (succ (block-succ block))
 958                    (pushnew succ (block-succ pred))
 959                    (setf (block-pred succ) (remove block (block-pred succ)))
 960                    (pushnew pred (block-pred succ))))
 961                t))
 962            ;; This function duplicates the block in component for each input
 963            ;; edge. A technique useful to make a general flowgraph reducible.
 964            (S (block)
 965              (let ((predecessors (block-pred block)))
 966                (when predecessors
 967                  (setf (block-pred block) (list (car predecessors)))
 968                  (let ((newblocks '()))
 969                    (dolist (pred (cdr predecessors) newblocks)
 970                      (let ((newblock (copy-basic-block block)))
 971                        (setf (block-pred newblock) (list pred))
 972                        (setf (block-succ pred) (remove block (block-succ pred)))
 973                        (pushnew newblock (block-succ pred))
 974                        (push newblock newblocks))))))))
 975       ;; Reduce component using the transformations T1 and T2 as much
 976       ;; as possible. Then apply the node splitting transformation (S)
 977       ;; to some blocks. By now, we apply it to every block with
 978       ;; multiple predecessors, but most smart policy is possible,
 979       ;; see: "Making Graphs Reducible with Controlled Node
 980       ;; Splitting". These transformations do not affect to the
 981       ;; original component flowgraph out of the SAVE-COMPONENT-EDGES
 982       ;; extent. Eventually, we will reduce the component to a single
 983       ;; node and the reduction finishes.
 984       (save-component-edges
 985         (while (< 1 (fill-pointer vector-blocks))
 986           ;; Reduce component using T1 and T2 as much as possible
 987           (do ((changes t))
 988               ((not changes))
 989             (setf changes nil)
 990             (do ((i 0 (1+ i)))
 991                 ((>= i (length vector-blocks)))
 992               (let ((block (aref vector-blocks i)))
 993                 (when (T1 block)
 994                   (setf changes t))
 995                 (when (T2 block)
 996                   ;; Move the block to the end of the vector and
 997                   ;; remove decrementing the fill pointer.
 998                   (rotatef (aref vector-blocks i) (aref vector-blocks (1- (length vector-blocks))))
 999                   (vector-pop vector-blocks)
1000                   (setf changes t)))))
1001           ;; TODO: Implement a better selection of the nodes in the
1002           ;; flowgraph to split. Paper to study: "Making Graphs
1003           ;; Reducible with Controlled Node Splitting".
1004           (dotimes (i (length vector-blocks))
1005             (let ((block (aref vector-blocks i)))
1006               (when (S block)
1007                 (push block nodes-to-split))))))
1008       ;; Reapply the node splitting transformation to the same nodes
1009       ;; on the original component.
1010       (when nodes-to-split
1011         (warn "Irreducible component. Applying node splitting")
1012         (dolist (block nodes-to-split)
1013           (assert (member block (component-blocks component)))
1014           (dolist (newblock (S block))
1015             (push newblock (component-blocks component))))))))
1016
1017
1018
1019 ;;;; IR Debugging
1020 ;;;;
1021 ;;;; This section provides a function `/print' which write a textual
1022 ;;;; representation of a component to the standard output. Also, a
1023 ;;;; `/ir' macro is provided, which takes a form, convert it to IR and
1024 ;;;; then print the component as above.  They are useful commands if
1025 ;;;; you are hacking the front-end of the compiler.
1026 ;;;;
1027
1028 (defun format-block-name (block)
1029   (cond
1030     ((eq block (unlist (block-succ (component-entry (block-component block)))))
1031      (format nil "ENTRY-~a" (component-id (block-component block))))
1032     ((component-exit-p block)
1033      (format nil "EXIT-~a" (component-id (block-component block))))
1034     (t
1035      (format nil "BLOCK ~a" (block-order block)))))
1036
1037
1038 (defun print-node (node)
1039   (when (node-lvar node)
1040     (format t "$~a = " (lvar-id (node-lvar node))))
1041   (cond
1042     ((ref-p node)
1043      (let ((leaf (ref-leaf node)))
1044        (cond
1045          ((var-p leaf)
1046           (format t "~a" (var-name leaf)))
1047          ((constant-p leaf)
1048           (format t "'~s" (constant-value leaf)))
1049          ((functional-p leaf)
1050           (format t "#<function ~a>" (functional-name leaf))))))
1051     ((assignment-p node)
1052      (format t "set ~a $~a"
1053              (var-name (assignment-variable node))
1054              (lvar-id (assignment-value node))))
1055     ((primitive-call-p node)
1056      (format t "primitive ~a" (primitive-name (primitive-call-function node)))
1057      (dolist (arg (primitive-call-arguments node))
1058        (format t " $~a" (lvar-id arg))))
1059     ((call-p node)
1060      (format t "call $~a" (lvar-id (call-function node)))
1061      (dolist (arg (call-arguments node))
1062        (format t " $~a" (lvar-id arg))))
1063     ((conditional-p node)
1064      (format t "if $~a then ~a else ~a~%"
1065              (lvar-id (conditional-test node))
1066              (format-block-name (conditional-consequent node))
1067              (format-block-name (conditional-alternative node))))
1068     (t
1069      (error "`print-node' does not support printing ~S as a node." node)))
1070   (terpri))
1071
1072 (defun print-block (block)
1073   (write-string (format-block-name block))
1074   (if (loop-header-p block)
1075       (write-line " [LOOP_HEADER]")
1076       (terpri))
1077   (do-nodes (node block)
1078     (print-node node))
1079   (when (singlep (block-succ block))
1080     (format t "GO ~a~%~%" (format-block-name (unlist (block-succ block))))))
1081
1082 (defun /print (component &optional (stream *standard-output*))
1083   (format t ";;; COMPONENT ~a (~a) ~%~%" (component-name component) (component-id component))
1084   (let ((*standard-output* stream))
1085     (do-blocks-forward (block component)
1086       (print-block block)))
1087   (format t ";;; END COMPONENT ~a ~%~%" (component-name component))
1088   (let ((*standard-output* stream))
1089     (dolist (func (component-functions component))
1090       (/print (functional-component func)))))
1091
1092 ;;; Translate FORM into IR and print a textual repreresentation of the
1093 ;;; component.
1094 (defun convert-toplevel-and-print (form)
1095   (let ((*counter-alist* nil))
1096     (with-component-compilation ('toplevel)
1097       (ir-convert form (make-lvar :id "out"))
1098       (ir-normalize)
1099       (reduce-component)
1100       (compute-reverse-post-order)
1101       (compute-dominators)
1102       (find-natural-loops)
1103       (/print *component*)
1104       *component*)))
1105
1106 (defmacro /ir (form)
1107   `(convert-toplevel-and-print ',form))
1108
1109
1110 ;;;; Backend [DRAFT]
1111 ;;;;
1112 ;;;; This section implements a starting point of the back-end of the
1113 ;;;; compiler. It takes IR data as input and yield Javascript code.
1114 ;;;; This process is conceptually comprised of several stages.
1115 ;;;;
1116 ;;;; Fistly, we do structural analysis on the flow graph to recover a
1117 ;;;; set of nested or disjoint regions, which can be loops,
1118 ;;;; conditionals and exit-point ones. It yields a list of Javascript
1119 ;;;; statements.
1120 ;;;;
1121 ;;;; Then, every basic block is compiled individually in a list of
1122 ;;;; Javascript expressions. We assume every lvar is used only once,
1123 ;;;; so the only live lvars at the end of the basic block are
1124 ;;;; (possibly a subset) of the toplevel lvars. In other words, no
1125 ;;;; expression can live across basic block boundaries.
1126 ;;;;
1127
1128 ;;; Do structural analysis of the flow graph of component to "recover"
1129 ;;; high level control flow constructions. Particularly, it finds
1130 ;;; loops, conditionals and forward jumps (which will be compiled to
1131 ;;; labeled breaks).
1132 ;;;
1133 ;;; This information is enough to generate Javascript code. In effect,
1134 ;;; loops are defined by back-edges, which become break/continue in
1135 ;;; the header of the loop. Moreover, the component is reducible so
1136 ;;; they are the only retreating edges. Therefore, the remaining graph
1137 ;;; is acyclic. Any acyclic graph is expressable with labeled
1138 ;;; statements and conditionals. However, the resulting structure is
1139 ;;; nicer if we looking for natural conditionals before to avoid
1140 ;;; unnecessary breaks.
1141
1142 (defstruct region
1143   header
1144   childs)
1145
1146 (defun natural-conditional-header-p (block)
1147   ;; multiple successors and dominate some of them
1148   (and (not (null (cdr (block-succ block))))
1149        (some (lambda (succ) (dominate-p block succ)) (block-succ block))
1150        (not (loop-header-p block))))
1151
1152 (defun structure-component (component)
1153   (let* ((entry (unlist (block-succ (component-entry component))))
1154          ;; Root of the tree of regions
1155          (top (make-region :header entry)))
1156     ;; Process the natural loops from outermost to innermost, creating
1157     ;; a hierarchy of regions for them.
1158     (let ((table (make-hash-table :test #'eq)))
1159       (labels ((process-loop (loop)
1160                  (multiple-value-bind (region existp)
1161                      (gethash loop table)
1162                    (when existp (return-from process-loop region))
1163                    (let* ((parent-loop (natural-loop-parent loop))
1164                           (parent-region
1165                            (if parent-loop
1166                                (process-loop parent-loop)
1167                                top)))
1168                      (push (make-region :header (natural-loop-header loop))
1169                            (region-childs parent-region))
1170                      region))))
1171         (dolist (loop (component-loops component))
1172           (process-loop loop))))
1173     ;; Process "natural" conditionals.
1174     (dolist (block (component-blocks component))
1175       (when (natural-conditional-header-p block)
1176         (make-region :header block :childs nil)
1177
1178         ))
1179     top))
1180
1181
1182
1183 ;;;; Primitives
1184 ;;;;
1185 ;;;; Primitive functions are a set of functions provided by the
1186 ;;;; compiler. They cannot usually be written in terms of other
1187 ;;;; functions. When the compiler tries to compile a function call, it
1188 ;;;; looks for a primitive function firstly, and if it is found and
1189 ;;;; the declarations allow it, a primitive call is inserted in the
1190 ;;;; IR. The back-end of the compiler knows how to compile primitive
1191 ;;;; calls.
1192 ;;;;
1193
1194 (defvar *primitive-function-table* nil)
1195
1196 (defstruct primitive
1197   name)
1198
1199 (defmacro define-primitive (name args &body body)
1200   (declare (ignore args body))
1201   `(push (make-primitive :name ',name)
1202          *primitive-function-table*))
1203
1204 (defun find-primitive (name)
1205   (find name *primitive-function-table* :key #'primitive-name))
1206
1207 (define-primitive symbol-function (symbol))
1208 (define-primitive symbol-value (symbol))
1209 (define-primitive set (symbol value))
1210 (define-primitive fset (symbol value))
1211
1212 (define-primitive + (&rest numbers))
1213 (define-primitive - (number &rest other-numbers))
1214
1215 (define-primitive consp (x))
1216 (define-primitive cons (x y))
1217 (define-primitive car (x))
1218 (define-primitive cdr (x))
1219
1220
1221 ;;; compiler.lisp ends here