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 ;;;; Utils
  24
  25 (defmacro with-gensyms ((&rest vars) &body body)
  26   `(let ,(mapcar (lambda (var) `(,var (gensym ,(string var)))) vars)
  27      ,@body))
  28
  29 (defun singlep (x)
  30   (and (consp x) (null (cdr x))))
  31
  32 (defun unlist (x)
  33   (assert (singlep x))
  34   (first x))
  35
  36 ;;;; Lexical environment
  37 ;;;;
  38 ;;;; The Lexical environment comprises a list of bindings, which
  39 ;;;; associates information to symbols. It tracks lexical variables,
  40 ;;;; tags, local declarations and many other information in order to
  41 ;;;; guide the compiler.
  42
  43 (defstruct binding
  44   name type value declarations)
  45
  46 (defstruct lexenv
  47   bindings)
  48
  49
  50 ;;;; Intermediate representation
  51 ;;;;
  52 ;;;; This intermediate representation (IR) is a simplified version of
  53 ;;;; first intermediate representation what you will find if you have
  54 ;;;; a you have the source code of SBCL. Some terminology is also
  55 ;;;; used, but other is changed, so be careful if you assume you know
  56 ;;;; what it is because you know the name.
  57 ;;;;
  58
  59 ;;; A leaf stands for leaf in the tree of computations. Lexical
  60 ;;; variables, constants and literal functions are leafs. Leafs are
  61 ;;; not nodes itself, a `ref' node will stands for putting a leaf into
  62 ;;; a lvar, which can be used in computations.
  63 (defstruct leaf)
  64
  65 ;;; Reference a lexical variable. Special variables have not a
  66 ;;; representation in IR. They are handled via the primitive functions
  67 ;;; `%symbol-function' and `%symbol-value'.
  68 (defstruct (var (:include leaf))
  69   ;; Name is the symbol used to identify this variable in the lexical
  70   ;; environment.
  71   name)
  72
  73 ;;; A constant value, mostly from a quoted form, but maybe introduced
  74 ;;; in some pass of the compiler.
  75 (defstruct (constant (:include leaf))
  76   value)
  77
  78 ;;; A literal function. Why do we use `functional' as name? Well,
  79 ;;; function is taken, isn't it?
  80 (defstruct (functional (:include leaf))
  81   ;; The symbol which names this function in the source code.
  82   name
  83   ;; A list of lvars which are bound to the argument values in a call
  84   ;; to this function.
  85   arguments
  86   ;; LVAR which contains the return values of the function.
  87   return-lvar
  88   ;; The basic block which contain the code which be executed firstly
  89   ;; when you call this function.
  90   entry-point)
  91
  92
  93 ;;; Used to transfer data between the computations in the intermediate
  94 ;;; representation. Each node is valued into a LVar. And nodes which
  95 ;;; use resulting values from other nodes use such LVar.
  96 (defstruct lvar
  97   (id (gensym "$")))
  98
  99 ;;; A computation node. It represents a simple computation in the
 100 ;;; intermediate representation. Nodes are grouped in basic blocks,
 101 ;;; which are delimited by the special nodes `block-entry' and
 102 ;;; `block-exit'. Resulting value of the node is stored in LVAR, which it
 103 ;;; could be null if the value is discarded.
 104 (defstruct node
 105   next
 106   prev
 107   lvar)
 108
 109 ;;; Sentinel nodes. No computation really, but they make easier to
 110 ;;; manipulate the doubly linked-list.
 111 (defstruct (block-entry (:include node)))
 112 (defstruct (block-exit (:include node)))
 113
 114 ;;; A reference to a leaf.
 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 ;;; Call the lvar FUNCTION with a list of lvars as ARGUMENTS.
 124 (defstruct (call (:include node))
 125   function
 126   arguments)
 127
 128 ;;; A conditional branch. If the LVAR is not NIL, then we will jump to
 129 ;;; the basic block CONSEQUENT, jumping to ALTERNATIVE otherwise. By
 130 ;;; definition, a conditional must appear at the end of a basic block.
 131 (defstruct (conditional (:include node))
 132   test
 133   consequent
 134   alternative)
 135
 136 ;;; Blocks are `basic block', which is a maximal sequence of nodes
 137 ;;; with an entry point and an exit. Basic blocks are organized as a
 138 ;;; control flow graph with some more information in omponents.
 139 (defstruct (basic-block
 140              (:conc-name "BLOCK-")
 141              (:constructor make-block)
 142              (:predicate block-p))
 143   (id (gensym "L"))
 144   succ
 145   pred
 146   entry
 147   exit)
 148
 149 (defstruct (component-entry (:include basic-block)))
 150 (defstruct (component-exit (:include basic-block)))
 151
 152 (defun make-empty-block ()
 153   (let ((entry (make-block-entry))
 154         (exit (make-block-exit)))
 155     (setf (node-next entry) exit
 156           (node-prev exit) entry)
 157     (make-block :entry entry :exit exit)))
 158
 159 (defun empty-block-p (b)
 160   (block-exit-p (node-next (block-entry b))))
 161
 162 (defmacro do-nodes
 163     ((node block &optional result &key include-sentinel-p) &body body)
 164   `(do ((,node ,(if include-sentinel-p
 165                     `(block-entry ,block)
 166                     `(node-next (block-entry ,block)))
 167                (node-next ,node)))
 168        (,(if include-sentinel-p
 169              `(null ,node)
 170              `(block-exit-p ,node))
 171         ,result)
 172      ,@body))
 173
 174 (defmacro do-nodes-backward
 175     ((node block &optional result &key include-sentinel-p) &body body)
 176   `(do ((,node ,(if include-sentinel-p
 177                     `(block-exit ,block)
 178                     `(node-prev (block-entry ,block)))
 179                (node-prev ,node)))
 180        (,(if include-sentinel-p
 181              `(null ,node)
 182              `(block-entry-p ,node))
 183         ,result)
 184      ,@body))
 185
 186 ;;; Link FROM and TO nodes together. FROM and TO must belong to the
 187 ;;; same basic block and appear in such order. The nodes between FROM
 188 ;;; and TO are discarded.
 189 (defun link-nodes (from to)
 190   (setf (node-next from) to
 191         (node-prev to) from)
 192   (values))
 193
 194 ;;; Components are connected pieces of the control flow graph with
 195 ;;; some additional information. Components have well-defined entry
 196 ;;; and exit nodes. They also track what basic blocks we have and
 197 ;;; other useful information. It is the toplevel organizational entity
 198 ;;; in the compiler. The IR translation result is accumulated into
 199 ;;; components incrementally.
 200 (defstruct (component #-jscl (:print-object print-component))
 201   entry
 202   exit)
 203
 204 ;;; Create a new component with sentinel nodes and an empty basic
 205 ;;; block, ready to start conversion to IR. It returns the component
 206 ;;; and the basic block as multiple values.
 207 (defun make-empty-component ()
 208   (let ((entry (make-component-entry))
 209         (block (make-empty-block))
 210         (exit (make-component-exit)))
 211     (setf (block-succ entry)  (list block)
 212           (block-pred exit)   (list block)
 213           (block-succ block) (list exit)
 214           (block-pred block) (list entry))
 215     (values (make-component :entry entry :exit exit) block)))
 216
 217 ;;; Return the list of blocks in COMPONENT.
 218 (defun component-blocks (component)
 219   (let ((output nil))
 220     (labels ((compute-rdfo-from (block)
 221                (unless (or (component-exit-p block) (find block output))
 222                  (dolist (successor (block-succ block))
 223                    (unless (component-exit-p block)
 224                      (compute-rdfo-from successor)))
 225                  (push block output))))
 226       (compute-rdfo-from (unlist (block-succ (component-entry component))))
 227       output)))
 228
 229 ;;; Iterate across different blocks in COMPONENT.
 230 (defmacro do-blocks ((block component &optional result) &body body)
 231   `(dolist (,block (component-blocks ,component) ,result)
 232      ,@body))
 233
 234 (defun delete-empty-block (block)
 235   (when (or (component-entry-p block) (component-exit-p block))
 236     (error "Cannot delete entry or exit basic blocks."))
 237   (unless (empty-block-p block)
 238     (error "Block `~S' is not empty!" (block-id block)))
 239   (let ((succ (unlist (block-succ block))))
 240     (setf (block-pred succ) (remove block (block-pred succ)))
 241     (dolist (pred (block-pred block))
 242       (setf (block-succ pred) (substitute succ block (block-succ pred)))
 243       (pushnew pred (block-pred succ)))))
 244
 245 (defun finish-component (component)
 246   (do-blocks (block component)
 247     (when (empty-block-p block)
 248       (delete-empty-block block))))
 249
 250 ;;; IR Translation
 251
 252 ;;; The current component. We accumulate the results of the IR
 253 ;;; conversion in this component.
 254 (defvar *component*)
 255
 256 ;;; Prepare a new component with a current empty block ready to start
 257 ;;; IR conversion bound in the current cursor. BODY is evaluated and
 258 ;;; the value of the last form is returned.
 259 (defmacro with-component-compilation (&body body)
 260   (let ((block (gensym)))
 261     `(multiple-value-bind (*component* ,block)
 262          (make-empty-component)
 263        (with-cursor (:block ,block)
 264          ,@body))))
 265
 266 ;;; A cursor stands for a point between two nodes in some basic block
 267 ;;; in the IR representation where manipulations can take place,
 268 ;;; similarly to the cursors in text editing.
 269 (defstruct cursor
 270   block next)
 271
 272 ;;; The current cursor. It is the point where IR manipulations act by
 273 ;;; default. Particularly, newly converted IR code is inserted here.
 274 (defvar *cursor*)
 275
 276 ;;; Create a cursor which pointsto the basic block BLOCK. If omitted,
 277 ;;; then the current block is used.
 278 ;;;
 279 ;;; The keywords AFTER and BEFORE specify the cursor will point after
 280 ;;; or before that node respectively. If none is specified, the cursor
 281 ;;; is created before the exit node in BLOCK. An error is signaled if
 282 ;;; both keywords are specified inconsistently, or if the nodes do not
 283 ;;; belong to BLOCK.
 284 ;;;
 285 ;;; The special values :ENTRY and :EXIT stand for the entry and exit
 286 ;;; nodes of the block respectively.
 287 (defun cursor (&key (block (cursor-block *cursor*))
 288                  (before nil before-p)
 289                  (after nil after-p))
 290   ;; Handle special values :ENTRY and :EXIT.
 291   (flet ((node-designator (x)
 292            (case x
 293              (:entry (block-entry block))
 294              (:exit  (block-exit block))
 295              (t x))))
 296     (setq before (node-designator before))
 297     (setq after  (node-designator after)))
 298   (let* ((next (or before (and after (node-next after)) (block-exit block)))
 299          (cursor (make-cursor :block block :next next)))
 300     (flet ((out-of-range-cursor ()
 301              (error "Out of range cursor."))
 302            (ambiguous-cursor ()
 303              (error "Ambiguous cursor specified between two non-adjacent nodes.")))
 304       (when (or (null next) (block-entry-p next))
 305         (out-of-range-cursor))
 306       (when (and before-p after-p (not (eq after before)))
 307         (ambiguous-cursor))
 308       (do-nodes-backward (node block (out-of-range-cursor) :include-sentinel-p t)
 309         (when (eq next node) (return))))
 310     cursor))
 311
 312 (defun set-cursor (&rest cursor-spec)
 313   (let ((newcursor (apply #'cursor cursor-spec)))
 314     (setf (cursor-block *cursor*) (cursor-block newcursor))
 315     (setf (cursor-next *cursor*) (cursor-next newcursor))
 316     *cursor*))
 317
 318 ;;; Create and bind the current cursor. The cursor specification is
 319 ;;; the same as described in the function `create-cursor'.
 320 (defmacro with-cursor ((&rest cursor-spec) &body body)
 321   `(let* ((*cursor* (cursor ,@cursor-spec)))
 322      ,@body))
 323
 324 (defun end-of-block-p (&optional (cursor *cursor*))
 325   (block-exit-p (cursor-next cursor)))
 326
 327 ;;; Insert NODE at cursor.
 328 (defun insert-node (node &optional (cursor *cursor*))
 329   (link-nodes (node-prev (cursor-next cursor)) node)
 330   (link-nodes node (cursor-next cursor))
 331   t)
 332
 333 ;;; Split the block CURSOR points in two basic blocks, returning the
 334 ;;; new basic block. The cursor is kept to point at the end of shrunk
 335 ;;; basic block.
 336 (defun split-block (&optional (cursor *cursor*))
 337   (let* ((block (cursor-block cursor))
 338          (exit (block-exit block))
 339          newblock
 340          (newexit (make-block-exit))
 341          (newentry (make-block-entry)))
 342     (insert-node newexit)
 343     (insert-node newentry)
 344     (setf (node-next newexit)  nil)
 345     (setf (node-prev newentry) nil)
 346     (setf (block-exit block) newexit)
 347     (setq newblock (make-block :entry newentry :exit exit))
 348     (shiftf (block-succ newblock) (block-succ block) (list newblock))
 349     newblock))
 350
 351
 352 ;;; A alist of IR translator functions.
 353 (defvar *ir-translator* nil)
 354
 355 ;;; Define a IR translator for NAME.
 356 (defmacro define-ir-translator (name lambda-list &body body)
 357   (check-type name symbol)
 358   (let ((fname (intern (format nil "IR-CONVERT-~a" (string name))))
 359         (result (gensym))
 360         (form (gensym)))
 361     `(progn
 362        (defun ,fname (,form ,result)
 363          (flet ((result-lvar () ,result))
 364            (destructuring-bind ,lambda-list ,form
 365              ,@body)))
 366        (push (cons ',name #',fname) *ir-translator*))))
 367
 368 (defun ir-convert-constant (form result)
 369   (let* ((leaf (make-constant :value form)))
 370     (insert-node (make-ref :leaf leaf :lvar result))))
 371
 372 (define-ir-translator quote (form)
 373   (ir-convert-constant form (result-lvar)))
 374
 375 (define-ir-translator setq (variable value)
 376   (let ((var (make-var :name variable))
 377         (value-lvar (make-lvar)))
 378     (ir-convert value value-lvar)
 379     (let ((assign (make-assignment :variable var :value value-lvar :lvar (result-lvar))))
 380       (insert-node assign))))
 381
 382 (define-ir-translator progn (&body body)
 383   (dolist (form (butlast body))
 384     (ir-convert form))
 385   (ir-convert (car (last body)) (result-lvar)))
 386
 387 (define-ir-translator if (test then &optional else)
 388   (when (conditional-p (cursor-next *cursor*))
 389     (error "Impossible to insert a conditional after another conditional."))
 390   ;; Split the basic block if we are in the middle of one.
 391   (unless (end-of-block-p) (split-block))
 392   (let ((test-lvar (make-lvar))
 393          (then-block (make-empty-block))
 394          (else-block (make-empty-block))
 395          (join-block (make-empty-block)))
 396     (ir-convert test test-lvar)
 397     (insert-node (make-conditional :test test-lvar :consequent then-block :alternative else-block))
 398     (let* ((block (cursor-block *cursor*))
 399            (tail-block (unlist (block-succ block))))
 400       ;; Link together the different created basic blocks.
 401       (setf (block-succ block)      (list else-block then-block)
 402             (block-pred else-block) (list block)
 403             (block-pred then-block) (list block)
 404             (block-succ then-block) (list join-block)
 405             (block-succ else-block) (list join-block)
 406             (block-pred join-block) (list else-block then-block)
 407             (block-succ join-block) (list tail-block)
 408             (block-pred tail-block) (substitute join-block block (block-pred tail-block))))
 409     ;; Convert he consequent and alternative forms and update cursor.
 410     (ir-convert then (result-lvar) (cursor :block then-block))
 411     (ir-convert else (result-lvar) (cursor :block else-block))
 412     (set-cursor :block join-block)))
 413
 414
 415 (defun ir-convert-var (form result)
 416   (let* ((leaf (make-var :name form))
 417          (ref (make-ref :leaf leaf :lvar result)))
 418     (insert-node ref)))
 419
 420 (defun ir-convert-call (form result)
 421   (destructuring-bind (function &rest args) form
 422     (let ((func-lvar (make-lvar))
 423           (args-lvars nil))
 424       (when (symbolp function)
 425         (ir-convert `(%symbol-function ,function) func-lvar))
 426       (dolist (arg args)
 427         (let ((arg-lvar (make-lvar)))
 428           (push arg-lvar args-lvars)
 429           (ir-convert arg arg-lvar)))
 430       (setq args-lvars (reverse args-lvars))
 431       (let ((call (make-call :function func-lvar :arguments args-lvars :lvar result)))
 432         (insert-node call)))))
 433
 434 ;;; Convert the Lisp expression FORM into IR before the NEXT node, it
 435 ;;; may create new basic blocks into the current component. During the
 436 ;;; initial IR conversion, The NEXT node is the EXIT node of the
 437 ;;; current basic block, but optimizations could call it to insert IR
 438 ;;; code somewhere.
 439 (defun ir-convert (form &optional result (*cursor* *cursor*))
 440   (cond
 441     ((atom form)
 442      (cond
 443        ((symbolp form)
 444         (ir-convert-var form result))
 445        (t
 446         (ir-convert-constant form result))))
 447     (t
 448      (destructuring-bind (op &rest args) form
 449        (let ((translator (cdr (assoc op *ir-translator*))))
 450          (if translator
 451              (funcall translator args result)
 452              (ir-convert-call form result))))))
 453   (values))
 454
 455
 456 ;;; IR Debugging
 457
 458 (defun print-node (node)
 459   (when (node-lvar node)
 460     (format t "~a = " (lvar-id (node-lvar node))))
 461   (cond
 462     ((ref-p node)
 463      (let ((leaf (ref-leaf node)))
 464        (cond
 465          ((var-p leaf)
 466           (format t "~a" (var-name leaf)))
 467          ((constant-p leaf)
 468           (format t "'~a" (constant-value leaf)))
 469          ((functional-p leaf)
 470           (format t "#<function ~a at ~a>"
 471                   (functional-name leaf)
 472                   (functional-entry-point leaf))))))
 473     ((assignment-p node)
 474      (format t "set ~a ~a"
 475              (var-name (assignment-variable node))
 476              (lvar-id (assignment-value node))))
 477     ((call-p node)
 478      (format t "call ~a" (lvar-id (call-function node)))
 479      (dolist (arg (call-arguments node))
 480        (format t " ~a" (lvar-id arg))))
 481     ((conditional-p node)
 482      (format t "if ~a ~a ~a"
 483              (lvar-id (conditional-test node))
 484              (block-id (conditional-consequent node))
 485              (block-id (conditional-alternative node))))
 486     (t
 487      (error "`print-node' does not support printing ~S as a node." node)))
 488   (terpri))
 489
 490 (defun print-block (block)
 491   (flet ((block-name (block)
 492            (cond
 493              ((and (singlep (block-pred block))
 494                    (component-entry-p (block-pred block)))
 495               "ENTRY")
 496              ((component-exit-p block)
 497               "EXIT")
 498              (t (string (block-id block))))))
 499     (format t "BLOCK ~a:~%" (block-name block))
 500     (do-nodes (node block)
 501       (print-node node))
 502     (when (singlep (block-succ block))
 503       (format t "GO ~a~%" (block-name (first (block-succ block)))))
 504     (terpri)))
 505
 506 (defun print-component (component &optional (stream *standard-output*))
 507   (let ((*standard-output* stream))
 508     (do-blocks (block component)
 509       (print-block block))))
 510
 511 ;;; A few consistency checks in the IR useful for catching bugs.
 512 (defun check-ir-consistency (&optional (component *component*))
 513   (with-simple-restart (continue "Continue execution")
 514     (do-blocks (block component)
 515       (dolist (succ (block-succ block))
 516         (unless (find block (block-pred succ))
 517           (error "The block `~S' does not belong to the predecessors list of the its successor `~S'"
 518                  (block-id block)
 519                  (block-id succ))))
 520       (dolist (pred (block-pred block))
 521         (unless (find block (block-succ pred))
 522           (error "The block `~S' does not belong to the successors' list of its predecessor `~S'"
 523                  (block-id block)
 524                  (block-id pred)))))))
 525
 526 ;;; Translate FORM into IR and print a textual repreresentation of the
 527 ;;; component.
 528 (defun describe-ir (form)
 529   (with-component-compilation
 530     (ir-convert form (make-lvar :id "$out"))
 531     (finish-component *component*)
 532     (check-ir-consistency)
 533     (print-component *component*)))
 534
 535
 536
 537
 538 ;;;; Code generation
 539
 540
 541 (defun relooper (component)
 542   )
 543
 544
 545
 546
 547
 548 ;;; compiler.lisp ends here