src/code/byte-interp.lisp

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