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