src/code/byte-interp.lisp

   1 ;;;; the byte code interpreter
   2
   3 ;;; FIXME: should really be in SB!BYTECODE
   4 (in-package "SB!C")
   5
   6 ;;;; This software is part of the SBCL system. See the README file for
   7 ;;;; more information.
   8 ;;;;
   9 ;;;; This software is derived from the CMU CL system, which was
  10 ;;;; written at Carnegie Mellon University and released into the
  11 ;;;; public domain. The software is in the public domain and is
  12 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  13 ;;;; files for more information.
  14
  15 ;;; We need at least this level of DEBUGness in order for the local
  16 ;;; declaration in WITH-DEBUGGER-INFO to take effect.
  17 ;;;
  18 ;;; FIXME: This will cause source code location information to be
  19 ;;; compiled into the executable, which will probably cause problems
  20 ;;; for users running without the sources and/or without the
  21 ;;; build-the-system readtable.
  22 (declaim (optimize (debug 2)))
  23 \f
  24 ;;; Return a function type approximating the type of a byte-compiled
  25 ;;; function. We really only capture the arg signature.
  26 (defun byte-function-type (x)
  27   (specifier-type
  28    (etypecase x
  29      (simple-byte-function
  30       `(function ,(make-list (simple-byte-function-num-args x)
  31                              :initial-element t)
  32                  *))
  33      (hairy-byte-function
  34       (collect ((res))
  35         (let ((min (hairy-byte-function-min-args x))
  36               (max (hairy-byte-function-max-args x)))
  37           (dotimes (i min) (res t))
  38           (when (> max min)
  39             (res '&optional)
  40             (dotimes (i (- max min))
  41               (res t))))
  42         (when (hairy-byte-function-rest-arg-p x)
  43           (res '&rest t))
  44         (ecase (hairy-byte-function-keywords-p x)
  45           ((t :allow-others)
  46            (res '&key)
  47            (dolist (key (hairy-byte-function-keywords x))
  48                    (res `(,(car key) t)))
  49            (when (eql (hairy-byte-function-keywords-p x) :allow-others)
  50              (res '&allow-other-keys)))
  51           ((nil)))
  52         `(function ,(res) *))))))
  53 \f
  54 ;;;; the 'evaluation stack'
  55 ;;;;
  56 ;;;; (The name dates back to CMU CL, when it was used for the IR1
  57 ;;;; interpreted implementation of EVAL. In SBCL >=0.7.0, it's just
  58 ;;;; the byte interpreter stack.)
  59
  60 (defvar *eval-stack* (make-array 100)) ; will grow as needed
  61
  62 ;;; the index of the next free element of the interpreter's evaluation stack
  63 (defvar *eval-stack-top* 0)
  64
  65 #!-sb-fluid (declaim (inline eval-stack-ref))
  66 (defun eval-stack-ref (offset)
  67   (declare (type stack-pointer offset))
  68   (svref sb!bytecode::*eval-stack* offset))
  69
  70 #!-sb-fluid (declaim (inline (setf eval-stack-ref)))
  71 (defun (setf eval-stack-ref) (new-value offset)
  72   (declare (type stack-pointer offset))
  73   (setf (svref sb!bytecode::*eval-stack* offset) new-value))
  74
  75 (defun push-eval-stack (value)
  76   (let ((len (length (the simple-vector sb!bytecode::*eval-stack*)))
  77         (sp *eval-stack-top*))
  78     (when (= len sp)
  79       (let ((new-stack (make-array (ash len 1))))
  80         (replace new-stack sb!bytecode::*eval-stack* :end1 len :end2 len)
  81         (setf sb!bytecode::*eval-stack* new-stack)))
  82     (setf *eval-stack-top* (1+ sp))
  83     (setf (eval-stack-ref sp) value)))
  84
  85 (defun allocate-eval-stack (amount)
  86   (let* ((len (length (the simple-vector sb!bytecode::*eval-stack*)))
  87          (sp *eval-stack-top*)
  88          (new-sp (+ sp amount)))
  89     (declare (type index sp new-sp))
  90     (when (>= new-sp len)
  91       (let ((new-stack (make-array (ash new-sp 1))))
  92         (replace new-stack sb!bytecode::*eval-stack* :end1 len :end2 len)
  93         (setf sb!bytecode::*eval-stack* new-stack)))
  94     (setf *eval-stack-top* new-sp)
  95     (let ((stack sb!bytecode::*eval-stack*))
  96       (do ((i sp (1+ i))) ; FIXME: Use CL:FILL.
  97           ((= i new-sp))
  98         (setf (svref stack i) '#:uninitialized-eval-stack-element))))
  99   (values))
 100
 101 (defun pop-eval-stack ()
 102   (let* ((new-sp (1- *eval-stack-top*))
 103          (value (eval-stack-ref new-sp)))
 104     (setf *eval-stack-top* new-sp)
 105     value))
 106
 107 (defmacro multiple-value-pop-eval-stack ((&rest vars) &body body)
 108   #+nil (declare (optimize (inhibit-warnings 3)))
 109   (let ((num-vars (length vars))
 110         (index -1)
 111         (new-sp-var (gensym "NEW-SP-"))
 112         (decls nil))
 113     (loop
 114       (unless (and (consp body)
 115                    (consp (car body))
 116                    (eq (caar body) 'declare))
 117         (return))
 118       (push (pop body) decls))
 119     `(let ((,new-sp-var (- *eval-stack-top* ,num-vars)))
 120        (declare (type stack-pointer ,new-sp-var))
 121        (let ,(mapcar #'(lambda (var)
 122                          `(,var (eval-stack-ref
 123                                  (+ ,new-sp-var ,(incf index)))))
 124                      vars)
 125          ,@(nreverse decls)
 126          (setf *eval-stack-top* ,new-sp-var)
 127          ,@body))))
 128
 129 (defun eval-stack-copy (dest src count)
 130   (declare (type stack-pointer dest src count))
 131   (let ((stack *eval-stack*))
 132     (if (< dest src)
 133         (dotimes (i count)
 134           (setf (svref stack dest) (svref stack src))
 135           (incf dest)
 136           (incf src))
 137         (do ((si (1- (+ src count))
 138                  (1- si))
 139              (di (1- (+ dest count))
 140                  (1- di)))
 141             ((< si src))
 142           (declare (fixnum si di))
 143           (setf (svref stack di) (svref stack si)))))
 144   (values))
 145 \f
 146 ;;;; component access magic
 147
 148 #!-sb-fluid (declaim (inline component-ref))
 149 (defun component-ref (component pc)
 150   (declare (type code-component component)
 151            (type pc pc))
 152   (sap-ref-8 (code-instructions component) pc))
 153
 154 #!-sb-fluid (declaim (inline (setf component-ref)))
 155 (defun (setf component-ref) (value component pc)
 156   (declare (type (unsigned-byte 8) value)
 157            (type code-component component)
 158            (type pc pc))
 159   (setf (sap-ref-8 (code-instructions component) pc) value))
 160
 161 #!-sb-fluid (declaim (inline component-ref-signed))
 162 (defun component-ref-signed (component pc)
 163   (let ((byte (component-ref component pc)))
 164     (if (logbitp 7 byte)
 165         (logior (ash -1 8) byte)
 166         byte)))
 167
 168 #!-sb-fluid (declaim (inline component-ref-24))
 169 (defun component-ref-24 (component pc)
 170   (logior (ash (component-ref component pc) 16)
 171           (ash (component-ref component (1+ pc)) 8)
 172           (component-ref component (+ pc 2))))
 173 \f
 174 ;;;; debugging support
 175
 176 ;;; This macro binds three magic variables. When the debugger notices that
 177 ;;; these three variables are bound, it makes a byte-code frame out of the
 178 ;;; supplied information instead of a compiled frame. We set each var in
 179 ;;; addition to binding it so the compiler doens't optimize away the binding.
 180 (defmacro with-debugger-info ((component pc fp) &body body)
 181   `(let ((%byte-interp-component ,component)
 182          (%byte-interp-pc ,pc)
 183          (%byte-interp-fp ,fp))
 184      ;; FIXME: This will cause source code location information to be compiled
 185      ;; into the executable, which will probably cause problems for users
 186      ;; running without the sources and/or without the build-the-system
 187      ;; readtable.
 188      (declare (optimize (debug 3)))
 189      (setf %byte-interp-component %byte-interp-component)
 190      (setf %byte-interp-pc %byte-interp-pc)
 191      (setf %byte-interp-fp %byte-interp-fp)
 192      ,@body))
 193
 194 (defun byte-install-breakpoint (component pc)
 195   (declare (type code-component component)
 196            (type pc pc)
 197            (values (unsigned-byte 8)))
 198   (let ((orig (component-ref component pc)))
 199     (setf (component-ref component pc)
 200           #.(logior byte-xop
 201                     (xop-index-or-lose 'breakpoint)))
 202     orig))
 203
 204 (defun byte-remove-breakpoint (component pc orig)
 205   (declare (type code-component component)
 206            (type pc pc)
 207            (type (unsigned-byte 8) orig)
 208            (values (unsigned-byte 8)))
 209   (setf (component-ref component pc) orig))
 210
 211 (defun byte-skip-breakpoint (component pc fp orig)
 212   (declare (type code-component component)
 213            (type pc pc)
 214            (type stack-pointer fp)
 215            (type (unsigned-byte 8) orig))
 216   (byte-interpret-byte component fp pc orig))
 217 \f
 218 ;;;; system constants
 219
 220 ;;; a table mapping system constant indices to run-time values. We don't
 221 ;;; reference the compiler variable at load time, since the interpreter is
 222 ;;; loaded first.
 223 (defparameter *system-constants*
 224   (let ((res (make-array 256)))
 225     (dolist (x '#.(collect ((res))
 226                     (dohash (key value *system-constant-codes*)
 227                       (res (cons key value)))
 228                     (res)))
 229       (let ((key (car x))
 230             (value (cdr x)))
 231         (setf (svref res value)
 232               (if (and (consp key) (eq (car key) '%fdefinition-marker%))
 233                   (fdefinition-object (cdr key) t)
 234                   key))))
 235     res))
 236 \f
 237 ;;;; byte compiled function constructors/extractors
 238
 239 (defun initialize-byte-compiled-function (xep)
 240   (declare (type byte-function xep))
 241   (push xep (code-header-ref (byte-function-component xep)
 242                              sb!vm:code-trace-table-offset-slot))
 243   (setf (funcallable-instance-function xep)
 244         #'(instance-lambda (&more context count)
 245             (let ((old-sp *eval-stack-top*))
 246               (declare (type stack-pointer old-sp))
 247               (dotimes (i count)
 248                 (push-eval-stack (%more-arg context i)))
 249               (invoke-xep nil 0 old-sp 0 count xep))))
 250   xep)
 251
 252 (defun make-byte-compiled-closure (xep closure-vars)
 253   (declare (type byte-function xep)
 254            (type simple-vector closure-vars))
 255   (let ((res (make-byte-closure xep closure-vars)))
 256     (setf (funcallable-instance-function res)
 257           #'(instance-lambda (&more context count)
 258               (let ((old-sp *eval-stack-top*))
 259                 (declare (type stack-pointer old-sp))
 260                 (dotimes (i count)
 261                   (push-eval-stack (%more-arg context i)))
 262                 (invoke-xep nil 0 old-sp 0 count
 263                             (byte-closure-function res)
 264                             (byte-closure-data res)))))
 265     res))
 266 \f
 267 ;;;; INLINEs
 268
 269 ;;; (The idea here seems to be to make sure it's at least 100,
 270 ;;; in order to be able to compile the 32+ inline functions
 271 ;;; in EXPAND-INTO-INLINES as intended. -- WHN 19991206)
 272 (eval-when (:compile-toplevel :execute)
 273   (setq sb!ext:*inline-expansion-limit* 100))
 274
 275 ;;; FIXME: This doesn't seem to be needed in the target Lisp, only
 276 ;;; at build-the-system time.
 277 ;;;
 278 ;;; KLUDGE: This expands into code like
 279 ;;; (IF (ZEROP (LOGAND BYTE 16))
 280 ;;;     (IF (ZEROP (LOGAND BYTE 8))
 281 ;;;      (IF (ZEROP (LOGAND BYTE 4))
 282 ;;;          (IF (ZEROP (LOGAND BYTE 2))
 283 ;;;              (IF (ZEROP (LOGAND BYTE 1))
 284 ;;;                  (ERROR "Unknown inline function, id=~D" 0)
 285 ;;;                  (ERROR "Unknown inline function, id=~D" 1))
 286 ;;;              (IF (ZEROP (LOGAND BYTE 1))
 287 ;;;                  (ERROR "Unknown inline function, id=~D" 2)
 288 ;;;                  (ERROR "Unknown inline function, id=~D" 3)))
 289 ;;;          (IF (ZEROP (LOGAND BYTE 2))
 290 ;;;      ..) ..) ..)
 291 ;;; That's probably more efficient than doing a function call (even a
 292 ;;; local function call) for every byte interpreted, but I doubt it's
 293 ;;; as fast as doing a jump through a table of sixteen addresses.
 294 ;;; Perhaps it would be good to recode this as a straightforward
 295 ;;; CASE statement and redirect the cleverness previously devoted to
 296 ;;; this code to an optimizer for CASE which is smart enough to
 297 ;;; implement suitable code as jump tables.
 298 (defmacro expand-into-inlines ()
 299   #+nil (declare (optimize (inhibit-warnings 3)))
 300   (named-let build-dispatch ((bit 4)
 301                              (base 0))
 302     (if (minusp bit)
 303         (let ((info (svref *inline-functions* base)))
 304           (if info
 305               (let* ((spec (type-specifier
 306                             (inline-function-info-type info)))
 307                      (arg-types (second spec))
 308                      (result-type (third spec))
 309                      (args (make-gensym-list (length arg-types)))
 310                      (func
 311                       `(the ,result-type
 312                             (,(inline-function-info-interpreter-function info)
 313                              ,@args))))
 314                 `(multiple-value-pop-eval-stack ,args
 315                    (declare ,@(mapcar #'(lambda (type var)
 316                                           `(type ,type ,var))
 317                                       arg-types args))
 318                    ,(if (and (consp result-type)
 319                              (eq (car result-type) 'values))
 320                         (let ((results (make-gensym-list
 321                                         (length (cdr result-type)))))
 322                           `(multiple-value-bind ,results ,func
 323                              ,@(mapcar #'(lambda (res)
 324                                            `(push-eval-stack ,res))
 325                                        results)))
 326                         `(push-eval-stack ,func))))
 327               `(error "unknown inline function, id=~D" ,base)))
 328         `(if (zerop (logand byte ,(ash 1 bit)))
 329              ,(build-dispatch (1- bit) base)
 330              ,(build-dispatch (1- bit) (+ base (ash 1 bit)))))))
 331
 332 #!-sb-fluid (declaim (inline value-cell-setf))
 333 (defun value-cell-setf (value cell)
 334   (value-cell-set cell value)
 335   value)
 336
 337 #!-sb-fluid (declaim (inline setf-symbol-value))
 338 (defun setf-symbol-value (value symbol)
 339   (setf (symbol-value symbol) value))
 340
 341 #!-sb-fluid (declaim (inline %setf-instance-ref))
 342 (defun %setf-instance-ref (new-value instance index)
 343   (setf (%instance-ref instance index) new-value))
 344
 345 (eval-when (:compile-toplevel)
 346
 347 (sb!xc:defmacro %byte-symbol-value (x)
 348   `(let ((x ,x))
 349      (unless (boundp x)
 350        (with-debugger-info (component pc fp)
 351          (error "unbound variable: ~S" x)))
 352      (symbol-value x)))
 353
 354 (sb!xc:defmacro %byte-car (x)
 355   `(let ((x ,x))
 356      (unless (listp x)
 357        (with-debugger-info (component pc fp)
 358          (error 'simple-type-error :item x :expected-type 'list
 359                 :format-control "non-list argument to CAR: ~S"
 360                 :format-arguments (list x))))
 361      (car x)))
 362
 363 (sb!xc:defmacro %byte-cdr (x)
 364   `(let ((x ,x))
 365      (unless (listp x)
 366        (with-debugger-info (component pc fp)
 367          (error 'simple-type-error :item x :expected-type 'list
 368                 :format-control "non-list argument to CDR: ~S"
 369                 :format-arguments (list x))))
 370      (cdr x)))
 371
 372 ) ; EVAL-WHEN
 373
 374 #!-sb-fluid (declaim (inline %byte-special-bind))
 375 (defun %byte-special-bind (value symbol)
 376   (sb!sys:%primitive bind value symbol)
 377   (values))
 378
 379 #!-sb-fluid (declaim (inline %byte-special-unbind))
 380 (defun %byte-special-unbind ()
 381   (sb!sys:%primitive unbind)
 382   (values))
 383 \f
 384 ;;;; two-arg function stubs
 385 ;;;;
 386 ;;;; We have two-arg versions of some n-ary functions that are normally
 387 ;;;; open-coded.
 388
 389 (defun two-arg-char= (x y) (char= x y))
 390 (defun two-arg-char< (x y) (char< x y))
 391 (defun two-arg-char> (x y) (char> x y))
 392 (defun two-arg-char-equal (x y) (char-equal x y))
 393 (defun two-arg-char-lessp (x y) (char-lessp x y))
 394 (defun two-arg-char-greaterp (x y) (char-greaterp x y))
 395 (defun two-arg-string= (x y) (string= x y))
 396 (defun two-arg-string< (x y) (string= x y))
 397 (defun two-arg-string> (x y) (string= x y))
 398 \f
 399 ;;;; funny functions
 400
 401 ;;; (used both by the byte interpreter and by the IR1 interpreter)
 402 (defun %progv (vars vals fun)
 403   (progv vars vals
 404     (funcall fun)))
 405 \f
 406 ;;;; XOPs
 407
 408 ;;; Extension operations (XOPs) are various magic things that the byte
 409 ;;; interpreter needs to do, but can't be represented as a function call.
 410 ;;; When the byte interpreter encounters an XOP in the byte stream, it
 411 ;;; tail-calls the corresponding XOP routine extracted from *byte-xops*.
 412 ;;; The XOP routine can do whatever it wants, probably re-invoking the
 413 ;;; byte interpreter.
 414
 415 ;;; Fetch an 8/24 bit operand out of the code stream.
 416 (eval-when (:compile-toplevel :execute)
 417   (sb!xc:defmacro with-extended-operand ((component pc operand new-pc)
 418                                          &body body)
 419     (once-only ((n-component component)
 420                 (n-pc pc))
 421       `(multiple-value-bind (,operand ,new-pc)
 422            (let ((,operand (component-ref ,n-component ,n-pc)))
 423              (if (= ,operand #xff)
 424                  (values (component-ref-24 ,n-component (1+ ,n-pc))
 425                          (+ ,n-pc 4))
 426                  (values ,operand (1+ ,n-pc))))
 427          (declare (type index ,operand ,new-pc))
 428          ,@body))))
 429
 430 ;;; If a real XOP hasn't been defined, this gets invoked and signals an
 431 ;;; error. This shouldn't happen in normal operation.
 432 (defun undefined-xop (component old-pc pc fp)
 433   (declare (ignore component old-pc pc fp))
 434   (error "undefined XOP"))
 435
 436 ;;; a simple vector of the XOP functions
 437 (declaim (type (simple-vector 256) *byte-xops*))
 438 (defvar *byte-xops*
 439   (make-array 256 :initial-element #'undefined-xop))
 440
 441 ;;; Define a XOP function and install it in *BYTE-XOPS*.
 442 (eval-when (:compile-toplevel :execute)
 443   (sb!xc:defmacro define-xop (name lambda-list &body body)
 444     (let ((defun-name (symbolicate "BYTE-" name "-XOP")))
 445       `(progn
 446          (defun ,defun-name ,lambda-list
 447            ,@body)
 448          (setf (aref *byte-xops* ,(xop-index-or-lose name)) #',defun-name)
 449          ',defun-name))))
 450
 451 ;;; This is spliced in by the debugger in order to implement breakpoints.
 452 (define-xop breakpoint (component old-pc pc fp)
 453   (declare (type code-component component)
 454            (type pc old-pc)
 455            (ignore pc)
 456            (type stack-pointer fp))
 457   ;; Invoke the debugger.
 458   (with-debugger-info (component old-pc fp)
 459     (sb!di::handle-breakpoint component old-pc fp))
 460   ;; Retry the breakpoint XOP in case it was replaced with the original
 461   ;; displaced byte-code.
 462   (byte-interpret component old-pc fp))
 463
 464 ;;; This just duplicates whatever is on the top of the stack.
 465 (define-xop dup (component old-pc pc fp)
 466   (declare (type code-component component)
 467            (ignore old-pc)
 468            (type pc pc)
 469            (type stack-pointer fp))
 470   (let ((value (eval-stack-ref (1- *eval-stack-top*))))
 471     (push-eval-stack value))
 472   (byte-interpret component pc fp))
 473
 474 (define-xop make-closure (component old-pc pc fp)
 475   (declare (type code-component component)
 476            (ignore old-pc)
 477            (type pc pc)
 478            (type stack-pointer fp))
 479   (let* ((num-closure-vars (pop-eval-stack))
 480          (closure-vars (make-array num-closure-vars)))
 481     (declare (type index num-closure-vars)
 482              (type simple-vector closure-vars))
 483     (named-let frob ((index (1- num-closure-vars)))
 484       (unless (minusp index)
 485         (setf (svref closure-vars index) (pop-eval-stack))
 486         (frob (1- index))))
 487     (push-eval-stack (make-byte-compiled-closure (pop-eval-stack)
 488                                                  closure-vars)))
 489   (byte-interpret component pc fp))
 490
 491 (define-xop merge-unknown-values (component old-pc pc fp)
 492   (declare (type code-component component)
 493            (ignore old-pc)
 494            (type pc pc)
 495            (type stack-pointer fp))
 496   (labels ((grovel (remaining-blocks block-count-ptr)
 497              (declare (type index remaining-blocks)
 498                       (type stack-pointer block-count-ptr))
 499              (declare (values index stack-pointer))
 500              (let ((block-count (eval-stack-ref block-count-ptr)))
 501                (declare (type index block-count))
 502                (if (= remaining-blocks 1)
 503                    (values block-count block-count-ptr)
 504                    (let ((src (- block-count-ptr block-count)))
 505                      (declare (type index src))
 506                      (multiple-value-bind (values-above dst)
 507                          (grovel (1- remaining-blocks) (1- src))
 508                        (eval-stack-copy dst src block-count)
 509                        (values (+ values-above block-count)
 510                                (+ dst block-count))))))))
 511     (multiple-value-bind (total-count end-ptr)
 512         (grovel (pop-eval-stack) (1- *eval-stack-top*))
 513       (setf (eval-stack-ref end-ptr) total-count)
 514       (setf *eval-stack-top* (1+ end-ptr))))
 515   (byte-interpret component pc fp))
 516
 517 (define-xop default-unknown-values (component old-pc pc fp)
 518   (declare (type code-component component)
 519            (ignore old-pc)
 520            (type pc pc)
 521            (type stack-pointer fp))
 522   (let* ((desired (pop-eval-stack))
 523          (supplied (pop-eval-stack))
 524          (delta (- desired supplied)))
 525     (declare (type index desired supplied)
 526              (type fixnum delta))
 527     (cond ((minusp delta)
 528            (incf *eval-stack-top* delta))
 529           ((plusp delta)
 530            (dotimes (i delta)
 531              (push-eval-stack nil)))))
 532   (byte-interpret component pc fp))
 533
 534 ;;; %THROW is compiled down into this xop. The stack contains the tag, the
 535 ;;; values, and then a count of the values. We special case various small
 536 ;;; numbers of values to keep from consing if we can help it.
 537 ;;;
 538 ;;; Basically, we just extract the values and the tag and then do a throw.
 539 ;;; The native compiler will convert this throw into whatever is necessary
 540 ;;; to throw, so we don't have to duplicate all that cruft.
 541 (define-xop throw (component old-pc pc fp)
 542   (declare (type code-component component)
 543            (type pc old-pc)
 544            (ignore pc)
 545            (type stack-pointer fp))
 546   (let ((num-results (pop-eval-stack)))
 547     (declare (type index num-results))
 548     (case num-results
 549       (0
 550        (let ((tag (pop-eval-stack)))
 551          (with-debugger-info (component old-pc fp)
 552            (throw tag (values)))))
 553       (1
 554        (multiple-value-pop-eval-stack
 555            (tag result)
 556          (with-debugger-info (component old-pc fp)
 557            (throw tag result))))
 558       (2
 559        (multiple-value-pop-eval-stack
 560            (tag result0 result1)
 561          (with-debugger-info (component old-pc fp)
 562            (throw tag (values result0 result1)))))
 563       (t
 564        (let ((results nil))
 565          (dotimes (i num-results)
 566            (push (pop-eval-stack) results))
 567          (let ((tag (pop-eval-stack)))
 568            (with-debugger-info (component old-pc fp)
 569              (throw tag (values-list results)))))))))
 570
 571 ;;; This is used for both CATCHes and BLOCKs that are closed over. We
 572 ;;; establish a catcher for the supplied tag (from the stack top), and
 573 ;;; recursivly enter the byte interpreter. If the byte interpreter exits,
 574 ;;; it must have been because of a BREAKUP (see below), so we branch (by
 575 ;;; tail-calling the byte interpreter) to the pc returned by BREAKUP.
 576 ;;; If we are thrown to, then we branch to the address encoded in the 3 bytes
 577 ;;; following the catch XOP.
 578 (define-xop catch (component old-pc pc fp)
 579   (declare (type code-component component)
 580            (ignore old-pc)
 581            (type pc pc)
 582            (type stack-pointer fp))
 583   (let ((new-pc (block nil
 584                   (let ((results
 585                          (multiple-value-list
 586                           (catch (pop-eval-stack)
 587                             (return (byte-interpret component (+ pc 3) fp))))))
 588                     (let ((num-results 0))
 589                       (declare (type index num-results))
 590                       (dolist (result results)
 591                         (push-eval-stack result)
 592                         (incf num-results))
 593                       (push-eval-stack num-results))
 594                     (component-ref-24 component pc)))))
 595     (byte-interpret component new-pc fp)))
 596
 597 ;;; Blow out of the dynamically nested CATCH or TAGBODY. We just return the
 598 ;;; pc following the BREAKUP XOP and the drop-through code in CATCH or
 599 ;;; TAGBODY will do the correct thing.
 600 (define-xop breakup (component old-pc pc fp)
 601   (declare (ignore component old-pc fp)
 602            (type pc pc))
 603   pc)
 604
 605 ;;; This is exactly like THROW, except that the tag is the last thing
 606 ;;; on the stack instead of the first. This is used for RETURN-FROM
 607 ;;; (hence the name).
 608 (define-xop return-from (component old-pc pc fp)
 609   (declare (type code-component component)
 610            (type pc old-pc)
 611            (ignore pc)
 612            (type stack-pointer fp))
 613   (let ((tag (pop-eval-stack))
 614         (num-results (pop-eval-stack)))
 615     (declare (type index num-results))
 616     (case num-results
 617       (0
 618        (with-debugger-info (component old-pc fp)
 619          (throw tag (values))))
 620       (1
 621        (let ((value (pop-eval-stack)))
 622          (with-debugger-info (component old-pc fp)
 623            (throw tag value))))
 624       (2
 625        (multiple-value-pop-eval-stack
 626            (result0 result1)
 627          (with-debugger-info (component old-pc fp)
 628            (throw tag (values result0 result1)))))
 629       (t
 630        (let ((results nil))
 631          (dotimes (i num-results)
 632            (push (pop-eval-stack) results))
 633          (with-debugger-info (component old-pc fp)
 634            (throw tag (values-list results))))))))
 635
 636 ;;; Similar to CATCH, except for TAGBODY. One significant difference is that
 637 ;;; when thrown to, we don't want to leave the dynamic extent of the tagbody
 638 ;;; so we loop around and re-enter the catcher. We keep looping until BREAKUP
 639 ;;; is used to blow out. When that happens, we just branch to the pc supplied
 640 ;;; by BREAKUP.
 641 (define-xop tagbody (component old-pc pc fp)
 642   (declare (type code-component component)
 643            (ignore old-pc)
 644            (type pc pc)
 645            (type stack-pointer fp))
 646   (let* ((tag (pop-eval-stack))
 647          (new-pc (block nil
 648                    (loop
 649                      (setf pc
 650                            (catch tag
 651                              (return (byte-interpret component pc fp))))))))
 652     (byte-interpret component new-pc fp)))
 653
 654 ;;; Yup, you guessed it. This XOP implements GO. There are no values to
 655 ;;; pass, so we don't have to mess with them, and multiple exits can all be
 656 ;;; using the same tag so we have to pass the pc we want to go to.
 657 (define-xop go (component old-pc pc fp)
 658   (declare (type code-component component)
 659            (type pc old-pc pc)
 660            (type stack-pointer fp))
 661   (let ((tag (pop-eval-stack))
 662         (new-pc (component-ref-24 component pc)))
 663     (with-debugger-info (component old-pc fp)
 664       (throw tag new-pc))))
 665
 666 ;;; UNWIND-PROTECTs are handled significantly different in the byte
 667 ;;; compiler and the native compiler. Basically, we just use the
 668 ;;; native compiler's UNWIND-PROTECT, and let it worry about
 669 ;;; continuing the unwind.
 670 (define-xop unwind-protect (component old-pc pc fp)
 671   (declare (type code-component component)
 672            (ignore old-pc)
 673            (type pc pc)
 674            (type stack-pointer fp))
 675   (let ((new-pc nil))
 676     (unwind-protect
 677         (setf new-pc (byte-interpret component (+ pc 3) fp))
 678       (unless new-pc
 679         ;; The cleanup function expects 3 values to be one the stack, so
 680         ;; we have to put something there.
 681         (push-eval-stack nil)
 682         (push-eval-stack nil)
 683         (push-eval-stack nil)
 684         ;; Now run the cleanup code.
 685         (byte-interpret component (component-ref-24 component pc) fp)))
 686     (byte-interpret component new-pc fp)))
 687
 688 (define-xop fdefn-function-or-lose (component old-pc pc fp)
 689   (let* ((fdefn (pop-eval-stack))
 690          (fun (fdefn-function fdefn)))
 691     (declare (type fdefn fdefn))
 692     (cond (fun
 693            (push-eval-stack fun)
 694            (byte-interpret component pc fp))
 695           (t
 696            (with-debugger-info (component old-pc fp)
 697              (error 'undefined-function :name (fdefn-name fdefn)))))))
 698
 699 ;;; This is used to insert placeholder arguments for unused arguments
 700 ;;; to local calls.
 701 (define-xop push-n-under (component old-pc pc fp)
 702   (declare (ignore old-pc))
 703   (with-extended-operand (component pc howmany new-pc)
 704     (let ((val (pop-eval-stack)))
 705       (allocate-eval-stack howmany)
 706       (push-eval-stack val))
 707     (byte-interpret component new-pc fp)))
 708 \f
 709 ;;;; type checking
 710
 711 ;;; These two hashtables map between type specifiers and type
 712 ;;; predicate functions that test those types. They are initialized
 713 ;;; according to the standard type predicates of the target system.
 714 (defvar *byte-type-predicates* (make-hash-table :test 'equal))
 715 (defvar *byte-predicate-types* (make-hash-table :test 'eq))
 716
 717 (loop for (type predicate) in
 718           '#.(loop for (type . predicate) in
 719                    *backend-type-predicates*
 720                collect `(,(type-specifier type) ,predicate))
 721       do
 722   (let ((fun (fdefinition predicate)))
 723     (setf (gethash type *byte-type-predicates*) fun)
 724     (setf (gethash fun *byte-predicate-types*) type)))
 725
 726 ;;; This is called by the loader to convert a type specifier into a
 727 ;;; type predicate (as used by the TYPE-CHECK XOP.) If it is a
 728 ;;; structure type with a predicate or has a predefined predicate,
 729 ;;; then return the predicate function, otherwise return the CTYPE
 730 ;;; structure for the type.
 731 (defun load-type-predicate (desc)
 732   (or (gethash desc *byte-type-predicates*)
 733       (let ((type (specifier-type desc)))
 734         (if (typep type 'structure-class)
 735             (let ((info (layout-info (class-layout type))))
 736               (if (and info (eq (dd-type info) 'structure))
 737                   (let ((predicate-name (dd-predicate-name info)))
 738                     (if (and predicate-name (fboundp predicate-name))
 739                         (fdefinition predicate-name)
 740                         type))
 741                   type))
 742             type))))
 743
 744 ;;; Check the type of the value on the top of the stack. The type is
 745 ;;; designated by an entry in the constants. If the value is a
 746 ;;; function, then it is called as a type predicate. Otherwise, the
 747 ;;; value is a CTYPE object, and we call %TYPEP on it.
 748 (define-xop type-check (component old-pc pc fp)
 749   (declare (type code-component component)
 750            (type pc old-pc pc)
 751            (type stack-pointer fp))
 752   (with-extended-operand (component pc operand new-pc)
 753     (let ((value (eval-stack-ref (1- *eval-stack-top*)))
 754           (type (code-header-ref component
 755                                  (+ operand sb!vm:code-constants-offset))))
 756       (unless (if (functionp type)
 757                   (funcall type value)
 758                   (%typep value type))
 759         (with-debugger-info (component old-pc fp)
 760           (error 'type-error
 761                  :datum value
 762                  :expected-type (if (functionp type)
 763                                     (gethash type *byte-predicate-types*)
 764                                     (type-specifier type))))))
 765
 766     (byte-interpret component new-pc fp)))
 767 \f
 768 ;;;; the actual byte-interpreter
 769
 770 ;;; The various operations are encoded as follows.
 771 ;;;
 772 ;;; 0000xxxx push-local op
 773 ;;; 0001xxxx push-arg op   [push-local, but negative]
 774 ;;; 0010xxxx push-constant op
 775 ;;; 0011xxxx push-system-constant op
 776 ;;; 0100xxxx push-int op
 777 ;;; 0101xxxx push-neg-int op
 778 ;;; 0110xxxx pop-local op
 779 ;;; 0111xxxx pop-n op
 780 ;;; 1000nxxx call op
 781 ;;; 1001nxxx tail-call op
 782 ;;; 1010nxxx multiple-call op
 783 ;;; 10110xxx local-call
 784 ;;; 10111xxx local-tail-call
 785 ;;; 11000xxx local-multiple-call
 786 ;;; 11001xxx return
 787 ;;; 1101000r branch
 788 ;;; 1101001r if-true
 789 ;;; 1101010r if-false
 790 ;;; 1101011r if-eq
 791 ;;; 11011xxx Xop
 792 ;;; 11100000
 793 ;;;    to    various inline functions.
 794 ;;; 11111111
 795 ;;;
 796 ;;; This encoding is rather hard wired into BYTE-INTERPRET due to the
 797 ;;; binary dispatch tree.
 798
 799 (defvar *byte-trace* nil)
 800
 801 ;;; the main entry point to the byte interpreter
 802 (defun byte-interpret (component pc fp)
 803   (declare (type code-component component)
 804            (type pc pc)
 805            (type stack-pointer fp))
 806   (byte-interpret-byte component pc fp (component-ref component pc)))
 807
 808 ;;; This is separated from BYTE-INTERPRET in order to let us continue
 809 ;;; from a breakpoint without having to replace the breakpoint with
 810 ;;; the original instruction and arrange to somehow put the breakpoint
 811 ;;; back after executing the instruction. We just leave the breakpoint
 812 ;;; there, and call this function with the byte that the breakpoint
 813 ;;; displaced.
 814 (defun byte-interpret-byte (component pc fp byte)
 815   (declare (type code-component component)
 816            (type pc pc)
 817            (type stack-pointer fp)
 818            (type (unsigned-byte 8) byte))
 819   (locally
 820     #+nil (declare (optimize (inhibit-warnings 3)))
 821     (when *byte-trace*
 822       (let ((*byte-trace* nil))
 823         (format *trace-output*
 824                 "pc=~D, fp=~D, sp=~D, byte=#b~,'0X, frame:~%    ~S~%"
 825                 pc fp *eval-stack-top* byte
 826                 (subseq sb!bytecode::*eval-stack* fp *eval-stack-top*)))))
 827   (if (zerop (logand byte #x80))
 828       ;; Some stack operation. No matter what, we need the operand,
 829       ;; so compute it.
 830       (multiple-value-bind (operand new-pc)
 831           (let ((operand (logand byte #xf)))
 832             (if (= operand #xf)
 833                 (let ((operand (component-ref component (1+ pc))))
 834                   (if (= operand #xff)
 835                       (values (component-ref-24 component (+ pc 2))
 836                               (+ pc 5))
 837                       (values operand (+ pc 2))))
 838                 (values operand (1+ pc))))
 839         (if (zerop (logand byte #x40))
 840             (push-eval-stack (if (zerop (logand byte #x20))
 841                                  (if (zerop (logand byte #x10))
 842                                      (eval-stack-ref (+ fp operand))
 843                                      (eval-stack-ref (- fp operand 5)))
 844                                  (if (zerop (logand byte #x10))
 845                                      (code-header-ref
 846                                       component
 847                                       (+ operand sb!vm:code-constants-offset))
 848                                      (svref *system-constants* operand))))
 849             (if (zerop (logand byte #x20))
 850                 (push-eval-stack (if (zerop (logand byte #x10))
 851                                      operand
 852                                      (- (1+ operand))))
 853                 (if (zerop (logand byte #x10))
 854                     (setf (eval-stack-ref (+ fp operand)) (pop-eval-stack))
 855                     (if (zerop operand)
 856                         (let ((operand (pop-eval-stack)))
 857                           (declare (type index operand))
 858                           (decf *eval-stack-top* operand))
 859                         (decf *eval-stack-top* operand)))))
 860         (byte-interpret component new-pc fp))
 861       (if (zerop (logand byte #x40))
 862           ;; Some kind of call.
 863           (let ((args (let ((args (logand byte #x07)))
 864                         (if (= args #x07)
 865                             (pop-eval-stack)
 866                             args))))
 867             (if (zerop (logand byte #x20))
 868                 (let ((named (not (zerop (logand byte #x08)))))
 869                   (if (zerop (logand byte #x10))
 870                       ;; Call for single value.
 871                       (do-call component pc (1+ pc) fp args named)
 872                       ;; Tail call.
 873                       (do-tail-call component pc fp args named)))
 874                 (if (zerop (logand byte #x10))
 875                     ;; Call for multiple-values.
 876                     (do-call component pc (- (1+ pc)) fp args
 877                              (not (zerop (logand byte #x08))))
 878                     (if (zerop (logand byte #x08))
 879                         ;; Local call
 880                         (do-local-call component pc (+ pc 4) fp args)
 881                         ;; Local tail-call
 882                         (do-tail-local-call component pc fp args)))))
 883           (if (zerop (logand byte #x20))
 884               ;; local-multiple-call, Return, branch, or Xop.
 885               (if (zerop (logand byte #x10))
 886                   ;; local-multiple-call or return.
 887                   (if (zerop (logand byte #x08))
 888                       ;; Local-multiple-call.
 889                       (do-local-call component pc (- (+ pc 4)) fp
 890                                      (let ((args (logand byte #x07)))
 891                                        (if (= args #x07)
 892                                            (pop-eval-stack)
 893                                            args)))
 894                       ;; Return.
 895                       (let ((num-results
 896                              (let ((num-results (logand byte #x7)))
 897                                (if (= num-results 7)
 898                                    (pop-eval-stack)
 899                                    num-results))))
 900                         (do-return fp num-results)))
 901                   ;; Branch or Xop.
 902                   (if (zerop (logand byte #x08))
 903                       ;; Branch.
 904                       (if (if (zerop (logand byte #x04))
 905                               (if (zerop (logand byte #x02))
 906                                   t
 907                                   (pop-eval-stack))
 908                               (if (zerop (logand byte #x02))
 909                                   (not (pop-eval-stack))
 910                                   (multiple-value-pop-eval-stack
 911                                    (val1 val2)
 912                                    (eq val1 val2))))
 913                           ;; Branch taken.
 914                           (byte-interpret
 915                            component
 916                            (if (zerop (logand byte #x01))
 917                                (component-ref-24 component (1+ pc))
 918                                (+ pc 2
 919                                   (component-ref-signed component (1+ pc))))
 920                            fp)
 921                           ;; Branch not taken.
 922                           (byte-interpret component
 923                                           (if (zerop (logand byte #x01))
 924                                               (+ pc 4)
 925                                               (+ pc 2))
 926                                           fp))
 927                       ;; Xop.
 928                       (multiple-value-bind (sub-code new-pc)
 929                           (let ((operand (logand byte #x7)))
 930                             (if (= operand #x7)
 931                                 (values (component-ref component (+ pc 1))
 932                                         (+ pc 2))
 933                                 (values operand (1+ pc))))
 934                         (funcall (the function (svref *byte-xops* sub-code))
 935                                  component pc new-pc fp))))
 936               ;; some miscellaneous inline function
 937               (progn
 938                 (expand-into-inlines)
 939                 (byte-interpret component (1+ pc) fp))))))
 940
 941 (defun do-local-call (component pc old-pc old-fp num-args)
 942   (declare (type pc pc)
 943            (type return-pc old-pc)
 944            (type stack-pointer old-fp)
 945            (type (integer 0 #.call-arguments-limit) num-args))
 946   (invoke-local-entry-point component (component-ref-24 component (1+ pc))
 947                             component old-pc
 948                             (- *eval-stack-top* num-args)
 949                             old-fp))
 950
 951 (defun do-tail-local-call (component pc fp num-args)
 952   (declare (type code-component component) (type pc pc)
 953            (type stack-pointer fp)
 954            (type index num-args))
 955   (let ((old-fp (eval-stack-ref (- fp 1)))
 956         (old-sp (eval-stack-ref (- fp 2)))
 957         (old-pc (eval-stack-ref (- fp 3)))
 958         (old-component (eval-stack-ref (- fp 4)))
 959         (start-of-args (- *eval-stack-top* num-args)))
 960     (eval-stack-copy old-sp start-of-args num-args)
 961     (setf *eval-stack-top* (+ old-sp num-args))
 962     (invoke-local-entry-point component (component-ref-24 component (1+ pc))
 963                               old-component old-pc old-sp old-fp)))
 964
 965 (defun invoke-local-entry-point (component target old-component old-pc old-sp
 966                                            old-fp &optional closure-vars)
 967   (declare (type pc target)
 968            (type return-pc old-pc)
 969            (type stack-pointer old-sp old-fp)
 970            (type (or null simple-vector) closure-vars))
 971   (when closure-vars
 972     (named-let more ((index (1- (length closure-vars))))
 973       (unless (minusp index)
 974         (push-eval-stack (svref closure-vars index))
 975         (more (1- index)))))
 976   (push-eval-stack old-component)
 977   (push-eval-stack old-pc)
 978   (push-eval-stack old-sp)
 979   (push-eval-stack old-fp)
 980   (multiple-value-bind (stack-frame-size entry-pc)
 981       (let ((byte (component-ref component target)))
 982         (if (= byte 255)
 983             (values (component-ref-24 component (1+ target)) (+ target 4))
 984             (values (* byte 2) (1+ target))))
 985     (declare (type pc entry-pc))
 986     (let ((fp *eval-stack-top*))
 987       (allocate-eval-stack stack-frame-size)
 988       (byte-interpret component entry-pc fp))))
 989
 990 ;;; Call a function with some arguments popped off of the interpreter
 991 ;;; stack, and restore the SP to the specified value.
 992 (defun byte-apply (function num-args restore-sp)
 993   (declare (type function function) (type index num-args))
 994   (let ((start (- *eval-stack-top* num-args)))
 995     (declare (type stack-pointer start))
 996     (macrolet ((frob ()
 997                  `(case num-args
 998                     ,@(loop for n below 8
 999                         collect `(,n (call-1 ,n)))
1000                     (t
1001                      (let ((args ())
1002                            (end (+ start num-args)))
1003                        (declare (type stack-pointer end))
1004                        (do ((i (1- end) (1- i)))
1005                            ((< i start))
1006                          (declare (fixnum i))
1007                          (push (eval-stack-ref i) args))
1008                        (setf *eval-stack-top* restore-sp)
1009                        (apply function args)))))
1010                (call-1 (n)
1011                  (collect ((binds)
1012                            (args))
1013                    (dotimes (i n)
1014                      (let ((dum (gensym)))
1015                        (binds `(,dum (eval-stack-ref (+ start ,i))))
1016                        (args dum)))
1017                    `(let ,(binds)
1018                       (setf *eval-stack-top* restore-sp)
1019                       (funcall function ,@(args))))))
1020       (frob))))
1021
1022 ;;; Note: negative RET-PC is a convention for "we need multiple return
1023 ;;; values".
1024 (defun do-call (old-component call-pc ret-pc old-fp num-args named)
1025   (declare (type code-component old-component)
1026            (type pc call-pc)
1027            (type return-pc ret-pc)
1028            (type stack-pointer old-fp)
1029            (type (integer 0 #.call-arguments-limit) num-args)
1030            (type (member t nil) named))
1031   (let* ((old-sp (- *eval-stack-top* num-args 1))
1032          (fun-or-fdefn (eval-stack-ref old-sp))
1033          (function (if named
1034                        (or (fdefn-function fun-or-fdefn)
1035                            (with-debugger-info (old-component call-pc old-fp)
1036                              (error 'undefined-function
1037                                     :name (fdefn-name fun-or-fdefn))))
1038                        fun-or-fdefn)))
1039     (declare (type stack-pointer old-sp)
1040              (type (or function fdefn) fun-or-fdefn)
1041              (type function function))
1042     (typecase function
1043       (byte-function
1044        (invoke-xep old-component ret-pc old-sp old-fp num-args function))
1045       (byte-closure
1046        (invoke-xep old-component ret-pc old-sp old-fp num-args
1047                    (byte-closure-function function)
1048                    (byte-closure-data function)))
1049       (t
1050        (cond ((minusp ret-pc)
1051               (let* ((ret-pc (- ret-pc))
1052                      (results
1053                       (multiple-value-list
1054                        (with-debugger-info
1055                            (old-component ret-pc old-fp)
1056                          (byte-apply function num-args old-sp)))))
1057                 (dolist (result results)
1058                   (push-eval-stack result))
1059                 (push-eval-stack (length results))
1060                 (byte-interpret old-component ret-pc old-fp)))
1061              (t
1062               (push-eval-stack
1063                (with-debugger-info
1064                    (old-component ret-pc old-fp)
1065                  (byte-apply function num-args old-sp)))
1066               (byte-interpret old-component ret-pc old-fp)))))))
1067
1068 (defun do-tail-call (component pc fp num-args named)
1069   (declare (type code-component component)
1070            (type pc pc)
1071            (type stack-pointer fp)
1072            (type (integer 0 #.call-arguments-limit) num-args)
1073            (type (member t nil) named))
1074   (let* ((start-of-args (- *eval-stack-top* num-args))
1075          (fun-or-fdefn (eval-stack-ref (1- start-of-args)))
1076          (function (if named
1077                        (or (fdefn-function fun-or-fdefn)
1078                            (with-debugger-info (component pc fp)
1079                              (error 'undefined-function
1080                                     :name (fdefn-name fun-or-fdefn))))
1081                        fun-or-fdefn))
1082          (old-fp (eval-stack-ref (- fp 1)))
1083          (old-sp (eval-stack-ref (- fp 2)))
1084          (old-pc (eval-stack-ref (- fp 3)))
1085          (old-component (eval-stack-ref (- fp 4))))
1086     (declare (type stack-pointer old-fp old-sp start-of-args)
1087              (type return-pc old-pc)
1088              (type (or fdefn function) fun-or-fdefn)
1089              (type function function))
1090     (typecase function
1091       (byte-function
1092        (eval-stack-copy old-sp start-of-args num-args)
1093        (setf *eval-stack-top* (+ old-sp num-args))
1094        (invoke-xep old-component old-pc old-sp old-fp num-args function))
1095       (byte-closure
1096        (eval-stack-copy old-sp start-of-args num-args)
1097        (setf *eval-stack-top* (+ old-sp num-args))
1098        (invoke-xep old-component old-pc old-sp old-fp num-args
1099                    (byte-closure-function function)
1100                    (byte-closure-data function)))
1101       (t
1102        ;; We are tail-calling native code.
1103        (cond ((null old-component)
1104               ;; We were called by native code.
1105               (byte-apply function num-args old-sp))
1106              ((minusp old-pc)
1107               ;; We were called for multiple values. So return multiple
1108               ;; values.
1109               (let* ((old-pc (- old-pc))
1110                      (results
1111                       (multiple-value-list
1112                        (with-debugger-info
1113                         (old-component old-pc old-fp)
1114                         (byte-apply function num-args old-sp)))))
1115                 (dolist (result results)
1116                   (push-eval-stack result))
1117                 (push-eval-stack (length results))
1118                 (byte-interpret old-component old-pc old-fp)))
1119              (t
1120               ;; We were called for one value. So return one value.
1121               (push-eval-stack
1122                (with-debugger-info
1123                    (old-component old-pc old-fp)
1124                  (byte-apply function num-args old-sp)))
1125               (byte-interpret old-component old-pc old-fp)))))))
1126
1127 (defvar *byte-trace-calls* nil)
1128
1129 (defun invoke-xep (old-component ret-pc old-sp old-fp num-args xep
1130                                  &optional closure-vars)
1131   (declare (type (or null code-component) old-component)
1132            (type index num-args)
1133            (type return-pc ret-pc)
1134            (type stack-pointer old-sp old-fp)
1135            (type byte-function xep)
1136            (type (or null simple-vector) closure-vars))
1137   ;; FIXME: Perhaps BYTE-TRACE-CALLS stuff should be conditional on SB-SHOW.
1138   (when *byte-trace-calls*
1139     (let ((*byte-trace-calls* nil)
1140           (*byte-trace* nil)
1141           (*print-level* sb!debug:*debug-print-level*)
1142           (*print-length* sb!debug:*debug-print-length*)
1143           (sp *eval-stack-top*))
1144       (format *trace-output*
1145               "~&INVOKE-XEP: ocode= ~S[~D]~%  ~
1146                osp= ~D, ofp= ~D, nargs= ~D, SP= ~D:~%  ~
1147                Fun= ~S ~@[~S~]~%  Args= ~S~%"
1148               old-component ret-pc old-sp old-fp num-args sp
1149               xep closure-vars (subseq *eval-stack* (- sp num-args) sp))
1150       (force-output *trace-output*)))
1151
1152   (let ((entry-point
1153          (cond
1154           ((typep xep 'simple-byte-function)
1155            (unless (eql (simple-byte-function-num-args xep) num-args)
1156              (with-debugger-info (old-component ret-pc old-fp)
1157                (error "wrong number of arguments")))
1158            (simple-byte-function-entry-point xep))
1159           (t
1160            (let ((min (hairy-byte-function-min-args xep))
1161                  (max (hairy-byte-function-max-args xep)))
1162              (cond
1163               ((< num-args min)
1164                (with-debugger-info (old-component ret-pc old-fp)
1165                  (error "not enough arguments")))
1166               ((<= num-args max)
1167                (nth (- num-args min) (hairy-byte-function-entry-points xep)))
1168               ((null (hairy-byte-function-more-args-entry-point xep))
1169                (with-debugger-info (old-component ret-pc old-fp)
1170                  (error "too many arguments")))
1171               (t
1172                (let* ((more-args-supplied (- num-args max))
1173                       (sp *eval-stack-top*)
1174                       (more-args-start (- sp more-args-supplied))
1175                       (restp (hairy-byte-function-rest-arg-p xep))
1176                       (rest (and restp
1177                                  (do ((index (1- sp) (1- index))
1178                                       (result nil
1179                                               (cons (eval-stack-ref index)
1180                                                     result)))
1181                                      ((< index more-args-start) result)
1182                                    (declare (fixnum index))))))
1183                  (declare (type index more-args-supplied)
1184                           (type stack-pointer more-args-start))
1185                  (cond
1186                   ((not (hairy-byte-function-keywords-p xep))
1187                    (aver restp)
1188                    (setf *eval-stack-top* (1+ more-args-start))
1189                    (setf (eval-stack-ref more-args-start) rest))
1190                   (t
1191                    (unless (evenp more-args-supplied)
1192                      (with-debugger-info (old-component ret-pc old-fp)
1193                        (error "odd number of &KEY arguments")))
1194                    ;; If there are &KEY args, then we need to leave
1195                    ;; the defaulted and supplied-p values where the
1196                    ;; more args currently are. There might be more or
1197                    ;; fewer. And also, we need to flatten the parsed
1198                    ;; args with the defaults before we scan the
1199                    ;; keywords. So we copy all the &MORE args to a
1200                    ;; temporary area at the end of the stack.
1201                    (let* ((num-more-args
1202                            (hairy-byte-function-num-more-args xep))
1203                           (new-sp (+ more-args-start num-more-args))
1204                           (temp (max sp new-sp))
1205                           (temp-sp (+ temp more-args-supplied))
1206                           (keywords (hairy-byte-function-keywords xep)))
1207                      (declare (type index temp)
1208                               (type stack-pointer new-sp temp-sp))
1209                      (allocate-eval-stack (- temp-sp sp))
1210                      (eval-stack-copy temp more-args-start more-args-supplied)
1211                      (when restp
1212                        (setf (eval-stack-ref more-args-start) rest)
1213                        (incf more-args-start))
1214                      (let ((index more-args-start))
1215                        (dolist (keyword keywords)
1216                          (setf (eval-stack-ref index) (cadr keyword))
1217                          (incf index)
1218                          (when (caddr keyword)
1219                            (setf (eval-stack-ref index) nil)
1220                            (incf index))))
1221                      (let ((index temp-sp)
1222                            (allow (eq (hairy-byte-function-keywords-p xep)
1223                                       :allow-others))
1224                            (bogus-key nil)
1225                            (bogus-key-p nil))
1226                        (declare (type fixnum index))
1227                        (loop
1228                          (decf index 2)
1229                          (when (< index temp)
1230                            (return))
1231                          (let ((key (eval-stack-ref index))
1232                                (value (eval-stack-ref (1+ index))))
1233                            (if (eq key :allow-other-keys)
1234                                (setf allow value)
1235                                (let ((target more-args-start))
1236                                  (declare (type stack-pointer target))
1237                                  (dolist (keyword keywords
1238                                                   (setf bogus-key key
1239                                                         bogus-key-p t))
1240                                    (cond ((eq (car keyword) key)
1241                                           (setf (eval-stack-ref target) value)
1242                                           (when (caddr keyword)
1243                                             (setf (eval-stack-ref (1+ target))
1244                                                   t))
1245                                           (return))
1246                                          ((caddr keyword)
1247                                           (incf target 2))
1248                                          (t
1249                                           (incf target))))))))
1250                        (when (and bogus-key-p (not allow))
1251                          (with-debugger-info (old-component ret-pc old-fp)
1252                            (error "unknown keyword: ~S" bogus-key))))
1253                      (setf *eval-stack-top* new-sp)))))
1254                (hairy-byte-function-more-args-entry-point xep))))))))
1255     (declare (type pc entry-point))
1256     (invoke-local-entry-point (byte-function-component xep) entry-point
1257                               old-component ret-pc old-sp old-fp
1258                               closure-vars)))
1259
1260 (defun do-return (fp num-results)
1261   (declare (type stack-pointer fp) (type index num-results))
1262   (let ((old-component (eval-stack-ref (- fp 4))))
1263     (typecase old-component
1264       (code-component
1265        ;; returning to more byte-interpreted code
1266        (do-local-return old-component fp num-results))
1267       (null
1268        ;; returning to native code
1269        (let ((old-sp (eval-stack-ref (- fp 2))))
1270          (case num-results
1271            (0
1272             (setf *eval-stack-top* old-sp)
1273             (values))
1274            (1
1275             (let ((result (pop-eval-stack)))
1276               (setf *eval-stack-top* old-sp)
1277               result))
1278            (t
1279             (let ((results nil))
1280               (dotimes (i num-results)
1281                 (push (pop-eval-stack) results))
1282               (setf *eval-stack-top* old-sp)
1283               (values-list results))))))
1284       (t
1285        ;; ### function end breakpoint?
1286        (error "Function-end breakpoints are not supported.")))))
1287
1288 (defun do-local-return (old-component fp num-results)
1289   (declare (type stack-pointer fp) (type index num-results))
1290   (let ((old-fp (eval-stack-ref (- fp 1)))
1291         (old-sp (eval-stack-ref (- fp 2)))
1292         (old-pc (eval-stack-ref (- fp 3))))
1293     (declare (type (signed-byte 25) old-pc))
1294     (if (plusp old-pc)
1295         ;; wants single value
1296         (let ((result (if (zerop num-results)
1297                           nil
1298                           (eval-stack-ref (- *eval-stack-top*
1299                                              num-results)))))
1300           (setf *eval-stack-top* old-sp)
1301           (push-eval-stack result)
1302           (byte-interpret old-component old-pc old-fp))
1303         ;; wants multiple values
1304         (progn
1305           (eval-stack-copy old-sp
1306                            (- *eval-stack-top* num-results)
1307                            num-results)
1308           (setf *eval-stack-top* (+ old-sp num-results))
1309           (push-eval-stack num-results)
1310           (byte-interpret old-component (- old-pc) old-fp)))))
1311