src/code/byte-interp.lisp

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