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 (defun singlep (x)
  26   (and (consp x) (null (cdr x))))
  27
  28 (defun unlist (x)
  29   (assert (singlep x))
  30   (first x))
  31
  32 ;;;; Intermediate representation
  33 ;;;;
  34 ;;;; This intermediate representation (IR) is a simplified version of
  35 ;;;; first intermediate representation what you will find if you have
  36 ;;;; a you have the source code of SBCL. Some terminology is also
  37 ;;;; used, but other is changed, so be careful if you assume you know
  38 ;;;; what it is because you know the name.
  39 ;;;;
  40
  41 ;;; A leaf stands for leaf in the tree of computations. Lexical
  42 ;;; variables, constants and literal functions are leafs. Leafs are
  43 ;;; not nodes itself, a `ref' node will stands for putting a leaf into
  44 ;;; a lvar, which can be used in computations.
  45 (defstruct leaf)
  46
  47 ;;; Reference a lexical variable. Special variables have not a
  48 ;;; representation in IR. They are handled via the primitive functions
  49 ;;; `%symbol-function' and `%symbol-value'.
  50 (defstruct (var (:include leaf))
  51   ;; Name is the symbol used to identify this variable in the lexical
  52   ;; environment.
  53   name)
  54
  55 ;;; A constant value, mostly from a quoted form, but maybe introduced
  56 ;;; in some pass of the compiler.
  57 (defstruct (constant (:include leaf))
  58   value)
  59
  60 ;;; A literal function. Why do we use `functional' as name? Well,
  61 ;;; function is taken, isn't it?
  62 (defstruct (functional (:include leaf))
  63   ;; The symbol which names this function in the source code.
  64   name
  65   ;; A list of lvars which are bound to the argument values in a call
  66   ;; to this function.
  67   arguments
  68   ;; LVAR which contains the return values of the function.
  69   return-lvar
  70   ;; The basic block which contain the code which be executed firstly
  71   ;; when you call this function.
  72   entry-point)
  73
  74
  75 ;;; Used to transfer data between the computations in the intermediate
  76 ;;; representation. Each node is valued into a LVar. And nodes which
  77 ;;; use resulting values from other nodes use such LVar.
  78 (defstruct lvar
  79   (id (gensym "$")))
  80
  81 ;;; A computation node. It represents a simple computation in the
  82 ;;; intermediate representation. Nodes are grouped in basic blocks,
  83 ;;; which are delimited by the special nodes `block-entry' and
  84 ;;; `block-exit'. Resulting value of the node is stored in LVAR, which it
  85 ;;; could be null if the value is discarded.
  86 (defstruct node
  87   next
  88   prev
  89   lvar)
  90
  91 ;;; Sentinel nodes. No computation really, but they make easier to
  92 ;;; manipulate the doubly linked-list.
  93 (defstruct (block-entry (:include node)))
  94 (defstruct (block-exit (:include node)))
  95
  96 ;;; A reference to a leaf.
  97 (defstruct (ref (:include node))
  98   leaf)
  99
 100 ;;; An assignation of the LVAR VALUE into the var VARIABLE.
 101 (defstruct (assignment (:include node))
 102   variable
 103   value)
 104
 105 ;;; Call the lvar FUNCTION with a list of lvars as ARGUMENTS.
 106 (defstruct (call (:include node))
 107   function
 108   arguments)
 109
 110 ;;; A conditional branch. If the LVAR is not NIL, then we will jump to
 111 ;;; the basic block CONSEQUENT, jumping to ALTERNATIVE otherwise. By
 112 ;;; definition, a conditional must appear at the end of a basic block.
 113 (defstruct (conditional (:include node))
 114   test
 115   consequent
 116   alternative)
 117
 118
 119 ;;; BBlock stands for `basic block', which is a maximal sequence of
 120 ;;; nodes with an entry point and an exit. Basic blocks are organized
 121 ;;; as a control flow graph with some more information in omponents.
 122 (defstruct bblock
 123   (id (gensym "L"))
 124   succ
 125   pred
 126   entry
 127   exit)
 128
 129 (defstruct (component-entry (:include bblock)))
 130 (defstruct (component-exit (:include bblock)))
 131
 132 (defun make-empty-bblock ()
 133   (let ((entry (make-block-entry))
 134         (exit (make-block-exit)))
 135     (setf (node-next entry) exit
 136           (node-prev exit) entry)
 137     (make-bblock :entry entry :exit exit)))
 138
 139 (defun empty-block-p (b)
 140   (block-exit-p (node-next (bblock-entry b))))
 141
 142 (defmacro do-nodes ((node block &optional result) &body body)
 143   (check-type node symbol)
 144   `(do ((,node (node-next (bblock-entry ,block)) (node-next ,node)))
 145        ((block-exit-p ,node) ,result)
 146      ,@body))
 147
 148 ;;; Link FROM and TO nodes together. FROM and TO must belong to the
 149 ;;; same basic block and appear in such order. The nodes between FROM
 150 ;;; and TO are discarded.
 151 (defun link-nodes (from to)
 152   (setf (node-next from) to
 153         (node-prev to) from)
 154   (values))
 155
 156 ;;; Insert NODE before NEXT.
 157 (defun insert-node-before (next node)
 158   (link-nodes (node-prev next) node)
 159   (link-nodes node next))
 160
 161
 162 ;;; Components are connected pieces of the control flow graph with
 163 ;;; some additional information. Components have well-defined entry
 164 ;;; and exit nodes. They also track what basic blocks we have and
 165 ;;; other useful information. It is the toplevel organizational entity
 166 ;;; in the compiler. The IR translation result is accumulated into
 167 ;;; components incrementally.
 168 (defstruct (component
 169              #-jscl (:print-object print-component))
 170   entry
 171   exit
 172   blocks)
 173
 174 ;;; Create a new component, compromised of the sentinel nodes and a
 175 ;;; empty basic block, ready to start conversion to IR. It returnes
 176 ;;; the component and the basic block as multiple values.
 177 (defun make-empty-component ()
 178   (let ((entry (make-component-entry))
 179         (bblock (make-empty-bblock))
 180         (exit (make-component-exit)))
 181     (setf (bblock-succ entry)  (list bblock)
 182           (bblock-pred exit)   (list bblock)
 183           (bblock-succ bblock) (list exit)
 184           (bblock-pred bblock) (list entry))
 185     (values (make-component :entry entry :exit exit) bblock)))
 186
 187 ;;; Delete an empty block. It is the same as a jump to an
 188 ;;; uncondiditonal jump.
 189 (defun delete-empty-block (block)
 190   (when (or (component-entry-p block) (component-exit-p block))
 191     (error "Cannot delete entry or exit basic blocks."))
 192   (unless (empty-block-p block)
 193     (error "Block `~S' is not empty!" (bblock-id block)))
 194   (assert (singlep (bblock-succ block)))
 195   (let ((successor (first (bblock-succ block))))
 196     (dolist (pred (bblock-pred block))
 197       (setf (bblock-succ pred)
 198             (substitute successor block (bblock-succ pred)))
 199       (pushnew pred (bblock-pred successor)))))
 200
 201 (defun finish-component (&optional (component *component*))
 202   (dolist (blk (bblock-pred (component-exit component)))
 203     (when (empty-block-p blk)
 204       (delete-empty-block blk))))
 205
 206 ;;; IR Translation
 207
 208 ;;; The current component. We accumulate the results of the IR
 209 ;;; conversion in this component.
 210 (defvar *component*)
 211
 212 ;;; The current block in the current component. IR conversion usually
 213 ;;; append nodes to this block. Branching instructions will modify
 214 ;;; this variable.
 215 (defvar *bblock*)
 216
 217 ;;; Prepare a new component with a current empty content block ready
 218 ;;; to start IR conversion. Then BODY is evaluated and the value of
 219 ;;; the last form is returned.
 220 (defmacro with-component-compilation (&body body)
 221   `(multiple-value-bind (*component* *bblock*)
 222        (make-empty-component)
 223      ,@body))
 224
 225 ;;; The Lexical environment is compromised of a list of bindings,
 226 ;;; which associates information to symbols. It tracks lexical
 227 ;;; variables, tags, local declarations and many other information in
 228 ;;; order to guide the compiler.
 229 (defstruct binding
 230   name type value declarations)
 231
 232 (defstruct lexenv
 233   bindings)
 234
 235 ;;; A alist of IR translator functions.
 236 (defvar *ir-translator* nil)
 237
 238 ;;; Define a IR translator for NAME.
 239 (defmacro define-ir-translator (name (next result) lambda-list &body body)
 240   (let ((fname (intern (format nil "IR-CONVERT-~a" (string name))))
 241         (form (gensym)))
 242     (check-type name symbol)
 243     (check-type next symbol)
 244     `(progn
 245        (defun ,fname (,form ,next ,result)
 246          (destructuring-bind ,lambda-list ,form
 247            ,@body))
 248        (push (cons ',name #',fname) *ir-translator*))))
 249
 250
 251 (defun ir-convert-constant (form next result)
 252   (let* ((leaf (make-constant :value form))
 253          (ref (make-ref :leaf leaf :lvar result)))
 254     (insert-node-before next ref)))
 255
 256 (define-ir-translator quote (next result) (form)
 257   (ir-convert-constant form next result))
 258
 259 (define-ir-translator setq (next result) (variable value)
 260   (let ((var (make-var :name variable))
 261         (value-lvar (make-lvar)))
 262     (ir-convert value next value-lvar)
 263     (let ((assign (make-assignment :variable var :value value-lvar :lvar result)))
 264       (insert-node-before next assign))))
 265
 266 ;;; Split BLOCK in two basic blocks. BLOCK ends just before BLOCK. A
 267 ;;; new block is created starting at NODE until the exit of the
 268 ;;; original block. The successors of BLOCK become the successors of
 269 ;;; the new block.
 270 (defun split-basic-block-before (node block)
 271   (let ((exit (node-prev (bblock-exit block)))
 272         (newexit (make-block-exit))
 273         (newentry (make-block-entry))
 274         newblock)
 275     (insert-node-before node newentry)
 276     (insert-node-before newentry newexit)
 277     (setf (node-next newexit)  nil)
 278     (setf (node-prev newentry) nil)
 279     (setf (bblock-exit block) newexit)
 280     (setq newblock (make-bblock :entry newentry :exit exit))
 281     (rotatef (bblock-succ block) (bblock-succ newblock))
 282     newblock))
 283
 284 (define-ir-translator if (next result) (test then &optional else)
 285   (let ((test-lvar (make-lvar))
 286         (then-block (make-empty-bblock))
 287         (else-block (make-empty-bblock))
 288         (join-block (make-empty-bblock)))
 289     ;; Convert the test into the current basic block.
 290     (ir-convert test next test-lvar)
 291     (setq next (bblock-exit *bblock*))
 292     (let ((cond (make-conditional :test test-lvar :consequent then-block :alternative else-block)))
 293       (insert-node-before next cond))
 294     ;; If we are not at the end of the content block, split it.
 295     (unless (block-exit-p next)
 296       (setq join-block (split-basic-block-before next *bblock*)))
 297     (dolist (succ (bblock-succ *bblock*))
 298       (setf (bblock-pred succ) (substitute join-block *bblock* (bblock-pred succ))))
 299     (psetf (bblock-succ *bblock*)   (list else-block then-block)
 300            (bblock-pred else-block) (list *bblock*)
 301            (bblock-pred then-block) (list *bblock*)
 302            (bblock-succ then-block) (list join-block)
 303            (bblock-succ else-block) (list join-block)
 304            (bblock-pred join-block) (list else-block then-block)
 305            (bblock-succ join-block) (bblock-succ *bblock*))
 306     (let ((*bblock* then-block))
 307       (ir-convert then (bblock-exit then-block) result))
 308     (let ((*bblock* else-block))
 309       (ir-convert else (bblock-exit else-block) result))
 310     (setq *bblock* join-block)))
 311
 312
 313 (defun ir-convert-var (form next result)
 314   (let* ((leaf (make-var :name form))
 315          (ref (make-ref :leaf leaf :lvar result)))
 316     (insert-node-before next ref)))
 317
 318 (defun ir-convert-call (form next result)
 319   (destructuring-bind (function &rest args) form
 320     (let ((func-lvar (make-lvar))
 321           (args-lvars nil))
 322       (when (symbolp function)
 323         (ir-convert `(%symbol-function ,function) next func-lvar))
 324       (dolist (arg args)
 325         (push (make-lvar) args-lvars)
 326         (ir-convert arg next (first args-lvars)))
 327       (setq args-lvars (reverse args-lvars))
 328       (let ((call (make-call :function func-lvar :arguments args-lvars :lvar result)))
 329         (insert-node-before next call)))))
 330
 331
 332 ;;; Convert the Lisp expression FORM into IR before the NEXT node, it
 333 ;;; may create new basic blocks into the current component. During the
 334 ;;; initial IR conversion, The NEXT node is the EXIT node of the
 335 ;;; current basic block, but optimizations could call it to insert IR
 336 ;;; code somewhere.
 337 (defun ir-convert (form next result)
 338   (when (block-entry-p next)
 339     (error "Can't insert IR before the entry node."))
 340   (cond
 341     ((atom form)
 342      (cond
 343        ((symbolp form)
 344         (ir-convert-var form next result))
 345        (t
 346         (ir-convert-constant form next result))))
 347     (t
 348      (destructuring-bind (op &rest args) form
 349        (let ((translator (cdr (assoc op *ir-translator*))))
 350          (if translator
 351              (funcall translator args next result)
 352              (ir-convert-call form next result))))))
 353   (values))
 354
 355 (defun compute-dfo (component)
 356   (or (component-blocks component)
 357       (let ((output nil))
 358         (labels ((compute-dfo-from (block)
 359                    (unless (or (component-exit-p block) (find block output))
 360                      (dolist (successor (bblock-succ block))
 361                        (unless (component-exit-p block)
 362                          (compute-dfo-from successor)))
 363                      (push block output))))
 364           (compute-dfo-from (unlist (bblock-succ (component-entry component))))
 365           (setf (component-blocks component) output)))))
 366
 367 (defmacro do-blocks ((bblock component &optional result) &body body)
 368   `(dolist (,bblock (compute-dfo ,component) ,result)
 369      ,@body))
 370
 371 ;;; IR Debugging
 372
 373 (defun print-node (node)
 374   (when (node-lvar node)
 375     (format t "~a = " (lvar-id (node-lvar node))))
 376   (cond
 377     ((ref-p node)
 378      (let ((leaf (ref-leaf node)))
 379        (cond
 380          ((var-p leaf)
 381           (format t "~a" (var-name leaf)))
 382          ((constant-p leaf)
 383           (format t "'~a" (constant-value leaf)))
 384          ((functional-p leaf)
 385           (format t "#<function ~a at ~a>"
 386                   (functional-name leaf)
 387                   (functional-entry-point leaf))))))
 388     ((assignment-p node)
 389      (format t "set ~a ~a"
 390              (var-name (assignment-variable node))
 391              (lvar-id (assignment-value node))))
 392     ((call-p node)
 393      (format t "call ~a" (lvar-id (call-function node)))
 394      (dolist (arg (call-arguments node))
 395        (format t " ~a" (lvar-id arg))))
 396     ((conditional-p node)
 397      (format t "if ~a ~a ~a"
 398              (lvar-id (conditional-test node))
 399              (bblock-id (conditional-consequent node))
 400              (bblock-id (conditional-alternative node))))
 401     (t
 402      (error "`print-node' does not support printing ~S as a node." node)))
 403   (terpri))
 404
 405 (defun print-bblock (block)
 406   (flet ((bblock-name (block)
 407            (cond
 408              ((and (singlep (bblock-pred block))
 409                    (component-entry-p (bblock-pred block)))
 410               "ENTRY")
 411              ((component-exit-p block)
 412               "EXIT")
 413              (t (string (bblock-id block))))))
 414     (format t "BLOCK ~a:~%" (bblock-name block))
 415     (do-nodes (node block)
 416      (print-node node))
 417     (when (singlep (bblock-succ block))
 418       (format t "GO ~a~%" (bblock-name (first (bblock-succ block)))))
 419     (terpri)))
 420
 421 (defun print-component (component &optional (stream *standard-output*))
 422   (let ((*standard-output* stream))
 423     (do-blocks (block component)
 424       (print-bblock block))))
 425
 426 (defun check-ir-consistency (&optional (component *component*))
 427   (with-simple-restart (continue "Continue execution")
 428     (do-blocks (block component)
 429       (dolist (succ (bblock-succ block))
 430         (unless (find block (bblock-pred succ))
 431           (error "The block `~S' does not belong to the predecessors list of the its successor `~S'"
 432                  (bblock-id block)
 433                  (bblock-id succ))))
 434       (dolist (pred (bblock-pred block))
 435         (unless (find block (bblock-succ pred))
 436           (error "The block `~S' does not belong to the successors' list of its predecessor `~S'"
 437                  (bblock-id block)
 438                  (bblock-id pred)))))))
 439
 440 ;;; Translate FORM into IR and print a textual repreresentation of the
 441 ;;; component.
 442 (defun describe-ir (form)
 443   (with-component-compilation
 444     (ir-convert form (bblock-exit *bblock*) (make-lvar :id "$out"))
 445     (finish-component)
 446     (check-ir-consistency)
 447     (print-component *component*)))
 448
 449
 450 ;;; compiler.lisp ends here