3 ;; Copyright (C) 2013 David Vazquez
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.
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.
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/>.
25 ;;;; Random Common Lisp code useful to use here and there.
27 (defmacro with-gensyms ((&rest vars) &body body)
28 `(let ,(mapcar (lambda (var) `(,var (gensym ,(concatenate 'string (string var) "-")))) vars)
32 (and (consp x) (null (cdr x))))
38 (defun generic-printer (x stream)
39 (print-unreadable-object (x stream :type t :identity t)))
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*)))
50 (push (cons class 1) *counter-alist*)))))
52 (defmacro while (condition &body body)
53 `(do nil ((not ,condition)) ,@body))
55 ;;;; Intermediate representation structures
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.
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'.
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.
77 ;;; A literal Lisp object. It usually comes from a quoted expression.
78 (defstruct (constant (:include leaf))
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.
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.
97 (id (generate-id 'lvar)))
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.
105 ;; Lvar which stands for the result of the computation of this node.
108 ;;; Sentinel nodes in the basic block sequence of nodes.
109 (defstruct (block-entry (:include node)))
110 (defstruct (block-exit (:include node)))
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
115 (defstruct (ref (:include node))
118 ;;; An assignation of the LVAR VALUE into the var VARIABLE.
119 (defstruct (assignment (:include node))
123 ;;; A base node to function calls with a list of lvar as ARGUMENTS.
124 (defstruct (combination (:include node) (:constructor))
127 ;;; A function call to the ordinary Lisp function in the lvar FUNCTION.
128 (defstruct (call (:include combination))
131 ;;; A function call to the primitive FUNCTION.
132 (defstruct (primitive-call (:include combination))
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))
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)
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.
154 ;; The sentinel nodes of the sequence.
156 ;; The component where the basic block belongs to.
158 ;; The order in the reverse post ordering of the blocks.
160 ;; The innermost loop this block belongs to.
162 ;; A bit-vector representing the set of dominators. See the function
163 ;; `compute-dominators' to know how to use it properly.
165 ;; Arbitrary data which could be necessary to keep during IR
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)))
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)))))
178 (defun boundary-block-p (block)
179 (or (component-entry-p block)
180 (component-exit-p block)))
182 ;;; Iterate across the nodes in a basic block forward.
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)))
189 (,(if include-sentinel-p
191 `(block-exit-p ,node))
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
200 `(node-prev (block-entry ,block)))
202 (,(if include-sentinel-p
204 `(block-entry-p ,node))
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
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))
228 ;; TODO: Replace with a flags slot for indicate what
229 ;; analysis/transformations have been carried out.
231 ;; List of natural loops in this component.
235 ;;; The current component.
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*))
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
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))))
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'"
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'"
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))))))
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)))
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)
299 (labels ((compute-from (block)
300 (unless (find 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))
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)))))))))
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
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
339 (setf (block-pred successor) (remove block (block-pred successor)))
340 (setf (block-succ block) nil))))
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.
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
358 ;;; The current cursor. It is the default cursor for many functions
359 ;;; which work on cursors.
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*))
367 ;;; Create a cursor which points to the basic block BLOCK. If omitted,
368 ;;; then the current block is used.
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
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)
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)
386 (:entry (block-entry block))
387 (:exit (block-exit block))
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."))
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)))
403 (do-nodes-backward (node block (out-of-range-cursor) :include-sentinel-p t)
404 (when (eq next node) (return))))
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))
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))
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
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
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*))
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)))
458 ;;;; Lexical environment
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.
465 name namespace type value)
467 (defvar *lexenv* nil)
469 (defun find-binding (name namespace)
471 (and (eq (binding-name b) name)
472 (eq (binding-namespace b) namespace)))
475 (defun push-binding (name namespace value &optional type)
476 (push (make-binding :name name
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.
491 ;;; A alist of IR translator functions.
492 (defvar *ir-translator* nil)
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.
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)
506 (defun ,fname (,form ,result)
507 (flet ((result-lvar () ,result))
508 (declare (ignorable (function result-lvar)))
509 (destructuring-bind ,lambda-list ,form
511 (push (cons ',name #',fname) *ir-translator*)))))
513 ;;; Return the unique successor of the current block. If it is not
514 ;;; unique signal an error.
516 (unlist (block-succ (current-block))))
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))
527 (defun ir-convert-constant (form result)
528 (let* ((leaf (make-constant :value form)))
529 (insert-node (make-ref :leaf leaf :lvar result))))
531 (define-ir-translator quote (form)
532 (ir-convert-constant form (result-lvar)))
534 (define-ir-translator setq (variable value)
535 (let ((b (find-binding variable 'variable)))
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))))
544 (ir-convert `(set ',variable ,value) (result-lvar))))))
546 (define-ir-translator progn (&body body)
547 (mapc #'ir-convert (butlast body))
548 (ir-convert (car (last body)) (result-lvar)))
550 (define-ir-translator if (test then &optional else)
551 ;; It is the schema of how the basic blocks will look like
554 ;; <aaaaXX> --< >-- <|> -- <zzzz>
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)))
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)))
588 (define-ir-translator return-from (name &optional value)
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)))))
603 (define-ir-translator tagbody (&rest statements)
605 (or (integerp x) (symbolp x))))
606 (let* ((tags (remove-if-not #'go-tag-p statements))
608 ;; Create a chain of basic blocks for the tags, recording each
609 ;; block in a alist in TAG-BLOCKS.
610 (let ((*cursor* *cursor*))
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)
621 (set-cursor :block (cdr (assoc stmt tag-blocks))))
623 (error "Invalid tag `~S'" stmt))
625 (ir-convert stmt)))))))
627 (define-ir-translator go (label)
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))))
637 (defun convert-functional (result name arguments &rest body)
639 (return-lvar (make-lvar)))
640 (with-component-compilation (name)
641 (ir-convert `(progn ,@body) return-lvar)
643 (setq component *component*))
649 :return-lvar return-lvar)))
650 (push functional (component-functions *component*))
651 (insert-node (make-ref :leaf functional :lvar result)))))
653 (define-ir-translator function (name)
655 (ir-convert `(symbol-function ,name) (result-lvar))
657 ((lambda named-lambda)
658 (let ((desc (cdr name)))
659 (when (eq 'lambda (car name))
661 (apply #'convert-functional (result-lvar) desc)))
664 (defun ir-convert-var (form result)
665 (let ((binds (find-binding form 'variable)))
667 (insert-node (make-ref :leaf (binding-value binds) :lvar result))
668 (ir-convert `(symbol-value ',form) result))))
670 (defun ir-convert-call (form result)
671 (destructuring-bind (function &rest args) form
672 (let ((func-lvar (make-lvar))
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))
681 (if (find-primitive function)
682 (insert-node (make-primitive-call
683 :function (find-primitive function)
684 :arguments args-lvars
687 (ir-convert `(symbol-function ',function) func-lvar)
688 (insert-node (make-call :function func-lvar
689 :arguments args-lvars
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
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.
708 (ir-convert-var form result))
710 (ir-convert-constant form result))))
712 (destructuring-bind (op &rest args) form
713 (let ((translator (cdr (assoc op *ir-translator*))))
715 (funcall translator args result)
716 (ir-convert-call form result))))))
720 ;;;; IR Normalization
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.
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)
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))
755 (let ((block-list nil))
756 (dolist (block (component-blocks component))
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.
775 (push block block-list))))
776 (setf (component-blocks component) block-list))
777 (check-ir-consistency))
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.
787 (defun compute-reverse-post-order (&optional (component *component*))
789 (index (length (component-blocks component))))
790 (flet ((add-block-to-list (block)
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)))
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))
811 ,@(if (member ends '(:tail :both))
813 `((if (component-exit-p ,block) (return))))
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)
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)
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.
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)
856 (setq changes (not (equal (block-dominators% block) new-dominators))))
857 (setf (block-dominators% block) new-dominators)
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))))
869 (defstruct natural-loop
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
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)
889 :parent (block-loop 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))))))))
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))))
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)
924 (dolist (block (component-blocks *component*))
925 (push (list block (block-succ block) (block-pred block)) ,edges))
926 (unwind-protect (progn ,@body)
928 (dolist (entry ,edges)
929 (destructuring-bind (block succ pred) entry
930 (setf (block-succ block) succ
931 (block-pred block) pred)))))))
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.
939 (make-array (length list-blocks)
940 :initial-contents (component-blocks component)
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
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)))
952 ;; Collapse a block back into its predecessor if it is unique
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))))
962 ;; This function duplicates the block in component for each input
963 ;; edge. A technique useful to make a general flowgraph reducible.
965 (let ((predecessors (block-pred block)))
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
991 ((>= i (length vector-blocks)))
992 (let ((block (aref vector-blocks i)))
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)))
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))))))))
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.
1028 (defun format-block-name (block)
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))))
1035 (format nil "BLOCK ~a" (block-order block)))))
1038 (defun print-node (node)
1039 (when (node-lvar node)
1040 (format t "$~a = " (lvar-id (node-lvar node))))
1043 (let ((leaf (ref-leaf node)))
1046 (format t "~a" (var-name 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))))
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))))
1069 (error "`print-node' does not support printing ~S as a node." node)))
1072 (defun print-block (block)
1073 (write-string (format-block-name block))
1074 (if (loop-header-p block)
1075 (write-line " [LOOP_HEADER]")
1077 (do-nodes (node block)
1079 (when (singlep (block-succ block))
1080 (format t "GO ~a~%~%" (format-block-name (unlist (block-succ block))))))
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)))))
1092 ;;; Translate FORM into IR and print a textual repreresentation of the
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"))
1100 (compute-reverse-post-order)
1101 (compute-dominators)
1102 (find-natural-loops)
1103 (/print *component*)
1106 (defmacro /ir (form)
1107 `(convert-toplevel-and-print ',form))
1110 ;;;; Backend [DRAFT]
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.
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
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.
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).
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.
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))))
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))
1166 (process-loop parent-loop)
1168 (push (make-region :header (natural-loop-header loop))
1169 (region-childs parent-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)
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
1194 (defvar *primitive-function-table* nil)
1196 (defstruct primitive
1199 (defmacro define-primitive (name args &body body)
1200 (declare (ignore args body))
1201 `(push (make-primitive :name ',name)
1202 *primitive-function-table*))
1204 (defun find-primitive (name)
1205 (find name *primitive-function-table* :key #'primitive-name))
1207 (define-primitive symbol-function (symbol))
1208 (define-primitive symbol-value (symbol))
1209 (define-primitive set (symbol value))
1210 (define-primitive fset (symbol value))
1212 (define-primitive + (&rest numbers))
1213 (define-primitive - (number &rest other-numbers))
1215 (define-primitive consp (x))
1216 (define-primitive cons (x y))
1217 (define-primitive car (x))
1218 (define-primitive cdr (x))
1221 ;;; compiler.lisp ends here