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