1 ;;;; that part of the byte compiler which exists not only in the
2 ;;;; target Lisp, but also in the cross-compilation host Lisp
4 ;;;; This software is part of the SBCL system. See the README file for
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.
15 ;;; ### remaining work:
17 ;;; - add more inline operations.
18 ;;; - Breakpoints/debugging info.
20 ;;;; stuff to emit noise
22 ;;; Note: We use the regular assembler, but we don't use any
23 ;;; ``instructions'' because there is no way to keep our byte-code
24 ;;; instructions separate from the instructions used by the native
25 ;;; backend. Besides, we don't want to do any scheduling or anything
26 ;;; like that, anyway.
28 #!-sb-fluid (declaim (inline output-byte))
29 (defun output-byte (segment byte)
30 (declare (type sb!assem:segment segment)
31 (type (unsigned-byte 8) byte))
32 (sb!assem:emit-byte segment byte))
34 ;;; Output OPERAND as 1 or 4 bytes, using #xFF as the extend code.
35 (defun output-extended-operand (segment operand)
36 (declare (type (unsigned-byte 24) operand))
37 (cond ((<= operand 254)
38 (output-byte segment operand))
40 (output-byte segment #xFF)
41 (output-byte segment (ldb (byte 8 16) operand))
42 (output-byte segment (ldb (byte 8 8) operand))
43 (output-byte segment (ldb (byte 8 0) operand)))))
45 ;;; Output a byte, logior'ing in a 4 bit immediate constant. If that
46 ;;; immediate won't fit, then emit it as the next 1-4 bytes.
47 (defun output-byte-with-operand (segment byte operand)
48 (declare (type sb!assem:segment segment)
49 (type (unsigned-byte 8) byte)
50 (type (unsigned-byte 24) operand))
51 (cond ((<= operand 14)
52 (output-byte segment (logior byte operand)))
54 (output-byte segment (logior byte 15))
55 (output-extended-operand segment operand)))
58 (defun output-label (segment label)
59 (declare (type sb!assem:segment segment)
60 (type sb!assem:label label))
61 (sb!assem:assemble (segment)
62 (sb!assem:emit-label label)))
64 ;;; Output a reference to LABEL.
65 (defun output-reference (segment label)
66 (declare (type sb!assem:segment segment)
67 (type sb!assem:label label))
68 (sb!assem:emit-back-patch
71 #'(lambda (segment posn)
72 (declare (type sb!assem:segment segment)
74 (let ((target (sb!assem:label-position label)))
75 (aver (<= 0 target (1- (ash 1 24))))
76 (output-byte segment (ldb (byte 8 16) target))
77 (output-byte segment (ldb (byte 8 8) target))
78 (output-byte segment (ldb (byte 8 0) target))))))
80 ;;; Output some branch byte-sequence.
81 (defun output-branch (segment kind label)
82 (declare (type sb!assem:segment segment)
83 (type (unsigned-byte 8) kind)
84 (type sb!assem:label label))
85 (sb!assem:emit-chooser
87 #'(lambda (segment posn delta)
88 (when (<= (- (ash 1 7))
89 (- (sb!assem:label-position label posn delta) posn 2)
91 (sb!assem:emit-chooser
93 #'(lambda (segment posn delta)
94 (declare (ignore segment) (type index posn delta))
95 (when (zerop (- (sb!assem:label-position label posn delta)
97 ;; Don't emit anything, because the branch is to the following
100 #'(lambda (segment posn)
101 ;; We know that we fit in one byte.
102 (declare (type sb!assem:segment segment)
104 (output-byte segment (logior kind 1))
107 (- (sb!assem:label-position label) posn 2)))))
109 #'(lambda (segment posn)
110 (declare (type sb!assem:segment segment)
112 (let ((target (sb!assem:label-position label)))
113 (aver (<= 0 target (1- (ash 1 24))))
114 (output-byte segment kind)
115 (output-byte segment (ldb (byte 8 16) target))
116 (output-byte segment (ldb (byte 8 8) target))
117 (output-byte segment (ldb (byte 8 0) target))))))
119 ;;;; system constants, Xops, and inline functions
121 ;;; If (%FDEFINITION-MARKER% . NAME) is a key in the table, then the
122 ;;; corresponding value is the byte code fdefinition.
123 (eval-when (:compile-toplevel :load-toplevel :execute)
124 (defvar *system-constant-codes* (make-hash-table :test 'equal)))
126 (eval-when (:compile-toplevel :load-toplevel :execute)
127 (flet ((def-system-constant (index form)
128 (setf (gethash form *system-constant-codes*) index)))
129 (def-system-constant 0 nil)
130 (def-system-constant 1 t)
131 (def-system-constant 2 :start)
132 (def-system-constant 3 :end)
133 (def-system-constant 4 :test)
134 (def-system-constant 5 :count)
135 (def-system-constant 6 :test-not)
136 (def-system-constant 7 :key)
137 (def-system-constant 8 :from-end)
138 (def-system-constant 9 :type)
139 (def-system-constant 10 '(%fdefinition-marker% . error))
140 (def-system-constant 11 '(%fdefinition-marker% . format))
141 (def-system-constant 12 '(%fdefinition-marker% . %typep))
142 (def-system-constant 13 '(%fdefinition-marker% . eql))
143 (def-system-constant 14 '(%fdefinition-marker% . %negate))
144 (def-system-constant 15 '(%fdefinition-marker% . %%defun))
145 (def-system-constant 16 '(%fdefinition-marker% . %%defmacro))
146 ;; no longer used as of sbcl-0.pre7:
147 #+nil (def-system-constant 17 '(%fdefinition-marker% . %%defconstant))
148 (def-system-constant 18 '(%fdefinition-marker% . length))
149 (def-system-constant 19 '(%fdefinition-marker% . equal))
150 (def-system-constant 20 '(%fdefinition-marker% . append))
151 (def-system-constant 21 '(%fdefinition-marker% . reverse))
152 (def-system-constant 22 '(%fdefinition-marker% . nreverse))
153 (def-system-constant 23 '(%fdefinition-marker% . nconc))
154 (def-system-constant 24 '(%fdefinition-marker% . list))
155 (def-system-constant 25 '(%fdefinition-marker% . list*))
156 (def-system-constant 26 '(%fdefinition-marker% . %coerce-name-to-function))
157 (def-system-constant 27 '(%fdefinition-marker% . values-list))))
159 (eval-when (#+sb-xc :compile-toplevel :load-toplevel :execute)
161 (defparameter *xop-names*
165 fdefn-function-or-lose; 3
166 default-unknown-values; 4
180 (defun xop-index-or-lose (name)
181 (or (position name *xop-names* :test #'eq)
182 (error "unknown XOP ~S" name)))
186 ;;; FIXME: The hardwired 32 here (found also in (MOD 32) above, and in
187 ;;; the number of bits tested in EXPAND-INTO-INLINES, and perhaps
188 ;;; elsewhere) is ugly. There should be some symbolic constant for the
189 ;;; number of bits devoted to coding byte-inline functions.
190 (eval-when (:compile-toplevel :load-toplevel :execute)
192 (defstruct (inline-function-info (:copier nil))
193 ;; the name of the function that we convert into calls to this
194 (function (required-argument) :type symbol)
195 ;; the name of the function that the interpreter should call to
196 ;; implement this. This may not be the same as the FUNCTION slot
197 ;; value if extra safety checks are required.
198 (interpreter-function (required-argument) :type symbol)
199 ;; the inline operation number, i.e. the byte value actually
200 ;; written into byte-compiled code
201 (number (required-argument) :type (mod 32))
202 ;; the type that calls must satisfy
203 (type (required-argument) :type function-type)
204 ;; Can we skip type checking of the arguments?
205 (safe (required-argument) :type boolean))
207 (defparameter *inline-functions* (make-array 32 :initial-element nil))
208 (defparameter *inline-function-table* (make-hash-table :test 'eq))
211 '((+ (fixnum fixnum) fixnum)
212 (- (fixnum fixnum) fixnum)
213 (make-value-cell (t) t)
214 (value-cell-ref (t) t)
215 (value-cell-setf (t t) (values))
216 (symbol-value (symbol) t
217 :interpreter-function %byte-symbol-value)
218 (setf-symbol-value (t symbol) (values))
219 (%byte-special-bind (t symbol) (values))
220 (%byte-special-unbind () (values))
221 (%negate (fixnum) fixnum)
222 (< (fixnum fixnum) t)
223 (> (fixnum fixnum) t)
224 (car (t) t :interpreter-function %byte-car :safe t)
225 (cdr (t) t :interpreter-function %byte-cdr :safe t)
230 (%instance-ref (t t) t)
231 (%setf-instance-ref (t t t) (values))))
233 (name arg-types result-type
234 &key (interpreter-function name) alias safe)
237 (make-inline-function-info
240 :interpreter-function interpreter-function
241 :type (specifier-type `(function ,arg-types ,result-type))
243 (setf (svref *inline-functions* number) info)
244 (setf (gethash name *inline-function-table*) info))
245 (unless alias (incf number))))))
247 (defun inline-function-number-or-lose (function)
248 (let ((info (gethash function *inline-function-table*)))
250 (inline-function-info-number info)
251 (error "unknown inline function: ~S" function))))
253 ;;;; transforms which are specific to byte code
255 ;;; It appears that the idea here is that in byte code, EQ is more
256 ;;; efficient than CHAR=. -- WHN 199910
258 (deftransform eql ((x y) ((or fixnum character) (or fixnum character))
262 (deftransform char= ((x y) * * :when :byte)
265 ;;;; annotations hung off the IR1 while compiling
267 (defstruct (byte-component-info (:copier nil))
268 (constants (make-array 10 :adjustable t :fill-pointer 0)))
270 (defstruct (byte-lambda-info (:copier nil))
271 (label nil :type (or null label))
272 (stack-size 0 :type index)
273 ;; FIXME: should be INTERESTING-P T :TYPE BOOLEAN
274 (interesting t :type (member t nil)))
276 (defun block-interesting (block)
277 (byte-lambda-info-interesting (lambda-info (block-home-lambda block))))
279 (defstruct (byte-lambda-var-info (:copier nil))
280 (argp nil :type (member t nil))
281 (offset 0 :type index))
283 (defstruct (byte-nlx-info (:copier nil))
284 (stack-slot nil :type (or null index))
285 (label (sb!assem:gen-label) :type sb!assem:label)
286 (duplicate nil :type (member t nil)))
288 (defstruct (byte-block-info
290 (:include block-annotation)
291 (:constructor make-byte-block-info
292 (block &key produces produces-sset consumes
293 total-consumes nlx-entries nlx-entry-p)))
294 (label (sb!assem:gen-label) :type sb!assem:label)
295 ;; A list of the CONTINUATIONs describing values that this block
296 ;; pushes onto the stack. Note: PRODUCES and CONSUMES can contain
297 ;; the keyword :NLX-ENTRY marking the place on the stack where a
298 ;; non-local-exit frame is added or removed. Since breaking up a NLX
299 ;; restores the stack, we don't have to about (and in fact must not)
300 ;; discard values underneath a :NLX-ENTRY marker evern though they
301 ;; appear to be dead (since they might not be.)
302 (produces nil :type list)
303 ;; An SSET of the produces for faster set manipulations. The
304 ;; elements are the BYTE-CONTINUATION-INFO objects. :NLX-ENTRY
305 ;; markers are not represented.
306 (produces-sset (make-sset) :type sset)
307 ;; A list of the continuations that this block pops from the stack.
309 (consumes nil :type list)
310 ;; The transitive closure of what this block and all its successors
311 ;; consume. After stack-analysis, that is.
312 (total-consumes (make-sset) :type sset)
313 ;; Set to T whenever the consumes lists of a successor changes and
314 ;; the block is queued for re-analysis so we can easily avoid
315 ;; queueing the same block several times.
316 (already-queued nil :type (member t nil))
317 ;; The continuations and :NLX-ENTRY markers on the stack (in order)
318 ;; when this block starts.
319 (start-stack :unknown :type (or (member :unknown) list))
320 ;; The continuations and :NLX-ENTRY markers on the stack (in order)
321 ;; when this block ends.
322 (end-stack nil :type list)
323 ;; List of ((nlx-info*) produces consumes) for each ENTRY in this
324 ;; block that is a NLX target.
325 (nlx-entries nil :type list)
326 ;; T if this is an %nlx-entry point, and we shouldn't just assume we
327 ;; know what is going to be on the stack.
328 (nlx-entry-p nil :type (member t nil)))
330 (defprinter (byte-block-info)
333 (defstruct (byte-continuation-info
334 (:include sset-element)
335 (:constructor make-byte-continuation-info
336 (continuation results placeholders))
338 (continuation (required-argument) :type continuation)
339 (results (required-argument)
340 :type (or (member :fdefinition :eq-test :unknown) index))
341 ;; If the DEST is a local non-MV call, then we may need to push some
342 ;; number of placeholder args corresponding to deleted
343 ;; (unreferenced) args. If PLACEHOLDERS /= 0, then RESULTS is
345 (placeholders (required-argument) :type index))
347 (defprinter (byte-continuation-info)
350 (placeholders :test (/= placeholders 0)))
352 ;;;; Annotate the IR1.
354 (defun annotate-continuation (cont results &optional (placeholders 0))
355 ;; For some reason, DO-NODES does the same return node multiple
356 ;; times, which causes ANNOTATE-CONTINUATION to be called multiple
357 ;; times on the same continuation. So we can't assert that we
360 (aver (null (continuation-info cont)))
361 (setf (continuation-info cont)
362 (make-byte-continuation-info cont results placeholders))
365 (defun annotate-set (set)
366 ;; Annotate the value for one value.
367 (annotate-continuation (set-value set) 1))
369 ;;; We do different stack magic for non-MV and MV calls to figure out
370 ;;; how many values should be pushed during compilation of each arg.
372 ;;; Since byte functions are directly caller by the interpreter (there
373 ;;; is no XEP), and it doesn't know which args are actually used, byte
374 ;;; functions must allow unused args to be passed. But this creates a
375 ;;; problem with local calls, because these unused args would not
376 ;;; otherwise be pushed (since the continuation has been deleted.) So,
377 ;;; in this function, we count up placeholders for any unused args
378 ;;; contiguously preceding this one. These placeholders are inserted
379 ;;; under the referenced arg by CHECKED-CANONICALIZE-VALUES.
381 ;;; With MV calls, we try to figure out how many values are actually
382 ;;; generated. We allow initial args to supply a fixed number of
383 ;;; values, but everything after the first :unknown arg must also be
384 ;;; unknown. This picks off most of the standard uses (i.e. calls to
385 ;;; apply), but still is easy to implement.
386 (defun annotate-basic-combination-args (call)
387 (declare (type basic-combination call))
390 (if (and (eq (basic-combination-kind call) :local)
391 (member (functional-kind (combination-lambda call))
392 '(nil :optional :cleanup)))
393 (let ((placeholders 0))
394 (declare (type index placeholders))
395 (dolist (arg (combination-args call))
397 (annotate-continuation arg (1+ placeholders) placeholders)
398 (setq placeholders 0))
400 (incf placeholders)))))
401 (dolist (arg (combination-args call))
403 (annotate-continuation arg 1)))))
406 ((allow-fixed (remaining)
408 (let* ((cont (car remaining))
411 (continuation-derived-type cont)))))
412 (cond ((eq values :unknown)
413 (force-to-unknown remaining))
415 (annotate-continuation cont values)
416 (allow-fixed (cdr remaining)))))))
417 (force-to-unknown (remaining)
419 (let ((cont (car remaining)))
421 (annotate-continuation cont :unknown)))
422 (force-to-unknown (cdr remaining)))))
423 (allow-fixed (mv-combination-args call)))))
426 (defun annotate-local-call (call)
427 (cond ((mv-combination-p call)
428 (annotate-continuation
429 (first (basic-combination-args call))
430 (length (lambda-vars (combination-lambda call)))))
432 (annotate-basic-combination-args call)
433 (when (member (functional-kind (combination-lambda call))
434 '(nil :optional :cleanup))
435 (dolist (arg (basic-combination-args call))
437 (setf (continuation-%type-check arg) nil))))))
438 (annotate-continuation (basic-combination-fun call) 0)
439 (when (node-tail-p call)
440 (set-tail-local-call-successor call)))
442 ;;; Annotate the values for any :full combination. This includes
443 ;;; inline functions, multiple value calls & throw. If a real full
444 ;;; call or a safe inline operation, then clear any type-check
445 ;;; annotations. When we are done, remove jump to return for tail
448 ;;; Also, we annotate slot accessors as inline if no type check is
449 ;;; needed and (for setters) no value needs to be left on the stack.
450 (defun annotate-full-call (call)
451 (let* ((fun (basic-combination-fun call))
452 (args (basic-combination-args call))
453 (name (continuation-function-name fun))
454 (info (gethash name *inline-function-table*)))
455 (flet ((annotate-args ()
456 (annotate-basic-combination-args call)
458 (when (continuation-type-check arg)
459 (setf (continuation-%type-check arg) :deleted)))
460 (annotate-continuation
462 (if (continuation-function-name fun) :fdefinition 1))))
463 (cond ((mv-combination-p call)
464 (cond ((eq name '%throw)
465 (aver (= (length args) 2))
466 (annotate-continuation (first args) 1)
467 (annotate-continuation (second args) :unknown)
468 (setf (node-tail-p call) nil)
469 (annotate-continuation fun 0))
473 (valid-function-use call (inline-function-info-type info)))
474 (annotate-basic-combination-args call)
475 (setf (node-tail-p call) nil)
476 (setf (basic-combination-info call) info)
477 (annotate-continuation fun 0)
478 (when (inline-function-info-safe info)
480 (when (continuation-type-check arg)
481 (setf (continuation-%type-check arg) :deleted)))))
483 (let ((leaf (ref-leaf (continuation-use fun))))
484 (and (slot-accessor-p leaf)
485 (or (policy call (zerop safety))
487 :key #'continuation-type-check)))
489 (not (continuation-dest (node-cont call)))
491 (setf (basic-combination-info call)
492 (gethash (if (consp name) '%setf-instance-ref '%instance-ref)
493 *inline-function-table*))
494 (setf (node-tail-p call) nil)
495 (annotate-continuation fun 0)
496 (annotate-basic-combination-args call))
500 ;; If this is (still) a tail-call, then blow away the return.
501 (when (node-tail-p call)
502 (node-ends-block call)
503 (let ((block (node-block call)))
504 (unlink-blocks block (first (block-succ block)))
505 (link-blocks block (component-tail (block-component block)))))
509 (defun annotate-known-call (call)
510 (annotate-basic-combination-args call)
511 (setf (node-tail-p call) nil)
512 (annotate-continuation (basic-combination-fun call) 0)
515 (defun annotate-basic-combination (call)
516 ;; Annotate the function.
517 (let ((kind (basic-combination-kind call)))
520 (annotate-local-call call))
522 (annotate-full-call call))
524 (setf (basic-combination-kind call) :full)
525 (annotate-full-call call))
527 (unless (and (function-info-byte-compile kind)
528 (funcall (or (function-info-byte-annotate kind)
529 #'annotate-known-call)
531 (setf (basic-combination-kind call) :full)
532 (annotate-full-call call)))))
536 (defun annotate-if (if)
537 ;; Annotate the test.
538 (let* ((cont (if-test if))
539 (use (continuation-use cont)))
540 (annotate-continuation
542 (if (and (combination-p use)
543 (eq (continuation-function-name (combination-fun use)) 'eq)
544 (= (length (combination-args use)) 2))
545 ;; If the test is a call to EQ, then we can use branch-if-eq
546 ;; so don't need to actually funcall the test.
548 ;; Otherwise, funcall the test for 1 value.
551 (defun annotate-return (return)
552 (let ((cont (return-result return)))
553 (annotate-continuation
555 (nth-value 1 (values-types (continuation-derived-type cont))))))
557 (defun annotate-exit (exit)
558 (let ((cont (exit-value exit)))
560 (annotate-continuation cont :unknown))))
562 (defun annotate-block (block)
563 (do-nodes (node cont block)
567 (cset (annotate-set node))
568 (basic-combination (annotate-basic-combination node))
569 (cif (annotate-if node))
570 (creturn (annotate-return node))
572 (exit (annotate-exit node))))
575 (defun annotate-ir1 (component)
576 (do-blocks (block component)
577 (when (block-interesting block)
578 (annotate-block block)))
583 (defvar *byte-continuation-counter*)
585 ;;; Scan the nodes in BLOCK and compute the information that we will
586 ;;; need to do flow analysis and our stack simulation walk. We simulate
587 ;;; the stack within the block, reducing it to ordered lists
588 ;;; representing the values we remove from the top of the stack and
589 ;;; place on the stack (not considering values that are produced and
590 ;;; consumed within the block.) A NLX entry point is considered to
591 ;;; push a :NLX-ENTRY marker (can be though of as the run-time catch
593 (defun compute-produces-and-consumes (block)
596 (total-consumes (make-sset))
599 (labels ((interesting (cont)
601 (let ((info (continuation-info cont)))
603 (not (member (byte-continuation-info-results info)
606 (cond ((not (or (eq cont :nlx-entry) (interesting cont))))
608 (aver (eq (car stack) cont))
611 (adjoin-cont cont total-consumes)
612 (push cont consumes))))
613 (adjoin-cont (cont sset)
614 (unless (eq cont :nlx-entry)
615 (let ((info (continuation-info cont)))
616 (unless (byte-continuation-info-number info)
617 (setf (byte-continuation-info-number info)
618 (incf *byte-continuation-counter*)))
619 (sset-adjoin info sset)))))
620 (do-nodes (node cont block)
625 (consume (set-value node)))
627 (dolist (arg (reverse (basic-combination-args node)))
630 (consume (basic-combination-fun node))
631 (case (continuation-function-name (basic-combination-fun node))
633 (let ((nlx-info (continuation-value
634 (first (basic-combination-args node)))))
635 (ecase (cleanup-kind (nlx-info-cleanup nlx-info))
636 ((:catch :unwind-protect)
637 (consume :nlx-entry))
638 ;; If for a lexical exit, we will see a breakup
639 ;; later, so don't consume :NLX-ENTRY now.
642 (let ((cont (nlx-info-continuation nlx-info)))
643 (when (interesting cont)
644 (push cont stack))))))
645 (setf nlx-entry-p t))
646 (%lexical-exit-breakup
647 (unless (byte-nlx-info-duplicate
650 (first (basic-combination-args node)))))
651 (consume :nlx-entry)))
652 ((%catch-breakup %unwind-protect-breakup)
653 (consume :nlx-entry))))
655 (consume (if-test node)))
657 (consume (return-result node)))
659 (let* ((cup (entry-cleanup node))
660 (nlx-info (cleanup-nlx-info cup)))
662 (push :nlx-entry stack)
663 (push (list nlx-info stack (reverse consumes))
666 (when (exit-value node)
667 (consume (exit-value node)))))
668 (when (and (not (exit-p node)) (interesting cont))
671 (setf (block-info block)
672 (make-byte-block-info
675 :produces-sset (let ((res (make-sset)))
676 (dolist (product stack)
677 (adjoin-cont product res))
679 :consumes (reverse consumes)
680 :total-consumes total-consumes
681 :nlx-entries nlx-entries
682 :nlx-entry-p nlx-entry-p))))
686 (defun walk-successors (block stack)
687 (let ((tail (component-tail (block-component block))))
688 (dolist (succ (block-succ block))
689 (unless (or (eq succ tail)
690 (not (block-interesting succ))
691 (byte-block-info-nlx-entry-p (block-info succ)))
692 (walk-block succ block stack)))))
694 ;;; Take a stack and a consumes list, and remove the appropriate
695 ;;; stuff. When we consume a :NLX-ENTRY, we just remove the top
696 ;;; marker, and leave any values on top intact. This represents the
697 ;;; desired effect of %CATCH-BREAKUP, etc., which don't affect any
698 ;;; values on the stack.
699 (defun consume-stuff (stack stuff)
700 (let ((new-stack stack))
702 (cond ((eq cont :nlx-entry)
703 (aver (find :nlx-entry new-stack))
704 (setq new-stack (remove :nlx-entry new-stack :count 1)))
706 (aver (eq (car new-stack) cont))
710 ;;; NLX-INFOS is the list of NLX-INFO structures for this ENTRY note.
711 ;;; CONSUME and PRODUCE are the values from outside this block that
712 ;;; were consumed and produced by this block before the ENTRY node.
713 ;;; STACK is the globally simulated stack at the start of this block.
714 (defun walk-nlx-entry (nlx-infos stack produce consume)
715 (let ((stack (consume-stuff stack consume)))
716 (dolist (nlx-info nlx-infos)
717 (walk-block (nlx-info-target nlx-info) nil (append produce stack))))
720 ;;; Simulate the stack across block boundaries, discarding any values
721 ;;; that are dead. A :NLX-ENTRY marker prevents values live at a NLX
722 ;;; entry point from being discarded prematurely.
723 (defun walk-block (block pred stack)
724 ;; Pop everything off of stack that isn't live.
725 (let* ((info (block-info block))
726 (live (byte-block-info-total-consumes info)))
729 (flet ((flush-fixed ()
730 (unless (zerop fixed)
731 (pops `(%byte-pop-stack ,fixed))
736 (let ((cont (car stack)))
737 (when (or (eq cont :nlx-entry)
738 (sset-member (continuation-info cont) live))
742 (byte-continuation-info-results
743 (continuation-info cont))))
747 (pops `(%byte-pop-stack 0)))
751 (incf fixed results))))))
756 (insert-cleanup-code pred block
757 (continuation-next (block-start block))
759 (annotate-block cleanup-block))))
761 (cond ((eq (byte-block-info-start-stack info) :unknown)
762 ;; Record what the stack looked like at the start of this block.
763 (setf (byte-block-info-start-stack info) stack)
764 ;; Process any nlx entries that build off of our stack.
765 (dolist (stuff (byte-block-info-nlx-entries info))
766 (walk-nlx-entry (first stuff) stack (second stuff) (third stuff)))
767 ;; Remove whatever we consume.
768 (setq stack (consume-stuff stack (byte-block-info-consumes info)))
769 ;; Add whatever we produce.
770 (setf stack (append (byte-block-info-produces info) stack))
771 (setf (byte-block-info-end-stack info) stack)
772 ;; Pass that on to all our successors.
773 (walk-successors block stack))
775 ;; We have already processed the successors of this block. Just
776 ;; make sure we thing the stack is the same now as before.
777 (aver (equal (byte-block-info-start-stack info) stack)))))
780 ;;; Do lifetime flow analysis on values pushed on the stack, then call
781 ;;; do the stack simulation walk to discard dead values. In addition
782 ;;; to considering the obvious inputs from a block's successors, we
783 ;;; must also consider %NLX-ENTRY targets to be successors in order to
784 ;;; ensure that any values only used in the NLX entry stay alive until
785 ;;; we reach the mess-up node. After then, we can keep the values from
786 ;;; being discarded by placing a marker on the simulated stack.
787 (defun byte-stack-analyze (component)
788 (declare (notinline find)) ; to avoid bug 117 bogowarnings
790 (let ((*byte-continuation-counter* 0))
791 (do-blocks (block component)
792 (when (block-interesting block)
793 (compute-produces-and-consumes block)
795 (setf (byte-block-info-already-queued (block-info block)) t))))
796 (let ((tail (last head)))
797 (labels ((maybe-enqueue (block)
798 (when (block-interesting block)
799 (let ((info (block-info block)))
800 (unless (byte-block-info-already-queued info)
801 (setf (byte-block-info-already-queued info) t)
802 (let ((new (list block)))
804 (setf (cdr tail) new)
807 (maybe-enqueue-predecessors (block)
808 (when (byte-block-info-nlx-entry-p (block-info block))
814 (environment-nlx-info (block-environment block))
815 :key #'nlx-info-target))))))
817 (dolist (pred (block-pred block))
818 (unless (eq pred (component-head (block-component block)))
819 (maybe-enqueue pred)))))
823 (let* ((block (pop head))
824 (info (block-info block))
825 (total-consumes (byte-block-info-total-consumes info))
826 (produces-sset (byte-block-info-produces-sset info))
828 (setf (byte-block-info-already-queued info) nil)
829 (dolist (succ (block-succ block))
830 (unless (eq succ (component-tail component))
831 (let ((succ-info (block-info succ)))
832 (when (sset-union-of-difference
834 (byte-block-info-total-consumes succ-info)
836 (setf did-anything t)))))
837 (dolist (nlx-list (byte-block-info-nlx-entries info))
838 (dolist (nlx-info (first nlx-list))
839 (when (sset-union-of-difference
841 (byte-block-info-total-consumes
843 (nlx-info-target nlx-info)))
845 (setf did-anything t))))
847 (maybe-enqueue-predecessors block)))))))
849 (walk-successors (component-head component) nil)
852 ;;;; Actually generate the byte code.
854 (defvar *byte-component-info*)
856 ;;; FIXME: These might as well be generated with DEFENUM, right?
857 ;;; It would also be nice to give them less ambiguous names, perhaps
858 ;;; with a "BYTEOP-" prefix instead of "BYTE-".
859 (defconstant byte-push-local #b00000000)
860 (defconstant byte-push-arg #b00010000)
861 (defconstant byte-push-constant #b00100000)
862 (defconstant byte-push-system-constant #b00110000)
863 (defconstant byte-push-int #b01000000)
864 (defconstant byte-push-neg-int #b01010000)
865 (defconstant byte-pop-local #b01100000)
866 (defconstant byte-pop-n #b01110000)
867 (defconstant byte-call #b10000000)
868 (defconstant byte-tail-call #b10010000)
869 (defconstant byte-multiple-call #b10100000)
870 (defconstant byte-named #b00001000)
871 (defconstant byte-local-call #b10110000)
872 (defconstant byte-local-tail-call #b10111000)
873 (defconstant byte-local-multiple-call #b11000000)
874 (defconstant byte-return #b11001000)
875 (defconstant byte-branch-always #b11010000)
876 (defconstant byte-branch-if-true #b11010010)
877 (defconstant byte-branch-if-false #b11010100)
878 (defconstant byte-branch-if-eq #b11010110)
879 (defconstant byte-xop #b11011000)
880 (defconstant byte-inline-function #b11100000)
882 (defun output-push-int (segment int)
883 (declare (type sb!assem:segment segment)
884 (type (integer #.(- (ash 1 24)) #.(1- (ash 1 24)))))
886 (output-byte-with-operand segment byte-push-neg-int (- (1+ int)))
887 (output-byte-with-operand segment byte-push-int int)))
889 (defun output-push-constant-leaf (segment constant)
890 (declare (type sb!assem:segment segment)
891 (type constant constant))
892 (let ((info (constant-info constant)))
894 (output-byte-with-operand segment
897 byte-push-system-constant)
901 (let ((const (constant-value constant)))
902 (if (and (integerp const) (< (- (ash 1 24)) const (ash 1 24)))
903 ;; It can be represented as an immediate.
904 (output-push-int segment const)
905 ;; We need to store it in the constants pool.
907 (unless (and (consp const)
908 (eq (car const) '%fdefinition-marker%))
909 (gethash const *system-constant-codes*)))
911 (cons :system-constant posn)
912 (cons :local-constant
915 (byte-component-info-constants
916 *byte-component-info*))))))
917 (setf (constant-info constant) new-info)
918 (output-push-constant-leaf segment constant)))))))
920 (defun output-push-constant (segment value)
921 (if (and (integerp value)
922 (< (- (ash 1 24)) value (ash 1 24)))
923 (output-push-int segment value)
924 (output-push-constant-leaf segment (find-constant value))))
926 ;;; Return the offset of a load-time constant in the constant pool,
927 ;;; adding it if absent.
928 (defun byte-load-time-constant-index (kind datum)
929 (let ((constants (byte-component-info-constants *byte-component-info*)))
930 (or (position-if #'(lambda (x)
934 (cons (equal (cdr x) datum))
935 (ctype (type= (cdr x) datum))
937 (eq (cdr x) datum)))))
939 (vector-push-extend (cons kind datum) constants))))
941 (defun output-push-load-time-constant (segment kind datum)
942 (output-byte-with-operand segment byte-push-constant
943 (byte-load-time-constant-index kind datum))
946 (defun output-do-inline-function (segment function)
947 ;; Note: we don't annotate this as a call site, because it is used
948 ;; for internal stuff. Functions that get inlined have code
949 ;; locations added byte generate-byte-code-for-full-call below.
951 (logior byte-inline-function
952 (inline-function-number-or-lose function))))
954 (defun output-do-xop (segment xop)
955 (let ((index (xop-index-or-lose xop)))
957 (output-byte segment (logior byte-xop index)))
959 (output-byte segment (logior byte-xop 7))
960 (output-byte segment index)))))
962 (defun closure-position (var env)
963 (or (position var (environment-closure env))
964 (error "Can't find ~S" var)))
966 (defun output-ref-lambda-var (segment var env
967 &optional (indirect-value-cells t))
968 (declare (type sb!assem:segment segment)
969 (type lambda-var var)
970 (type environment env))
971 (if (eq (lambda-environment (lambda-var-home var)) env)
972 (let ((info (leaf-info var)))
973 (output-byte-with-operand segment
974 (if (byte-lambda-var-info-argp info)
977 (byte-lambda-var-info-offset info)))
978 (output-byte-with-operand segment
980 (closure-position var env)))
981 (when (and indirect-value-cells (lambda-var-indirect var))
982 (output-do-inline-function segment 'value-cell-ref)))
984 (defun output-ref-nlx-info (segment info env)
985 (if (eq (node-environment (cleanup-mess-up (nlx-info-cleanup info))) env)
986 (output-byte-with-operand segment
988 (byte-nlx-info-stack-slot
989 (nlx-info-info info)))
990 (output-byte-with-operand segment
992 (closure-position info env))))
994 (defun output-set-lambda-var (segment var env &optional make-value-cells)
995 (declare (type sb!assem:segment segment)
996 (type lambda-var var)
997 (type environment env))
998 (let ((indirect (lambda-var-indirect var)))
999 (cond ((not (eq (lambda-environment (lambda-var-home var)) env))
1000 ;; This is not this guy's home environment. So we need to
1001 ;; get it the value cell out of the closure, and fill it in.
1003 (aver (not make-value-cells))
1004 (output-byte-with-operand segment byte-push-arg
1005 (closure-position var env))
1006 (output-do-inline-function segment 'value-cell-setf))
1008 (let* ((pushp (and indirect (not make-value-cells)))
1009 (byte-code (if pushp byte-push-local byte-pop-local))
1010 (info (leaf-info var)))
1011 (aver (not (byte-lambda-var-info-argp info)))
1012 (when (and indirect make-value-cells)
1013 ;; Replace the stack top with a value cell holding the
1015 (output-do-inline-function segment 'make-value-cell))
1016 (output-byte-with-operand segment byte-code
1017 (byte-lambda-var-info-offset info))
1019 (output-do-inline-function segment 'value-cell-setf)))))))
1021 ;;; Output whatever noise is necessary to canonicalize the values on
1022 ;;; the top of the stack. DESIRED is the number we want, and SUPPLIED
1023 ;;; is the number we have. Either push NIL or pop-n to make them
1024 ;;; balanced. Note: either desired or supplied can be :unknown, in
1025 ;;; which case it means use the ``unknown-values'' convention (which
1026 ;;; is the stack values followed by the number of values).
1027 (defun canonicalize-values (segment desired supplied)
1028 (declare (type sb!assem:segment segment)
1029 (type (or (member :unknown) index) desired supplied))
1030 (cond ((eq desired :unknown)
1031 (unless (eq supplied :unknown)
1032 (output-byte-with-operand segment byte-push-int supplied)))
1033 ((eq supplied :unknown)
1034 (unless (eq desired :unknown)
1035 (output-push-int segment desired)
1036 (output-do-xop segment 'default-unknown-values)))
1037 ((< supplied desired)
1038 (dotimes (i (- desired supplied))
1039 (output-push-constant segment nil)))
1040 ((> supplied desired)
1041 (output-byte-with-operand segment byte-pop-n (- supplied desired))))
1044 (defparameter *byte-type-weakenings*
1045 (mapcar #'specifier-type
1046 '(fixnum single-float double-float simple-vector simple-bit-vector
1049 ;;; Emit byte code to check that the value on top of the stack is of
1050 ;;; the specified TYPE. NODE is used for policy information. We weaken
1051 ;;; or entirely omit the type check whether speed is more important
1053 (defun byte-generate-type-check (segment type node)
1054 (declare (type ctype type) (type node node))
1055 (unless (or (policy node (zerop safety))
1056 (csubtypep *universal-type* type))
1057 (let ((type (if (policy node (> speed safety))
1058 (dolist (super *byte-type-weakenings* type)
1059 (when (csubtypep type super) (return super)))
1061 (output-do-xop segment 'type-check)
1062 (output-extended-operand
1064 (byte-load-time-constant-index :type-predicate type)))))
1066 ;;; This function is used when we are generating code which delivers
1067 ;;; values to a continuation. If this continuation needs a type check,
1068 ;;; and has a single value, then we do a type check. We also
1069 ;;; CANONICALIZE-VALUES for the continuation's desired number of
1070 ;;; values (without the placeholders.)
1072 ;;; Somewhat unrelatedly, we also push placeholders for deleted
1073 ;;; arguments to local calls. Although we check first, the actual
1074 ;;; PUSH-N-UNDER is done afterward, since then the single value we
1075 ;;; want is stack top.
1076 (defun checked-canonicalize-values (segment cont supplied)
1077 (let ((info (continuation-info cont)))
1079 (let ((desired (byte-continuation-info-results info))
1080 (placeholders (byte-continuation-info-placeholders info)))
1081 (unless (zerop placeholders)
1082 (aver (eql desired (1+ placeholders)))
1086 (byte-generate-type-check
1088 (single-value-type (continuation-asserted-type cont))
1089 (continuation-dest cont))))
1091 ((member (continuation-type-check cont) '(nil :deleted))
1092 (canonicalize-values segment desired supplied))
1095 (canonicalize-values segment desired supplied))
1097 (canonicalize-values segment desired supplied)
1100 (canonicalize-values segment desired supplied))))
1102 (unless (zerop placeholders)
1103 (output-do-xop segment 'push-n-under)
1104 (output-extended-operand segment placeholders)))
1106 (canonicalize-values segment 0 supplied))))
1108 ;;; Emit prologue for non-LET functions. Assigned arguments must be
1109 ;;; copied into locals, and argument type checking may need to be done.
1110 (defun generate-byte-code-for-bind (segment bind cont)
1111 (declare (type sb!assem:segment segment) (type bind bind)
1113 (let ((lambda (bind-lambda bind))
1114 (env (node-environment bind)))
1115 (ecase (lambda-kind lambda)
1116 ((nil :top-level :escape :cleanup :optional)
1117 (let* ((info (lambda-info lambda))
1118 (type-check (policy (lambda-bind lambda) (not (zerop safety))))
1119 (frame-size (byte-lambda-info-stack-size info)))
1120 (cond ((< frame-size (* 255 2))
1121 (output-byte segment (ceiling frame-size 2)))
1123 (output-byte segment 255)
1124 (output-byte segment (ldb (byte 8 16) frame-size))
1125 (output-byte segment (ldb (byte 8 8) frame-size))
1126 (output-byte segment (ldb (byte 8 0) frame-size))))
1128 (do ((argnum (1- (+ (length (lambda-vars lambda))
1129 (length (environment-closure
1130 (lambda-environment lambda)))))
1132 (vars (lambda-vars lambda) (cdr vars))
1135 (unless (zerop pops)
1136 (output-byte-with-operand segment byte-pop-n pops)))
1137 (declare (fixnum argnum pops))
1138 (let* ((var (car vars))
1139 (info (lambda-var-info var))
1140 (type (leaf-type var)))
1142 ((byte-lambda-var-info-argp info)
1143 (when (and type-check
1144 (not (csubtypep *universal-type* type)))
1145 (output-byte-with-operand segment byte-push-arg argnum)
1146 (byte-generate-type-check segment type bind)
1149 (output-byte-with-operand segment byte-push-arg argnum)
1151 (byte-generate-type-check segment type bind))
1152 (output-set-lambda-var segment var env t)))))))
1154 ;; Everything has been taken care of in the combination node.
1155 ((:let :mv-let :assignment))))
1158 ;;; This hashtable translates from n-ary function names to the
1159 ;;; two-arg-specific versions which we call to avoid &REST-arg consing.
1160 (defvar *two-arg-functions* (make-hash-table :test 'eq))
1162 (dolist (fun '((sb!kernel:two-arg-ior logior)
1163 (sb!kernel:two-arg-* *)
1164 (sb!kernel:two-arg-+ +)
1165 (sb!kernel:two-arg-/ /)
1166 (sb!kernel:two-arg-- -)
1167 (sb!kernel:two-arg-> >)
1168 (sb!kernel:two-arg-< <)
1169 (sb!kernel:two-arg-= =)
1170 (sb!kernel:two-arg-lcm lcm)
1171 (sb!kernel:two-arg-and logand)
1172 (sb!kernel:two-arg-gcd gcd)
1173 (sb!kernel:two-arg-xor logxor)
1175 (two-arg-char= char=)
1176 (two-arg-char< char<)
1177 (two-arg-char> char>)
1178 (two-arg-char-equal char-equal)
1179 (two-arg-char-lessp char-lessp)
1180 (two-arg-char-greaterp char-greaterp)
1181 (two-arg-string= string=)
1182 (two-arg-string< string<)
1183 (two-arg-string> string>)))
1185 (setf (gethash (second fun) *two-arg-functions*) (first fun)))
1187 ;;; If a system constant, push that, otherwise use a load-time constant.
1188 (defun output-push-fdefinition (segment name)
1189 (let ((offset (gethash `(%fdefinition-marker% . ,name)
1190 *system-constant-codes*)))
1192 (output-byte-with-operand segment byte-push-system-constant
1194 (output-push-load-time-constant segment :fdefinition name))))
1196 (defun generate-byte-code-for-ref (segment ref cont)
1197 (declare (type sb!assem:segment segment) (type ref ref)
1198 (type continuation cont))
1199 (let ((info (continuation-info cont)))
1200 ;; If there is no info, then nobody wants the result.
1202 (let ((values (byte-continuation-info-results info))
1203 (leaf (ref-leaf ref)))
1205 ((eq values :fdefinition)
1206 (aver (and (global-var-p leaf)
1207 (eq (global-var-kind leaf)
1209 (let* ((name (global-var-name leaf))
1210 (found (gethash name *two-arg-functions*)))
1211 (output-push-fdefinition
1214 (= (length (basic-combination-args
1215 (continuation-dest cont)))
1225 (cond ((legal-immediate-constant-p leaf)
1226 (output-push-constant-leaf segment leaf))
1228 (output-push-constant segment (leaf-name leaf))
1229 (output-do-inline-function segment 'symbol-value))))
1231 (let* ((referred-env (lambda-environment leaf))
1232 (closure (environment-closure referred-env)))
1234 (output-push-load-time-constant segment :entry leaf)
1235 (let ((my-env (node-environment ref)))
1236 (output-push-load-time-constant segment :entry leaf)
1237 (dolist (thing closure)
1240 (output-ref-lambda-var segment thing my-env nil))
1242 (output-ref-nlx-info segment thing my-env))))
1243 (output-push-int segment (length closure))
1244 (output-do-xop segment 'make-closure)))))
1246 (output-push-load-time-constant segment :entry leaf))
1248 (output-ref-lambda-var segment leaf (node-environment ref)))
1250 (ecase (global-var-kind leaf)
1251 ((:special :global :constant)
1252 (output-push-constant segment (global-var-name leaf))
1253 (output-do-inline-function segment 'symbol-value))
1255 (output-push-fdefinition segment (global-var-name leaf))
1256 (output-do-xop segment 'fdefn-function-or-lose)))))
1257 (checked-canonicalize-values segment cont 1))))))
1260 (defun generate-byte-code-for-set (segment set cont)
1261 (declare (type sb!assem:segment segment) (type cset set)
1262 (type continuation cont))
1263 (let* ((leaf (set-var set))
1264 (info (continuation-info cont))
1266 (byte-continuation-info-results info)
1268 (unless (eql values 0)
1269 ;; Someone wants the value, so copy it.
1270 (output-do-xop segment 'dup))
1273 (ecase (global-var-kind leaf)
1275 (output-push-constant segment (global-var-name leaf))
1276 (output-do-inline-function segment 'setf-symbol-value))))
1278 ;; Note: It's important to test for whether there are any
1279 ;; references to the variable before we actually try to set it.
1280 ;; (Setting a lexical variable with no refs caused bugs ca. CMU
1281 ;; CL 18c, because the compiler deletes such variables.)
1282 (cond ((leaf-refs leaf)
1283 (output-set-lambda-var segment leaf (node-environment set)))
1284 ;; If no one wants the value, then pop it, else leave it
1287 (output-byte-with-operand segment byte-pop-n 1)))))
1288 (unless (eql values 0)
1289 (checked-canonicalize-values segment cont 1)))
1292 (defun generate-byte-code-for-local-call (segment call cont num-args)
1293 (let* ((lambda (combination-lambda call))
1294 (vars (lambda-vars lambda))
1295 (env (lambda-environment lambda)))
1296 (ecase (functional-kind lambda)
1298 (dolist (var (reverse vars))
1299 (when (lambda-var-refs var)
1300 (output-set-lambda-var segment var env t))))
1302 (let ((do-check (member (continuation-type-check
1303 (first (basic-combination-args call)))
1305 (dolist (var (reverse vars))
1307 (byte-generate-type-check segment (leaf-type var) call))
1308 (output-set-lambda-var segment var env t))))
1309 ((nil :optional :cleanup)
1310 ;; We got us a local call.
1311 (aver (not (eq num-args :unknown)))
1312 ;; Push any trailing placeholder args...
1313 (dolist (x (reverse (basic-combination-args call)))
1315 (output-push-int segment 0))
1316 ;; Then push closure vars.
1317 (let ((closure (environment-closure env)))
1319 (let ((my-env (node-environment call)))
1320 (dolist (thing (reverse closure))
1323 (output-ref-lambda-var segment thing my-env nil))
1325 (output-ref-nlx-info segment thing my-env)))))
1326 (incf num-args (length closure))))
1328 (let ((info (continuation-info cont)))
1330 (byte-continuation-info-results info)
1332 ;; Emit the op for whatever flavor of call we are using.
1334 (cond ((> num-args 6)
1335 (output-push-int segment num-args)
1339 (multiple-value-bind (opcode ret-vals)
1340 (cond ((node-tail-p call)
1341 (values byte-local-tail-call 0))
1342 ((member results '(0 1))
1343 (values byte-local-call 1))
1345 (values byte-local-multiple-call :unknown)))
1347 (output-byte segment (logior opcode operand))
1348 ;; Emit a reference to the label.
1349 (output-reference segment
1350 (byte-lambda-info-label (lambda-info lambda)))
1351 ;; ### :unknown-return
1352 ;; Fix up the results.
1353 (unless (node-tail-p call)
1354 (checked-canonicalize-values segment cont ret-vals))))))))
1357 (defun generate-byte-code-for-full-call (segment call cont num-args)
1358 (let ((info (basic-combination-info call))
1360 (let ((info (continuation-info cont)))
1362 (byte-continuation-info-results info)
1366 ;; It's an inline function.
1367 (aver (not (node-tail-p call)))
1368 (let* ((type (inline-function-info-type info))
1369 (desired-args (function-type-nargs type))
1372 (values-types (function-type-returns type))))
1373 (leaf (ref-leaf (continuation-use (basic-combination-fun call)))))
1374 (cond ((slot-accessor-p leaf)
1375 (aver (= num-args (1- desired-args)))
1376 (output-push-int segment (dsd-index (slot-accessor-slot leaf))))
1378 (canonicalize-values segment desired-args num-args)))
1380 (output-byte segment (logior byte-inline-function
1381 (inline-function-info-number info)))
1382 ;; ### :known-return
1383 (checked-canonicalize-values segment cont supplied-results)))
1386 (cond ((eq num-args :unknown)
1389 (output-push-int segment num-args)
1393 (when (eq (byte-continuation-info-results
1395 (basic-combination-fun call)))
1397 (setf operand (logior operand byte-named)))
1401 (output-byte segment (logior byte-tail-call operand)))
1403 (multiple-value-bind (opcode ret-vals)
1405 (:unknown (values byte-multiple-call :unknown))
1406 ((0 1) (values byte-call 1))
1407 (t (values byte-multiple-call :unknown)))
1408 (output-byte segment (logior opcode operand))
1409 ;; ### :unknown-return
1410 (checked-canonicalize-values segment cont ret-vals)))))))))
1412 (defun generate-byte-code-for-known-call (segment call cont num-args)
1414 (catch 'give-up-ir1-transform
1415 (funcall (function-info-byte-compile (basic-combination-kind call)) call
1416 (let ((info (continuation-info cont)))
1418 (byte-continuation-info-results info)
1422 (aver (member (byte-continuation-info-results
1424 (basic-combination-fun call)))
1426 (generate-byte-code-for-full-call segment call cont num-args))
1429 (defun generate-byte-code-for-generic-combination (segment call cont)
1430 (declare (type sb!assem:segment segment) (type basic-combination call)
1431 (type continuation cont))
1432 (labels ((examine (args num-fixed)
1435 ;; None of the arugments supply :UNKNOWN values, so
1436 ;; we know exactly how many there are.
1440 (byte-continuation-info-results
1441 (continuation-info (car args)))))
1444 (unless (null (cdr args))
1445 ;; There are (LENGTH ARGS) :UNKNOWN value blocks on
1446 ;; the top of the stack. We need to combine them.
1447 (output-push-int segment (length args))
1448 (output-do-xop segment 'merge-unknown-values))
1449 (unless (zerop num-fixed)
1450 ;; There are num-fixed fixed args above the unknown
1451 ;; values block that want in on the action also.
1452 ;; So add num-fixed to the count.
1453 (output-push-int segment num-fixed)
1454 (output-do-inline-function segment '+))
1457 (examine (cdr args) (+ num-fixed vals)))))))))
1458 (let* ((args (basic-combination-args call))
1459 (kind (basic-combination-kind call))
1460 (num-args (if (and (eq kind :local)
1461 (combination-p call))
1466 (generate-byte-code-for-local-call segment call cont num-args))
1468 (generate-byte-code-for-full-call segment call cont num-args))
1470 (generate-byte-code-for-known-call segment call cont num-args))))))
1472 (defun generate-byte-code-for-basic-combination (segment call cont)
1473 (cond ((and (mv-combination-p call)
1474 (eq (continuation-function-name (basic-combination-fun call))
1476 ;; ### :internal-error
1477 (output-do-xop segment 'throw))
1479 (generate-byte-code-for-generic-combination segment call cont))))
1481 (defun generate-byte-code-for-if (segment if cont)
1482 (declare (type sb!assem:segment segment) (type cif if)
1484 (let* ((next-info (byte-block-info-next (block-info (node-block if))))
1485 (consequent-info (block-info (if-consequent if)))
1486 (alternate-info (block-info (if-alternative if))))
1487 (cond ((eq (byte-continuation-info-results
1488 (continuation-info (if-test if)))
1490 (output-branch segment
1492 (byte-block-info-label consequent-info))
1493 (unless (eq next-info alternate-info)
1494 (output-branch segment
1496 (byte-block-info-label alternate-info))))
1497 ((eq next-info consequent-info)
1498 (output-branch segment
1499 byte-branch-if-false
1500 (byte-block-info-label alternate-info)))
1502 (output-branch segment
1504 (byte-block-info-label consequent-info))
1505 (unless (eq next-info alternate-info)
1506 (output-branch segment
1508 (byte-block-info-label alternate-info)))))))
1510 (defun generate-byte-code-for-return (segment return cont)
1511 (declare (type sb!assem:segment segment) (type creturn return)
1513 (let* ((result (return-result return))
1514 (info (continuation-info result))
1515 (results (byte-continuation-info-results info)))
1516 (cond ((eq results :unknown)
1519 (output-byte-with-operand segment byte-push-int results)
1521 (output-byte segment (logior byte-return results)))
1524 (defun generate-byte-code-for-entry (segment entry cont)
1525 (declare (type sb!assem:segment segment) (type entry entry)
1527 (dolist (exit (entry-exits entry))
1528 (let ((nlx-info (find-nlx-info entry (node-cont exit))))
1530 (let ((kind (cleanup-kind (nlx-info-cleanup nlx-info))))
1531 (when (member kind '(:block :tagbody))
1532 ;; Generate a unique tag.
1533 (output-push-constant
1537 (component-name *component-being-compiled*)))
1538 (output-push-constant segment nil)
1539 (output-do-inline-function segment 'cons)
1540 ;; Save it so people can close over it.
1541 (output-do-xop segment 'dup)
1542 (output-byte-with-operand segment
1544 (byte-nlx-info-stack-slot
1545 (nlx-info-info nlx-info)))
1546 ;; Now do the actual XOP.
1549 (output-do-xop segment 'catch)
1550 (output-reference segment
1551 (byte-nlx-info-label
1552 (nlx-info-info nlx-info))))
1554 (output-do-xop segment 'tagbody)))
1558 (defun generate-byte-code-for-exit (segment exit cont)
1559 (declare (ignore cont))
1560 (let ((nlx-info (find-nlx-info (exit-entry exit) (node-cont exit))))
1561 (output-byte-with-operand segment
1563 (closure-position nlx-info
1564 (node-environment exit)))
1565 (ecase (cleanup-kind (nlx-info-cleanup nlx-info))
1567 ;; ### :internal-error
1568 (output-do-xop segment 'return-from))
1570 ;; ### :internal-error
1571 (output-do-xop segment 'go)
1572 (output-reference segment
1573 (byte-nlx-info-label (nlx-info-info nlx-info)))))))
1575 (defun generate-byte-code (segment component)
1576 (let ((*byte-component-info* (component-info component)))
1577 (do* ((info (byte-block-info-next (block-info (component-head component)))
1579 (block (byte-block-info-block info) (byte-block-info-block info))
1580 (next (byte-block-info-next info) (byte-block-info-next info)))
1581 ((eq block (component-tail component)))
1582 (when (block-interesting block)
1583 (output-label segment (byte-block-info-label info))
1584 (do-nodes (node cont block)
1586 (bind (generate-byte-code-for-bind segment node cont))
1587 (ref (generate-byte-code-for-ref segment node cont))
1588 (cset (generate-byte-code-for-set segment node cont))
1590 (generate-byte-code-for-basic-combination
1592 (cif (generate-byte-code-for-if segment node cont))
1593 (creturn (generate-byte-code-for-return segment node cont))
1594 (entry (generate-byte-code-for-entry segment node cont))
1596 (when (exit-entry node)
1597 (generate-byte-code-for-exit segment node cont)))))
1598 (let* ((succ (block-succ block))
1599 (first-succ (car succ))
1600 (last (block-last block)))
1601 (unless (or (cdr succ)
1602 (eq (byte-block-info-block next) first-succ)
1603 (eq (component-tail component) first-succ)
1604 (and (basic-combination-p last)
1606 ;; Tail local calls that have been
1607 ;; converted to an assignment need the
1609 (not (and (eq (basic-combination-kind last) :local)
1610 (member (functional-kind
1611 (combination-lambda last))
1612 '(:let :assignment))))))
1613 (output-branch segment
1615 (byte-block-info-label
1616 (block-info first-succ))))))))
1619 ;;;; special purpose annotate/compile optimizers
1621 (defoptimizer (eq byte-annotate) ((this that) node)
1622 (declare (ignore this that))
1623 (when (if-p (continuation-dest (node-cont node)))
1624 (annotate-known-call node)
1627 (defoptimizer (eq byte-compile) ((this that) call results num-args segment)
1628 (progn segment) ; ignorable.
1629 ;; We don't have to do anything, because everything is handled by
1630 ;; the IF byte-generator.
1631 (aver (eq results :eq-test))
1632 (aver (eql num-args 2))
1635 (defoptimizer (values byte-compile)
1636 ((&rest values) node results num-args segment)
1637 (canonicalize-values segment results num-args))
1639 (defknown %byte-pop-stack (index) (values))
1641 (defoptimizer (%byte-pop-stack byte-annotate) ((count) node)
1642 (aver (constant-continuation-p count))
1643 (annotate-continuation count 0)
1644 (annotate-continuation (basic-combination-fun node) 0)
1645 (setf (node-tail-p node) nil)
1648 (defoptimizer (%byte-pop-stack byte-compile)
1649 ((count) node results num-args segment)
1650 (aver (and (zerop num-args) (zerop results)))
1651 (output-byte-with-operand segment byte-pop-n (continuation-value count)))
1653 (defoptimizer (%special-bind byte-annotate) ((var value) node)
1654 (annotate-continuation var 0)
1655 (annotate-continuation value 1)
1656 (annotate-continuation (basic-combination-fun node) 0)
1657 (setf (node-tail-p node) nil)
1660 (defoptimizer (%special-bind byte-compile)
1661 ((var value) node results num-args segment)
1662 (aver (and (eql num-args 1) (zerop results)))
1663 (output-push-constant segment (leaf-name (continuation-value var)))
1664 (output-do-inline-function segment '%byte-special-bind))
1666 (defoptimizer (%special-unbind byte-annotate) ((var) node)
1667 (annotate-continuation var 0)
1668 (annotate-continuation (basic-combination-fun node) 0)
1669 (setf (node-tail-p node) nil)
1672 (defoptimizer (%special-unbind byte-compile)
1673 ((var) node results num-args segment)
1674 (aver (and (zerop num-args) (zerop results)))
1675 (output-do-inline-function segment '%byte-special-unbind))
1677 (defoptimizer (%catch byte-annotate) ((nlx-info tag) node)
1678 (annotate-continuation nlx-info 0)
1679 (annotate-continuation tag 1)
1680 (annotate-continuation (basic-combination-fun node) 0)
1681 (setf (node-tail-p node) nil)
1684 (defoptimizer (%catch byte-compile)
1685 ((nlx-info tag) node results num-args segment)
1686 (progn node) ; ignore
1687 (aver (and (= num-args 1) (zerop results)))
1688 (output-do-xop segment 'catch)
1689 (let ((info (nlx-info-info (continuation-value nlx-info))))
1690 (output-reference segment (byte-nlx-info-label info))))
1692 (defoptimizer (%cleanup-point byte-compile) (() node results num-args segment)
1693 (progn node segment) ; ignore
1694 (aver (and (zerop num-args) (zerop results))))
1696 (defoptimizer (%catch-breakup byte-compile) (() node results num-args segment)
1697 (progn node) ; ignore
1698 (aver (and (zerop num-args) (zerop results)))
1699 (output-do-xop segment 'breakup))
1701 (defoptimizer (%lexical-exit-breakup byte-annotate) ((nlx-info) node)
1702 (annotate-continuation nlx-info 0)
1703 (annotate-continuation (basic-combination-fun node) 0)
1704 (setf (node-tail-p node) nil)
1707 (defoptimizer (%lexical-exit-breakup byte-compile)
1708 ((nlx-info) node results num-args segment)
1709 (aver (and (zerop num-args) (zerop results)))
1710 (let ((nlx-info (continuation-value nlx-info)))
1711 (when (ecase (cleanup-kind (nlx-info-cleanup nlx-info))
1713 ;; We only want to do this for the fall-though case.
1714 (not (eq (car (block-pred (node-block node)))
1715 (nlx-info-target nlx-info))))
1717 ;; Only want to do it once per tagbody.
1718 (not (byte-nlx-info-duplicate (nlx-info-info nlx-info)))))
1719 (output-do-xop segment 'breakup))))
1721 (defoptimizer (%nlx-entry byte-annotate) ((nlx-info) node)
1722 (annotate-continuation nlx-info 0)
1723 (annotate-continuation (basic-combination-fun node) 0)
1724 (setf (node-tail-p node) nil)
1727 (defoptimizer (%nlx-entry byte-compile)
1728 ((nlx-info) node results num-args segment)
1729 (progn node results) ; ignore
1730 (aver (eql num-args 0))
1731 (let* ((info (continuation-value nlx-info))
1732 (byte-info (nlx-info-info info)))
1733 (output-label segment (byte-nlx-info-label byte-info))
1734 ;; ### :non-local-entry
1735 (ecase (cleanup-kind (nlx-info-cleanup info))
1737 (checked-canonicalize-values segment
1738 (nlx-info-continuation info)
1740 ((:tagbody :unwind-protect)))))
1742 (defoptimizer (%unwind-protect byte-annotate)
1743 ((nlx-info cleanup-fun) node)
1744 (annotate-continuation nlx-info 0)
1745 (annotate-continuation cleanup-fun 0)
1746 (annotate-continuation (basic-combination-fun node) 0)
1747 (setf (node-tail-p node) nil)
1750 (defoptimizer (%unwind-protect byte-compile)
1751 ((nlx-info cleanup-fun) node results num-args segment)
1752 (aver (and (zerop num-args) (zerop results)))
1753 (output-do-xop segment 'unwind-protect)
1754 (output-reference segment
1755 (byte-nlx-info-label
1757 (continuation-value nlx-info)))))
1759 (defoptimizer (%unwind-protect-breakup byte-compile)
1760 (() node results num-args segment)
1761 (progn node) ; ignore
1762 (aver (and (zerop num-args) (zerop results)))
1763 (output-do-xop segment 'breakup))
1765 (defoptimizer (%continue-unwind byte-annotate) ((a b c) node)
1766 (annotate-continuation a 0)
1767 (annotate-continuation b 0)
1768 (annotate-continuation c 0)
1769 (annotate-continuation (basic-combination-fun node) 0)
1770 (setf (node-tail-p node) nil)
1773 (defoptimizer (%continue-unwind byte-compile)
1774 ((a b c) node results num-args segment)
1775 (progn node) ; ignore
1776 (aver (member results '(0 nil)))
1777 (aver (eql num-args 0))
1778 (output-do-xop segment 'breakup))
1780 (defoptimizer (%load-time-value byte-annotate) ((handle) node)
1781 (annotate-continuation handle 0)
1782 (annotate-continuation (basic-combination-fun node) 0)
1783 (setf (node-tail-p node) nil)
1786 (defoptimizer (%load-time-value byte-compile)
1787 ((handle) node results num-args segment)
1788 (progn node) ; ignore
1789 (aver (zerop num-args))
1790 (output-push-load-time-constant segment :load-time-value
1791 (continuation-value handle))
1792 (canonicalize-values segment results 1))
1794 ;;; Make a byte-function for LAMBDA.
1795 (defun make-xep-for (lambda)
1796 (flet ((entry-point-for (entry)
1797 (let ((info (lambda-info entry)))
1798 (aver (byte-lambda-info-interesting info))
1799 (sb!assem:label-position (byte-lambda-info-label info)))))
1800 (let ((entry (lambda-entry-function lambda)))
1803 (let ((rest-arg-p nil)
1805 (declare (type index num-more))
1806 (collect ((keywords))
1807 (dolist (var (nthcdr (optional-dispatch-max-args entry)
1808 (optional-dispatch-arglist entry)))
1809 (let ((arg-info (lambda-var-arg-info var)))
1811 (ecase (arg-info-kind arg-info)
1813 (aver (not rest-arg-p))
1815 (setf rest-arg-p t))
1817 ;; FIXME: Since ANSI specifies that &KEY arguments
1818 ;; needn't actually be keywords, :KEY would be a
1819 ;; better label for this behavior than :KEYWORD is,
1820 ;; and (KEY-ARGS) would be a better name for the
1821 ;; accumulator than (KEYWORDS) is.
1822 (let ((s-p (arg-info-supplied-p arg-info))
1823 (default (arg-info-default arg-info)))
1824 (incf num-more (if s-p 2 1))
1825 (keywords (list (arg-info-key arg-info)
1826 (if (constantp default)
1829 (if s-p t nil))))))))
1830 (make-hairy-byte-function
1831 :name (leaf-name entry)
1832 :min-args (optional-dispatch-min-args entry)
1833 :max-args (optional-dispatch-max-args entry)
1835 (mapcar #'entry-point-for (optional-dispatch-entry-points entry))
1836 :more-args-entry-point
1837 (entry-point-for (optional-dispatch-main-entry entry))
1838 :num-more-args num-more
1839 :rest-arg-p rest-arg-p
1841 (if (optional-dispatch-keyp entry)
1842 (if (optional-dispatch-allowp entry)
1844 :keywords (keywords)))))
1846 (let ((args (length (lambda-vars entry))))
1847 (make-simple-byte-function
1848 :name (leaf-name entry)
1850 :entry-point (entry-point-for entry))))))))
1852 (defun generate-xeps (component)
1854 (dolist (lambda (component-lambdas component))
1855 (when (member (lambda-kind lambda) '(:external :top-level))
1856 (push (cons lambda (make-xep-for lambda)) xeps)))
1859 ;;;; noise to actually do the compile
1861 (defun assign-locals (component)
1862 ;; Process all of the lambdas in component, and assign stack frame
1863 ;; locations for all the locals.
1864 (dolist (lambda (component-lambdas component))
1865 ;; We don't generate any code for :EXTERNAL lambdas, so we don't
1866 ;; need to allocate stack space. Also, we don't use the ``more''
1867 ;; entry, so we don't need code for it.
1869 ((or (eq (lambda-kind lambda) :external)
1870 (and (eq (lambda-kind lambda) :optional)
1871 (eq (optional-dispatch-more-entry
1872 (lambda-optional-dispatch lambda))
1874 (setf (lambda-info lambda)
1875 (make-byte-lambda-info :interesting nil)))
1877 (let ((num-locals 0))
1878 (let* ((vars (lambda-vars lambda))
1879 (arg-num (+ (length vars)
1880 (length (environment-closure
1881 (lambda-environment lambda))))))
1884 (cond ((or (lambda-var-sets var) (lambda-var-indirect var))
1885 (setf (leaf-info var)
1886 (make-byte-lambda-var-info :offset num-locals))
1889 (setf (leaf-info var)
1890 (make-byte-lambda-var-info :argp t
1891 :offset arg-num))))))
1892 (dolist (let (lambda-lets lambda))
1893 (dolist (var (lambda-vars let))
1894 (setf (leaf-info var)
1895 (make-byte-lambda-var-info :offset num-locals))
1897 (let ((entry-nodes-already-done nil))
1898 (dolist (nlx-info (environment-nlx-info (lambda-environment lambda)))
1899 (ecase (cleanup-kind (nlx-info-cleanup nlx-info))
1901 (setf (nlx-info-info nlx-info)
1902 (make-byte-nlx-info :stack-slot num-locals))
1905 (let* ((entry (cleanup-mess-up (nlx-info-cleanup nlx-info)))
1906 (cruft (assoc entry entry-nodes-already-done)))
1908 (setf (nlx-info-info nlx-info)
1909 (make-byte-nlx-info :stack-slot (cdr cruft)
1912 (push (cons entry num-locals) entry-nodes-already-done)
1913 (setf (nlx-info-info nlx-info)
1914 (make-byte-nlx-info :stack-slot num-locals))
1915 (incf num-locals)))))
1916 ((:catch :unwind-protect)
1917 (setf (nlx-info-info nlx-info) (make-byte-nlx-info))))))
1918 (setf (lambda-info lambda)
1919 (make-byte-lambda-info :stack-size num-locals))))))
1923 (defun byte-compile-component (component)
1924 (setf (component-info component) (make-byte-component-info))
1925 (maybe-mumble "ByteAnn ")
1927 ;; Assign offsets for all the locals, and figure out which args can
1928 ;; stay in the argument area and which need to be moved into locals.
1929 (assign-locals component)
1931 ;; Annotate every continuation with information about how we want
1933 (annotate-ir1 component)
1935 ;; Determine what stack values are dead, and emit cleanup code to
1937 (byte-stack-analyze component)
1939 ;; Make sure any newly added blocks have a block-number.
1940 (dfo-as-needed component)
1942 ;; Assign an ordering of the blocks.
1943 (control-analyze component #'make-byte-block-info)
1945 ;; Find the start labels for the lambdas.
1946 (dolist (lambda (component-lambdas component))
1947 (let ((info (lambda-info lambda)))
1948 (when (byte-lambda-info-interesting info)
1949 (setf (byte-lambda-info-label info)
1950 (byte-block-info-label
1951 (block-info (node-block (lambda-bind lambda))))))))
1953 ;; Delete any blocks that we are not going to emit from the emit order.
1954 (do-blocks (block component)
1955 (unless (block-interesting block)
1956 (let* ((info (block-info block))
1957 (prev (byte-block-info-prev info))
1958 (next (byte-block-info-next info)))
1959 (setf (byte-block-info-next prev) next)
1960 (setf (byte-block-info-prev next) prev))))
1962 (maybe-mumble "ByteGen ")
1963 (let ((segment nil))
1966 (setf segment (sb!assem:make-segment :name "Byte Output"))
1967 (generate-byte-code segment component)
1968 (let ((code-length (sb!assem:finalize-segment segment))
1969 (xeps (generate-xeps component))
1970 (constants (byte-component-info-constants
1971 (component-info component))))
1972 (when *compiler-trace-output*
1973 (describe-component component *compiler-trace-output*)
1974 (describe-byte-component component xeps segment
1975 *compiler-trace-output*))
1976 (etypecase *compile-object*
1978 (maybe-mumble "FASL")
1979 (fasl-dump-byte-component segment code-length constants xeps
1982 (maybe-mumble "Core")
1983 (make-core-byte-component segment code-length constants xeps
1988 ;;;; extra stuff for debugging
1991 (defun dump-stack-info (component)
1992 (do-blocks (block component)
1993 (when (block-interesting block)
1995 (let ((info (block-info block)))
1999 "start-stack ~S~%consume ~S~%produce ~S~%end-stack ~S~%~
2000 total-consume ~S~%~@[nlx-entries ~S~%~]~@[nlx-entry-p ~S~%~]"
2001 (byte-block-info-start-stack info)
2002 (byte-block-info-consumes info)
2003 (byte-block-info-produces info)
2004 (byte-block-info-end-stack info)
2005 (byte-block-info-total-consumes info)
2006 (byte-block-info-nlx-entries info)
2007 (byte-block-info-nlx-entry-p info)))
2009 (format t "no info~%")))))))