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