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