1 ;;;; the byte code interpreter
5 ;;;; This software is part of the SBCL system. See the README file for
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.
14 ;;; We need at least this level of DEBUGness in order for the local
15 ;;; declaration in WITH-DEBUGGER-INFO to take effect.
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)))
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)
29 `(function ,(make-list (simple-byte-function-num-args x)
34 (let ((min (hairy-byte-function-min-args x))
35 (max (hairy-byte-function-max-args x)))
36 (dotimes (i min) (res t))
39 (dotimes (i (- max min))
41 (when (hairy-byte-function-rest-arg-p x)
43 (ecase (hairy-byte-function-keywords-p x)
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)))
51 `(function ,(res) *))))))
53 ;;;; the evaluation stack
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
64 ;;; the index of the next free element of the interpreter's evaluation stack
65 (defvar *eval-stack-top* 0)
67 #!-sb-fluid (declaim (inline eval-stack-ref))
68 (defun eval-stack-ref (offset)
69 (declare (type stack-pointer offset))
70 (svref sb!eval::*eval-stack* offset))
72 #!-sb-fluid (declaim (inline (setf eval-stack-ref)))
73 (defun (setf eval-stack-ref) (new-value offset)
74 (declare (type stack-pointer offset))
75 (setf (svref sb!eval::*eval-stack* offset) new-value))
77 (defun push-eval-stack (value)
78 (let ((len (length (the simple-vector sb!eval::*eval-stack*)))
79 (sp *eval-stack-top*))
81 (let ((new-stack (make-array (ash len 1))))
82 (replace new-stack sb!eval::*eval-stack* :end1 len :end2 len)
83 (setf sb!eval::*eval-stack* new-stack)))
84 (setf *eval-stack-top* (1+ sp))
85 (setf (eval-stack-ref sp) value)))
87 (defun allocate-eval-stack (amount)
88 (let* ((len (length (the simple-vector sb!eval::*eval-stack*)))
90 (new-sp (+ sp amount)))
91 (declare (type index sp new-sp))
93 (let ((new-stack (make-array (ash new-sp 1))))
94 (replace new-stack sb!eval::*eval-stack* :end1 len :end2 len)
95 (setf sb!eval::*eval-stack* new-stack)))
96 (setf *eval-stack-top* new-sp)
97 (let ((stack sb!eval::*eval-stack*))
98 (do ((i sp (1+ i))) ; FIXME: DOTIMES? or just :INITIAL-ELEMENT in MAKE-ARRAY?
100 (setf (svref stack i) '#:uninitialized))))
103 (defun pop-eval-stack ()
104 (let* ((new-sp (1- *eval-stack-top*))
105 (value (eval-stack-ref new-sp)))
106 (setf *eval-stack-top* new-sp)
109 (defmacro multiple-value-pop-eval-stack ((&rest vars) &body body)
110 #+nil (declare (optimize (inhibit-warnings 3)))
111 (let ((num-vars (length vars))
113 (new-sp-var (gensym "NEW-SP-"))
116 (unless (and (consp body)
118 (eq (caar body) 'declare))
120 (push (pop body) decls))
121 `(let ((,new-sp-var (- *eval-stack-top* ,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)))))
128 (setf *eval-stack-top* ,new-sp-var)
131 (defun eval-stack-copy (dest src count)
132 (declare (type stack-pointer dest src count))
133 (let ((stack *eval-stack*))
136 (setf (svref stack dest) (svref stack src))
139 (do ((si (1- (+ src count))
141 (di (1- (+ dest count))
144 (declare (fixnum si di))
145 (setf (svref stack di) (svref stack si)))))
148 ;;;; component access magic
150 #!-sb-fluid (declaim (inline component-ref))
151 (defun component-ref (component pc)
152 (declare (type code-component component)
154 (sap-ref-8 (code-instructions component) pc))
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)
161 (setf (sap-ref-8 (code-instructions component) pc) value))
163 #!-sb-fluid (declaim (inline component-ref-signed))
164 (defun component-ref-signed (component pc)
165 (let ((byte (component-ref component pc)))
167 (logior (ash -1 8) byte)
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))))
176 ;;;; debugging support
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
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)
196 (defun byte-install-breakpoint (component pc)
197 (declare (type code-component component)
199 (values (unsigned-byte 8)))
200 (let ((orig (component-ref component pc)))
201 (setf (component-ref component pc)
203 (xop-index-or-lose 'breakpoint)))
206 (defun byte-remove-breakpoint (component pc orig)
207 (declare (type code-component component)
209 (type (unsigned-byte 8) orig)
210 (values (unsigned-byte 8)))
211 (setf (component-ref component pc) orig))
213 (defun byte-skip-breakpoint (component pc fp orig)
214 (declare (type code-component component)
216 (type stack-pointer fp)
217 (type (unsigned-byte 8) orig))
218 (byte-interpret-byte component fp pc orig))
220 ;;;; system constants
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
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)))
233 (setf (svref res value)
234 (if (and (consp key) (eq (car key) '%fdefinition-marker%))
235 (fdefinition-object (cdr key) t)
239 ;;;; byte compiled function constructors/extractors
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 *eval-stack-top*))
248 (declare (type stack-pointer old-sp))
250 (push-eval-stack (%more-arg context i)))
251 (invoke-xep nil 0 old-sp 0 count xep))))
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 *eval-stack-top*))
261 (declare (type stack-pointer old-sp))
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)))))
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))
277 ;;; FIXME: This doesn't seem to be needed in the target Lisp, only
278 ;;; at build-the-system time.
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))
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)
305 (let ((info (svref *inline-functions* base)))
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)))
314 (,(inline-function-info-interpreter-function info)
316 `(multiple-value-pop-eval-stack ,args
317 (declare ,@(mapcar #'(lambda (type var)
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))
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)))))))
334 #!-sb-fluid (declaim (inline value-cell-setf))
335 (defun value-cell-setf (value cell)
336 (value-cell-set cell value)
339 #!-sb-fluid (declaim (inline setf-symbol-value))
340 (defun setf-symbol-value (value symbol)
341 (setf (symbol-value symbol) value))
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))
347 (eval-when (:compile-toplevel)
349 (sb!xc:defmacro %byte-symbol-value (x)
352 (with-debugger-info (component pc fp)
353 (error "unbound variable: ~S" x)))
356 (sb!xc:defmacro %byte-car (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))))
365 (sb!xc:defmacro %byte-cdr (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))))
376 #!-sb-fluid (declaim (inline %byte-special-bind))
377 (defun %byte-special-bind (value symbol)
378 (sb!sys:%primitive bind value symbol)
381 #!-sb-fluid (declaim (inline %byte-special-unbind))
382 (defun %byte-special-unbind ()
383 (sb!sys:%primitive unbind)
386 ;;;; two-arg function stubs
388 ;;;; We have two-arg versions of some n-ary functions that are normally
391 (defun two-arg-char= (x y) (char= x y))
392 (defun two-arg-char< (x y) (char< x y))
393 (defun two-arg-char> (x y) (char> x y))
394 (defun two-arg-char-equal (x y) (char-equal x y))
395 (defun two-arg-char-lessp (x y) (char-lessp x y))
396 (defun two-arg-char-greaterp (x y) (char-greaterp x y))
397 (defun two-arg-string= (x y) (string= x y))
398 (defun two-arg-string< (x y) (string= x y))
399 (defun two-arg-string> (x y) (string= x y))
401 ;;;; miscellaneous primitive stubs
403 (macrolet ((def-frob (name &optional (args '(x)))
404 `(defun ,name ,args (,name ,@args))))
405 (def-frob %code-code-size)
406 (def-frob %code-debug-info)
407 (def-frob %code-entry-points)
408 (def-frob %funcallable-instance-function)
409 (def-frob %funcallable-instance-layout)
410 (def-frob %funcallable-instance-lexenv)
411 (def-frob %function-next)
412 (def-frob %function-self)
413 (def-frob %set-funcallable-instance-function (fin new-val)))
417 ;;; (used both by the byte interpreter and by the IR1 interpreter)
418 (defun %progv (vars vals fun)
424 ;;; Extension operations (XOPs) are various magic things that the byte
425 ;;; interpreter needs to do, but can't be represented as a function call.
426 ;;; When the byte interpreter encounters an XOP in the byte stream, it
427 ;;; tail-calls the corresponding XOP routine extracted from *byte-xops*.
428 ;;; The XOP routine can do whatever it wants, probably re-invoking the
429 ;;; byte interpreter.
431 ;;; Fetch an 8/24 bit operand out of the code stream.
432 (eval-when (:compile-toplevel :execute)
433 (sb!xc:defmacro with-extended-operand ((component pc operand new-pc)
435 (once-only ((n-component component)
437 `(multiple-value-bind (,operand ,new-pc)
438 (let ((,operand (component-ref ,n-component ,n-pc)))
439 (if (= ,operand #xff)
440 (values (component-ref-24 ,n-component (1+ ,n-pc))
442 (values ,operand (1+ ,n-pc))))
443 (declare (type index ,operand ,new-pc))
446 ;;; If a real XOP hasn't been defined, this gets invoked and signals an
447 ;;; error. This shouldn't happen in normal operation.
448 (defun undefined-xop (component old-pc pc fp)
449 (declare (ignore component old-pc pc fp))
450 (error "undefined XOP"))
452 ;;; a simple vector of the XOP functions
453 (declaim (type (simple-vector 256) *byte-xops*))
455 (make-array 256 :initial-element #'undefined-xop))
457 ;;; Define a XOP function and install it in *BYTE-XOPS*.
458 (eval-when (:compile-toplevel :execute)
459 (sb!xc:defmacro define-xop (name lambda-list &body body)
460 (let ((defun-name (symbolicate "BYTE-" name "-XOP")))
462 (defun ,defun-name ,lambda-list
464 (setf (aref *byte-xops* ,(xop-index-or-lose name)) #',defun-name)
467 ;;; This is spliced in by the debugger in order to implement breakpoints.
468 (define-xop breakpoint (component old-pc pc fp)
469 (declare (type code-component component)
472 (type stack-pointer fp))
473 ;; Invoke the debugger.
474 (with-debugger-info (component old-pc fp)
475 (sb!di::handle-breakpoint component old-pc fp))
476 ;; Retry the breakpoint XOP in case it was replaced with the original
477 ;; displaced byte-code.
478 (byte-interpret component old-pc fp))
480 ;;; This just duplicates whatever is on the top of the stack.
481 (define-xop dup (component old-pc pc fp)
482 (declare (type code-component component)
485 (type stack-pointer fp))
486 (let ((value (eval-stack-ref (1- *eval-stack-top*))))
487 (push-eval-stack value))
488 (byte-interpret component pc fp))
490 (define-xop make-closure (component old-pc pc fp)
491 (declare (type code-component component)
494 (type stack-pointer fp))
495 (let* ((num-closure-vars (pop-eval-stack))
496 (closure-vars (make-array num-closure-vars)))
497 (declare (type index num-closure-vars)
498 (type simple-vector closure-vars))
499 (named-let frob ((index (1- num-closure-vars)))
500 (unless (minusp index)
501 (setf (svref closure-vars index) (pop-eval-stack))
503 (push-eval-stack (make-byte-compiled-closure (pop-eval-stack)
505 (byte-interpret component pc fp))
507 (define-xop merge-unknown-values (component old-pc pc fp)
508 (declare (type code-component component)
511 (type stack-pointer fp))
512 (labels ((grovel (remaining-blocks block-count-ptr)
513 (declare (type index remaining-blocks)
514 (type stack-pointer block-count-ptr))
515 (declare (values index stack-pointer))
516 (let ((block-count (eval-stack-ref block-count-ptr)))
517 (declare (type index block-count))
518 (if (= remaining-blocks 1)
519 (values block-count block-count-ptr)
520 (let ((src (- block-count-ptr block-count)))
521 (declare (type index src))
522 (multiple-value-bind (values-above dst)
523 (grovel (1- remaining-blocks) (1- src))
524 (eval-stack-copy dst src block-count)
525 (values (+ values-above block-count)
526 (+ dst block-count))))))))
527 (multiple-value-bind (total-count end-ptr)
528 (grovel (pop-eval-stack) (1- *eval-stack-top*))
529 (setf (eval-stack-ref end-ptr) total-count)
530 (setf *eval-stack-top* (1+ end-ptr))))
531 (byte-interpret component pc fp))
533 (define-xop default-unknown-values (component old-pc pc fp)
534 (declare (type code-component component)
537 (type stack-pointer fp))
538 (let* ((desired (pop-eval-stack))
539 (supplied (pop-eval-stack))
540 (delta (- desired supplied)))
541 (declare (type index desired supplied)
543 (cond ((minusp delta)
544 (incf *eval-stack-top* delta))
547 (push-eval-stack nil)))))
548 (byte-interpret component pc fp))
550 ;;; %THROW is compiled down into this xop. The stack contains the tag, the
551 ;;; values, and then a count of the values. We special case various small
552 ;;; numbers of values to keep from consing if we can help it.
554 ;;; Basically, we just extract the values and the tag and then do a throw.
555 ;;; The native compiler will convert this throw into whatever is necessary
556 ;;; to throw, so we don't have to duplicate all that cruft.
557 (define-xop throw (component old-pc pc fp)
558 (declare (type code-component component)
561 (type stack-pointer fp))
562 (let ((num-results (pop-eval-stack)))
563 (declare (type index num-results))
566 (let ((tag (pop-eval-stack)))
567 (with-debugger-info (component old-pc fp)
568 (throw tag (values)))))
570 (multiple-value-pop-eval-stack
572 (with-debugger-info (component old-pc fp)
573 (throw tag result))))
575 (multiple-value-pop-eval-stack
576 (tag result0 result1)
577 (with-debugger-info (component old-pc fp)
578 (throw tag (values result0 result1)))))
581 (dotimes (i num-results)
582 (push (pop-eval-stack) results))
583 (let ((tag (pop-eval-stack)))
584 (with-debugger-info (component old-pc fp)
585 (throw tag (values-list results)))))))))
587 ;;; This is used for both CATCHes and BLOCKs that are closed over. We
588 ;;; establish a catcher for the supplied tag (from the stack top), and
589 ;;; recursivly enter the byte interpreter. If the byte interpreter exits,
590 ;;; it must have been because of a BREAKUP (see below), so we branch (by
591 ;;; tail-calling the byte interpreter) to the pc returned by BREAKUP.
592 ;;; If we are thrown to, then we branch to the address encoded in the 3 bytes
593 ;;; following the catch XOP.
594 (define-xop catch (component old-pc pc fp)
595 (declare (type code-component component)
598 (type stack-pointer fp))
599 (let ((new-pc (block nil
602 (catch (pop-eval-stack)
603 (return (byte-interpret component (+ pc 3) fp))))))
604 (let ((num-results 0))
605 (declare (type index num-results))
606 (dolist (result results)
607 (push-eval-stack result)
609 (push-eval-stack num-results))
610 (component-ref-24 component pc)))))
611 (byte-interpret component new-pc fp)))
613 ;;; Blow out of the dynamically nested CATCH or TAGBODY. We just return the
614 ;;; pc following the BREAKUP XOP and the drop-through code in CATCH or
615 ;;; TAGBODY will do the correct thing.
616 (define-xop breakup (component old-pc pc fp)
617 (declare (ignore component old-pc fp)
621 ;;; This is exactly like THROW, except that the tag is the last thing on
622 ;;; the stack instead of the first. This is used for RETURN-FROM (hence the
624 (define-xop return-from (component old-pc pc fp)
625 (declare (type code-component component)
628 (type stack-pointer fp))
629 (let ((tag (pop-eval-stack))
630 (num-results (pop-eval-stack)))
631 (declare (type index num-results))
634 (with-debugger-info (component old-pc fp)
635 (throw tag (values))))
637 (let ((value (pop-eval-stack)))
638 (with-debugger-info (component old-pc fp)
641 (multiple-value-pop-eval-stack
643 (with-debugger-info (component old-pc fp)
644 (throw tag (values result0 result1)))))
647 (dotimes (i num-results)
648 (push (pop-eval-stack) results))
649 (with-debugger-info (component old-pc fp)
650 (throw tag (values-list results))))))))
652 ;;; Similar to CATCH, except for TAGBODY. One significant difference is that
653 ;;; when thrown to, we don't want to leave the dynamic extent of the tagbody
654 ;;; so we loop around and re-enter the catcher. We keep looping until BREAKUP
655 ;;; is used to blow out. When that happens, we just branch to the pc supplied
657 (define-xop tagbody (component old-pc pc fp)
658 (declare (type code-component component)
661 (type stack-pointer fp))
662 (let* ((tag (pop-eval-stack))
667 (return (byte-interpret component pc fp))))))))
668 (byte-interpret component new-pc fp)))
670 ;;; Yup, you guessed it. This XOP implements GO. There are no values to
671 ;;; pass, so we don't have to mess with them, and multiple exits can all be
672 ;;; using the same tag so we have to pass the pc we want to go to.
673 (define-xop go (component old-pc pc fp)
674 (declare (type code-component component)
676 (type stack-pointer fp))
677 (let ((tag (pop-eval-stack))
678 (new-pc (component-ref-24 component pc)))
679 (with-debugger-info (component old-pc fp)
680 (throw tag new-pc))))
682 ;;; UNWIND-PROTECTs are handled significantly different in the byte
683 ;;; compiler and the native compiler. Basically, we just use the
684 ;;; native compiler's UNWIND-PROTECT, and let it worry about
685 ;;; continuing the unwind.
686 (define-xop unwind-protect (component old-pc pc fp)
687 (declare (type code-component component)
690 (type stack-pointer fp))
693 (setf new-pc (byte-interpret component (+ pc 3) fp))
695 ;; The cleanup function expects 3 values to be one the stack, so
696 ;; we have to put something there.
697 (push-eval-stack nil)
698 (push-eval-stack nil)
699 (push-eval-stack nil)
700 ;; Now run the cleanup code.
701 (byte-interpret component (component-ref-24 component pc) fp)))
702 (byte-interpret component new-pc fp)))
704 (define-xop fdefn-function-or-lose (component old-pc pc fp)
705 (let* ((fdefn (pop-eval-stack))
706 (fun (fdefn-function fdefn)))
707 (declare (type fdefn fdefn))
709 (push-eval-stack fun)
710 (byte-interpret component pc fp))
712 (with-debugger-info (component old-pc fp)
713 (error 'undefined-function :name (fdefn-name fdefn)))))))
715 ;;; This is used to insert placeholder arguments for unused arguments
717 (define-xop push-n-under (component old-pc pc fp)
718 (declare (ignore old-pc))
719 (with-extended-operand (component pc howmany new-pc)
720 (let ((val (pop-eval-stack)))
721 (allocate-eval-stack howmany)
722 (push-eval-stack val))
723 (byte-interpret component new-pc fp)))
727 ;;; These two hashtables map between type specifiers and type
728 ;;; predicate functions that test those types. They are initialized
729 ;;; according to the standard type predicates of the target system.
730 (defvar *byte-type-predicates* (make-hash-table :test 'equal))
731 (defvar *byte-predicate-types* (make-hash-table :test 'eq))
733 (loop for (type predicate) in
734 '#.(loop for (type . predicate) in
735 *backend-type-predicates*
736 collect `(,(type-specifier type) ,predicate))
738 (let ((fun (fdefinition predicate)))
739 (setf (gethash type *byte-type-predicates*) fun)
740 (setf (gethash fun *byte-predicate-types*) type)))
742 ;;; This is called by the loader to convert a type specifier into a
743 ;;; type predicate (as used by the TYPE-CHECK XOP.) If it is a
744 ;;; structure type with a predicate or has a predefined predicate,
745 ;;; then return the predicate function, otherwise return the CTYPE
746 ;;; structure for the type.
747 (defun load-type-predicate (desc)
748 (or (gethash desc *byte-type-predicates*)
749 (let ((type (specifier-type desc)))
750 (if (typep type 'structure-class)
751 (let ((info (layout-info (class-layout type))))
752 (if (and info (eq (dd-type info) 'structure))
753 (let ((pred (dd-predicate info)))
754 (if (and pred (fboundp pred))
760 ;;; Check the type of the value on the top of the stack. The type is
761 ;;; designated by an entry in the constants. If the value is a
762 ;;; function, then it is called as a type predicate. Otherwise, the
763 ;;; value is a CTYPE object, and we call %TYPEP on it.
764 (define-xop type-check (component old-pc pc fp)
765 (declare (type code-component component)
767 (type stack-pointer fp))
768 (with-extended-operand (component pc operand new-pc)
769 (let ((value (eval-stack-ref (1- *eval-stack-top*)))
770 (type (code-header-ref component
771 (+ operand sb!vm:code-constants-offset))))
772 (unless (if (functionp type)
775 (with-debugger-info (component old-pc fp)
778 :expected-type (if (functionp type)
779 (gethash type *byte-predicate-types*)
780 (type-specifier type))))))
782 (byte-interpret component new-pc fp)))
784 ;;;; the actual byte-interpreter
786 ;;; The various operations are encoded as follows.
788 ;;; 0000xxxx push-local op
789 ;;; 0001xxxx push-arg op [push-local, but negative]
790 ;;; 0010xxxx push-constant op
791 ;;; 0011xxxx push-system-constant op
792 ;;; 0100xxxx push-int op
793 ;;; 0101xxxx push-neg-int op
794 ;;; 0110xxxx pop-local op
795 ;;; 0111xxxx pop-n op
797 ;;; 1001nxxx tail-call op
798 ;;; 1010nxxx multiple-call op
799 ;;; 10110xxx local-call
800 ;;; 10111xxx local-tail-call
801 ;;; 11000xxx local-multiple-call
805 ;;; 1101010r if-false
809 ;;; to various inline functions.
812 ;;; This encoding is rather hard wired into BYTE-INTERPRET due to the
813 ;;; binary dispatch tree.
815 (defvar *byte-trace* nil)
817 ;;; the main entry point to the byte interpreter
818 (defun byte-interpret (component pc fp)
819 (declare (type code-component component)
821 (type stack-pointer fp))
822 (byte-interpret-byte component pc fp (component-ref component pc)))
824 ;;; This is separated from BYTE-INTERPRET in order to let us continue
825 ;;; from a breakpoint without having to replace the breakpoint with
826 ;;; the original instruction and arrange to somehow put the breakpoint
827 ;;; back after executing the instruction. We just leave the breakpoint
828 ;;; there, and call this function with the byte that the breakpoint
830 (defun byte-interpret-byte (component pc fp byte)
831 (declare (type code-component component)
833 (type stack-pointer fp)
834 (type (unsigned-byte 8) byte))
836 #+nil (declare (optimize (inhibit-warnings 3)))
838 (let ((*byte-trace* nil))
839 (format *trace-output*
840 "pc=~D, fp=~D, sp=~D, byte=#b~,'0X, frame:~% ~S~%"
841 pc fp *eval-stack-top* byte
842 (subseq sb!eval::*eval-stack* fp *eval-stack-top*)))))
843 (if (zerop (logand byte #x80))
844 ;; Some stack operation. No matter what, we need the operand,
846 (multiple-value-bind (operand new-pc)
847 (let ((operand (logand byte #xf)))
849 (let ((operand (component-ref component (1+ pc))))
851 (values (component-ref-24 component (+ pc 2))
853 (values operand (+ pc 2))))
854 (values operand (1+ pc))))
855 (if (zerop (logand byte #x40))
856 (push-eval-stack (if (zerop (logand byte #x20))
857 (if (zerop (logand byte #x10))
858 (eval-stack-ref (+ fp operand))
859 (eval-stack-ref (- fp operand 5)))
860 (if (zerop (logand byte #x10))
863 (+ operand sb!vm:code-constants-offset))
864 (svref *system-constants* operand))))
865 (if (zerop (logand byte #x20))
866 (push-eval-stack (if (zerop (logand byte #x10))
869 (if (zerop (logand byte #x10))
870 (setf (eval-stack-ref (+ fp operand)) (pop-eval-stack))
872 (let ((operand (pop-eval-stack)))
873 (declare (type index operand))
874 (decf *eval-stack-top* operand))
875 (decf *eval-stack-top* operand)))))
876 (byte-interpret component new-pc fp))
877 (if (zerop (logand byte #x40))
878 ;; Some kind of call.
879 (let ((args (let ((args (logand byte #x07)))
883 (if (zerop (logand byte #x20))
884 (let ((named (not (zerop (logand byte #x08)))))
885 (if (zerop (logand byte #x10))
886 ;; Call for single value.
887 (do-call component pc (1+ pc) fp args named)
889 (do-tail-call component pc fp args named)))
890 (if (zerop (logand byte #x10))
891 ;; Call for multiple-values.
892 (do-call component pc (- (1+ pc)) fp args
893 (not (zerop (logand byte #x08))))
894 (if (zerop (logand byte #x08))
896 (do-local-call component pc (+ pc 4) fp args)
898 (do-tail-local-call component pc fp args)))))
899 (if (zerop (logand byte #x20))
900 ;; local-multiple-call, Return, branch, or Xop.
901 (if (zerop (logand byte #x10))
902 ;; local-multiple-call or return.
903 (if (zerop (logand byte #x08))
904 ;; Local-multiple-call.
905 (do-local-call component pc (- (+ pc 4)) fp
906 (let ((args (logand byte #x07)))
912 (let ((num-results (logand byte #x7)))
913 (if (= num-results 7)
916 (do-return fp num-results)))
918 (if (zerop (logand byte #x08))
920 (if (if (zerop (logand byte #x04))
921 (if (zerop (logand byte #x02))
924 (if (zerop (logand byte #x02))
925 (not (pop-eval-stack))
926 (multiple-value-pop-eval-stack
932 (if (zerop (logand byte #x01))
933 (component-ref-24 component (1+ pc))
935 (component-ref-signed component (1+ pc))))
938 (byte-interpret component
939 (if (zerop (logand byte #x01))
944 (multiple-value-bind (sub-code new-pc)
945 (let ((operand (logand byte #x7)))
947 (values (component-ref component (+ pc 1))
949 (values operand (1+ pc))))
950 (funcall (the function (svref *byte-xops* sub-code))
951 component pc new-pc fp))))
952 ;; some miscellaneous inline function
954 (expand-into-inlines)
955 (byte-interpret component (1+ pc) fp))))))
957 (defun do-local-call (component pc old-pc old-fp num-args)
958 (declare (type pc pc)
959 (type return-pc old-pc)
960 (type stack-pointer old-fp)
961 (type (integer 0 #.call-arguments-limit) num-args))
962 (invoke-local-entry-point component (component-ref-24 component (1+ pc))
964 (- *eval-stack-top* num-args)
967 (defun do-tail-local-call (component pc fp num-args)
968 (declare (type code-component component) (type pc pc)
969 (type stack-pointer fp)
970 (type index num-args))
971 (let ((old-fp (eval-stack-ref (- fp 1)))
972 (old-sp (eval-stack-ref (- fp 2)))
973 (old-pc (eval-stack-ref (- fp 3)))
974 (old-component (eval-stack-ref (- fp 4)))
975 (start-of-args (- *eval-stack-top* num-args)))
976 (eval-stack-copy old-sp start-of-args num-args)
977 (setf *eval-stack-top* (+ old-sp num-args))
978 (invoke-local-entry-point component (component-ref-24 component (1+ pc))
979 old-component old-pc old-sp old-fp)))
981 (defun invoke-local-entry-point (component target old-component old-pc old-sp
982 old-fp &optional closure-vars)
983 (declare (type pc target)
984 (type return-pc old-pc)
985 (type stack-pointer old-sp old-fp)
986 (type (or null simple-vector) closure-vars))
988 (named-let more ((index (1- (length closure-vars))))
989 (unless (minusp index)
990 (push-eval-stack (svref closure-vars index))
992 (push-eval-stack old-component)
993 (push-eval-stack old-pc)
994 (push-eval-stack old-sp)
995 (push-eval-stack old-fp)
996 (multiple-value-bind (stack-frame-size entry-pc)
997 (let ((byte (component-ref component target)))
999 (values (component-ref-24 component (1+ target)) (+ target 4))
1000 (values (* byte 2) (1+ target))))
1001 (declare (type pc entry-pc))
1002 (let ((fp *eval-stack-top*))
1003 (allocate-eval-stack stack-frame-size)
1004 (byte-interpret component entry-pc fp))))
1006 ;;; Call a function with some arguments popped off of the interpreter
1007 ;;; stack, and restore the SP to the specified value.
1008 (defun byte-apply (function num-args restore-sp)
1009 (declare (type function function) (type index num-args))
1010 (let ((start (- *eval-stack-top* num-args)))
1011 (declare (type stack-pointer start))
1014 ,@(loop for n below 8
1015 collect `(,n (call-1 ,n)))
1018 (end (+ start num-args)))
1019 (declare (type stack-pointer end))
1020 (do ((i (1- end) (1- i)))
1022 (declare (fixnum i))
1023 (push (eval-stack-ref i) args))
1024 (setf *eval-stack-top* restore-sp)
1025 (apply function args)))))
1030 (let ((dum (gensym)))
1031 (binds `(,dum (eval-stack-ref (+ start ,i))))
1034 (setf *eval-stack-top* restore-sp)
1035 (funcall function ,@(args))))))
1038 ;;; Note: negative RET-PC is a convention for "we need multiple return
1040 (defun do-call (old-component call-pc ret-pc old-fp num-args named)
1041 (declare (type code-component old-component)
1043 (type return-pc ret-pc)
1044 (type stack-pointer old-fp)
1045 (type (integer 0 #.call-arguments-limit) num-args)
1046 (type (member t nil) named))
1047 (let* ((old-sp (- *eval-stack-top* num-args 1))
1048 (fun-or-fdefn (eval-stack-ref old-sp))
1050 (or (fdefn-function fun-or-fdefn)
1051 (with-debugger-info (old-component call-pc old-fp)
1052 (error 'undefined-function
1053 :name (fdefn-name fun-or-fdefn))))
1055 (declare (type stack-pointer old-sp)
1056 (type (or function fdefn) fun-or-fdefn)
1057 (type function function))
1060 (invoke-xep old-component ret-pc old-sp old-fp num-args function))
1062 (invoke-xep old-component ret-pc old-sp old-fp num-args
1063 (byte-closure-function function)
1064 (byte-closure-data function)))
1066 (cond ((minusp ret-pc)
1067 (let* ((ret-pc (- ret-pc))
1069 (multiple-value-list
1071 (old-component ret-pc old-fp)
1072 (byte-apply function num-args old-sp)))))
1073 (dolist (result results)
1074 (push-eval-stack result))
1075 (push-eval-stack (length results))
1076 (byte-interpret old-component ret-pc old-fp)))
1080 (old-component ret-pc old-fp)
1081 (byte-apply function num-args old-sp)))
1082 (byte-interpret old-component ret-pc old-fp)))))))
1084 (defun do-tail-call (component pc fp num-args named)
1085 (declare (type code-component component)
1087 (type stack-pointer fp)
1088 (type (integer 0 #.call-arguments-limit) num-args)
1089 (type (member t nil) named))
1090 (let* ((start-of-args (- *eval-stack-top* num-args))
1091 (fun-or-fdefn (eval-stack-ref (1- start-of-args)))
1093 (or (fdefn-function fun-or-fdefn)
1094 (with-debugger-info (component pc fp)
1095 (error 'undefined-function
1096 :name (fdefn-name fun-or-fdefn))))
1098 (old-fp (eval-stack-ref (- fp 1)))
1099 (old-sp (eval-stack-ref (- fp 2)))
1100 (old-pc (eval-stack-ref (- fp 3)))
1101 (old-component (eval-stack-ref (- fp 4))))
1102 (declare (type stack-pointer old-fp old-sp start-of-args)
1103 (type return-pc old-pc)
1104 (type (or fdefn function) fun-or-fdefn)
1105 (type function function))
1108 (eval-stack-copy old-sp start-of-args num-args)
1109 (setf *eval-stack-top* (+ old-sp num-args))
1110 (invoke-xep old-component old-pc old-sp old-fp num-args function))
1112 (eval-stack-copy old-sp start-of-args num-args)
1113 (setf *eval-stack-top* (+ old-sp num-args))
1114 (invoke-xep old-component old-pc old-sp old-fp num-args
1115 (byte-closure-function function)
1116 (byte-closure-data function)))
1118 ;; We are tail-calling native code.
1119 (cond ((null old-component)
1120 ;; We were called by native code.
1121 (byte-apply function num-args old-sp))
1123 ;; We were called for multiple values. So return multiple
1125 (let* ((old-pc (- old-pc))
1127 (multiple-value-list
1129 (old-component old-pc old-fp)
1130 (byte-apply function num-args old-sp)))))
1131 (dolist (result results)
1132 (push-eval-stack result))
1133 (push-eval-stack (length results))
1134 (byte-interpret old-component old-pc old-fp)))
1136 ;; We were called for one value. So return one value.
1139 (old-component old-pc old-fp)
1140 (byte-apply function num-args old-sp)))
1141 (byte-interpret old-component old-pc old-fp)))))))
1143 (defvar *byte-trace-calls* nil)
1145 (defun invoke-xep (old-component ret-pc old-sp old-fp num-args xep
1146 &optional closure-vars)
1147 (declare (type (or null code-component) old-component)
1148 (type index num-args)
1149 (type return-pc ret-pc)
1150 (type stack-pointer old-sp old-fp)
1151 (type byte-function xep)
1152 (type (or null simple-vector) closure-vars))
1153 ;; FIXME: Perhaps BYTE-TRACE-CALLS stuff should be conditional on SB-SHOW.
1154 (when *byte-trace-calls*
1155 (let ((*byte-trace-calls* nil)
1157 (*print-level* sb!debug:*debug-print-level*)
1158 (*print-length* sb!debug:*debug-print-length*)
1159 (sp *eval-stack-top*))
1160 (format *trace-output*
1161 "~&INVOKE-XEP: ocode= ~S[~D]~% ~
1162 osp= ~D, ofp= ~D, nargs= ~D, SP= ~D:~% ~
1163 Fun= ~S ~@[~S~]~% Args= ~S~%"
1164 old-component ret-pc old-sp old-fp num-args sp
1165 xep closure-vars (subseq *eval-stack* (- sp num-args) sp))
1166 (force-output *trace-output*)))
1170 ((typep xep 'simple-byte-function)
1171 (unless (eql (simple-byte-function-num-args xep) num-args)
1172 (with-debugger-info (old-component ret-pc old-fp)
1173 (error "wrong number of arguments")))
1174 (simple-byte-function-entry-point xep))
1176 (let ((min (hairy-byte-function-min-args xep))
1177 (max (hairy-byte-function-max-args xep)))
1180 (with-debugger-info (old-component ret-pc old-fp)
1181 (error "not enough arguments")))
1183 (nth (- num-args min) (hairy-byte-function-entry-points xep)))
1184 ((null (hairy-byte-function-more-args-entry-point xep))
1185 (with-debugger-info (old-component ret-pc old-fp)
1186 (error "too many arguments")))
1188 (let* ((more-args-supplied (- num-args max))
1189 (sp *eval-stack-top*)
1190 (more-args-start (- sp more-args-supplied))
1191 (restp (hairy-byte-function-rest-arg-p xep))
1193 (do ((index (1- sp) (1- index))
1195 (cons (eval-stack-ref index)
1197 ((< index more-args-start) result)
1198 (declare (fixnum index))))))
1199 (declare (type index more-args-supplied)
1200 (type stack-pointer more-args-start))
1202 ((not (hairy-byte-function-keywords-p xep))
1204 (setf *eval-stack-top* (1+ more-args-start))
1205 (setf (eval-stack-ref more-args-start) rest))
1207 (unless (evenp more-args-supplied)
1208 (with-debugger-info (old-component ret-pc old-fp)
1209 (error "odd number of &KEY arguments")))
1210 ;; If there are &KEY args, then we need to leave
1211 ;; the defaulted and supplied-p values where the
1212 ;; more args currently are. There might be more or
1213 ;; fewer. And also, we need to flatten the parsed
1214 ;; args with the defaults before we scan the
1215 ;; keywords. So we copy all the &MORE args to a
1216 ;; temporary area at the end of the stack.
1217 (let* ((num-more-args
1218 (hairy-byte-function-num-more-args xep))
1219 (new-sp (+ more-args-start num-more-args))
1220 (temp (max sp new-sp))
1221 (temp-sp (+ temp more-args-supplied))
1222 (keywords (hairy-byte-function-keywords xep)))
1223 (declare (type index temp)
1224 (type stack-pointer new-sp temp-sp))
1225 (allocate-eval-stack (- temp-sp sp))
1226 (eval-stack-copy temp more-args-start more-args-supplied)
1228 (setf (eval-stack-ref more-args-start) rest)
1229 (incf more-args-start))
1230 (let ((index more-args-start))
1231 (dolist (keyword keywords)
1232 (setf (eval-stack-ref index) (cadr keyword))
1234 (when (caddr keyword)
1235 (setf (eval-stack-ref index) nil)
1237 (let ((index temp-sp)
1238 (allow (eq (hairy-byte-function-keywords-p xep)
1242 (declare (type fixnum index))
1245 (when (< index temp)
1247 (let ((key (eval-stack-ref index))
1248 (value (eval-stack-ref (1+ index))))
1249 (if (eq key :allow-other-keys)
1251 (let ((target more-args-start))
1252 (declare (type stack-pointer target))
1253 (dolist (keyword keywords
1256 (cond ((eq (car keyword) key)
1257 (setf (eval-stack-ref target) value)
1258 (when (caddr keyword)
1259 (setf (eval-stack-ref (1+ target))
1265 (incf target))))))))
1266 (when (and bogus-key-p (not allow))
1267 (with-debugger-info (old-component ret-pc old-fp)
1268 (error "unknown keyword: ~S" bogus-key))))
1269 (setf *eval-stack-top* new-sp)))))
1270 (hairy-byte-function-more-args-entry-point xep))))))))
1271 (declare (type pc entry-point))
1272 (invoke-local-entry-point (byte-function-component xep) entry-point
1273 old-component ret-pc old-sp old-fp
1276 (defun do-return (fp num-results)
1277 (declare (type stack-pointer fp) (type index num-results))
1278 (let ((old-component (eval-stack-ref (- fp 4))))
1279 (typecase old-component
1281 ;; returning to more byte-interpreted code
1282 (do-local-return old-component fp num-results))
1284 ;; returning to native code
1285 (let ((old-sp (eval-stack-ref (- fp 2))))
1288 (setf *eval-stack-top* old-sp)
1291 (let ((result (pop-eval-stack)))
1292 (setf *eval-stack-top* old-sp)
1295 (let ((results nil))
1296 (dotimes (i num-results)
1297 (push (pop-eval-stack) results))
1298 (setf *eval-stack-top* old-sp)
1299 (values-list results))))))
1301 ;; ### function end breakpoint?
1302 (error "Function-end breakpoints are not supported.")))))
1304 (defun do-local-return (old-component fp num-results)
1305 (declare (type stack-pointer fp) (type index num-results))
1306 (let ((old-fp (eval-stack-ref (- fp 1)))
1307 (old-sp (eval-stack-ref (- fp 2)))
1308 (old-pc (eval-stack-ref (- fp 3))))
1309 (declare (type (signed-byte 25) old-pc))
1311 ;; wants single value
1312 (let ((result (if (zerop num-results)
1314 (eval-stack-ref (- *eval-stack-top*
1316 (setf *eval-stack-top* old-sp)
1317 (push-eval-stack result)
1318 (byte-interpret old-component old-pc old-fp))
1319 ;; wants multiple values
1321 (eval-stack-copy old-sp
1322 (- *eval-stack-top* num-results)
1324 (setf *eval-stack-top* (+ old-sp num-results))
1325 (push-eval-stack num-results)
1326 (byte-interpret old-component (- old-pc) old-fp)))))