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