src/compiler/byte-comp.lisp

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