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