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