/[cmucl]/src/compiler/byte-comp.lisp
ViewVC logotype

Contents of /src/compiler/byte-comp.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.52 - (show annotations)
Sat Jul 31 16:56:00 2010 UTC (3 years, 8 months ago) by rtoy
Branch: MAIN
CVS Tags: release-20b-pre1, release-20b-pre2, GIT-CONVERSION, cross-sol-x86-merged, RELEASE_20b, cross-sol-x86-base, snapshot-2010-12, snapshot-2010-11, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2010-08, cross-sol-x86-2010-12-20, cross-sparc-branch-base, HEAD
Branch point for: cross-sparc-branch, RELEASE-20B-BRANCH, cross-sol-x86-branch
Changes since 1.51: +2 -2 lines
Since it's about time, and while we're doing the cross-compile anyway,
let's update the fasl version to 20b.

To build this, use boot-2010-07-1-cross as the cross-compile script
and -B src/bootfiles/20a/boot-2010-07-1.lisp for cross-build-world.sh.

If there are any restarts, choose the clobber-it restart.

bootfiles/20a/boot-20b.lisp:
o Bootstrap the change to fasl version 20b.

bootfiles/20a/boot-2010-07-1.lisp:
o Load boot-20b.lisp.

compiler/byte-comp.lisp:
o Update byte-fasl-file-version to 20b.
1 ;;; -*- Package: C -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;;
7 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/compiler/byte-comp.lisp,v 1.52 2010/07/31 16:56:00 rtoy Rel $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; This file contains the noise to byte-compile stuff. It uses the
13 ;;; same front end as the real compiler, but generates a byte-code instead
14 ;;; of native code.
15 ;;;
16 ;;; Written by William Lott
17 ;;;
18
19 (in-package "C")
20 (intl:textdomain "cmucl")
21
22 (export '(disassem-byte-component
23 disassem-byte-fun
24 backend-byte-fasl-file-type
25 backend-byte-fasl-file-implementation
26 byte-fasl-file-version))
27
28 ;;; ### Remaining work:
29 ;;;
30 ;;; - add more inline operations.
31 ;;; - Breakpoints/debugging info.
32 ;;;
33
34
35 ;;;; Fasl file format:
36
37 (defconstant byte-fasl-file-version #x20b)
38
39 (let* ((version-string (format nil "~X" byte-fasl-file-version)))
40 (sys:register-lisp-feature (intern (concatenate 'string "CMU" version-string) :keyword))
41 (sys:register-lisp-feature (intern (concatenate 'string "CMU"
42 (subseq version-string 0 (1- (length version-string))))
43 :keyword)))
44
45 (defun backend-byte-fasl-file-type (backend)
46 (ecase (backend-byte-order backend)
47 (:big-endian "bytef")
48 (:little-endian "lbytef")))
49
50 (defun backend-byte-fasl-file-implementation (backend)
51 (ecase (backend-byte-order backend)
52 (:big-endian big-endian-fasl-file-implementation)
53 (:little-endian little-endian-fasl-file-implementation)))
54
55
56 ;;;; Stuff to emit noise.
57
58 ;;; Note: we use the regular assembler, but we don't use any ``instructions''
59 ;;; because there is no way to keep our byte-code instructions seperate from
60 ;;; the instructions used by the native backend. Besides, we don't want to do
61 ;;; any scheduling or anything like that, anyway.
62
63 (declaim (inline output-byte))
64 (defun output-byte (segment byte)
65 (declare (type new-assem:segment segment)
66 (type (unsigned-byte 8) byte))
67 (new-assem:emit-byte segment byte))
68
69
70 ;;; OUTPUT-EXTENDED-OPERAND -- Internal
71 ;;;
72 ;;; Output Operand as 1 or 4 bytes, using #xFF as the extend code.
73 ;;;
74 (defun output-extended-operand (segment operand)
75 (declare (type (unsigned-byte 24) operand))
76 (cond ((<= operand 254)
77 (output-byte segment operand))
78 (t
79 (output-byte segment #xFF)
80 (output-byte segment (ldb (byte 8 16) operand))
81 (output-byte segment (ldb (byte 8 8) operand))
82 (output-byte segment (ldb (byte 8 0) operand)))))
83
84
85 ;;; OUTPUT-BYTE-WITH-OPERAND -- internal.
86 ;;;
87 ;;; Output a byte, logior'ing in a 4 bit immediate constant. If that
88 ;;; immediate won't fit, then emit it as the next 1-4 bytes.
89 ;;;
90 (defun output-byte-with-operand (segment byte operand)
91 (declare (type new-assem:segment segment)
92 (type (unsigned-byte 8) byte)
93 (type (unsigned-byte 24) operand))
94 (cond ((<= operand 14)
95 (output-byte segment (logior byte operand)))
96 (t
97 (output-byte segment (logior byte 15))
98 (output-extended-operand segment operand)))
99 (undefined-value))
100
101
102 ;;; OUTPUT-LABEL -- internal.
103 ;;;
104 (defun output-label (segment label)
105 (declare (type new-assem:segment segment)
106 (type new-assem:label label))
107 (new-assem:assemble (segment)
108 (new-assem:emit-label label)))
109
110 ;;; OUTPUT-REFERENCE -- internal.
111 ;;;
112 ;;; Output a reference to LABEL. If RELATIVE is NIL, then this reference
113 ;;; can never be relative.
114 ;;;
115 (defun output-reference (segment label)
116 (declare (type new-assem:segment segment)
117 (type new-assem:label label))
118 (new-assem:emit-back-patch
119 segment
120 3
121 #'(lambda (segment posn)
122 (declare (type new-assem:segment segment)
123 (ignore posn))
124 (let ((target (new-assem:label-position label)))
125 (assert (<= 0 target (1- (ash 1 24))))
126 (output-byte segment (ldb (byte 8 16) target))
127 (output-byte segment (ldb (byte 8 8) target))
128 (output-byte segment (ldb (byte 8 0) target))))))
129
130 ;;; OUTPUT-BRANCH -- internal.
131 ;;;
132 ;;; Output some branch byte-sequence.
133 ;;;
134 (defun output-branch (segment kind label)
135 (declare (type new-assem:segment segment)
136 (type (unsigned-byte 8) kind)
137 (type new-assem:label label))
138 (new-assem:emit-chooser
139 segment 4 1
140 #'(lambda (segment posn delta)
141 (when (<= (- (ash 1 7))
142 (- (new-assem:label-position label posn delta) posn 2)
143 (1- (ash 1 7)))
144 (new-assem:emit-chooser
145 segment 2 1
146 #'(lambda (segment posn delta)
147 (declare (ignore segment) (type index posn delta))
148 (when (and (eql kind byte-branch-always)
149 (zerop (- (new-assem:label-position label posn delta)
150 posn 2)))
151 ;; Don't emit anything, because the branch is to the following
152 ;; instruction. Only do this for unconditional branches,
153 ;; because the conditional ones pop the byte stack.
154 t))
155 #'(lambda (segment posn)
156 ;; We know we fit in one byte.
157 (declare (type new-assem:segment segment)
158 (type index posn))
159 (output-byte segment (logior kind 1))
160 (output-byte segment
161 (ldb (byte 8 0)
162 (- (new-assem:label-position label) posn 2)))))
163 t))
164 #'(lambda (segment posn)
165 (declare (type new-assem:segment segment)
166 (ignore posn))
167 (let ((target (new-assem:label-position label)))
168 (assert (<= 0 target (1- (ash 1 24))))
169 (output-byte segment kind)
170 (output-byte segment (ldb (byte 8 16) target))
171 (output-byte segment (ldb (byte 8 8) target))
172 (output-byte segment (ldb (byte 8 0) target))))))
173
174
175 ;;;; System constants, Xops, and inline functions.
176
177 ;;; If (%fdefinition-marker% . name), then the value is the fdefinition
178 (defvar *system-constant-codes* (make-hash-table :test #'equal))
179
180 (eval-when (compile eval)
181 (defmacro def-system-constant (index form)
182 `(let ((val ,form))
183 (setf (gethash val *system-constant-codes*) ,index))))
184
185 (def-system-constant 0 nil)
186 (def-system-constant 1 t)
187 (def-system-constant 2 :start)
188 (def-system-constant 3 :end)
189 (def-system-constant 4 :test)
190 (def-system-constant 5 :count)
191 (def-system-constant 6 :test-not)
192 (def-system-constant 7 :key)
193 (def-system-constant 8 :from-end)
194 (def-system-constant 9 :type)
195 (def-system-constant 10 '(%fdefinition-marker% . error))
196 (def-system-constant 11 '(%fdefinition-marker% . format))
197 (def-system-constant 12 '(%fdefinition-marker% . %typep))
198 (def-system-constant 13 '(%fdefinition-marker% . eql))
199 (def-system-constant 14 '(%fdefinition-marker% . %negate))
200
201 (def-system-constant 15 '(%fdefinition-marker% . %%defun))
202 (def-system-constant 16 '(%fdefinition-marker% . %%defmacro))
203 (def-system-constant 17 '(%fdefinition-marker% . %%defconstant))
204 (def-system-constant 18 '(%fdefinition-marker% . length))
205 (def-system-constant 19 '(%fdefinition-marker% . equal))
206 (def-system-constant 20 '(%fdefinition-marker% . append))
207 (def-system-constant 21 '(%fdefinition-marker% . reverse))
208 (def-system-constant 22 '(%fdefinition-marker% . nreverse))
209 (def-system-constant 23 '(%fdefinition-marker% . nconc))
210 (def-system-constant 24 '(%fdefinition-marker% . list))
211 (def-system-constant 25 '(%fdefinition-marker% . list*))
212 (def-system-constant 26 '(%fdefinition-marker% . %coerce-to-function))
213 (def-system-constant 27 '(%fdefinition-marker% . values-list))
214
215 (defparameter *xop-names*
216 '(breakpoint; 0
217 dup; 1
218 type-check; 2
219 fdefn-function-or-lose; 3
220 default-unknown-values; 4
221 push-n-under; 5
222 xop6
223 xop7
224 merge-unknown-values
225 make-closure
226 throw
227 catch
228 breakup
229 return-from
230 tagbody
231 go
232 unwind-protect))
233
234 (defun xop-index-or-lose (name)
235 (or (position name *xop-names* :test #'eq)
236 (error (intl:gettext "Unknown XOP ~S") name)))
237
238
239 (defstruct inline-function-info
240 ;;
241 ;; Name of the function that we convert into calls to this.
242 (function (required-argument) :type symbol)
243 ;;
244 ;; Name of function that the interpreter should call to implement this. May
245 ;; not be the same as above if extra safety checks are required.
246 (interpreter-function (required-argument) :type symbol)
247 ;;
248 ;; Inline operation number.
249 (number (required-argument) :type (mod 32))
250 ;;
251 ;; Type calls must statisfy.
252 (type (required-argument) :type function-type)
253 ;;
254 ;; If true, arg type checking need not be done.
255 (safe (required-argument) :type (member t nil)))
256
257 (defparameter *inline-functions* (make-array 32 :initial-element nil))
258 (defparameter *inline-function-table* (make-hash-table :test #'eq))
259 (let ((number 0))
260 (dolist (stuff
261 '((+ (fixnum fixnum) fixnum)
262 (- (fixnum fixnum) fixnum)
263 (make-value-cell (t) t)
264 (value-cell-ref (t) t)
265 (value-cell-setf (t t) (values))
266 (symbol-value (symbol) t :interpreter-function %byte-symbol-value)
267 (setf-symbol-value (t symbol) (values))
268 (%byte-special-bind (t symbol) (values))
269 (%byte-special-unbind () (values))
270 (cons-unique-tag () t); obsolete...
271 (%negate (fixnum) fixnum)
272 (< (fixnum fixnum) t)
273 (> (fixnum fixnum) t)
274 (car (t) t :interpreter-function %byte-car :safe t)
275 (cdr (t) t :interpreter-function %byte-cdr :safe t)
276 (length (list) t)
277 (cons (t t) t)
278 (list (t t) t)
279 (list* (t t t) t)
280 (%instance-ref (t t) t)
281 (%setf-instance-ref (t t t) (values))))
282 (destructuring-bind (name arg-types result-type
283 &key (interpreter-function name) alias safe)
284 stuff
285 (let ((info
286 (make-inline-function-info
287 :function name
288 :number number
289 :interpreter-function interpreter-function
290 :type (specifier-type `(function ,arg-types ,result-type))
291 :safe safe)))
292 (setf (svref *inline-functions* number) info)
293 (setf (gethash name *inline-function-table*) info))
294 (unless alias (incf number)))))
295
296
297 (defun inline-function-number-or-lose (function)
298 (let ((info (gethash function *inline-function-table*)))
299 (if info
300 (inline-function-info-number info)
301 (error (intl:gettext "Unknown inline function: ~S") function))))
302
303
304 ;;;; Byte-code specific transforms:
305
306 (deftransform eql ((x y) ((or fixnum character) (or fixnum character))
307 * :when :byte)
308 '(eq x y))
309
310 (deftransform char= ((x y) * * :when :byte)
311 '(eq x y))
312
313
314 ;;;; Annotations hung off the IR1 while compiling.
315
316 (defstruct byte-component-info
317 (constants (make-array 10 :adjustable t :fill-pointer 0)))
318
319
320 (defstruct byte-lambda-info
321 (label nil :type (or null label))
322 (stack-size 0 :type index)
323 (interesting t :type (member t nil)))
324
325 (defun block-interesting (block)
326 (byte-lambda-info-interesting (lambda-info (block-home-lambda block))))
327
328 (defstruct byte-lambda-var-info
329 (argp nil :type (member t nil))
330 (offset 0 :type index))
331
332 (defstruct byte-nlx-info
333 (stack-slot nil :type (or null index))
334 (label (new-assem:gen-label) :type new-assem:label)
335 (duplicate nil :type (member t nil)))
336
337 (defstruct (byte-block-info
338 (:include block-annotation)
339 (:print-function %print-byte-block-info)
340 (:constructor make-byte-block-info
341 (block &key produces produces-sset consumes
342 total-consumes nlx-entries nlx-entry-p)))
343 (label (new-assem:gen-label) :type new-assem:label)
344 ;;
345 ;; A list of the CONTINUATIONs describing values that this block pushes onto
346 ;; the stack. Note: PRODUCES and CONSUMES can contain the keyword :NLX-ENTRY
347 ;; marking the place on the stack where a non-local-exit frame is added or
348 ;; removed. Since breaking up a NLX restores the stack, we don't have to
349 ;; about (and in fact must not) discard values underneath a :NLX-ENTRY marker
350 ;; evern though they appear to be dead (since they might not be.)
351 (produces nil :type list)
352 ;;
353 ;; An SSET of the produces for faster set manipulations. The elements are
354 ;; the BYTE-CONTINUATION-INFO objects. :NLX-ENTRY markers are not
355 ;; represented.
356 (produces-sset (make-sset) :type sset)
357 ;;
358 ;; A list of the continuations that this block pops from the stack. See
359 ;; PRODUCES.
360 (consumes nil :type list)
361 ;;
362 ;; The transitive closure of what this block and all its successors
363 ;; consume. After stack-analysis, that is.
364 (total-consumes (make-sset) :type sset)
365 ;;
366 ;; Set to T whenever the consumes lists of a successor changes and the
367 ;; block is queued for re-analysis so we can easily avoid queueing the same
368 ;; block several times.
369 (already-queued nil :type (member t nil))
370 ;;
371 ;; The continuations and :NLX-ENTRY markers on the stack (in order) when this
372 ;; block starts.
373 (start-stack :unknown :type (or (member :unknown) list))
374 ;;
375 ;; The continuations and :NLX-ENTRY markers on the stack (in order) when this
376 ;; block ends.
377 (end-stack nil :type list)
378 ;;
379 ;; List of ((nlx-info*) produces consumes) for each ENTRY in this block that
380 ;; is a NLX target.
381 (nlx-entries nil :type list)
382 ;;
383 ;; T if this is an %nlx-entry point, and we shouldn't just assume we know
384 ;; what is going to be on the stack.
385 (nlx-entry-p nil :type (member t nil)))
386
387 (defprinter byte-block-info
388 block)
389
390 (defstruct (byte-continuation-info
391 (:include sset-element)
392 (:print-function %print-byte-continuation-info)
393 (:constructor make-byte-continuation-info
394 (continuation results placeholders)))
395 (continuation (required-argument) :type continuation)
396 (results (required-argument)
397 :type (or (member :fdefinition :eq-test :unknown) index))
398 ;;
399 ;; If the DEST is a local non-MV call, then we may need to push some number
400 ;; of placeholder args corresponding to deleted (unreferenced) args. If
401 ;; PLACEHOLDERS /= 0, then RESULTS is PLACEHOLDERS + 1.
402 (placeholders (required-argument) :type index))
403
404 (defprinter byte-continuation-info
405 continuation
406 results
407 (placeholders :test (/= placeholders 0)))
408
409
410 ;;;; Annotate the IR1
411
412 (defun annotate-continuation (cont results &optional (placeholders 0))
413 ;; For some reason, do-nodes does the same return node multiple times,
414 ;; which causes annotate-continuation to be called multiple times on the
415 ;; same continuation. So we can't assert that we haven't done it.
416 #+nil
417 (assert (null (continuation-info cont)))
418 (setf (continuation-info cont)
419 (make-byte-continuation-info cont results placeholders))
420 (undefined-value))
421
422 (defun annotate-set (set)
423 ;; Annotate the value for one value.
424 (annotate-continuation (set-value set) 1))
425
426
427 ;;; ANNOTATE-BASIC-COMBINATION-ARGS -- Internal
428 ;;;
429 ;;; We do different stack magic for non-MV and MV calls to figure out how
430 ;;; many values should be pushed during compilation of each arg.
431 ;;;
432 ;;; Since byte functions are directly caller by the interpreter (there is no
433 ;;; XEP), and it doesn't know which args are actually used, byte functions must
434 ;;; allow unused args to be passed. But this creates a problem with local
435 ;;; calls, because these unused args would not otherwise be pushed (since the
436 ;;; continuation has been deleted.) So, in this function, we count up
437 ;;; placeholders for any unused args contiguously preceding this one. These
438 ;;; placeholders are inserted under the referenced arg by
439 ;;; CHECKED-CANONICALIZE-VALUES.
440 ;;;
441 ;;; With MV calls, we try to figure out how many values are actually generated.
442 ;;; We allow initial args to supply a fixed number of values, but everything
443 ;;; after the first :unknown arg must also be unknown. This picks off most of
444 ;;; the standard uses (i.e. calls to apply), but still is easy to implement.
445 ;;;
446 (defun annotate-basic-combination-args (call)
447 (declare (type basic-combination call))
448 (etypecase call
449 (combination
450 (if (and (eq (basic-combination-kind call) :local)
451 (member (functional-kind (combination-lambda call))
452 '(nil :optional :cleanup)))
453 (let ((placeholders 0))
454 (declare (type index placeholders))
455 (dolist (arg (combination-args call))
456 (cond (arg
457 (annotate-continuation arg (1+ placeholders) placeholders)
458 (setq placeholders 0))
459 (t
460 (incf placeholders)))))
461 (dolist (arg (combination-args call))
462 (when arg
463 (annotate-continuation arg 1)))))
464 (mv-combination
465 (labels
466 ((allow-fixed (remaining)
467 (when remaining
468 (let* ((cont (car remaining))
469 (values (nth-value 1
470 (values-types
471 (continuation-derived-type cont)))))
472 (cond ((eq values :unknown)
473 (force-to-unknown remaining))
474 (t
475 (annotate-continuation cont values)
476 (allow-fixed (cdr remaining)))))))
477 (force-to-unknown (remaining)
478 (when remaining
479 (let ((cont (car remaining)))
480 (when cont
481 (annotate-continuation cont :unknown)))
482 (force-to-unknown (cdr remaining)))))
483 (allow-fixed (mv-combination-args call)))))
484 (undefined-value))
485
486 (defun annotate-local-call (call)
487 (cond ((mv-combination-p call)
488 (annotate-continuation
489 (first (basic-combination-args call))
490 (length (lambda-vars (combination-lambda call)))))
491 (t
492 (annotate-basic-combination-args call)
493 (when (member (functional-kind (combination-lambda call))
494 '(nil :optional :cleanup))
495 (dolist (arg (basic-combination-args call))
496 (when arg
497 (setf (continuation-%type-check arg) nil))))))
498 (annotate-continuation (basic-combination-fun call) 0)
499 (when (node-tail-p call)
500 (set-tail-local-call-successor call)))
501
502 ;;; ANNOTATE-FULL-CALL -- Internal
503 ;;;
504 ;;; Annotate the values for any :full combination. This includes inline
505 ;;; functions, multiple value calls & throw. If a real full call or a safe
506 ;;; inline operation, then clear any type-check annotations. When we are done,
507 ;;; remove jump to return for tail calls.
508 ;;;
509 ;;; Also, we annotate slot accessors as inline if no type check is needed and
510 ;;; (for setters) no value needs to be left on the stack.
511 ;;;
512 (defun annotate-full-call (call)
513 (let* ((fun (basic-combination-fun call))
514 (args (basic-combination-args call))
515 (name (continuation-function-name fun))
516 (info (gethash name *inline-function-table*)))
517 (flet ((annotate-args ()
518 (annotate-basic-combination-args call)
519 ;;
520 ;; We cannot assume that we can delete type checks here.
521 ;; For instance, (GCD X) will be source-transformed to
522 ;; (ABS X), and GCD expects an integer argument while ABS
523 ;; expects a number only.
524 (dolist (arg args)
525 (when (and (continuation-type-check arg)
526 (policy call (< safety 3)))
527 (setf (continuation-%type-check arg) :deleted)))
528 (annotate-continuation
529 fun
530 (if (continuation-function-name fun) :fdefinition 1))))
531 (cond ((mv-combination-p call)
532 (cond ((eq name '%throw)
533 (assert (= (length args) 2))
534 (annotate-continuation (first args) 1)
535 (annotate-continuation (second args) :unknown)
536 (setf (node-tail-p call) nil)
537 (annotate-continuation fun 0))
538 (t
539 (annotate-args))))
540 ((and info
541 (valid-function-use call (inline-function-info-type info)))
542 (annotate-basic-combination-args call)
543 (setf (node-tail-p call) nil)
544 (setf (basic-combination-info call) info)
545 (annotate-continuation fun 0)
546 (when (inline-function-info-safe info)
547 (dolist (arg args)
548 (when (continuation-type-check arg)
549 (setf (continuation-%type-check arg) :deleted)))))
550 ((and name
551 (let ((leaf (ref-leaf (continuation-use fun))))
552 (and (slot-accessor-p leaf)
553 (or (policy call (zerop safety))
554 (not (find 't args
555 :key #'continuation-type-check)))
556 (if (consp name)
557 (not (continuation-dest (node-cont call)))
558 t)
559 (= (length args) (if (consp name) 2 1)))))
560 (setf (basic-combination-info call)
561 (gethash (if (consp name) '%setf-instance-ref '%instance-ref)
562 *inline-function-table*))
563 (setf (node-tail-p call) nil)
564 (annotate-continuation fun 0)
565 (annotate-basic-combination-args call))
566 (t
567 (annotate-args)))))
568
569 ;; If this is (still) a tail-call, then blow away the return.
570 (when (node-tail-p call)
571 (node-ends-block call)
572 (let ((block (node-block call)))
573 (unlink-blocks block (first (block-succ block)))
574 (link-blocks block (component-tail (block-component block)))))
575
576 (undefined-value))
577
578 (defun annotate-known-call (call)
579 (annotate-basic-combination-args call)
580 (setf (node-tail-p call) nil)
581 (annotate-continuation (basic-combination-fun call) 0)
582 t)
583
584 (defun annotate-basic-combination (call)
585 ;; Annotate the function.
586 (let ((kind (basic-combination-kind call)))
587 (case kind
588 (:local
589 (annotate-local-call call))
590 (:full
591 (annotate-full-call call))
592 (:error
593 (setf (basic-combination-kind call) :full)
594 (annotate-full-call call))
595 (t
596 (unless (and (function-info-byte-compile kind)
597 (funcall (or (function-info-byte-annotate kind)
598 #'annotate-known-call)
599 call))
600 (setf (basic-combination-kind call) :full)
601 (annotate-full-call call)))))
602
603 (undefined-value))
604
605 (defun annotate-if (if)
606 ;; Annotate the test.
607 (let* ((cont (if-test if))
608 (use (continuation-use cont)))
609 (annotate-continuation
610 cont
611 (if (and (combination-p use)
612 (eq (continuation-function-name (combination-fun use)) 'eq)
613 (= (length (combination-args use)) 2))
614 ;; If the test is a call to EQ, then we can use branch-if-eq
615 ;; so don't need to actually funcall the test.
616 :eq-test
617 ;; Otherwise, funcall the test for 1 value.
618 1))))
619
620 (defun annotate-return (return)
621 (let ((cont (return-result return)))
622 (annotate-continuation
623 cont
624 (nth-value 1 (values-types (continuation-derived-type cont))))))
625
626 (defun annotate-exit (exit)
627 (let ((cont (exit-value exit)))
628 (when cont
629 (annotate-continuation cont :unknown))))
630
631 (defun annotate-block (block)
632 (do-nodes (node cont block)
633 (etypecase node
634 (bind)
635 (ref)
636 (cset (annotate-set node))
637 (basic-combination (annotate-basic-combination node))
638 (cif (annotate-if node))
639 (creturn (annotate-return node))
640 (entry)
641 (exit (annotate-exit node))))
642 (undefined-value))
643
644 (defun annotate-ir1 (component)
645 (do-blocks (block component)
646 (when (block-interesting block)
647 (annotate-block block)))
648 (undefined-value))
649
650
651
652 ;;;; Stack analysis.
653
654 (defvar *byte-continuation-counter*)
655
656 ;;; COMPUTE-PRODUCES-AND-CONSUMES -- Internal
657 ;;;
658 ;;; Scan the nodes in Block and compute the information that we will need to
659 ;;; do flow analysis and our stack simulation walk. We simulate the stack
660 ;;; within the block, reducing it to ordered lists representing the values we
661 ;;; remove from the top of the stack and place on the stack (not considering
662 ;;; values that are produced and consumed within the block.) A NLX entry point
663 ;;; is considered to push a :NLX-ENTRY marker (can be though of as the run-time
664 ;;; catch frame.)
665 ;;;
666 (defun compute-produces-and-consumes (block)
667 (let ((stack nil)
668 (consumes nil)
669 (total-consumes (make-sset))
670 (nlx-entries nil)
671 (nlx-entry-p nil))
672 (labels ((interesting (cont)
673 (and cont
674 (let ((info (continuation-info cont)))
675 (and info
676 (not (member (byte-continuation-info-results info)
677 '(0 :eq-test)))))))
678 (consume (cont)
679 (cond ((not (or (eq cont :nlx-entry) (interesting cont))))
680 (stack
681 (assert (eq (car stack) cont))
682 (pop stack))
683 (t
684 (adjoin-cont cont total-consumes)
685 (push cont consumes))))
686 (adjoin-cont (cont sset)
687 (unless (eq cont :nlx-entry)
688 (let ((info (continuation-info cont)))
689 (unless (byte-continuation-info-number info)
690 (setf (byte-continuation-info-number info)
691 (incf *byte-continuation-counter*)))
692 (sset-adjoin info sset)))))
693 (do-nodes (node cont block)
694 (etypecase node
695 (bind)
696 (ref)
697 (cset
698 (consume (set-value node)))
699 (basic-combination
700 (dolist (arg (reverse (basic-combination-args node)))
701 (when arg
702 (consume arg)))
703 (consume (basic-combination-fun node))
704 (case (continuation-function-name (basic-combination-fun node))
705 (%nlx-entry
706 (let ((nlx-info (continuation-value
707 (first (basic-combination-args node)))))
708 (ecase (cleanup-kind (nlx-info-cleanup nlx-info))
709 ((:catch :unwind-protect)
710 (consume :nlx-entry))
711 ;;
712 ;; If for a lexical exit, we will see a breakup later, so
713 ;; don't consume :NLX-ENTRY now.
714 ((:tagbody :dynamic-extent))
715 (:block
716 (let ((cont (nlx-info-continuation nlx-info)))
717 (when (interesting cont)
718 (push cont stack))))))
719 (setf nlx-entry-p t))
720 (%lexical-exit-breakup
721 (unless (byte-nlx-info-duplicate
722 (nlx-info-info
723 (continuation-value
724 (first (basic-combination-args node)))))
725 (consume :nlx-entry)))
726 ((%catch-breakup %unwind-protect-breakup)
727 (consume :nlx-entry))))
728 (cif
729 (consume (if-test node)))
730 (creturn
731 (consume (return-result node)))
732 (entry
733 (let* ((cup (entry-cleanup node))
734 (nlx-info (cleanup-nlx-info cup)))
735 (when nlx-info
736 (push :nlx-entry stack)
737 (push (list nlx-info stack (reverse consumes))
738 nlx-entries))))
739 (exit
740 (when (exit-value node)
741 (consume (exit-value node)))))
742 (when (and (not (exit-p node)) (interesting cont))
743 (push cont stack)))
744
745 (setf (block-info block)
746 (make-byte-block-info
747 block
748 :produces stack
749 :produces-sset (let ((res (make-sset)))
750 (dolist (product stack)
751 (adjoin-cont product res))
752 res)
753 :consumes (reverse consumes)
754 :total-consumes total-consumes
755 :nlx-entries nlx-entries
756 :nlx-entry-p nlx-entry-p))))
757
758 (undefined-value))
759
760 (defun walk-successors (block stack)
761 (let ((tail (component-tail (block-component block))))
762 (dolist (succ (block-succ block))
763 (unless (or (eq succ tail)
764 (not (block-interesting succ))
765 (byte-block-info-nlx-entry-p (block-info succ)))
766 (walk-block succ block stack)))))
767
768 ;;; CONSUME-STUFF -- Internal
769 ;;;
770 ;;; Take a stack and a consumes list, and remove the appropriate stuff.
771 ;;; When we consume a :NLX-ENTRY, we just remove the top marker, and leave any
772 ;;; values on top intact. This represents the desired effect of
773 ;;; %CATCH-BREAKUP, etc., which don't affect any values on the stack.
774 ;;;
775 (defun consume-stuff (stack stuff)
776 (let ((new-stack stack))
777 (dolist (cont stuff)
778 (cond ((eq cont :nlx-entry)
779 (assert (find :nlx-entry new-stack))
780 (setq new-stack (remove :nlx-entry new-stack :count 1)))
781 (t
782 (assert (eq (car new-stack) cont))
783 (pop new-stack))))
784 new-stack))
785
786 ;;; WALK-NLX-ENTRY -- Internal
787 ;;;
788 ;;; NLX-infos is the list of nlx-info structures for this ENTRY note. Consume
789 ;;; and Produce are the values from outside this block that were consumed and
790 ;;; produced by this block before the ENTRY node. Stack is the globally
791 ;;; simulated stack at the start of this block.
792 ;;;
793 (defun walk-nlx-entry (nlx-infos stack produce consume)
794 (let ((stack (consume-stuff stack consume)))
795 (dolist (nlx-info nlx-infos)
796 (walk-block (nlx-info-target nlx-info) nil (append produce stack))))
797 (undefined-value))
798
799
800 ;;; WALK-BLOCK -- Internal
801 ;;;
802 ;;; Simulate the stack across block boundaries, discarding any values that
803 ;;; are dead. A :NLX-ENTRY marker prevents values live at a NLX entry point
804 ;;; from being discarded prematurely.
805 ;;;
806 (defun walk-block (block pred stack)
807 ;; Pop everything off of stack that isn't live.
808 (let* ((info (block-info block))
809 (live (byte-block-info-total-consumes info)))
810 (collect ((pops))
811 (let ((fixed 0))
812 (flet ((flush-fixed ()
813 (unless (zerop fixed)
814 (pops `(%byte-pop-stack ,fixed))
815 (setf fixed 0))))
816 (loop
817 (unless stack
818 (return))
819 (let ((cont (car stack)))
820 (when (or (eq cont :nlx-entry)
821 (sset-member (continuation-info cont) live))
822 (return))
823 (pop stack)
824 (let ((results
825 (byte-continuation-info-results
826 (continuation-info cont))))
827 (case results
828 (:unknown
829 (flush-fixed)
830 (pops `(%byte-pop-stack 0)))
831 (:fdefinition
832 (incf fixed))
833 (t
834 (incf fixed results))))))
835 (flush-fixed)))
836 (when (pops)
837 (assert pred)
838 (let ((cleanup-block
839 (insert-cleanup-code pred block
840 (continuation-next (block-start block))
841 `(progn ,@(pops)))))
842 (annotate-block cleanup-block))))
843
844 (cond ((eq (byte-block-info-start-stack info) :unknown)
845 ;; Record what the stack looked like at the start of this block.
846 (setf (byte-block-info-start-stack info) stack)
847 ;; Process any nlx entries that build off of our stack.
848 (dolist (stuff (byte-block-info-nlx-entries info))
849 (walk-nlx-entry (first stuff) stack (second stuff) (third stuff)))
850 ;; Remove whatever we consume.
851 (setq stack (consume-stuff stack (byte-block-info-consumes info)))
852 ;; Add whatever we produce.
853 (setf stack (append (byte-block-info-produces info) stack))
854 (setf (byte-block-info-end-stack info) stack)
855 ;; Pass that on to all our successors.
856 (walk-successors block stack))
857 (t
858 ;; We have already processed the successors of this block. Just
859 ;; make sure we thing the stack is the same now as before.
860 ;;
861 ;; Comment out the assertion because it doesn't hold if there
862 ;; is an nlx-entry above. I think. --gerd 2003-10-09
863 #+nil
864 (assert (equal (byte-block-info-start-stack info) stack)))))
865 (undefined-value))
866
867 ;;; BYTE-STACK-ANALYZE -- Internal
868 ;;;
869 ;;; Do lifetime flow analysis on values pushed on the stack, then call do
870 ;;; the stack simulation walk to discard dead values. In addition to
871 ;;; considering the obvious inputs from a block's successors, we must also
872 ;;; consider %NLX-ENTRY targets to be successors in order to ensure that any
873 ;;; values only used in the NLX entry stay alive until we reach the mess-up
874 ;;; node. After then, we can keep the values from being discarded by placing a
875 ;;; marker on the simulated stack.
876 ;;;
877 (defun byte-stack-analyze (component)
878 (let ((head nil))
879 (let ((*byte-continuation-counter* 0))
880 (do-blocks (block component)
881 (when (block-interesting block)
882 (compute-produces-and-consumes block)
883 (push block head)
884 (setf (byte-block-info-already-queued (block-info block)) t))))
885 (let ((tail (last head)))
886 (labels ((maybe-enqueue (block)
887 (when (block-interesting block)
888 (let ((info (block-info block)))
889 (unless (byte-block-info-already-queued info)
890 (setf (byte-block-info-already-queued info) t)
891 (let ((new (list block)))
892 (if head
893 (setf (cdr tail) new)
894 (setf head new))
895 (setf tail new))))))
896 (maybe-enqueue-predecessors (block)
897 (when (byte-block-info-nlx-entry-p (block-info block))
898 (maybe-enqueue
899 (node-block
900 (cleanup-mess-up
901 (nlx-info-cleanup
902 (find block
903 (environment-nlx-info (block-environment block))
904 :key #'nlx-info-target))))))
905
906 (dolist (pred (block-pred block))
907 (unless (eq pred (component-head (block-component block)))
908 (maybe-enqueue pred)))))
909 (loop
910 (unless head
911 (return))
912 (let* ((block (pop head))
913 (info (block-info block))
914 (total-consumes (byte-block-info-total-consumes info))
915 (produces-sset (byte-block-info-produces-sset info))
916 (did-anything nil))
917 (setf (byte-block-info-already-queued info) nil)
918 (dolist (succ (block-succ block))
919 (unless (eq succ (component-tail component))
920 (let ((succ-info (block-info succ)))
921 (when (sset-union-of-difference
922 total-consumes
923 (byte-block-info-total-consumes succ-info)
924 produces-sset)
925 (setf did-anything t)))))
926 (dolist (nlx-list (byte-block-info-nlx-entries info))
927 (dolist (nlx-info (first nlx-list))
928 (when (sset-union-of-difference
929 total-consumes
930 (byte-block-info-total-consumes
931 (block-info
932 (nlx-info-target nlx-info)))
933 produces-sset)
934 (setf did-anything t))))
935 (when did-anything
936 (maybe-enqueue-predecessors block)))))))
937
938 (walk-successors (component-head component) nil)
939 (undefined-value))
940
941
942
943 ;;;; Actually generate the byte-code
944
945 (defvar *byte-component-info*)
946
947 (defconstant byte-push-local #b00000000)
948 (defconstant byte-push-arg #b00010000)
949 (defconstant byte-push-constant #b00100000)
950 (defconstant byte-push-system-constant #b00110000)
951 (defconstant byte-push-int #b01000000)
952 (defconstant byte-push-neg-int #b01010000)
953 (defconstant byte-pop-local #b01100000)
954 (defconstant byte-pop-n #b01110000)
955 (defconstant byte-call #b10000000)
956 (defconstant byte-tail-call #b10010000)
957 (defconstant byte-multiple-call #b10100000)
958 (defconstant byte-named #b00001000)
959 (defconstant byte-local-call #b10110000)
960 (defconstant byte-local-tail-call #b10111000)
961 (defconstant byte-local-multiple-call #b11000000)
962 (defconstant byte-return #b11001000)
963 (defconstant byte-branch-always #b11010000)
964 (defconstant byte-branch-if-true #b11010010)
965 (defconstant byte-branch-if-false #b11010100)
966 (defconstant byte-branch-if-eq #b11010110)
967 (defconstant byte-xop #b11011000)
968 (defconstant byte-inline-function #b11100000)
969
970
971 (defun output-push-int (segment int)
972 (declare (type new-assem:segment segment)
973 (type (integer #.(- (ash 1 24)) #.(1- (ash 1 24)))))
974 (if (minusp int)
975 (output-byte-with-operand segment byte-push-neg-int (- (1+ int)))
976 (output-byte-with-operand segment byte-push-int int)))
977
978 (defun output-push-constant-leaf (segment constant)
979 (declare (type new-assem:segment segment)
980 (type constant constant))
981 (let ((info (constant-info constant)))
982 (if info
983 (output-byte-with-operand segment
984 (ecase (car info)
985 (:system-constant
986 byte-push-system-constant)
987 (:local-constant
988 byte-push-constant))
989 (cdr info))
990 (let ((const (constant-value constant)))
991 (if (and (integerp const) (< (- (ash 1 24)) const (ash 1 24)))
992 ;; It can be represented as an immediate.
993 (output-push-int segment const)
994 ;; We need to store it in the constants pool.
995 (let* ((posn
996 (unless (and (consp const)
997 (eq (car const) '%fdefinition-marker%))
998 (gethash const *system-constant-codes*)))
999 (new-info (if posn
1000 (cons :system-constant posn)
1001 (cons :local-constant
1002 (vector-push-extend
1003 constant
1004 (byte-component-info-constants
1005 *byte-component-info*))))))
1006 (setf (constant-info constant) new-info)
1007 (output-push-constant-leaf segment constant)))))))
1008
1009 (defun output-push-constant (segment value)
1010 (if (and (integerp value)
1011 (< (- (ash 1 24)) value (ash 1 24)))
1012 (output-push-int segment value)
1013 (output-push-constant-leaf segment (find-constant value))))
1014
1015
1016 ;;; BYTE-LOAD-TIME-CONSTANT-INDEX -- Internal
1017 ;;;
1018 ;;; Return the offset of a load-time constant in the constant pool, adding
1019 ;;; it if absent.
1020 ;;;
1021 (defun byte-load-time-constant-index (kind datum)
1022 (let ((constants (byte-component-info-constants *byte-component-info*)))
1023 (or (position-if #'(lambda (x)
1024 (and (consp x)
1025 (eq (car x) kind)
1026 (typecase datum
1027 (cons (equal (cdr x) datum))
1028 (ctype (type= (cdr x) datum))
1029 (t
1030 (eq (cdr x) datum)))))
1031 constants)
1032 (vector-push-extend (cons kind datum) constants))))
1033
1034
1035 (defun output-push-load-time-constant (segment kind datum)
1036 (output-byte-with-operand segment byte-push-constant
1037 (byte-load-time-constant-index kind datum))
1038 (undefined-value))
1039
1040 (defun output-do-inline-function (segment function)
1041 ;; Note: we don't annotate this as a call site, because it is used for
1042 ;; internal stuff. Random functions that get inlined have code locations
1043 ;; added byte generate-byte-code-for-full-call below.
1044 (output-byte segment
1045 (logior byte-inline-function
1046 (inline-function-number-or-lose function))))
1047
1048 (defun output-do-xop (segment xop)
1049 (let ((index (xop-index-or-lose xop)))
1050 (cond ((< index 7)
1051 (output-byte segment (logior byte-xop index)))
1052 (t
1053 (output-byte segment (logior byte-xop 7))
1054 (output-byte segment index)))))
1055
1056 (defun closure-position (var env)
1057 (or (position var (environment-closure env))
1058 (error (intl:gettext "Can't find ~S") var)))
1059
1060 (defun output-ref-lambda-var (segment var env
1061 &optional (indirect-value-cells t))
1062 (declare (type new-assem:segment segment)
1063 (type lambda-var var)
1064 (type environment env))
1065 (if (eq (lambda-environment (lambda-var-home var)) env)
1066 (let ((info (leaf-info var)))
1067 (output-byte-with-operand segment
1068 (if (byte-lambda-var-info-argp info)
1069 byte-push-arg
1070 byte-push-local)
1071 (byte-lambda-var-info-offset info)))
1072 (output-byte-with-operand segment
1073 byte-push-arg
1074 (closure-position var env)))
1075 (when (and indirect-value-cells (lambda-var-indirect var))
1076 (output-do-inline-function segment 'value-cell-ref)))
1077
1078 (defun output-ref-nlx-info (segment info env)
1079 (if (eq (node-environment (cleanup-mess-up (nlx-info-cleanup info))) env)
1080 (output-byte-with-operand segment
1081 byte-push-local
1082 (byte-nlx-info-stack-slot
1083 (nlx-info-info info)))
1084 (output-byte-with-operand segment
1085 byte-push-arg
1086 (closure-position info env))))
1087
1088 (defun output-set-lambda-var (segment var env &optional make-value-cells)
1089 (declare (type new-assem:segment segment)
1090 (type lambda-var var)
1091 (type environment env))
1092 (let ((indirect (lambda-var-indirect var)))
1093 (cond ((not (eq (lambda-environment (lambda-var-home var)) env))
1094 ;; This is not this guys home environment. So we need to get it
1095 ;; the value cell out of the closure, and fill it in.
1096 (assert indirect)
1097 (assert (not make-value-cells))
1098 (output-byte-with-operand segment byte-push-arg
1099 (closure-position var env))
1100 (output-do-inline-function segment 'value-cell-setf))
1101 (t
1102 (let* ((pushp (and indirect (not make-value-cells)))
1103 (byte-code (if pushp byte-push-local byte-pop-local))
1104 (info (leaf-info var)))
1105 (assert (not (byte-lambda-var-info-argp info)))
1106 (when (and indirect make-value-cells)
1107 ;; Replace the stack top with a value cell holding the
1108 ;; stack top.
1109 (output-do-inline-function segment 'make-value-cell))
1110 (output-byte-with-operand segment byte-code
1111 (byte-lambda-var-info-offset info))
1112 (when pushp
1113 (output-do-inline-function segment 'value-cell-setf)))))))
1114
1115 ;;; CANONICALIZE-VALUES -- internal.
1116 ;;;
1117 ;;; Output whatever noise is necessary to canonicalize the values on the
1118 ;;; top of the stack. Desired is the number we want, and supplied is the
1119 ;;; number we have. Either push NIL or pop-n to make them balanced.
1120 ;;; Note: either desired or supplied can be :unknown, in which case it means
1121 ;;; use the ``unknown-values'' convention (which is the stack values followed
1122 ;;; by the number of values).
1123 ;;;
1124 (defun canonicalize-values (segment desired supplied)
1125 (declare (type new-assem:segment segment)
1126 (type (or (member :unknown) index) desired supplied))
1127 (cond ((eq desired :unknown)
1128 (unless (eq supplied :unknown)
1129 (output-byte-with-operand segment byte-push-int supplied)))
1130 ((eq supplied :unknown)
1131 (unless (eq desired :unknown)
1132 (output-push-int segment desired)
1133 (output-do-xop segment 'default-unknown-values)))
1134 ((< supplied desired)
1135 (dotimes (i (- desired supplied))
1136 (output-push-constant segment nil)))
1137 ((> supplied desired)
1138 (output-byte-with-operand segment byte-pop-n (- supplied desired))))
1139 (undefined-value))
1140
1141
1142 (defparameter *byte-type-weakenings*
1143 (mapcar #'specifier-type
1144 '(fixnum single-float double-float simple-vector simple-bit-vector
1145 bit-vector)))
1146
1147 ;;; BYTE-GENERATE-TYPE-CHECK -- Internal
1148 ;;;
1149 ;;; Emit byte code to check that the value on TOS is of the specified Type.
1150 ;;; Node is used for policy information. We weaken or entirely omit the type
1151 ;;; check if speed is more important than safety.
1152 ;;;
1153 (defun byte-generate-type-check (segment type node)
1154 (declare (type ctype type) (type node node))
1155 (unless (or (policy node (zerop safety))
1156 (csubtypep *universal-type* type))
1157 (let ((type (if (policy node (> speed safety))
1158 (dolist (super *byte-type-weakenings* type)
1159 (when (csubtypep type super) (return super)))
1160 type)))
1161 (output-do-xop segment 'type-check)
1162 (output-extended-operand
1163 segment
1164 (byte-load-time-constant-index :type-predicate type)))))
1165
1166
1167 ;;; CHECKED-CANONICALIZE-VALUES -- Internal
1168 ;;;
1169 ;;; This function is used when we are generating code which delivers values
1170 ;;; to a continuation. If this continuation needs a type check, and has a
1171 ;;; single value, then we do a type check. We also CANONICALIZE-VALUES for the
1172 ;;; continuation's desired number of values (w/o the placeholders.)
1173 ;;;
1174 ;;; Somewhat unrelatedly, we also push placeholders for deleted arguments to
1175 ;;; local calls. Although we check first, the actual PUSH-N-UNDER is done
1176 ;;; afterward, since then the single value we want is stack top.
1177 ;;;
1178 (defun checked-canonicalize-values (segment cont supplied)
1179 (let ((info (continuation-info cont)))
1180 (if info
1181 (let ((desired (byte-continuation-info-results info))
1182 (placeholders (byte-continuation-info-placeholders info)))
1183 (unless (zerop placeholders)
1184 (assert (eql desired (1+ placeholders)))
1185 (setq desired 1))
1186
1187 (flet ((do-check ()
1188 (byte-generate-type-check
1189 segment
1190 (single-value-type (continuation-asserted-type cont))
1191 (continuation-dest cont))))
1192 (cond
1193 ((member (continuation-type-check cont) '(nil :deleted))
1194 (canonicalize-values segment desired supplied))
1195 ((eql supplied 1)
1196 (do-check)
1197 (canonicalize-values segment desired supplied))
1198 ((eql desired 1)
1199 (canonicalize-values segment desired supplied)
1200 (do-check))
1201 (t
1202 (canonicalize-values segment desired supplied))))
1203
1204 (unless (zerop placeholders)
1205 (output-do-xop segment 'push-n-under)
1206 (output-extended-operand segment placeholders)))
1207
1208 (canonicalize-values segment 0 supplied))))
1209
1210
1211 ;;; GENERATE-BYTE-CODE-FOR-BIND -- Internal
1212 ;;;
1213 ;;; Emit prologue for non-let functions. Assigned arguments must be copied
1214 ;;; into locals, and argument type checking may need to be done.
1215 ;;;
1216 (defun generate-byte-code-for-bind (segment bind cont)
1217 (declare (type new-assem:segment segment) (type bind bind)
1218 (ignore cont))
1219 (let ((lambda (bind-lambda bind))
1220 (env (node-environment bind)))
1221 (ecase (lambda-kind lambda)
1222 ((nil :top-level :escape :cleanup :optional)
1223 (let* ((info (lambda-info lambda))
1224 (type-check (policy (lambda-bind lambda) (not (zerop safety))))
1225 (frame-size (byte-lambda-info-stack-size info)))
1226 (cond ((< frame-size (* 255 2))
1227 (output-byte segment (ceiling frame-size 2)))
1228 (t
1229 (output-byte segment 255)
1230 (output-byte segment (ldb (byte 8 16) frame-size))
1231 (output-byte segment (ldb (byte 8 8) frame-size))
1232 (output-byte segment (ldb (byte 8 0) frame-size))))
1233
1234 (do ((argnum (1- (+ (length (lambda-vars lambda))
1235 (length (environment-closure
1236 (lambda-environment lambda)))))
1237 (1- argnum))
1238 (vars (lambda-vars lambda) (cdr vars))
1239 (pops 0))
1240 ((null vars)
1241 (unless (zerop pops)
1242 (output-byte-with-operand segment byte-pop-n pops)))
1243 (declare (fixnum argnum pops))
1244 (let* ((var (car vars))
1245 (info (lambda-var-info var))
1246 (type (leaf-type var)))
1247 (cond ((not info))
1248 ((byte-lambda-var-info-argp info)
1249 (when (and type-check
1250 (not (csubtypep *universal-type* type)))
1251 (output-byte-with-operand segment byte-push-arg argnum)
1252 (byte-generate-type-check segment type bind)
1253 (incf pops)))
1254 (t
1255 (output-byte-with-operand segment byte-push-arg argnum)
1256 (when type-check
1257 (byte-generate-type-check segment type bind))
1258 (output-set-lambda-var segment var env t)))))))
1259
1260 ;; Everything has been taken care of in the combination node.
1261 ((:let :mv-let :assignment))))
1262 (undefined-value))
1263
1264
1265 ;;; This hashtable translates from n-ary function names to the two-arg specific
1266 ;;; versions which we call to avoid rest-arg consing.
1267 ;;;
1268 (defvar *two-arg-functions* (make-hash-table :test #'eq))
1269
1270 (dolist (fun '((KERNEL:TWO-ARG-IOR LOGIOR)
1271 (KERNEL:TWO-ARG-* *)
1272 (KERNEL:TWO-ARG-+ +)
1273 (KERNEL:TWO-ARG-/ /)
1274 (KERNEL:TWO-ARG-- -)
1275 (KERNEL:TWO-ARG-> >)
1276 (KERNEL:TWO-ARG-< <)
1277 (KERNEL:TWO-ARG-= =)
1278 (KERNEL:TWO-ARG-LCM LCM)
1279 (KERNEL:TWO-ARG-AND LOGAND)
1280 (KERNEL:TWO-ARG-GCD GCD)
1281 (KERNEL:TWO-ARG-XOR LOGXOR)
1282
1283 (two-arg-char= char=)
1284 (two-arg-char< char<)
1285 (two-arg-char> char>)
1286 (two-arg-char-equal char-equal)
1287 (two-arg-char-lessp char-lessp)
1288 (two-arg-char-greaterp char-greaterp)
1289 (two-arg-string= string=)
1290 (two-arg-string< string<)
1291 (two-arg-string> string>)))
1292
1293 (setf (gethash (second fun) *two-arg-functions*) (first fun)))
1294
1295
1296 ;;; If a system constant, push that, otherwise use a load-time constant.
1297 ;;;
1298 (defun output-push-fdefinition (segment name)
1299 (let ((offset (gethash `(%fdefinition-marker% . ,name)
1300 *system-constant-codes*)))
1301 (if offset
1302 (output-byte-with-operand segment byte-push-system-constant
1303 offset)
1304 (output-push-load-time-constant segment :fdefinition name))))
1305
1306 (defun generate-byte-code-for-ref (segment ref cont)
1307 (declare (type new-assem:segment segment) (type ref ref)
1308 (type continuation cont))
1309 (let ((info (continuation-info cont)))
1310 ;; If there is no info, then nobody wants the result.
1311 (when info
1312 (let ((values (byte-continuation-info-results info))
1313 (leaf (ref-leaf ref)))
1314 (cond
1315 ((eq values :fdefinition)
1316 (assert (and (global-var-p leaf)
1317 (eq (global-var-kind leaf)
1318 :global-function)))
1319 (let* ((name (global-var-name leaf))
1320 (dest (continuation-dest cont))
1321 (two-arg
1322 (when (and (not (mv-combination-p dest))
1323 (= 2 (length (basic-combination-args dest))))
1324 (gethash name *two-arg-functions*))))
1325 (output-push-fdefinition segment (or two-arg name))))
1326 ((eql values 0)
1327 ;; Real easy!
1328 nil)
1329 (t
1330 (etypecase leaf
1331 (constant
1332 (cond ((legal-immediate-constant-p leaf)
1333 (output-push-constant-leaf segment leaf))
1334 (t
1335 (output-push-constant segment (leaf-name leaf))
1336 (output-do-inline-function segment 'symbol-value))))
1337 (clambda
1338 (let* ((refered-env (lambda-environment leaf))
1339 (closure (and refered-env (environment-closure refered-env))))
1340 (if (null closure)
1341 (output-push-load-time-constant segment :entry leaf)
1342 (let ((my-env (node-environment ref)))
1343 (output-push-load-time-constant segment :entry leaf)
1344 (dolist (thing closure)
1345 (etypecase thing
1346 (lambda-var
1347 (output-ref-lambda-var segment thing my-env nil))
1348 (nlx-info
1349 (output-ref-nlx-info segment thing my-env))))
1350 (output-push-int segment (length closure))
1351 (output-do-xop segment 'make-closure)))))
1352 (functional
1353 (output-push-load-time-constant segment :entry leaf))
1354 (lambda-var
1355 (output-ref-lambda-var segment leaf (node-environment ref)))
1356 (global-var
1357 (ecase (global-var-kind leaf)
1358 ((:special :global :constant)
1359 (output-push-constant segment (global-var-name leaf))
1360 (output-do-inline-function segment 'symbol-value))
1361 (:global-function
1362 (output-push-fdefinition segment (global-var-name leaf))
1363 (output-do-xop segment 'fdefn-function-or-lose)))))
1364 (checked-canonicalize-values segment cont 1))))))
1365 (undefined-value))
1366
1367 (defun generate-byte-code-for-set (segment set cont)
1368 (declare (type new-assem:segment segment) (type cset set)
1369 (type continuation cont))
1370 (let* ((leaf (set-var set))
1371 (info (continuation-info cont))
1372 (values (if info
1373 (byte-continuation-info-results info)
1374 0)))
1375 (etypecase leaf
1376 (global-var
1377 (unless (eql values 0)
1378 ;; Someone wants the value, so copy it.
1379 (output-do-xop segment 'dup))
1380 (ecase (global-var-kind leaf)
1381 ((:special :global)
1382 (output-push-constant segment (global-var-name leaf))
1383 (output-do-inline-function segment 'setf-symbol-value))))
1384 (lambda-var
1385 (cond ((leaf-refs leaf)
1386 (unless (eql values 0)
1387 ;; Someone wants the value, so copy it.
1388 (output-do-xop segment 'dup))
1389 (output-set-lambda-var segment leaf (node-environment set)))
1390 ;; If no-one wants the value then pop it else leave it for them.
1391 ((eql values 0)
1392 (output-byte-with-operand segment byte-pop-n 1)))))
1393 (unless (eql values 0)
1394 (checked-canonicalize-values segment cont 1)))
1395 (undefined-value))
1396
1397 (defun generate-byte-code-for-local-call (segment call cont num-args)
1398 (let* ((lambda (combination-lambda call))
1399 (vars (lambda-vars lambda))
1400 (env (lambda-environment lambda)))
1401 (ecase (functional-kind lambda)
1402 ((:let :assignment)
1403 (dolist (var (reverse vars))
1404 (when (lambda-var-refs var)
1405 (output-set-lambda-var segment var env t))))
1406 (:mv-let
1407 (let ((do-check (member (continuation-type-check
1408 (first (basic-combination-args call)))
1409 '(t :error))))
1410 (dolist (var (reverse vars))
1411 (when do-check
1412 (byte-generate-type-check segment (leaf-type var) call))
1413 (output-set-lambda-var segment var env t))))
1414 ((nil :optional :cleanup)
1415 ;; We got us a local call.
1416 (assert (not (eq num-args :unknown)))
1417 ;;
1418 ;; Push any trailing placeholder args...
1419 (dolist (x (reverse (basic-combination-args call)))
1420 (when x (return))
1421 (output-push-int segment 0))
1422 ;;
1423 ;; Then push closure vars.
1424 (let ((closure (environment-closure env)))
1425 (when closure
1426 (let ((my-env (node-environment call)))
1427 (dolist (thing (reverse closure))
1428 (etypecase thing
1429 (lambda-var
1430 (output-ref-lambda-var segment thing my-env nil))
1431 (nlx-info
1432 (output-ref-nlx-info segment thing my-env)))))
1433 (incf num-args (length closure))))
1434 (let ((results
1435 (let ((info (continuation-info cont)))
1436 (if info
1437 (byte-continuation-info-results info)
1438 0))))
1439 ;; Emit the op for whatever flavor of call we are using.
1440 (let ((operand
1441 (cond ((> num-args 6)
1442 (output-push-int segment num-args)
1443 7)
1444 (t
1445 num-args))))
1446 (multiple-value-bind
1447 (opcode ret-vals)
1448 (cond ((node-tail-p call)
1449 (values byte-local-tail-call 0))
1450 ((member results '(0 1))
1451 (values byte-local-call 1))
1452 (t
1453 (values byte-local-multiple-call :unknown)))
1454 ;; ### :call-site
1455 (output-byte segment (logior opcode operand))
1456 ;; Emit a reference to the label.
1457 (output-reference segment
1458 (byte-lambda-info-label (lambda-info lambda)))
1459 ;; ### :unknown-return
1460 ;; Fix up the results.
1461 (unless (node-tail-p call)
1462 (checked-canonicalize-values segment cont ret-vals))))))))
1463 (undefined-value))
1464
1465 (defun generate-byte-code-for-full-call (segment call cont num-args)
1466 (let ((info (basic-combination-info call))
1467 (results
1468 (let ((info (continuation-info cont)))
1469 (if info
1470 (byte-continuation-info-results info)
1471 0))))
1472 (cond
1473 (info
1474 ;; It's an inline function.
1475 (assert (not (node-tail-p call)))
1476 (let* ((type (inline-function-info-type info))
1477 (desired-args (function-type-nargs type))
1478 (supplied-results
1479 (nth-value 1
1480 (values-types (function-type-returns type))))
1481 (leaf (ref-leaf (continuation-use (basic-combination-fun call)))))
1482 (cond ((slot-accessor-p leaf)
1483 (assert (= num-args (1- desired-args)))
1484 (output-push-int segment (dsd-index (slot-accessor-slot leaf))))
1485 (t
1486 (canonicalize-values segment desired-args num-args)))
1487 ;; ### :call-site
1488 (output-byte segment (logior byte-inline-function
1489 (inline-function-info-number info)))
1490 ;; ### :known-return
1491 (checked-canonicalize-values segment cont supplied-results)))
1492 (t
1493 (let ((operand
1494 (cond ((eq num-args :unknown)
1495 7)
1496 ((> num-args 6)
1497 (output-push-int segment num-args)
1498 7)
1499 (t
1500 num-args))))
1501 (when (eq (byte-continuation-info-results
1502 (continuation-info
1503 (basic-combination-fun call)))
1504 :fdefinition)
1505 (setf operand (logior operand byte-named)))
1506 ;; ### :call-site
1507 (cond
1508 ((node-tail-p call)
1509 (output-byte segment (logior byte-tail-call operand)))
1510 (t
1511 (multiple-value-bind
1512 (opcode ret-vals)
1513 (case results
1514 (:unknown (values byte-multiple-call :unknown))
1515 ((0 1) (values byte-call 1))
1516 (t (values byte-multiple-call :unknown)))
1517 (output-byte segment (logior opcode operand))
1518 ;; ### :unknown-return
1519 (checked-canonicalize-values segment cont ret-vals)))))))))
1520
1521
1522 (defun generate-byte-code-for-known-call (segment call cont num-args)
1523 (block nil
1524 (catch 'give-up
1525 (funcall (function-info-byte-compile (basic-combination-kind call)) call
1526 (let ((info (continuation-info cont)))
1527 (if info
1528 (byte-continuation-info-results info)
1529 0))
1530 num-args segment)
1531 (return))
1532 (assert (member (byte-continuation-info-results
1533 (continuation-info
1534 (basic-combination-fun call)))
1535 '(1 :fdefinition)))
1536 (generate-byte-code-for-full-call segment call cont num-args))
1537 (undefined-value))
1538
1539 (defun generate-byte-code-for-generic-combination (segment call cont)
1540 (declare (type new-assem:segment segment) (type basic-combination call)
1541 (type continuation cont))
1542 (labels ((examine (args num-fixed)
1543 (cond
1544 ((null args)
1545 ;; None of the arugments supply :unknown values, so
1546 ;; we know exactly how many there are.
1547 num-fixed)
1548 (t
1549 (let* ((vals
1550 (byte-continuation-info-results
1551 (continuation-info (car args)))))
1552 (cond
1553 ((eq vals :unknown)
1554 (unless (null (cdr args))
1555 ;; There are (length args) :unknown value blocks on
1556 ;; the top of the stack. We need to combine them.
1557 (output-push-int segment (length args))
1558 (output-do-xop segment 'merge-unknown-values))
1559 (unless (zerop num-fixed)
1560 ;; There are num-fixed fixed args above the unknown
1561 ;; values block that want in on the action also.
1562 ;; So add num-fixed to the count.
1563 (output-push-int segment num-fixed)
1564 (output-do-inline-function segment '+))
1565 :unknown)
1566 (t
1567 (examine (cdr args) (+ num-fixed vals)))))))))
1568 (let* ((args (basic-combination-args call))
1569 (kind (basic-combination-kind call))
1570 (num-args (if (and (eq kind :local)
1571 (combination-p call))
1572 (length args)
1573 (examine args 0))))
1574 (case kind
1575 (:local
1576 (generate-byte-code-for-local-call segment call cont num-args))
1577 (:full
1578 (generate-byte-code-for-full-call segment call cont num-args))
1579 (t
1580 (generate-byte-code-for-known-call segment call cont num-args))))))
1581
1582 (defun generate-byte-code-for-basic-combination (segment call cont)
1583 (cond ((and (mv-combination-p call)
1584 (eq (continuation-function-name (basic-combination-fun call))
1585 '%throw))
1586 ;; ### :internal-error
1587 (output-do-xop segment 'throw))
1588 (t
1589 (generate-byte-code-for-generic-combination segment call cont))))
1590
1591 (defun generate-byte-code-for-if (segment if cont)
1592 (declare (type new-assem:segment segment) (type cif if)
1593 (ignore cont))
1594 (let* ((next-info (byte-block-info-next (block-info (node-block if))))
1595 (consequent-info (block-info (if-consequent if)))
1596 (alternate-info (block-info (if-alternative if))))
1597 (cond ((eq (byte-continuation-info-results
1598 (continuation-info (if-test if)))
1599 :eq-test)
1600 (output-branch segment
1601 byte-branch-if-eq
1602 (byte-block-info-label consequent-info))
1603 (unless (eq next-info alternate-info)
1604 (output-branch segment
1605 byte-branch-always
1606 (byte-block-info-label alternate-info))))
1607 ((eq next-info consequent-info)
1608 (output-branch segment
1609 byte-branch-if-false
1610 (byte-block-info-label alternate-info)))
1611 (t
1612 (output-branch segment
1613 byte-branch-if-true
1614 (byte-block-info-label consequent-info))
1615 (unless (eq next-info alternate-info)
1616 (output-branch segment
1617 byte-branch-always
1618 (byte-block-info-label alternate-info)))))))
1619
1620 (defun generate-byte-code-for-return (segment return cont)
1621 (declare (type new-assem:segment segment) (type creturn return)
1622 (ignore cont))
1623 (let* ((result (return-result return))
1624 (info (continuation-info result))
1625 (results (byte-continuation-info-results info)))
1626 (cond ((eq results :unknown)
1627 (setf results 7))
1628 ((> results 6)
1629 (output-byte-with-operand segment byte-push-int results)
1630 (setf results 7)))
1631 (output-byte segment (logior byte-return results)))
1632 (undefined-value))
1633
1634 (defun generate-byte-code-for-entry (segment entry cont)
1635 (declare (type new-assem:segment segment) (type entry entry)
1636 (ignore cont))
1637 (dolist (exit (entry-exits entry))
1638 (let ((nlx-info (find-nlx-info entry (node-cont exit))))
1639 (when nlx-info
1640 (let ((kind (cleanup-kind (nlx-info-cleanup nlx-info))))
1641 (when (member kind '(:block :tagbody))
1642 ;; Generate a unique tag.
1643 (output-push-constant
1644 segment
1645 (format nil "Tag for ~A" (component-name *compile-component*)))
1646 (output-push-constant segment nil)
1647 (output-do-inline-function segment 'cons)
1648 ;; Save it so people can close over it.
1649 (output-do-xop segment 'dup)
1650 (output-byte-with-operand segment
1651 byte-pop-local
1652 (byte-nlx-info-stack-slot
1653 (nlx-info-info nlx-info)))
1654 ;; Now do the actual XOP.
1655 (ecase kind
1656 (:block
1657 (output-do-xop segment 'catch)
1658 (output-reference segment
1659 (byte-nlx-info-label
1660 (nlx-info-info nlx-info))))
1661 (:tagbody
1662 (output-do-xop segment 'tagbody)))
1663 (return))))))
1664 (undefined-value))
1665
1666 (defun generate-byte-code-for-exit (segment exit cont)
1667 (declare (ignore cont))
1668 (let ((nlx-info (find-nlx-info (exit-entry exit) (node-cont exit))))
1669 (output-byte-with-operand segment
1670 byte-push-arg
1671 (closure-position nlx-info
1672 (node-environment exit)))
1673 (ecase (cleanup-kind (nlx-info-cleanup nlx-info))
1674 (:block
1675 ;; ### :internal-error
1676 (output-do-xop segment 'return-from))
1677 (:tagbody
1678 ;; ### :internal-error
1679 (output-do-xop segment 'go)
1680 (output-reference segment
1681 (byte-nlx-info-label (nlx-info-info nlx-info)))))))
1682
1683 (defun generate-byte-code (segment component)
1684 (let ((*byte-component-info* (component-info component)))
1685 (do* ((info (byte-block-info-next (block-info (component-head component)))
1686 next)
1687 (block (byte-block-info-block info) (byte-block-info-block info))
1688 (next (byte-block-info-next info) (byte-block-info-next info)))
1689 ((eq block (component-tail component)))
1690 (when (block-interesting block)
1691 (output-label segment (byte-block-info-label info))
1692 (do-nodes (node cont block)
1693 (etypecase node
1694 (bind (generate-byte-code-for-bind segment node cont))
1695 (ref (generate-byte-code-for-ref segment node cont))
1696 (cset (generate-byte-code-for-set segment node cont))
1697 (basic-combination
1698 (generate-byte-code-for-basic-combination
1699 segment node cont))
1700 (cif (generate-byte-code-for-if segment node cont))
1701 (creturn (generate-byte-code-for-return segment node cont))
1702 (entry (generate-byte-code-for-entry segment node cont))
1703 (exit
1704 (when (exit-entry node)
1705 (generate-byte-code-for-exit segment node cont)))))
1706 (let* ((succ (block-succ block))
1707 (first-succ (car succ))
1708 (last (block-last block)))
1709 (unless (or (cdr succ)
1710 (eq (byte-block-info-block next) first-succ)
1711 (eq (component-tail component) first-succ)
1712 (and (basic-combination-p last)
1713 (node-tail-p last)
1714 ;; Tail local calls that have been
1715 ;; converted to an assignment need the branch.
1716 (not (and (eq (basic-combination-kind last) :local)
1717 (member (functional-kind
1718 (combination-lambda last))
1719 '(:let :assignment))))))
1720 (output-branch segment
1721 byte-branch-always
1722 (byte-block-info-label
1723 (block-info first-succ))))))))
1724 (undefined-value))
1725
1726
1727 ;;;; Special purpose annotate/compile optimizers.
1728
1729 (defoptimizer (eq byte-annotate) ((this that) node)
1730 (declare (ignore this that))
1731 (when (if-p (continuation-dest (node-cont node)))
1732 (annotate-known-call node)
1733 t))
1734
1735 (defoptimizer (eq byte-compile) ((this that) call results num-args segment)
1736 (progn segment) ; ignorable.
1737 ;; We don't have to do anything, because everything is handled by the
1738 ;; IF byte-generator.
1739 (assert (eq results :eq-test))
1740 (assert (eql num-args 2))
1741 (undefined-value))
1742
1743
1744 (defoptimizer (values byte-compile)
1745 ((&rest values) node results num-args segment)
1746 (canonicalize-values segment results num-args))
1747
1748
1749 (defknown %byte-pop-stack (index) (values))
1750
1751 (defoptimizer (%byte-pop-stack byte-annotate) ((count) node)
1752 (assert (constant-continuation-p count))
1753 (annotate-continuation count 0)
1754 (annotate-continuation (basic-combination-fun node) 0)
1755 (setf (node-tail-p node) nil)
1756 t)
1757
1758 (defoptimizer (%byte-pop-stack byte-compile)
1759 ((count) node results num-args segment)
1760 (assert (and (zerop num-args) (zerop results)))
1761 (output-byte-with-operand segment byte-pop-n (continuation-value count)))
1762
1763 (defoptimizer (%special-bind byte-annotate) ((var value) node)
1764 (annotate-continuation var 0)
1765 (annotate-continuation value 1)
1766 (annotate-continuation (basic-combination-fun node) 0)
1767 (setf (node-tail-p node) nil)
1768 t)
1769
1770 (defoptimizer (%special-bind byte-compile)
1771 ((var value) node results num-args segment)
1772 (assert (and (eql num-args 1) (zerop results)))
1773 (output-push-constant segment (leaf-name (continuation-value var)))
1774 (output-do-inline-function segment '%byte-special-bind))
1775
1776 (defoptimizer (%special-unbind byte-annotate) ((var) node)
1777 (annotate-continuation var 0)
1778 (annotate-continuation (basic-combination-fun node) 0)
1779 (setf (node-tail-p node) nil)
1780 t)
1781
1782 (defoptimizer (%special-unbind byte-compile)
1783 ((var) node results num-args segment)
1784 (assert (and (zerop num-args) (zerop results)))
1785 (output-do-inline-function segment '%byte-special-unbind))
1786
1787 (defoptimizer (%catch byte-annotate) ((nlx-info tag) node)
1788 (annotate-continuation nlx-info 0)
1789 (annotate-continuation tag 1)
1790 (annotate-continuation (basic-combination-fun node) 0)
1791 (setf (node-tail-p node) nil)
1792 t)
1793
1794 (defoptimizer (%catch byte-compile)
1795 ((nlx-info tag) node results num-args segment)
1796 (progn node) ; ignore
1797 (assert (and (= num-args 1) (zerop results)))
1798 (output-do-xop segment 'catch)
1799 (let ((info (nlx-info-info (continuation-value nlx-info))))
1800 (output-reference segment (byte-nlx-info-label info))))
1801
1802 (defoptimizer (%cleanup-point byte-compile) (() node results num-args segment)
1803 (progn node segment) ; ignore
1804 (assert (and (zerop num-args) (zerop results))))
1805
1806
1807 (defoptimizer (%catch-breakup byte-compile) (() node results num-args segment)
1808 (progn node) ; ignore
1809 (assert (and (zerop num-args) (zerop results)))
1810 (output-do-xop segment 'breakup))
1811
1812
1813 (defoptimizer (%lexical-exit-breakup byte-annotate) ((nlx-info) node)
1814 (annotate-continuation nlx-info 0)
1815 (annotate-continuation (basic-combination-fun node) 0)
1816 (setf (node-tail-p node) nil)
1817 t)
1818
1819 (defoptimizer (%lexical-exit-breakup byte-compile)
1820 ((nlx-info) node results num-args segment)
1821 (assert (and (zerop num-args) (zerop results)))
1822 (let ((nlx-info (continuation-value nlx-info)))
1823 (when (ecase (cleanup-kind (nlx-info-cleanup nlx-info))
1824 (:block
1825 ;; We only want to do this for the fall-though case.
1826 (not (eq (car (block-pred (node-block node)))
1827 (nlx-info-target nlx-info))))
1828 (:tagbody
1829 ;; Only want to do it once per tagbody.
1830 (not (byte-nlx-info-duplicate (nlx-info-info nlx-info)))))
1831 (output-do-xop segment 'breakup))))
1832
1833
1834 (defoptimizer (%nlx-entry byte-annotate) ((nlx-info) node)
1835 (annotate-continuation nlx-info 0)
1836 (annotate-continuation (basic-combination-fun node) 0)
1837 (setf (node-tail-p node) nil)
1838 t)
1839
1840 (defoptimizer (%nlx-entry byte-compile)
1841 ((nlx-info) node results num-args segment)
1842 (progn node results) ; ignore
1843 (assert (eql num-args 0))
1844 (let* ((info (continuation-value nlx-info))
1845 (byte-info (nlx-info-info info)))
1846 (output-label segment (byte-nlx-info-label byte-info))
1847 ;; ### :non-local-entry
1848 (ecase (cleanup-kind (nlx-info-cleanup info))
1849 ((:catch :block)
1850 (checked-canonicalize-values segment
1851 (nlx-info-continuation info)
1852 :unknown))
1853 ((:tagbody :unwind-protect)))))
1854
1855
1856 (defoptimizer (%unwind-protect byte-annotate)
1857 ((nlx-info cleanup-fun) node)
1858 (annotate-continuation nlx-info 0)
1859 (annotate-continuation cleanup-fun 0)
1860 (annotate-continuation (basic-combination-fun node) 0)
1861 (setf (node-tail-p node) nil)
1862 t)
1863
1864 (defoptimizer (%unwind-protect byte-compile)
1865 ((nlx-info cleanup-fun) node results num-args segment)
1866 (assert (and (zerop num-args) (zerop results)))
1867 (output-do-xop segment 'unwind-protect)
1868 (output-reference segment
1869 (byte-nlx-info-label
1870 (nlx-info-info
1871 (continuation-value nlx-info)))))
1872
1873 (defoptimizer (%unwind-protect-breakup byte-compile)
1874 (() node results num-args segment)
1875 (progn node) ; ignore
1876 (assert (and (zerop num-args) (zerop results)))
1877 (output-do-xop segment 'breakup))
1878
1879 (defoptimizer (%continue-unwind byte-annotate) ((a b c) node)
1880 (annotate-continuation a 0)
1881 (annotate-continuation b 0)
1882 (annotate-continuation c 0)
1883 (annotate-continuation (basic-combination-fun node) 0)
1884 (setf (node-tail-p node) nil)
1885 t)
1886
1887 (defoptimizer (%continue-unwind byte-compile)
1888 ((a b c) node results num-args segment)
1889 (progn node) ; ignore
1890 (assert (member results '(0 nil)))
1891 (assert (eql num-args 0))
1892 (output-do-xop segment 'breakup))
1893
1894
1895 (defoptimizer (%load-time-value byte-annotate) ((handle) node)
1896 (annotate-continuation handle 0)
1897 (annotate-continuation (basic-combination-fun node) 0)
1898 (setf (node-tail-p node) nil)
1899 t)
1900
1901 (defoptimizer (%load-time-value byte-compile)
1902 ((handle) node results num-args segment)
1903 (progn node) ; ignore
1904 (assert (zerop num-args))
1905 (output-push-load-time-constant segment :load-time-value
1906 (continuation-value handle))
1907 (canonicalize-values segment results 1))
1908
1909
1910 ;;; MAKE-XEP-FOR -- internal
1911 ;;;
1912 ;;; Make a byte-function for LAMBDA.
1913 ;;;
1914 (defun make-xep-for (lambda)
1915 (flet ((entry-point-for (entry)
1916 (let ((info (lambda-info entry)))
1917 (assert (byte-lambda-info-interesting info))
1918 (new-assem:label-position (byte-lambda-info-label info)))))
1919 (let ((entry (lambda-entry-function lambda)))
1920 (etypecase entry
1921 (optional-dispatch
1922 (let ((rest-arg-p nil)
1923 (num-more 0))
1924 (declare (type index num-more))
1925 (collect ((keywords))
1926 (dolist (var (nthcdr (optional-dispatch-max-args entry)
1927 (optional-dispatch-arglist entry)))
1928 (let ((arg-info (lambda-var-arg-info var)))
1929 (assert arg-info)
1930 (ecase (arg-info-kind arg-info)
1931 (:rest
1932 (assert (not rest-arg-p))
1933 (incf num-more)
1934 (setf rest-arg-p t))
1935 (:keyword
1936 (let ((s-p (arg-info-supplied-p arg-info))
1937 (default (arg-info-default arg-info)))
1938 (incf num-more (if s-p 2 1))
1939 (keywords (list (arg-info-keyword arg-info)
1940 (if (constantp default)
1941 (eval default)
1942 nil)
1943 (if s-p t nil)))))
1944 (:more-context
1945 (incf num-more 2)
1946 (setf rest-arg-p :more))
1947 (:more-count))))
1948 (make-hairy-byte-function
1949 :name (leaf-name entry)
1950 :min-args (optional-dispatch-min-args entry)
1951 :max-args (optional-dispatch-max-args entry)
1952 :entry-points
1953 (mapcar #'entry-point-for (optional-dispatch-entry-points entry))
1954 :more-args-entry-point
1955 (entry-point-for (optional-dispatch-main-entry entry))
1956 :num-more-args num-more
1957 :rest-arg-p rest-arg-p
1958 :keywords-p
1959 (if (optional-dispatch-keyp entry)
1960 (if (optional-dispatch-allowp entry)
1961 :allow-others t))
1962 :keywords (keywords)))))
1963 (clambda
1964 (let ((args (length (lambda-vars entry))))
1965 (make-simple-byte-function
1966 :name (leaf-name entry)
1967 :num-args args
1968 :entry-point (entry-point-for entry))))))))
1969
1970 (defun generate-xeps (component)
1971 (let ((xeps nil))
1972 (dolist (lambda (component-lambdas component))
1973 (when (member (lambda-kind lambda) '(:external :top-level))
1974 (push (cons lambda (make-xep-for lambda)) xeps)))
1975 xeps))
1976
1977
1978 ;;;; Noise to actually do the compile.
1979
1980 (defun assign-locals (component)
1981 ;;
1982 ;; Process all of the lambdas in component, and assign stack frame
1983 ;; locations for all the locals.
1984 (dolist (lambda (component-lambdas component))
1985 ;; We don't generate any code for :external lambdas, so we don't need
1986 ;; to allocate stack space. Also, we don't use the ``more'' entry,
1987 ;; so we don't need code for it.
1988 (cond
1989 ((or (eq (lambda-kind lambda) :external)
1990 (and (eq (lambda-kind lambda) :optional)
1991 (eq (optional-dispatch-more-entry
1992 (lambda-optional-dispatch lambda))
1993 lambda)))
1994 (setf (lambda-info lambda)
1995 (make-byte-lambda-info :interesting nil)))
1996 (t
1997 (let ((num-locals 0))
1998 (let* ((vars (lambda-vars lambda))
1999 (arg-num (+ (length vars)
2000 (length (environment-closure
2001 (lambda-environment lambda))))))
2002 (dolist (var vars)
2003 (decf arg-num)
2004 (cond ((or (lambda-var-sets var) (lambda-var-indirect var))
2005 (setf (leaf-info var)
2006 (make-byte-lambda-var-info :offset num-locals))
2007 (incf num-locals))
2008 ((leaf-refs var)
2009 (setf (leaf-info var)
2010 (make-byte-lambda-var-info :argp t
2011 :offset arg-num))))))
2012 (dolist (let (lambda-lets lambda))
2013 (dolist (var (lambda-vars let))
2014 (setf (leaf-info var)
2015 (make-byte-lambda-var-info :offset num-locals))
2016 (incf num-locals)))
2017 (let ((entry-nodes-already-done nil))
2018 (dolist (nlx-info (environment-nlx-info (lambda-environment lambda)))
2019 (ecase (cleanup-kind (nlx-info-cleanup nlx-info))
2020 (:block
2021 (setf (nlx-info-info nlx-info)
2022 (make-byte-nlx-info :stack-slot num-locals))
2023 (incf num-locals))
2024 (:tagbody
2025 (let* ((entry (cleanup-mess-up (nlx-info-cleanup nlx-info)))
2026 (cruft (assoc entry entry-nodes-already-done)))
2027 (cond (cruft
2028 (setf (nlx-info-info nlx-info)
2029 (make-byte-nlx-info :stack-slot (cdr cruft)
2030 :duplicate t)))
2031 (t
2032 (push (cons entry num-locals) entry-nodes-already-done)
2033 (setf (nlx-info-info nlx-info)
2034 (make-byte-nlx-info :stack-slot num-locals))
2035 (incf num-locals)))))
2036 ((:catch :unwind-protect)
2037 (setf (nlx-info-info nlx-info) (make-byte-nlx-info))))))
2038 (setf (lambda-info lambda)
2039 (make-byte-lambda-info :stack-size num-locals))))))
2040
2041 (undefined-value))
2042
2043
2044 ;;; BYTE-COMPILE-COMPONENT -- internal interface.
2045 ;;;
2046 (defun byte-compile-component (component)
2047 (setf (component-info component) (make-byte-component-info))
2048 (maybe-mumble "ByteAnn ")
2049
2050 ;; Assign offsets for all the locals, and figure out which args can
2051 ;; stay in the argument area and which need to be moved into locals.
2052 (assign-locals component)
2053
2054 ;; Annotate every continuation with information about how we want the
2055 ;; values.
2056 (annotate-ir1 component)
2057
2058 ;; Determine what stack values are dead, and emit cleanup code to pop
2059 ;; them.
2060 (byte-stack-analyze component)
2061
2062 ;; Make sure any newly added blocks have a block-number.
2063 (dfo-as-needed component)
2064
2065 ;; Assign an ordering of the blocks.
2066 (control-analyze component #'make-byte-block-info)
2067
2068 ;; Find the start labels for the lambdas.
2069 (dolist (lambda (component-lambdas component))
2070 (let ((info (lambda-info lambda)))
2071 (when (byte-lambda-info-interesting info)
2072 (setf (byte-lambda-info-label info)
2073 (byte-block-info-label
2074 (block-info (node-block (lambda-bind lambda))))))))
2075
2076 ;; Delete any blocks that we are not going to emit from the emit order.
2077 (do-blocks (block component)
2078 (unless (block-interesting block)
2079 (let* ((info (block-info block))
2080 (prev (byte-block-info-prev info))
2081 (next (byte-block-info-next info)))
2082 (setf (byte-block-info-next prev) next)
2083 (setf (byte-block-info-prev next) prev))))
2084
2085 (maybe-mumble "ByteGen ")
2086 (let ((segment nil))
2087 (unwind-protect
2088 (progn
2089 (setf segment (new-assem:make-segment :name "Byte Output"))
2090 (generate-byte-code segment component)
2091 (let ((code-length (new-assem:finalize-segment segment))
2092 (xeps (generate-xeps component))
2093 (constants (byte-component-info-constants
2094 (component-info component))))
2095 (when *compiler-trace-output*
2096 (describe-component component *compiler-trace-output*)
2097 (describe-byte-component component xeps segment
2098 *compiler-trace-output*))
2099 (etypecase *compile-object*
2100 (fasl-file
2101 (maybe-mumble "FASL")
2102 (fasl-dump-byte-component segment code-length constants xeps
2103 *compile-object*))
2104 (core-object
2105 (maybe-mumble "Core")
2106 (make-core-byte-component segment code-length constants xeps
2107 *compile-object*))
2108 (null))))
2109 (when segment
2110 (new-assem:release-segment segment))))
2111 (undefined-value))
2112
2113
2114
2115 ;;;; Extra stuff for debugging.
2116
2117 ;(declaim (optimize (inhibit-warnings 3)))
2118
2119 (defun dump-stack-info (component)
2120 (do-blocks (block component)
2121 (when (block-interesting block)
2122 (print-nodes block)
2123 (let ((info (block-info block)))
2124 (cond
2125 (info
2126 (format t
2127 "start-stack ~S~%consume ~S~%produce ~S~%end-stack ~S~%~
2128 total-consume ~S~%~@[nlx-entries ~S~%~]~@[nlx-entry-p ~S~%~]"
2129 (byte-block-info-start-stack info)
2130 (byte-block-info-consumes info)
2131 (byte-block-info-produces info)
2132 (byte-block-info-end-stack info)
2133 (byte-block-info-total-consumes info)
2134 (byte-block-info-nlx-entries info)
2135 (byte-block-info-nlx-entry-p info)))
2136 (t
2137 (format t "no info~%")))))))
2138
2139
2140 ;;; DESCRIBE-BYTE-COMPONENT -- Internal
2141 ;;;
2142 ;;; Generate trace-file output for the byte compiler back-end.
2143 ;;;
2144 (defun describe-byte-component (component xeps segment *standard-output*)
2145 (format t (intl:gettext "~|~%;;;; Byte component ~S~2%") (component-name component))
2146 (format t (intl:gettext ";;; Functions:~%"))
2147 (dolist (fun (component-lambdas component))
2148 (when (leaf-name fun)
2149 (let ((info (leaf-info fun)))
2150 (when info
2151 (format t "~6D: ~S~%"
2152 (new-assem:label-position (byte-lambda-info-label info))
2153 (leaf-name fun))))))
2154
2155 (format t (intl:gettext "~%;;;Disassembly:~2%"))
2156 (collect ((eps)
2157 (chunks))
2158 (dolist (x xeps)
2159 (let ((xep (cdr x)))
2160 (etypecase xep
2161 (simple-byte-function
2162 (eps (simple-byte-function-entry-point xep)))
2163 (hairy-byte-function
2164 (dolist (ep (hairy-byte-function-entry-points xep))
2165 (eps ep))
2166 (when (hairy-byte-function-more-args-entry-point xep)
2167 (eps (hairy-byte-function-more-args-entry-point xep)))))))
2168
2169 (new-assem:segment-map-output
2170 segment
2171 #'(lambda (sap bytes) (chunks (cons sap bytes))))
2172 (let* ((total-bytes (reduce #'+ (mapcar #'cdr (chunks))))
2173 (buf (allocate-system-memory total-bytes)))
2174 (let ((offset 0))
2175 (dolist (chunk (chunks))
2176 (let ((sap (car chunk))
2177 (bits (* (cdr chunk) vm:byte-bits)))
2178 (system-area-copy sap 0 buf offset bits)
2179 (incf offset bits))))
2180
2181 (disassem-byte-sap buf total-bytes
2182 (map 'vector
2183 #'(lambda (x)
2184 (if (constant-p x)
2185 (constant-value x)
2186 x))
2187 (byte-component-info-constants
2188 (component-info component)))
2189 (sort (eps) #'<))
2190 (terpri)
2191 (deallocate-system-memory buf total-bytes)
2192 (values))))
2193
2194
2195 ;;; DISASSEM-BYTE-FUN -- Interface
2196 ;;;
2197 ;;; Given a byte-compiled function, disassemble it to standard output.
2198 ;;;
2199 (defun disassem-byte-fun (xep)
2200 (declare (optimize (inhibit-warnings 3)))
2201 (disassem-byte-component
2202 (byte-function-component xep)
2203 (etypecase xep
2204 (simple-byte-function
2205 (list (simple-byte-function-entry-point xep)))
2206 (hairy-byte-function
2207 (sort (copy-list
2208 (if (hairy-byte-function-more-args-entry-point xep)
2209 (cons (hairy-byte-function-more-args-entry-point xep)
2210 (hairy-byte-function-entry-points xep))
2211 (hairy-byte-function-entry-points xep)))
2212 #'<)))))
2213
2214
2215 ;;; DISASSEM-BYTE-COMPONENT -- Interface
2216 ;;;
2217 ;;; Given a byte-compiled component, disassemble it to standard output.
2218 ;;; EPS is a list of the entry points.
2219 ;;;
2220 (defun disassem-byte-component (component &optional (eps '(0)))
2221 (let* ((bytes (* (code-header-ref component vm:code-code-size-slot)
2222 vm:word-bytes))
2223 (num-consts (- (get-header-data component) vm:code-constants-offset))
2224 (consts (make-array num-consts)))
2225 (dotimes (i num-consts)
2226 (setf (aref consts i)
2227 (code-header-ref component (+ i vm:code-constants-offset))))
2228 (without-gcing
2229 (disassem-byte-sap (code-instructions component) bytes
2230 consts eps))
2231 (values)))
2232
2233
2234 ;;; DISASSEM-BYTE-SAP -- Internal
2235 ;;;
2236 ;;; Disassemble byte code from a SAP and constants vector.
2237 ;;;
2238 (defun disassem-byte-sap (sap bytes constants eps)
2239 (declare (optimize (inhibit-warnings 3)))
2240 (let ((index 0))
2241 (labels ((newline ()
2242 (format t "~&~4D:" index))
2243 (next-byte ()
2244 (let ((byte (sap-ref-8 sap index)))
2245 (format t " ~2,'0X" byte)
2246 (incf index)
2247 byte))
2248 (extract-24-bits ()
2249 (logior (ash (next-byte) 16)
2250 (ash (next-byte) 8)
2251 (next-byte)))
2252 (extract-extended-op ()
2253 (let ((byte (next-byte)))
2254 (if (= byte 255)
2255 (extract-24-bits)
2256 byte)))
2257 (extract-4-bit-op (byte)
2258 (let ((4-bits (ldb (byte 4 0) byte)))
2259 (if (= 4-bits 15)
2260 (extract-extended-op)
2261 4-bits)))
2262 (extract-3-bit-op (byte)
2263 (let ((3-bits (ldb (byte 3 0) byte)))
2264 (if (= 3-bits 7)
2265 :var
2266 3-bits)))
2267 (extract-branch-target (byte)
2268 (if (logbitp 0 byte)
2269 (let ((disp (next-byte)))
2270 (if (logbitp 7 disp)
2271 (+ index disp -256)
2272 (+ index disp)))
2273 (extract-24-bits)))
2274 (note (string &rest noise)
2275 (format t "~12T~?" string noise))
2276 (get-constant (index)
2277 (if (< -1 index (length constants))
2278 (aref constants index)
2279 (intl:gettext "<bogus index>"))))
2280 (loop
2281 (unless (< index bytes)
2282 (return))
2283
2284 (when (eql index (first eps))
2285 (newline)
2286 (pop eps)
2287 (let ((frame-size
2288 (let ((byte (next-byte)))
2289 (if (< byte 255)
2290 (* byte 2)
2291 (logior (ash (next-byte) 16)
2292 (ash (next-byte) 8)
2293 (next-byte))))))
2294 (note (intl:gettext "Entry point, frame-size=~D~%") frame-size)))
2295
2296 (newline)
2297 (let ((byte (next-byte)))
2298 (macrolet ((dispatch (&rest clauses)
2299 `(cond ,@(mapcar #'(lambda (clause)
2300 `((= (logand byte ,(caar clause))
2301 ,(cadar clause))
2302 ,@(cdr clause)))
2303 clauses))))
2304 (dispatch
2305 ((#b11110000 #b00000000)
2306 (let ((op (extract-4-bit-op byte)))
2307 (note (intl:gettext "push-local ~D") op)))
2308 ((#b11110000 #b00010000)
2309 (let ((op (extract-4-bit-op byte)))
2310 (note (intl:gettext "push-arg ~D") op)))
2311 ((#b11110000 #b00100000)
2312 (let ((*print-level* 3)
2313 (*print-lines* 2))
2314 (note (intl:gettext "push-const ~S") (get-constant (extract-4-bit-op byte)))))
2315 ((#b11110000 #b00110000)
2316 (let ((op (extract-4-bit-op byte))
2317 (*print-level* 3)
2318 (*print-lines* 2))
2319 (note (intl:gettext "push-sys-const ~S")
2320 (svref system-constants op))))
2321 ((#b11110000 #b01000000)
2322 (let ((op (extract-4-bit-op byte)))
2323 (note (intl:gettext "push-int ~D") op)))
2324 ((#b11110000 #b01010000)
2325 (let ((op (extract-4-bit-op byte)))
2326 (note (intl:gettext "push-neg-int ~D") (- (1+ op)))))
2327 ((#b11110000 #b01100000)
2328 (let ((op (extract-4-bit-op byte)))
2329 (note (intl:gettext "pop-local ~D") op)))
2330 ((#b11110000 #b01110000)
2331 (let ((op (extract-4-bit-op byte)))
2332 (note (intl:gettext "pop-n ~D") op)))
2333 ((#b11110000 #b10000000)
2334 (let ((op (extract-3-bit-op byte)))
2335 (note (intl:gettext "~:[~;named-~]call, ~D args")
2336 (logbitp 3 byte) op)))
2337 ((#b11110000 #b10010000)
2338 (let ((op (extract-3-bit-op byte)))
2339 (note (intl:gettext "~:[~;named-~]tail-call, ~D args")
2340 (logbitp 3 byte) op)))
2341 ((#b11110000 #b10100000)
2342 (let ((op (extract-3-bit-op byte)))
2343 (note (intl:gettext "~:[~;named-~]multiple-call, ~D args")
2344 (logbitp 3 byte) op)))
2345 ((#b11111000 #b10110000)
2346 ;; local call
2347 (let ((op (extract-3-bit-op byte))
2348 (target (extract-24-bits)))
2349 (note (intl:gettext "local call ~D, ~D args") target op)))
2350 ((#b11111000 #b10111000)
2351 ;; local tail-call
2352 (let ((op (extract-3-bit-op byte))
2353 (target (extract-24-bits)))
2354 (note (intl:gettext "local tail-call ~D, ~D args") target op)))
2355 ((#b11111000 #b11000000)
2356 ;; local-multiple-call
2357 (let ((op (extract-3-bit-op byte))
2358 (target (extract-24-bits)))
2359 (note (intl:gettext "local multiple-call ~D, ~D args") target op)))
2360 ((#b11111000 #b11001000)
2361 ;; return
2362 (let ((op (extract-3-bit-op byte)))
2363 (note (intl:gettext "return, ~D vals") op)))
2364 ((#b11111110 #b11010000)
2365 ;; branch
2366 (note (intl:gettext "branch ~D") (extract-branch-target byte)))
2367 ((#b11111110 #b11010010)
2368 ;; if-true
2369 (note (intl:gettext "if-true ~D") (extract-branch-target byte)))
2370 ((#b11111110 #b11010100)
2371 ;; if-false
2372 (note (intl:gettext "if-false ~D") (extract-branch-target byte)))
2373 ((#b11111110 #b11010110)
2374 ;; if-eq
2375 (note (intl:gettext "if-eq ~D") (extract-branch-target byte)))
2376 ((#b11111000 #b11011000)
2377 ;; XOP
2378 (let* ((low-3-bits (extract-3-bit-op byte))
2379 (xop (nth (if (eq low-3-bits :var) (next-byte) low-3-bits)
2380 *xop-names*)))
2381 (note (intl:gettext "xop ~A~@[ ~D~]")
2382 xop
2383 (case xop
2384 ((catch go unwind-protect)
2385 (extract-24-bits))
2386 ((type-check push-n-under)
2387 (get-constant (extract-extended-op)))))))
2388
2389 ((#b11100000 #b11100000)
2390 ;; inline
2391 (note (intl:gettext "inline ~A")
2392 (inline-function-info-function
2393 (svref *inline-functions* (ldb (byte 5 0) byte))))))))))))

  ViewVC Help
Powered by ViewVC 1.1.5