Rename ir-complete to ir-normalize
[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 ;;;; Components
144 ;;;;
145 ;;;; Components are connected pieces of the control flow graph of
146 ;;;; basic blocks with some additional information. Components have
147 ;;;; well-defined entry and exit nodes. It is the toplevel
148 ;;;; organizational entity in the compiler. The IR translation result
149 ;;;; is accumulated into components incrementally.
150 (defstruct (component (:print-object generic-printer))
151   (id (generate-id 'component))
152   name
153   entry
154   exit
155   functions)
156
157 ;;; The current component. We accumulate the results of the IR
158 ;;; conversion in this component.
159 (defvar *component*)
160
161 ;;; Create a new component with an empty basic block, ready to start
162 ;;; conversion to IR. It returns the component and the basic block as
163 ;;; multiple values.
164 (defun make-empty-component (&optional name)
165   (let ((*component* (make-component :name name)))
166     (let ((entry (make-component-entry))
167           (block (make-empty-block))
168           (exit (make-component-exit)))
169       (setf (block-succ entry) (list block)
170             (block-pred exit)  (list block)
171             (block-succ block) (list exit)
172             (block-pred block) (list entry)
173             (component-entry *component*) entry
174             (component-exit  *component*) exit)
175       (values *component* block))))
176
177 ;;; Prepare a new component with a current empty block ready to start
178 ;;; IR conversion bound in the current cursor. BODY is evaluated and
179 ;;; the value of the last form is returned.
180 (defmacro with-component-compilation ((&optional name) &body body)
181   (with-gensyms (block)
182     `(multiple-value-bind (*component* ,block)
183          (make-empty-component ,name)
184        (let ((*cursor* (cursor :block ,block)))
185          ,@body))))
186
187 ;;; Return the list of blocks in COMPONENT, conveniently sorted.
188 (defun component-blocks (component)
189   (let ((seen nil)
190         (output nil))
191     (labels ((compute-rdfo-from (block)
192                (unless (or (component-exit-p block) (find block seen))
193                  (push block seen)
194                  (dolist (successor (block-succ block))
195                    (unless (component-exit-p block)
196                      (compute-rdfo-from successor)))
197                  (push block output))))
198       (compute-rdfo-from (unlist (block-succ (component-entry component))))
199       output)))
200
201 ;;; Iterate across different blocks in COMPONENT.
202 (defmacro do-blocks ((block component &optional result) &body body)
203   `(dolist (,block (component-blocks ,component) ,result)
204      ,@body))
205
206 (defmacro do-blocks-backward ((block component &optional result) &body body)
207   `(dolist (,block (reverse (component-blocks ,component)) ,result)
208      ,@body))
209
210 ;;; A few consistency checks in the IR useful for catching bugs.
211 (defun check-ir-consistency (&optional (component *component*))
212   (with-simple-restart (continue "Continue execution")
213     (do-blocks (block component)
214       (dolist (succ (block-succ block))
215         (unless (find block (block-pred succ))
216           (error "The block `~S' does not belong to the predecessors list of the its successor `~S'"
217                  (block-id block)
218                  (block-id succ))))
219       (dolist (pred (block-pred block))
220         (unless (find block (block-succ pred))
221           (error "The block `~S' does not belong to the successors' list of its predecessor `~S'"
222                  (block-id block)
223                  (block-id pred)))))))
224
225
226 ;;; Blocks are `basic block`. Basic blocks are organized as a control
227 ;;; flow graph with some more information in omponents.
228 (defstruct (basic-block
229              (:conc-name "BLOCK-")
230              (:constructor make-block)
231              (:predicate block-p))
232   (id (generate-id 'basic-block))
233   ;; List of successors and predecessors of this basic block.
234   succ pred
235   ;; The sentinel nodes of the sequence.
236   entry exit
237   ;; The component where this block belongs
238   (component *component*))
239
240 ;;; Sentinel nodes in the control flow graph of basic blocks.
241 (defstruct (component-entry (:include basic-block)))
242 (defstruct (component-exit (:include basic-block)))
243
244 ;;; Return a fresh empty basic block.
245 (defun make-empty-block ()
246   (let ((entry (make-block-entry))
247         (exit (make-block-exit)))
248     (setf (node-next entry) exit
249           (node-prev exit) entry)
250     (make-block :entry entry :exit exit)))
251
252 ;;; Return T if B is an empty basic block and NIL otherwise.
253 (defun empty-block-p (b)
254   (block-exit-p (node-next (block-entry b))))
255
256 ;;; Iterate across the nodes in a basic block forward.
257 (defmacro do-nodes
258     ((node block &optional result &key include-sentinel-p) &body body)
259   `(do ((,node ,(if include-sentinel-p
260                     `(block-entry ,block)
261                     `(node-next (block-entry ,block))) 
262                (node-next ,node)))
263        (,(if include-sentinel-p
264              `(null ,node)
265              `(block-exit-p ,node))
266         ,result)
267      ,@body))
268
269 ;;; Iterate across the nodes in a basic block backward.
270 (defmacro do-nodes-backward
271     ((node block &optional result &key include-sentinel-p) &body body)
272   `(do ((,node ,(if include-sentinel-p
273                     `(block-exit ,block)
274                     `(node-prev (block-entry ,block))) 
275                (node-prev ,node)))
276        (,(if include-sentinel-p
277              `(null ,node)
278              `(block-entry-p ,node))
279         ,result)
280      ,@body))
281
282 ;;; Link FROM and TO nodes together. FROM and TO must belong to the
283 ;;; same basic block and appear in such order. The nodes between FROM
284 ;;; and TO are discarded.
285 (defun link-nodes (from to)
286   (setf (node-next from) to
287         (node-prev to) from)
288   (values))
289
290
291
292 ;;;; Cursors
293 ;;;;
294 ;;;; A cursor is a point between two nodes in some basic block in the
295 ;;;; IR representation where manipulations can take place, similarly
296 ;;;; to the cursors in text editing.
297 ;;;;
298 ;;;; Cursors cannot point to special component's entry and exit basic
299 ;;;; blocks or after a conditional node. Conveniently, the `cursor'
300 ;;;; function will signal an error if the cursor is not positioned
301 ;;;; correctly, so the rest of the code does not need to check once
302 ;;;; and again.
303
304 (defstruct cursor
305   block next)
306
307 ;;; The current cursor. It is the default cursor for many functions
308 ;;; which work on cursors.
309 (defvar *cursor*)
310
311 ;;; Return the current basic block. It is to say, the basic block
312 ;;; where the current cursor is pointint.
313 (defun current-block ()
314   (cursor-block *cursor*))
315
316 ;;; Create a cursor which points to the basic block BLOCK. If omitted,
317 ;;; then the current block is used.
318 ;;;
319 ;;; The keywords AFTER and BEFORE specify the cursor will point after (or
320 ;;; before) that node respectively. If none is specified, the cursor is
321 ;;; created before the exit node in BLOCK. An error is signaled if both
322 ;;; keywords are specified inconsistently, or if the nodes do not belong
323 ;;; to BLOCK.
324 ;;;
325 ;;; AFTER and BEFORE could also be the special values :ENTRY and :EXIT,
326 ;;; which stand for the entry and exit nodes of the block respectively.
327 (defun cursor (&key (block (current-block))
328                  (before nil before-p)
329                  (after nil after-p))
330   (when (or (component-entry-p block) (component-exit-p block))
331     (error "Invalid cursor on special entry/exit basic block."))
332   ;; Handle special values :ENTRY and :EXIT.
333   (flet ((node-designator (x)
334            (case x
335              (:entry (block-entry block))
336              (:exit  (block-exit block))
337              (t x))))
338     (setq before (node-designator before))
339     (setq after  (node-designator after)))
340   (let* ((next (or before (and after (node-next after)) (block-exit block)))
341          (cursor (make-cursor :block block :next next)))
342     (flet ((out-of-range-cursor ()
343              (error "Out of range cursor."))
344            (ambiguous-cursor ()
345              (error "Ambiguous cursor specified between two non-adjacent nodes.")))
346       (when (conditional-p (node-prev next))
347         (error "Invalid cursor after conditional node."))
348       (when (or (null next) (block-entry-p next))
349         (out-of-range-cursor))
350       (when (and before-p after-p (not (eq after before)))
351         (ambiguous-cursor))
352       (do-nodes-backward (node block (out-of-range-cursor) :include-sentinel-p t)
353         (when (eq next node) (return))))
354     cursor))
355
356 ;;; Accept a cursor specification just as described in `cursor'
357 ;;; describing a position in the IR and modify destructively the
358 ;;; current cursor to point there.
359 (defun set-cursor (&rest cursor-spec)
360   (let ((newcursor (apply #'cursor cursor-spec)))
361     (setf (cursor-block *cursor*) (cursor-block newcursor))
362     (setf (cursor-next *cursor*) (cursor-next newcursor))
363     *cursor*))
364
365 ;;; Insert NODE at cursor.
366 (defun insert-node (node &optional (cursor *cursor*))
367   ;; After if? wrong!
368   (link-nodes (node-prev (cursor-next cursor)) node)
369   (link-nodes node (cursor-next cursor))
370   t)
371
372 ;;; Split the block at CURSOR. The cursor will point to the end of the
373 ;;; first basic block. Return the three basic blocks as multiple
374 ;;; values.
375 (defun split-block (&optional (cursor *cursor*))
376   ;; <aaaaa|zzzzz>  ==>  <aaaaa|>--<zzzzz>
377   (let* ((block (cursor-block cursor))
378          (newexit (make-block-exit))
379          (newentry (make-block-entry))
380          (exit (block-exit block))
381          (newblock (make-block :entry newentry
382                                :exit exit
383                                :pred (list block)
384                                :succ (block-succ block))))
385     (insert-node newexit)
386     (insert-node newentry)
387     (setf (node-next newexit)  nil)
388     (setf (node-prev newentry) nil)
389     (setf (block-exit block) newexit)
390     (setf (block-succ block) (list newblock))
391     (dolist (succ (block-succ newblock))
392       (setf (block-pred succ) (substitute newblock block (block-pred succ))))
393     (set-cursor :block block :before newexit)
394     newblock))
395
396 ;;; Split the block at CURSOR if it is in the middle of it. The cursor
397 ;;; will point to the end of the first basic block. Return the three
398 ;;; basic blocks as multiple values.
399 (defun maybe-split-block (&optional (cursor *cursor*))
400   ;; If we are converting IR into the end of the basic block, it's
401   ;; fine, we don't need to do anything.
402   (unless (block-exit-p (cursor-next cursor))
403     (split-block cursor)))
404
405
406
407 ;;;; Lexical environment
408 ;;;;
409 ;;;; It keeps an association between names and the IR entities. It is
410 ;;;; used to guide the translation from the Lisp source code to the
411 ;;;; intermediate representation.
412
413 (defstruct binding
414   name namespace type value)
415
416 (defvar *lexenv* nil)
417
418 (defun find-binding (name namespace)
419   (find-if (lambda (b)
420              (and (eq (binding-name b) name)
421                   (eq (binding-namespace b) namespace)))
422            *lexenv*))
423
424 (defun push-binding (name namespace value &optional type)
425   (push (make-binding :name name
426                       :namespace namespace
427                       :type type
428                       :value value)
429         *lexenv*))
430
431
432 ;;;; IR Translation
433 ;;;;
434 ;;;; This code covers the translation from Lisp source code to the
435 ;;;; intermediate representation. The main entry point function to do
436 ;;;; that is the `ir-convert' function, which dispatches to IR
437 ;;;; translators. This function ss intended to do the initial
438 ;;;; conversion as well as insert new IR code during optimizations.
439 ;;;;
440 ;;;; The function `ir-normalize' will coalesce basic blocks in a
441 ;;;; component to generate proper maximal basic blocks.
442
443 ;;; A alist of IR translator functions.
444 (defvar *ir-translator* nil)
445
446 ;;; Define a IR translator for NAME. LAMBDA-LIST is used to
447 ;;; destructure the arguments of the form. Calling the local function
448 ;;; `result-lvar' you can get the LVAR where the compilation of the
449 ;;; expression should store the result of the evaluation.
450 ;;;
451 ;;; The cursor is granted to be at the end of a basic block with a
452 ;;; unique successor, and so it should be when the translator returns.
453 (defmacro define-ir-translator (name lambda-list &body body)
454   (check-type name symbol)
455   (let ((fname (intern (format nil "IR-CONVERT-~a" (string name)))))
456     (with-gensyms (result form)
457       `(progn
458          (defun ,fname (,form ,result)
459            (flet ((result-lvar () ,result))
460              (declare (ignorable (function result-lvar)))
461              (destructuring-bind ,lambda-list ,form
462                ,@body)))
463          (push (cons ',name #',fname) *ir-translator*)))))
464
465 ;;; Return the unique successor of the current block. If it is not
466 ;;; unique signal an error.
467 (defun next-block ()
468   (unlist (block-succ (current-block))))
469
470 ;;; Set the next block of the current one.
471 (defun (setf next-block) (new-value)
472   (let ((block (current-block)))
473     (dolist (succ (block-succ block))
474       (setf (block-pred succ) (remove block (block-pred succ))))
475     (setf (block-succ block) (list new-value))
476     (push block (block-pred new-value))
477     new-value))
478
479 (defun ir-convert-constant (form result)
480   (let* ((leaf (make-constant :value form)))
481     (insert-node (make-ref :leaf leaf :lvar result))))
482
483 (define-ir-translator quote (form)
484   (ir-convert-constant form (result-lvar)))
485
486 (define-ir-translator setq (variable value)
487   (let ((b (find-binding variable 'variable)))
488     (cond
489       (b
490        (let ((var (make-var :name variable))
491              (value-lvar (make-lvar)))
492          (ir-convert value value-lvar)
493          (let ((assign (make-assignment :variable var :value value-lvar :lvar (result-lvar))))
494            (insert-node assign))))
495       (t
496        (ir-convert `(set ',variable ,value) (result-lvar))))))
497
498 (define-ir-translator progn (&body body)
499   (mapc #'ir-convert (butlast body))
500   (ir-convert (car (last body)) (result-lvar)))
501
502 (define-ir-translator if (test then &optional else)
503   ;; It is the schema of how the basic blocks will look like
504   ;;
505   ;;              / ..then.. \
506   ;;  <aaaaXX> --<            >-- <|> -- <zzzz>
507   ;;              \ ..else.. /
508   ;;
509   ;; Note that is important to leave the cursor in an empty basic
510   ;; block, as zzz could be the exit basic block of the component,
511   ;; which is an invalid position for a cursor.
512   (let ((test-lvar (make-lvar))
513         (then-block (make-empty-block))
514         (else-block (make-empty-block))
515         (join-block (make-empty-block)))
516     (ir-convert test test-lvar)
517     (insert-node (make-conditional :test test-lvar :consequent then-block :alternative else-block))
518     (let* ((block (current-block))
519            (tail-block (next-block)))
520       ;; Link together the different created basic blocks.
521       (setf (block-succ block)      (list else-block then-block)
522             (block-pred else-block) (list block)
523             (block-pred then-block) (list block)
524             (block-succ then-block) (list join-block)
525             (block-succ else-block) (list join-block)
526             (block-pred join-block) (list else-block then-block)
527             (block-succ join-block) (list tail-block)
528             (block-pred tail-block) (substitute join-block block (block-pred tail-block))))
529     ;; Convert he consequent and alternative forms and update cursor.
530     (ir-convert then (result-lvar) (cursor :block then-block))
531     (ir-convert else (result-lvar) (cursor :block else-block))
532     (set-cursor :block join-block)))
533
534 (define-ir-translator block (name &body body)
535   (let ((new (split-block)))
536     (push-binding name 'block (cons (next-block) (result-lvar)))
537     (ir-convert `(progn ,@body) (result-lvar))
538     (set-cursor :block new)))
539
540 (define-ir-translator return-from (name &optional value)
541   (let ((binding
542          (or (find-binding name 'block)
543              (error "Tried to return from unknown block `~S' name" name))))
544     (destructuring-bind (jump-block . lvar)
545         (binding-value binding)
546       (ir-convert value lvar)
547       (setf (next-block) jump-block)
548       ;; This block is really unreachable, even if the following code
549       ;; is labelled in a tagbody, as tagbody will create a new block
550       ;; for each label. However, we have to leave the cursor
551       ;; somewhere to convert new input.
552       (let ((dummy (make-empty-block)))
553         (set-cursor :block dummy)))))
554
555 (define-ir-translator tagbody (&rest statements)
556   (flet ((go-tag-p (x)
557            (or (integerp x) (symbolp x))))
558     (let* ((tags (remove-if-not #'go-tag-p statements))
559            (tag-blocks nil))
560       ;; Create a chain of basic blocks for the tags, recording each
561       ;; block in a alist in TAG-BLOCKS.
562       (let ((*cursor* *cursor*))
563         (dolist (tag tags)
564           (setq *cursor* (cursor :block (split-block)))
565           (push-binding tag 'tag (current-block))
566           (if (assoc tag tag-blocks)
567               (error "Duplicated tag `~S' in tagbody." tag)
568               (push (cons tag (current-block)) tag-blocks))))
569       ;; Convert the statements into the correct block.
570       (dolist (stmt statements)
571         (if (go-tag-p stmt)
572             (set-cursor :block (cdr (assoc stmt tag-blocks)))
573             (ir-convert stmt))))))
574
575 (define-ir-translator go (label)
576   (let ((tag-binding
577          (or (find-binding label 'tag)
578              (error "Unable to jump to the label `~S'" label))))
579     (setf (next-block) (binding-value tag-binding))
580     ;; Unreachable block.
581     (let ((dummy (make-empty-block)))
582       (set-cursor :block dummy))))
583
584
585 (defun ir-convert-functoid (result name arguments &rest body)
586   (let ((component)
587         (return-lvar (make-lvar)))
588     (with-component-compilation (name)
589       (ir-convert `(progn ,@body) return-lvar)
590       (ir-normalize)
591       (setq component *component*))
592     (let ((functional
593            (make-functional
594             :name name
595             :arguments arguments
596             :component component
597             :return-lvar return-lvar)))
598       (push functional (component-functions *component*))
599       (insert-node (make-ref :leaf functional :lvar result)))))
600
601 (define-ir-translator function (name)
602   (if (atom name)
603       (ir-convert `(symbol-function ,name) (result-lvar))
604       (ecase (car name)
605         ((lambda named-lambda)
606          (let ((desc (cdr name)))
607            (when (eq 'lambda (car name))
608              (push nil desc))
609            (apply #'ir-convert-functoid (result-lvar) desc)))
610         (setf))))
611
612 (defun ir-convert-var (form result)
613   (let ((binds (find-binding form 'variable)))
614     (if binds
615         (insert-node (make-ref :leaf (binding-value binds) :lvar result))
616         (ir-convert `(symbol-value ',form) result))))
617
618 (defun ir-convert-call (form result)
619   (destructuring-bind (function &rest args) form
620     (let ((func-lvar (make-lvar))
621           (args-lvars nil))
622       ;; Argument list
623       (dolist (arg args)
624         (let ((arg-lvar (make-lvar)))
625           (push arg-lvar args-lvars)
626           (ir-convert arg arg-lvar)))
627       (setq args-lvars (reverse args-lvars))
628       ;; Funcall
629       (if (find-primitive function)
630           (insert-node (make-primitive-call
631                         :function (find-primitive function)
632                         :arguments args-lvars
633                         :lvar result))
634           (progn
635             (ir-convert `(symbol-function ,function) func-lvar)
636             (insert-node (make-call :function func-lvar
637                                     :arguments args-lvars
638                                     :lvar result)))))))
639
640 ;;; Convert the Lisp expression FORM, it may create new basic
641 ;;; blocks. RESULT is the lvar representing the result of the
642 ;;; computation or null if the value should be discarded. The IR is
643 ;;; inserted at *CURSOR*.
644 (defun ir-convert (form &optional result (*cursor* *cursor*))
645   ;; Rebinding the lexical environment here we make sure that the
646   ;; lexical information introduced by FORM is just available for
647   ;; subforms.
648   (let ((*lexenv* *lexenv*))
649     ;; Possibly create additional blocks in order to make sure the
650     ;; cursor is at end the end of a basic block.
651     (maybe-split-block)
652     (cond
653       ((atom form)
654        (cond
655          ((symbolp form)
656           (ir-convert-var form result))
657          (t
658           (ir-convert-constant form result))))
659       (t
660        (destructuring-bind (op &rest args) form
661          (let ((translator (cdr (assoc op *ir-translator*))))
662            (if translator
663                (funcall translator args result)
664                (ir-convert-call form result))))))
665     (values)))
666
667
668 ;;; Change all the predecessors of BLOCK to precede NEW-BLOCK instead.
669 (defun replace-block (block new-block)
670   (let ((predecessors (block-pred block)))
671     (setf (block-pred new-block) (union (block-pred new-block) predecessors))
672     (dolist (pred predecessors)
673       (setf (block-succ pred) (substitute new-block block (block-succ pred)))
674       (unless (component-entry-p pred)
675         (let ((last-node (node-prev (block-exit pred))))
676           (when (conditional-p last-node)
677             (macrolet ((replacef (place)
678                          `(setf ,place (if (eq block ,place) new-block ,place))))
679               (replacef (conditional-consequent last-node))
680               (replacef (conditional-alternative last-node)))))))))
681
682 (defun delete-empty-block (block)
683   (when (or (component-entry-p block) (component-exit-p block))
684     (error "Cannot delete entry or exit basic blocks."))
685   (unless (empty-block-p block)
686     (error "Block `~S' is not empty!" (block-id block)))
687   (replace-block block (unlist (block-succ block))))
688
689 ;;; Try to coalesce BLOCK with the successor if it is unique and block
690 ;;; is its unique predecessor.
691 (defun maybe-coalesce-block (block)
692   (when (singlep (block-succ block))
693     (let ((succ (first (block-succ block))))
694       (when (and (not (component-exit-p succ)) (singlep (block-pred succ)))
695         (link-nodes (node-prev (block-exit block))
696                     (node-next (block-entry succ)))
697         (setf (block-succ block) (block-succ succ))
698         (dolist (next (block-succ succ))
699           (setf (block-pred next) (substitute block succ (block-pred next))))
700         t))))
701
702 (defun ir-normalize (&optional (component *component*))
703   (do-blocks-backward (block component)
704     (maybe-coalesce-block block)
705     (when (empty-block-p block)
706       (delete-empty-block block))))
707
708
709 ;;; IR Debugging
710
711 (defun format-block-name (block)
712   (cond
713     ((eq block (unlist (block-succ (component-entry (block-component block)))))
714      (format nil "ENTRY-~a" (component-id (block-component block))))
715     ((component-exit-p block)
716      (format nil "EXIT-~a" (component-id (block-component block))))
717     (t
718      (format nil "BLOCK ~a" (block-id block)))))
719
720 (defun print-node (node)
721   (when (node-lvar node)
722     (format t "$~a = " (lvar-id (node-lvar node))))
723   (cond
724     ((ref-p node)
725      (let ((leaf (ref-leaf node)))
726        (cond
727          ((var-p leaf)
728           (format t "~a" (var-name leaf)))
729          ((constant-p leaf)
730           (format t "'~s" (constant-value leaf)))
731          ((functional-p leaf)
732           (format t "#<function ~a>" (functional-name leaf))))))
733     ((assignment-p node)
734      (format t "set ~a $~a"
735              (var-name (assignment-variable node))
736              (lvar-id (assignment-value node))))
737     ((primitive-call-p node)
738      (format t "primitive ~a" (primitive-name (primitive-call-function node)))
739      (dolist (arg (primitive-call-arguments node))
740        (format t " $~a" (lvar-id arg))))
741     ((call-p node)
742      (format t "call $~a" (lvar-id (call-function node)))
743      (dolist (arg (call-arguments node))
744        (format t " $~a" (lvar-id arg))))
745     ((conditional-p node)
746      (format t "if $~a then ~a else ~a~%"
747              (lvar-id (conditional-test node))
748              (format-block-name (conditional-consequent node))
749              (format-block-name (conditional-alternative node))))
750     (t
751      (error "`print-node' does not support printing ~S as a node." node)))
752   (terpri))
753
754 (defun print-block (block)
755   (write-line (format-block-name block))
756   (do-nodes (node block)
757     (print-node node))
758   (when (singlep (block-succ block))
759     (format t "GO ~a~%~%" (format-block-name (unlist (block-succ block))))))
760
761 (defun print-component (component &optional (stream *standard-output*))
762   (format t ";;; COMPONENT ~a (~a) ~%~%" (component-name component) (component-id component))
763   (let ((*standard-output* stream))
764     (do-blocks (block component)
765       (print-block block)))
766   (format t ";;; END COMPONENT ~a ~%~%" (component-name component))
767   (let ((*standard-output* stream))
768     (dolist (func (component-functions component))
769       (print-component (functional-component func)))))
770
771 ;;; Translate FORM into IR and print a textual repreresentation of the
772 ;;; component.
773 (defun convert-toplevel-and-print (form &optional (normalize t))
774   (let ((*counter-alist* nil))
775     (with-component-compilation ('toplevel)
776       (ir-convert form (make-lvar :id "out"))
777       (when normalize (ir-normalize))
778       (check-ir-consistency)
779       (print-component *component*))))
780
781 (defmacro /ir (form)
782   `(convert-toplevel-and-print ',form))
783
784
785 ;;;; Primitives
786 ;;;;
787 ;;;; Primitive functions are a set of functions provided by the
788 ;;;; compiler. They cannot usually be written in terms of other
789 ;;;; functions. When the compiler tries to compile a function call, it
790 ;;;; looks for a primitive function firstly, and if it is found and
791 ;;;; the declarations allow it, a primitive call is inserted in the
792 ;;;; IR. The back-end of the compiler knows how to compile primitive
793 ;;;; calls.
794 ;;;; 
795
796 (defvar *primitive-function-table* nil)
797
798 (defstruct primitive
799   name)
800
801 (defmacro define-primitive (name args &body body)
802   (declare (ignore args body))
803   `(push (make-primitive :name ',name)
804          *primitive-function-table*))
805
806 (defun find-primitive (name)
807   (find name *primitive-function-table* :key #'primitive-name))
808
809 (define-primitive symbol-function (symbol))
810 (define-primitive symbol-value (symbol))
811 (define-primitive set (symbol value))
812 (define-primitive fset (symbol value))
813
814 (define-primitive + (&rest numbers))
815 (define-primitive - (number &rest other-numbers))
816
817 (define-primitive consp (x))
818 (define-primitive cons (x y))
819 (define-primitive car (x))
820 (define-primitive cdr (x))
821
822
823
824 ;;; compiler.lisp ends here