1 ;;;; the byte code interpreter
3 ;;; FIXME: should really be in SB!BYTECODE
6 ;;;; This software is part of the SBCL system. See the README file for
9 ;;;; This software is derived from the CMU CL system, which was
10 ;;;; written at Carnegie Mellon University and released into the
11 ;;;; public domain. The software is in the public domain and is
12 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
13 ;;;; files for more information.
15 ;;; We need at least this level of DEBUGness in order for the local
16 ;;; declaration in WITH-DEBUGGER-INFO to take effect.
18 ;;; FIXME: This will cause source code location information to be
19 ;;; compiled into the executable, which will probably cause problems
20 ;;; for users running without the sources and/or without the
21 ;;; build-the-system readtable.
22 (declaim (optimize (debug 2)))
24 ;;; Return a function type approximating the type of a byte-compiled
25 ;;; function. We really only capture the arg signature.
26 (defun byte-function-type (x)
30 `(function ,(make-list (simple-byte-function-num-args x)
35 (let ((min (hairy-byte-function-min-args x))
36 (max (hairy-byte-function-max-args x)))
37 (dotimes (i min) (res t))
40 (dotimes (i (- max min))
42 (when (hairy-byte-function-rest-arg-p x)
44 (ecase (hairy-byte-function-keywords-p x)
47 (dolist (key (hairy-byte-function-keywords x))
48 (res `(,(car key) t)))
49 (when (eql (hairy-byte-function-keywords-p x) :allow-others)
50 (res '&allow-other-keys)))
52 `(function ,(res) *))))))
54 ;;;; the 'evaluation stack'
56 ;;;; (The name dates back to CMU CL, when it was used for the IR1
57 ;;;; interpreted implementation of EVAL. In SBCL >=0.7.0, it's just
58 ;;;; the byte interpreter stack.)
60 (defvar *eval-stack* (make-array 100)) ; will grow as needed
62 ;;; the index of the next free element of the interpreter's evaluation stack
63 (defvar *eval-stack-top* 0)
65 #!-sb-fluid (declaim (inline eval-stack-ref))
66 (defun eval-stack-ref (offset)
67 (declare (type stack-pointer offset))
68 (svref sb!bytecode::*eval-stack* offset))
70 #!-sb-fluid (declaim (inline (setf eval-stack-ref)))
71 (defun (setf eval-stack-ref) (new-value offset)
72 (declare (type stack-pointer offset))
73 (setf (svref sb!bytecode::*eval-stack* offset) new-value))
75 (defun push-eval-stack (value)
76 (let ((len (length (the simple-vector sb!bytecode::*eval-stack*)))
77 (sp *eval-stack-top*))
79 (let ((new-stack (make-array (ash len 1))))
80 (replace new-stack sb!bytecode::*eval-stack* :end1 len :end2 len)
81 (setf sb!bytecode::*eval-stack* new-stack)))
82 (setf *eval-stack-top* (1+ sp))
83 (setf (eval-stack-ref sp) value)))
85 (defun allocate-eval-stack (amount)
86 (let* ((len (length (the simple-vector sb!bytecode::*eval-stack*)))
88 (new-sp (+ sp amount)))
89 (declare (type index sp new-sp))
91 (let ((new-stack (make-array (ash new-sp 1))))
92 (replace new-stack sb!bytecode::*eval-stack* :end1 len :end2 len)
93 (setf sb!bytecode::*eval-stack* new-stack)))
94 (setf *eval-stack-top* new-sp)
95 (let ((stack sb!bytecode::*eval-stack*))
96 (do ((i sp (1+ i))) ; FIXME: Use CL:FILL.
98 (setf (svref stack i) '#:uninitialized-eval-stack-element))))
101 (defun pop-eval-stack ()
102 (let* ((new-sp (1- *eval-stack-top*))
103 (value (eval-stack-ref new-sp)))
104 (setf *eval-stack-top* new-sp)
107 (defmacro multiple-value-pop-eval-stack ((&rest vars) &body body)
108 #+nil (declare (optimize (inhibit-warnings 3)))
109 (let ((num-vars (length vars))
111 (new-sp-var (gensym "NEW-SP-"))
114 (unless (and (consp body)
116 (eq (caar body) 'declare))
118 (push (pop body) decls))
119 `(let ((,new-sp-var (- *eval-stack-top* ,num-vars)))
120 (declare (type stack-pointer ,new-sp-var))
121 (let ,(mapcar #'(lambda (var)
122 `(,var (eval-stack-ref
123 (+ ,new-sp-var ,(incf index)))))
126 (setf *eval-stack-top* ,new-sp-var)
129 (defun eval-stack-copy (dest src count)
130 (declare (type stack-pointer dest src count))
131 (let ((stack *eval-stack*))
134 (setf (svref stack dest) (svref stack src))
137 (do ((si (1- (+ src count))
139 (di (1- (+ dest count))
142 (declare (fixnum si di))
143 (setf (svref stack di) (svref stack si)))))
146 ;;;; component access magic
148 #!-sb-fluid (declaim (inline component-ref))
149 (defun component-ref (component pc)
150 (declare (type code-component component)
152 (sap-ref-8 (code-instructions component) pc))
154 #!-sb-fluid (declaim (inline (setf component-ref)))
155 (defun (setf component-ref) (value component pc)
156 (declare (type (unsigned-byte 8) value)
157 (type code-component component)
159 (setf (sap-ref-8 (code-instructions component) pc) value))
161 #!-sb-fluid (declaim (inline component-ref-signed))
162 (defun component-ref-signed (component pc)
163 (let ((byte (component-ref component pc)))
165 (logior (ash -1 8) byte)
168 #!-sb-fluid (declaim (inline component-ref-24))
169 (defun component-ref-24 (component pc)
170 (logior (ash (component-ref component pc) 16)
171 (ash (component-ref component (1+ pc)) 8)
172 (component-ref component (+ pc 2))))
174 ;;;; debugging support
176 ;;; This macro binds three magic variables. When the debugger notices that
177 ;;; these three variables are bound, it makes a byte-code frame out of the
178 ;;; supplied information instead of a compiled frame. We set each var in
179 ;;; addition to binding it so the compiler doens't optimize away the binding.
180 (defmacro with-debugger-info ((component pc fp) &body body)
181 `(let ((%byte-interp-component ,component)
182 (%byte-interp-pc ,pc)
183 (%byte-interp-fp ,fp))
184 ;; FIXME: This will cause source code location information to be compiled
185 ;; into the executable, which will probably cause problems for users
186 ;; running without the sources and/or without the build-the-system
188 (declare (optimize (debug 3)))
189 (setf %byte-interp-component %byte-interp-component)
190 (setf %byte-interp-pc %byte-interp-pc)
191 (setf %byte-interp-fp %byte-interp-fp)
194 (defun byte-install-breakpoint (component pc)
195 (declare (type code-component component)
197 (values (unsigned-byte 8)))
198 (let ((orig (component-ref component pc)))
199 (setf (component-ref component pc)
201 (xop-index-or-lose 'breakpoint)))
204 (defun byte-remove-breakpoint (component pc orig)
205 (declare (type code-component component)
207 (type (unsigned-byte 8) orig)
208 (values (unsigned-byte 8)))
209 (setf (component-ref component pc) orig))
211 (defun byte-skip-breakpoint (component pc fp orig)
212 (declare (type code-component component)
214 (type stack-pointer fp)
215 (type (unsigned-byte 8) orig))
216 (byte-interpret-byte component fp pc orig))
218 ;;;; system constants
220 ;;; a table mapping system constant indices to run-time values. We don't
221 ;;; reference the compiler variable at load time, since the interpreter is
223 (defparameter *system-constants*
224 (let ((res (make-array 256)))
225 (dolist (x '#.(collect ((res))
226 (dohash (key value *system-constant-codes*)
227 (res (cons key value)))
231 (setf (svref res value)
232 (if (and (consp key) (eq (car key) '%fdefinition-marker%))
233 (fdefinition-object (cdr key) t)
237 ;;;; byte compiled function constructors/extractors
239 (defun initialize-byte-compiled-function (xep)
240 (declare (type byte-function xep))
241 (push xep (code-header-ref (byte-function-component xep)
242 sb!vm:code-trace-table-offset-slot))
243 (setf (funcallable-instance-function xep)
244 #'(instance-lambda (&more context count)
245 (let ((old-sp *eval-stack-top*))
246 (declare (type stack-pointer old-sp))
248 (push-eval-stack (%more-arg context i)))
249 (invoke-xep nil 0 old-sp 0 count xep))))
252 (defun make-byte-compiled-closure (xep closure-vars)
253 (declare (type byte-function xep)
254 (type simple-vector closure-vars))
255 (let ((res (make-byte-closure xep closure-vars)))
256 (setf (funcallable-instance-function res)
257 #'(instance-lambda (&more context count)
258 (let ((old-sp *eval-stack-top*))
259 (declare (type stack-pointer old-sp))
261 (push-eval-stack (%more-arg context i)))
262 (invoke-xep nil 0 old-sp 0 count
263 (byte-closure-function res)
264 (byte-closure-data res)))))
269 ;;; (The idea here seems to be to make sure it's at least 100,
270 ;;; in order to be able to compile the 32+ inline functions
271 ;;; in EXPAND-INTO-INLINES as intended. -- WHN 19991206)
272 (eval-when (:compile-toplevel :execute)
273 (setq sb!ext:*inline-expansion-limit* 100))
275 ;;; FIXME: This doesn't seem to be needed in the target Lisp, only
276 ;;; at build-the-system time.
278 ;;; KLUDGE: This expands into code like
279 ;;; (IF (ZEROP (LOGAND BYTE 16))
280 ;;; (IF (ZEROP (LOGAND BYTE 8))
281 ;;; (IF (ZEROP (LOGAND BYTE 4))
282 ;;; (IF (ZEROP (LOGAND BYTE 2))
283 ;;; (IF (ZEROP (LOGAND BYTE 1))
284 ;;; (ERROR "Unknown inline function, id=~D" 0)
285 ;;; (ERROR "Unknown inline function, id=~D" 1))
286 ;;; (IF (ZEROP (LOGAND BYTE 1))
287 ;;; (ERROR "Unknown inline function, id=~D" 2)
288 ;;; (ERROR "Unknown inline function, id=~D" 3)))
289 ;;; (IF (ZEROP (LOGAND BYTE 2))
291 ;;; That's probably more efficient than doing a function call (even a
292 ;;; local function call) for every byte interpreted, but I doubt it's
293 ;;; as fast as doing a jump through a table of sixteen addresses.
294 ;;; Perhaps it would be good to recode this as a straightforward
295 ;;; CASE statement and redirect the cleverness previously devoted to
296 ;;; this code to an optimizer for CASE which is smart enough to
297 ;;; implement suitable code as jump tables.
298 (defmacro expand-into-inlines ()
299 #+nil (declare (optimize (inhibit-warnings 3)))
300 (named-let build-dispatch ((bit 4)
303 (let ((info (svref *inline-functions* base)))
305 (let* ((spec (type-specifier
306 (inline-function-info-type info)))
307 (arg-types (second spec))
308 (result-type (third spec))
309 (args (make-gensym-list (length arg-types)))
312 (,(inline-function-info-interpreter-function info)
314 `(multiple-value-pop-eval-stack ,args
315 (declare ,@(mapcar #'(lambda (type var)
318 ,(if (and (consp result-type)
319 (eq (car result-type) 'values))
320 (let ((results (make-gensym-list
321 (length (cdr result-type)))))
322 `(multiple-value-bind ,results ,func
323 ,@(mapcar #'(lambda (res)
324 `(push-eval-stack ,res))
326 `(push-eval-stack ,func))))
327 `(error "unknown inline function, id=~D" ,base)))
328 `(if (zerop (logand byte ,(ash 1 bit)))
329 ,(build-dispatch (1- bit) base)
330 ,(build-dispatch (1- bit) (+ base (ash 1 bit)))))))
332 #!-sb-fluid (declaim (inline value-cell-setf))
333 (defun value-cell-setf (value cell)
334 (value-cell-set cell value)
337 #!-sb-fluid (declaim (inline setf-symbol-value))
338 (defun setf-symbol-value (value symbol)
339 (setf (symbol-value symbol) value))
341 #!-sb-fluid (declaim (inline %setf-instance-ref))
342 (defun %setf-instance-ref (new-value instance index)
343 (setf (%instance-ref instance index) new-value))
345 (eval-when (:compile-toplevel)
347 (sb!xc:defmacro %byte-symbol-value (x)
350 (with-debugger-info (component pc fp)
351 (error "unbound variable: ~S" x)))
354 (sb!xc:defmacro %byte-car (x)
357 (with-debugger-info (component pc fp)
358 (error 'simple-type-error :item x :expected-type 'list
359 :format-control "non-list argument to CAR: ~S"
360 :format-arguments (list x))))
363 (sb!xc:defmacro %byte-cdr (x)
366 (with-debugger-info (component pc fp)
367 (error 'simple-type-error :item x :expected-type 'list
368 :format-control "non-list argument to CDR: ~S"
369 :format-arguments (list x))))
374 #!-sb-fluid (declaim (inline %byte-special-bind))
375 (defun %byte-special-bind (value symbol)
376 (sb!sys:%primitive bind value symbol)
379 #!-sb-fluid (declaim (inline %byte-special-unbind))
380 (defun %byte-special-unbind ()
381 (sb!sys:%primitive unbind)
384 ;;;; two-arg function stubs
386 ;;;; We have two-arg versions of some n-ary functions that are normally
389 (defun two-arg-char= (x y) (char= x y))
390 (defun two-arg-char< (x y) (char< x y))
391 (defun two-arg-char> (x y) (char> x y))
392 (defun two-arg-char-equal (x y) (char-equal x y))
393 (defun two-arg-char-lessp (x y) (char-lessp x y))
394 (defun two-arg-char-greaterp (x y) (char-greaterp x y))
395 (defun two-arg-string= (x y) (string= x y))
396 (defun two-arg-string< (x y) (string= x y))
397 (defun two-arg-string> (x y) (string= x y))
401 ;;; (used both by the byte interpreter and by the IR1 interpreter)
402 (defun %progv (vars vals fun)
408 ;;; Extension operations (XOPs) are various magic things that the byte
409 ;;; interpreter needs to do, but can't be represented as a function call.
410 ;;; When the byte interpreter encounters an XOP in the byte stream, it
411 ;;; tail-calls the corresponding XOP routine extracted from *byte-xops*.
412 ;;; The XOP routine can do whatever it wants, probably re-invoking the
413 ;;; byte interpreter.
415 ;;; Fetch an 8/24 bit operand out of the code stream.
416 (eval-when (:compile-toplevel :execute)
417 (sb!xc:defmacro with-extended-operand ((component pc operand new-pc)
419 (once-only ((n-component component)
421 `(multiple-value-bind (,operand ,new-pc)
422 (let ((,operand (component-ref ,n-component ,n-pc)))
423 (if (= ,operand #xff)
424 (values (component-ref-24 ,n-component (1+ ,n-pc))
426 (values ,operand (1+ ,n-pc))))
427 (declare (type index ,operand ,new-pc))
430 ;;; If a real XOP hasn't been defined, this gets invoked and signals an
431 ;;; error. This shouldn't happen in normal operation.
432 (defun undefined-xop (component old-pc pc fp)
433 (declare (ignore component old-pc pc fp))
434 (error "undefined XOP"))
436 ;;; a simple vector of the XOP functions
437 (declaim (type (simple-vector 256) *byte-xops*))
439 (make-array 256 :initial-element #'undefined-xop))
441 ;;; Define a XOP function and install it in *BYTE-XOPS*.
442 (eval-when (:compile-toplevel :execute)
443 (sb!xc:defmacro define-xop (name lambda-list &body body)
444 (let ((defun-name (symbolicate "BYTE-" name "-XOP")))
446 (defun ,defun-name ,lambda-list
448 (setf (aref *byte-xops* ,(xop-index-or-lose name)) #',defun-name)
451 ;;; This is spliced in by the debugger in order to implement breakpoints.
452 (define-xop breakpoint (component old-pc pc fp)
453 (declare (type code-component component)
456 (type stack-pointer fp))
457 ;; Invoke the debugger.
458 (with-debugger-info (component old-pc fp)
459 (sb!di::handle-breakpoint component old-pc fp))
460 ;; Retry the breakpoint XOP in case it was replaced with the original
461 ;; displaced byte-code.
462 (byte-interpret component old-pc fp))
464 ;;; This just duplicates whatever is on the top of the stack.
465 (define-xop dup (component old-pc pc fp)
466 (declare (type code-component component)
469 (type stack-pointer fp))
470 (let ((value (eval-stack-ref (1- *eval-stack-top*))))
471 (push-eval-stack value))
472 (byte-interpret component pc fp))
474 (define-xop make-closure (component old-pc pc fp)
475 (declare (type code-component component)
478 (type stack-pointer fp))
479 (let* ((num-closure-vars (pop-eval-stack))
480 (closure-vars (make-array num-closure-vars)))
481 (declare (type index num-closure-vars)
482 (type simple-vector closure-vars))
483 (named-let frob ((index (1- num-closure-vars)))
484 (unless (minusp index)
485 (setf (svref closure-vars index) (pop-eval-stack))
487 (push-eval-stack (make-byte-compiled-closure (pop-eval-stack)
489 (byte-interpret component pc fp))
491 (define-xop merge-unknown-values (component old-pc pc fp)
492 (declare (type code-component component)
495 (type stack-pointer fp))
496 (labels ((grovel (remaining-blocks block-count-ptr)
497 (declare (type index remaining-blocks)
498 (type stack-pointer block-count-ptr))
499 (declare (values index stack-pointer))
500 (let ((block-count (eval-stack-ref block-count-ptr)))
501 (declare (type index block-count))
502 (if (= remaining-blocks 1)
503 (values block-count block-count-ptr)
504 (let ((src (- block-count-ptr block-count)))
505 (declare (type index src))
506 (multiple-value-bind (values-above dst)
507 (grovel (1- remaining-blocks) (1- src))
508 (eval-stack-copy dst src block-count)
509 (values (+ values-above block-count)
510 (+ dst block-count))))))))
511 (multiple-value-bind (total-count end-ptr)
512 (grovel (pop-eval-stack) (1- *eval-stack-top*))
513 (setf (eval-stack-ref end-ptr) total-count)
514 (setf *eval-stack-top* (1+ end-ptr))))
515 (byte-interpret component pc fp))
517 (define-xop default-unknown-values (component old-pc pc fp)
518 (declare (type code-component component)
521 (type stack-pointer fp))
522 (let* ((desired (pop-eval-stack))
523 (supplied (pop-eval-stack))
524 (delta (- desired supplied)))
525 (declare (type index desired supplied)
527 (cond ((minusp delta)
528 (incf *eval-stack-top* delta))
531 (push-eval-stack nil)))))
532 (byte-interpret component pc fp))
534 ;;; %THROW is compiled down into this xop. The stack contains the tag, the
535 ;;; values, and then a count of the values. We special case various small
536 ;;; numbers of values to keep from consing if we can help it.
538 ;;; Basically, we just extract the values and the tag and then do a throw.
539 ;;; The native compiler will convert this throw into whatever is necessary
540 ;;; to throw, so we don't have to duplicate all that cruft.
541 (define-xop throw (component old-pc pc fp)
542 (declare (type code-component component)
545 (type stack-pointer fp))
546 (let ((num-results (pop-eval-stack)))
547 (declare (type index num-results))
550 (let ((tag (pop-eval-stack)))
551 (with-debugger-info (component old-pc fp)
552 (throw tag (values)))))
554 (multiple-value-pop-eval-stack
556 (with-debugger-info (component old-pc fp)
557 (throw tag result))))
559 (multiple-value-pop-eval-stack
560 (tag result0 result1)
561 (with-debugger-info (component old-pc fp)
562 (throw tag (values result0 result1)))))
565 (dotimes (i num-results)
566 (push (pop-eval-stack) results))
567 (let ((tag (pop-eval-stack)))
568 (with-debugger-info (component old-pc fp)
569 (throw tag (values-list results)))))))))
571 ;;; This is used for both CATCHes and BLOCKs that are closed over. We
572 ;;; establish a catcher for the supplied tag (from the stack top), and
573 ;;; recursivly enter the byte interpreter. If the byte interpreter exits,
574 ;;; it must have been because of a BREAKUP (see below), so we branch (by
575 ;;; tail-calling the byte interpreter) to the pc returned by BREAKUP.
576 ;;; If we are thrown to, then we branch to the address encoded in the 3 bytes
577 ;;; following the catch XOP.
578 (define-xop catch (component old-pc pc fp)
579 (declare (type code-component component)
582 (type stack-pointer fp))
583 (let ((new-pc (block nil
586 (catch (pop-eval-stack)
587 (return (byte-interpret component (+ pc 3) fp))))))
588 (let ((num-results 0))
589 (declare (type index num-results))
590 (dolist (result results)
591 (push-eval-stack result)
593 (push-eval-stack num-results))
594 (component-ref-24 component pc)))))
595 (byte-interpret component new-pc fp)))
597 ;;; Blow out of the dynamically nested CATCH or TAGBODY. We just return the
598 ;;; pc following the BREAKUP XOP and the drop-through code in CATCH or
599 ;;; TAGBODY will do the correct thing.
600 (define-xop breakup (component old-pc pc fp)
601 (declare (ignore component old-pc fp)
605 ;;; This is exactly like THROW, except that the tag is the last thing
606 ;;; on the stack instead of the first. This is used for RETURN-FROM
607 ;;; (hence the name).
608 (define-xop return-from (component old-pc pc fp)
609 (declare (type code-component component)
612 (type stack-pointer fp))
613 (let ((tag (pop-eval-stack))
614 (num-results (pop-eval-stack)))
615 (declare (type index num-results))
618 (with-debugger-info (component old-pc fp)
619 (throw tag (values))))
621 (let ((value (pop-eval-stack)))
622 (with-debugger-info (component old-pc fp)
625 (multiple-value-pop-eval-stack
627 (with-debugger-info (component old-pc fp)
628 (throw tag (values result0 result1)))))
631 (dotimes (i num-results)
632 (push (pop-eval-stack) results))
633 (with-debugger-info (component old-pc fp)
634 (throw tag (values-list results))))))))
636 ;;; Similar to CATCH, except for TAGBODY. One significant difference is that
637 ;;; when thrown to, we don't want to leave the dynamic extent of the tagbody
638 ;;; so we loop around and re-enter the catcher. We keep looping until BREAKUP
639 ;;; is used to blow out. When that happens, we just branch to the pc supplied
641 (define-xop tagbody (component old-pc pc fp)
642 (declare (type code-component component)
645 (type stack-pointer fp))
646 (let* ((tag (pop-eval-stack))
651 (return (byte-interpret component pc fp))))))))
652 (byte-interpret component new-pc fp)))
654 ;;; Yup, you guessed it. This XOP implements GO. There are no values to
655 ;;; pass, so we don't have to mess with them, and multiple exits can all be
656 ;;; using the same tag so we have to pass the pc we want to go to.
657 (define-xop go (component old-pc pc fp)
658 (declare (type code-component component)
660 (type stack-pointer fp))
661 (let ((tag (pop-eval-stack))
662 (new-pc (component-ref-24 component pc)))
663 (with-debugger-info (component old-pc fp)
664 (throw tag new-pc))))
666 ;;; UNWIND-PROTECTs are handled significantly different in the byte
667 ;;; compiler and the native compiler. Basically, we just use the
668 ;;; native compiler's UNWIND-PROTECT, and let it worry about
669 ;;; continuing the unwind.
670 (define-xop unwind-protect (component old-pc pc fp)
671 (declare (type code-component component)
674 (type stack-pointer fp))
677 (setf new-pc (byte-interpret component (+ pc 3) fp))
679 ;; The cleanup function expects 3 values to be one the stack, so
680 ;; we have to put something there.
681 (push-eval-stack nil)
682 (push-eval-stack nil)
683 (push-eval-stack nil)
684 ;; Now run the cleanup code.
685 (byte-interpret component (component-ref-24 component pc) fp)))
686 (byte-interpret component new-pc fp)))
688 (define-xop fdefn-function-or-lose (component old-pc pc fp)
689 (let* ((fdefn (pop-eval-stack))
690 (fun (fdefn-function fdefn)))
691 (declare (type fdefn fdefn))
693 (push-eval-stack fun)
694 (byte-interpret component pc fp))
696 (with-debugger-info (component old-pc fp)
697 (error 'undefined-function :name (fdefn-name fdefn)))))))
699 ;;; This is used to insert placeholder arguments for unused arguments
701 (define-xop push-n-under (component old-pc pc fp)
702 (declare (ignore old-pc))
703 (with-extended-operand (component pc howmany new-pc)
704 (let ((val (pop-eval-stack)))
705 (allocate-eval-stack howmany)
706 (push-eval-stack val))
707 (byte-interpret component new-pc fp)))
711 ;;; These two hashtables map between type specifiers and type
712 ;;; predicate functions that test those types. They are initialized
713 ;;; according to the standard type predicates of the target system.
714 (defvar *byte-type-predicates* (make-hash-table :test 'equal))
715 (defvar *byte-predicate-types* (make-hash-table :test 'eq))
717 (loop for (type predicate) in
718 '#.(loop for (type . predicate) in
719 *backend-type-predicates*
720 collect `(,(type-specifier type) ,predicate))
722 (let ((fun (fdefinition predicate)))
723 (setf (gethash type *byte-type-predicates*) fun)
724 (setf (gethash fun *byte-predicate-types*) type)))
726 ;;; This is called by the loader to convert a type specifier into a
727 ;;; type predicate (as used by the TYPE-CHECK XOP.) If it is a
728 ;;; structure type with a predicate or has a predefined predicate,
729 ;;; then return the predicate function, otherwise return the CTYPE
730 ;;; structure for the type.
731 (defun load-type-predicate (desc)
732 (or (gethash desc *byte-type-predicates*)
733 (let ((type (specifier-type desc)))
734 (if (typep type 'structure-class)
735 (let ((info (layout-info (class-layout type))))
736 (if (and info (eq (dd-type info) 'structure))
737 (let ((predicate-name (dd-predicate-name info)))
738 (if (and predicate-name (fboundp predicate-name))
739 (fdefinition predicate-name)
744 ;;; Check the type of the value on the top of the stack. The type is
745 ;;; designated by an entry in the constants. If the value is a
746 ;;; function, then it is called as a type predicate. Otherwise, the
747 ;;; value is a CTYPE object, and we call %TYPEP on it.
748 (define-xop type-check (component old-pc pc fp)
749 (declare (type code-component component)
751 (type stack-pointer fp))
752 (with-extended-operand (component pc operand new-pc)
753 (let ((value (eval-stack-ref (1- *eval-stack-top*)))
754 (type (code-header-ref component
755 (+ operand sb!vm:code-constants-offset))))
756 (unless (if (functionp type)
759 (with-debugger-info (component old-pc fp)
762 :expected-type (if (functionp type)
763 (gethash type *byte-predicate-types*)
764 (type-specifier type))))))
766 (byte-interpret component new-pc fp)))
768 ;;;; the actual byte-interpreter
770 ;;; The various operations are encoded as follows.
772 ;;; 0000xxxx push-local op
773 ;;; 0001xxxx push-arg op [push-local, but negative]
774 ;;; 0010xxxx push-constant op
775 ;;; 0011xxxx push-system-constant op
776 ;;; 0100xxxx push-int op
777 ;;; 0101xxxx push-neg-int op
778 ;;; 0110xxxx pop-local op
779 ;;; 0111xxxx pop-n op
781 ;;; 1001nxxx tail-call op
782 ;;; 1010nxxx multiple-call op
783 ;;; 10110xxx local-call
784 ;;; 10111xxx local-tail-call
785 ;;; 11000xxx local-multiple-call
789 ;;; 1101010r if-false
793 ;;; to various inline functions.
796 ;;; This encoding is rather hard wired into BYTE-INTERPRET due to the
797 ;;; binary dispatch tree.
799 (defvar *byte-trace* nil)
801 ;;; the main entry point to the byte interpreter
802 (defun byte-interpret (component pc fp)
803 (declare (type code-component component)
805 (type stack-pointer fp))
806 (byte-interpret-byte component pc fp (component-ref component pc)))
808 ;;; This is separated from BYTE-INTERPRET in order to let us continue
809 ;;; from a breakpoint without having to replace the breakpoint with
810 ;;; the original instruction and arrange to somehow put the breakpoint
811 ;;; back after executing the instruction. We just leave the breakpoint
812 ;;; there, and call this function with the byte that the breakpoint
814 (defun byte-interpret-byte (component pc fp byte)
815 (declare (type code-component component)
817 (type stack-pointer fp)
818 (type (unsigned-byte 8) byte))
820 #+nil (declare (optimize (inhibit-warnings 3)))
822 (let ((*byte-trace* nil))
823 (format *trace-output*
824 "pc=~D, fp=~D, sp=~D, byte=#b~,'0X, frame:~% ~S~%"
825 pc fp *eval-stack-top* byte
826 (subseq sb!bytecode::*eval-stack* fp *eval-stack-top*)))))
827 (if (zerop (logand byte #x80))
828 ;; Some stack operation. No matter what, we need the operand,
830 (multiple-value-bind (operand new-pc)
831 (let ((operand (logand byte #xf)))
833 (let ((operand (component-ref component (1+ pc))))
835 (values (component-ref-24 component (+ pc 2))
837 (values operand (+ pc 2))))
838 (values operand (1+ pc))))
839 (if (zerop (logand byte #x40))
840 (push-eval-stack (if (zerop (logand byte #x20))
841 (if (zerop (logand byte #x10))
842 (eval-stack-ref (+ fp operand))
843 (eval-stack-ref (- fp operand 5)))
844 (if (zerop (logand byte #x10))
847 (+ operand sb!vm:code-constants-offset))
848 (svref *system-constants* operand))))
849 (if (zerop (logand byte #x20))
850 (push-eval-stack (if (zerop (logand byte #x10))
853 (if (zerop (logand byte #x10))
854 (setf (eval-stack-ref (+ fp operand)) (pop-eval-stack))
856 (let ((operand (pop-eval-stack)))
857 (declare (type index operand))
858 (decf *eval-stack-top* operand))
859 (decf *eval-stack-top* operand)))))
860 (byte-interpret component new-pc fp))
861 (if (zerop (logand byte #x40))
862 ;; Some kind of call.
863 (let ((args (let ((args (logand byte #x07)))
867 (if (zerop (logand byte #x20))
868 (let ((named (not (zerop (logand byte #x08)))))
869 (if (zerop (logand byte #x10))
870 ;; Call for single value.
871 (do-call component pc (1+ pc) fp args named)
873 (do-tail-call component pc fp args named)))
874 (if (zerop (logand byte #x10))
875 ;; Call for multiple-values.
876 (do-call component pc (- (1+ pc)) fp args
877 (not (zerop (logand byte #x08))))
878 (if (zerop (logand byte #x08))
880 (do-local-call component pc (+ pc 4) fp args)
882 (do-tail-local-call component pc fp args)))))
883 (if (zerop (logand byte #x20))
884 ;; local-multiple-call, Return, branch, or Xop.
885 (if (zerop (logand byte #x10))
886 ;; local-multiple-call or return.
887 (if (zerop (logand byte #x08))
888 ;; Local-multiple-call.
889 (do-local-call component pc (- (+ pc 4)) fp
890 (let ((args (logand byte #x07)))
896 (let ((num-results (logand byte #x7)))
897 (if (= num-results 7)
900 (do-return fp num-results)))
902 (if (zerop (logand byte #x08))
904 (if (if (zerop (logand byte #x04))
905 (if (zerop (logand byte #x02))
908 (if (zerop (logand byte #x02))
909 (not (pop-eval-stack))
910 (multiple-value-pop-eval-stack
916 (if (zerop (logand byte #x01))
917 (component-ref-24 component (1+ pc))
919 (component-ref-signed component (1+ pc))))
922 (byte-interpret component
923 (if (zerop (logand byte #x01))
928 (multiple-value-bind (sub-code new-pc)
929 (let ((operand (logand byte #x7)))
931 (values (component-ref component (+ pc 1))
933 (values operand (1+ pc))))
934 (funcall (the function (svref *byte-xops* sub-code))
935 component pc new-pc fp))))
936 ;; some miscellaneous inline function
938 (expand-into-inlines)
939 (byte-interpret component (1+ pc) fp))))))
941 (defun do-local-call (component pc old-pc old-fp num-args)
942 (declare (type pc pc)
943 (type return-pc old-pc)
944 (type stack-pointer old-fp)
945 (type (integer 0 #.call-arguments-limit) num-args))
946 (invoke-local-entry-point component (component-ref-24 component (1+ pc))
948 (- *eval-stack-top* num-args)
951 (defun do-tail-local-call (component pc fp num-args)
952 (declare (type code-component component) (type pc pc)
953 (type stack-pointer fp)
954 (type index num-args))
955 (let ((old-fp (eval-stack-ref (- fp 1)))
956 (old-sp (eval-stack-ref (- fp 2)))
957 (old-pc (eval-stack-ref (- fp 3)))
958 (old-component (eval-stack-ref (- fp 4)))
959 (start-of-args (- *eval-stack-top* num-args)))
960 (eval-stack-copy old-sp start-of-args num-args)
961 (setf *eval-stack-top* (+ old-sp num-args))
962 (invoke-local-entry-point component (component-ref-24 component (1+ pc))
963 old-component old-pc old-sp old-fp)))
965 (defun invoke-local-entry-point (component target old-component old-pc old-sp
966 old-fp &optional closure-vars)
967 (declare (type pc target)
968 (type return-pc old-pc)
969 (type stack-pointer old-sp old-fp)
970 (type (or null simple-vector) closure-vars))
972 (named-let more ((index (1- (length closure-vars))))
973 (unless (minusp index)
974 (push-eval-stack (svref closure-vars index))
976 (push-eval-stack old-component)
977 (push-eval-stack old-pc)
978 (push-eval-stack old-sp)
979 (push-eval-stack old-fp)
980 (multiple-value-bind (stack-frame-size entry-pc)
981 (let ((byte (component-ref component target)))
983 (values (component-ref-24 component (1+ target)) (+ target 4))
984 (values (* byte 2) (1+ target))))
985 (declare (type pc entry-pc))
986 (let ((fp *eval-stack-top*))
987 (allocate-eval-stack stack-frame-size)
988 (byte-interpret component entry-pc fp))))
990 ;;; Call a function with some arguments popped off of the interpreter
991 ;;; stack, and restore the SP to the specified value.
992 (defun byte-apply (function num-args restore-sp)
993 (declare (type function function) (type index num-args))
994 (let ((start (- *eval-stack-top* num-args)))
995 (declare (type stack-pointer start))
998 ,@(loop for n below 8
999 collect `(,n (call-1 ,n)))
1002 (end (+ start num-args)))
1003 (declare (type stack-pointer end))
1004 (do ((i (1- end) (1- i)))
1006 (declare (fixnum i))
1007 (push (eval-stack-ref i) args))
1008 (setf *eval-stack-top* restore-sp)
1009 (apply function args)))))
1014 (let ((dum (gensym)))
1015 (binds `(,dum (eval-stack-ref (+ start ,i))))
1018 (setf *eval-stack-top* restore-sp)
1019 (funcall function ,@(args))))))
1022 ;;; Note: negative RET-PC is a convention for "we need multiple return
1024 (defun do-call (old-component call-pc ret-pc old-fp num-args named)
1025 (declare (type code-component old-component)
1027 (type return-pc ret-pc)
1028 (type stack-pointer old-fp)
1029 (type (integer 0 #.call-arguments-limit) num-args)
1030 (type (member t nil) named))
1031 (let* ((old-sp (- *eval-stack-top* num-args 1))
1032 (fun-or-fdefn (eval-stack-ref old-sp))
1034 (or (fdefn-function fun-or-fdefn)
1035 (with-debugger-info (old-component call-pc old-fp)
1036 (error 'undefined-function
1037 :name (fdefn-name fun-or-fdefn))))
1039 (declare (type stack-pointer old-sp)
1040 (type (or function fdefn) fun-or-fdefn)
1041 (type function function))
1044 (invoke-xep old-component ret-pc old-sp old-fp num-args function))
1046 (invoke-xep old-component ret-pc old-sp old-fp num-args
1047 (byte-closure-function function)
1048 (byte-closure-data function)))
1050 (cond ((minusp ret-pc)
1051 (let* ((ret-pc (- ret-pc))
1053 (multiple-value-list
1055 (old-component ret-pc old-fp)
1056 (byte-apply function num-args old-sp)))))
1057 (dolist (result results)
1058 (push-eval-stack result))
1059 (push-eval-stack (length results))
1060 (byte-interpret old-component ret-pc old-fp)))
1064 (old-component ret-pc old-fp)
1065 (byte-apply function num-args old-sp)))
1066 (byte-interpret old-component ret-pc old-fp)))))))
1068 (defun do-tail-call (component pc fp num-args named)
1069 (declare (type code-component component)
1071 (type stack-pointer fp)
1072 (type (integer 0 #.call-arguments-limit) num-args)
1073 (type (member t nil) named))
1074 (let* ((start-of-args (- *eval-stack-top* num-args))
1075 (fun-or-fdefn (eval-stack-ref (1- start-of-args)))
1077 (or (fdefn-function fun-or-fdefn)
1078 (with-debugger-info (component pc fp)
1079 (error 'undefined-function
1080 :name (fdefn-name fun-or-fdefn))))
1082 (old-fp (eval-stack-ref (- fp 1)))
1083 (old-sp (eval-stack-ref (- fp 2)))
1084 (old-pc (eval-stack-ref (- fp 3)))
1085 (old-component (eval-stack-ref (- fp 4))))
1086 (declare (type stack-pointer old-fp old-sp start-of-args)
1087 (type return-pc old-pc)
1088 (type (or fdefn function) fun-or-fdefn)
1089 (type function function))
1092 (eval-stack-copy old-sp start-of-args num-args)
1093 (setf *eval-stack-top* (+ old-sp num-args))
1094 (invoke-xep old-component old-pc old-sp old-fp num-args function))
1096 (eval-stack-copy old-sp start-of-args num-args)
1097 (setf *eval-stack-top* (+ old-sp num-args))
1098 (invoke-xep old-component old-pc old-sp old-fp num-args
1099 (byte-closure-function function)
1100 (byte-closure-data function)))
1102 ;; We are tail-calling native code.
1103 (cond ((null old-component)
1104 ;; We were called by native code.
1105 (byte-apply function num-args old-sp))
1107 ;; We were called for multiple values. So return multiple
1109 (let* ((old-pc (- old-pc))
1111 (multiple-value-list
1113 (old-component old-pc old-fp)
1114 (byte-apply function num-args old-sp)))))
1115 (dolist (result results)
1116 (push-eval-stack result))
1117 (push-eval-stack (length results))
1118 (byte-interpret old-component old-pc old-fp)))
1120 ;; We were called for one value. So return one value.
1123 (old-component old-pc old-fp)
1124 (byte-apply function num-args old-sp)))
1125 (byte-interpret old-component old-pc old-fp)))))))
1127 (defvar *byte-trace-calls* nil)
1129 (defun invoke-xep (old-component ret-pc old-sp old-fp num-args xep
1130 &optional closure-vars)
1131 (declare (type (or null code-component) old-component)
1132 (type index num-args)
1133 (type return-pc ret-pc)
1134 (type stack-pointer old-sp old-fp)
1135 (type byte-function xep)
1136 (type (or null simple-vector) closure-vars))
1137 ;; FIXME: Perhaps BYTE-TRACE-CALLS stuff should be conditional on SB-SHOW.
1138 (when *byte-trace-calls*
1139 (let ((*byte-trace-calls* nil)
1141 (*print-level* sb!debug:*debug-print-level*)
1142 (*print-length* sb!debug:*debug-print-length*)
1143 (sp *eval-stack-top*))
1144 (format *trace-output*
1145 "~&INVOKE-XEP: ocode= ~S[~D]~% ~
1146 osp= ~D, ofp= ~D, nargs= ~D, SP= ~D:~% ~
1147 Fun= ~S ~@[~S~]~% Args= ~S~%"
1148 old-component ret-pc old-sp old-fp num-args sp
1149 xep closure-vars (subseq *eval-stack* (- sp num-args) sp))
1150 (force-output *trace-output*)))
1154 ((typep xep 'simple-byte-function)
1155 (unless (eql (simple-byte-function-num-args xep) num-args)
1156 (with-debugger-info (old-component ret-pc old-fp)
1157 (error "wrong number of arguments")))
1158 (simple-byte-function-entry-point xep))
1160 (let ((min (hairy-byte-function-min-args xep))
1161 (max (hairy-byte-function-max-args xep)))
1164 (with-debugger-info (old-component ret-pc old-fp)
1165 (error "not enough arguments")))
1167 (nth (- num-args min) (hairy-byte-function-entry-points xep)))
1168 ((null (hairy-byte-function-more-args-entry-point xep))
1169 (with-debugger-info (old-component ret-pc old-fp)
1170 (error "too many arguments")))
1172 (let* ((more-args-supplied (- num-args max))
1173 (sp *eval-stack-top*)
1174 (more-args-start (- sp more-args-supplied))
1175 (restp (hairy-byte-function-rest-arg-p xep))
1177 (do ((index (1- sp) (1- index))
1179 (cons (eval-stack-ref index)
1181 ((< index more-args-start) result)
1182 (declare (fixnum index))))))
1183 (declare (type index more-args-supplied)
1184 (type stack-pointer more-args-start))
1186 ((not (hairy-byte-function-keywords-p xep))
1188 (setf *eval-stack-top* (1+ more-args-start))
1189 (setf (eval-stack-ref more-args-start) rest))
1191 (unless (evenp more-args-supplied)
1192 (with-debugger-info (old-component ret-pc old-fp)
1193 (error "odd number of &KEY arguments")))
1194 ;; If there are &KEY args, then we need to leave
1195 ;; the defaulted and supplied-p values where the
1196 ;; more args currently are. There might be more or
1197 ;; fewer. And also, we need to flatten the parsed
1198 ;; args with the defaults before we scan the
1199 ;; keywords. So we copy all the &MORE args to a
1200 ;; temporary area at the end of the stack.
1201 (let* ((num-more-args
1202 (hairy-byte-function-num-more-args xep))
1203 (new-sp (+ more-args-start num-more-args))
1204 (temp (max sp new-sp))
1205 (temp-sp (+ temp more-args-supplied))
1206 (keywords (hairy-byte-function-keywords xep)))
1207 (declare (type index temp)
1208 (type stack-pointer new-sp temp-sp))
1209 (allocate-eval-stack (- temp-sp sp))
1210 (eval-stack-copy temp more-args-start more-args-supplied)
1212 (setf (eval-stack-ref more-args-start) rest)
1213 (incf more-args-start))
1214 (let ((index more-args-start))
1215 (dolist (keyword keywords)
1216 (setf (eval-stack-ref index) (cadr keyword))
1218 (when (caddr keyword)
1219 (setf (eval-stack-ref index) nil)
1221 (let ((index temp-sp)
1222 (allow (eq (hairy-byte-function-keywords-p xep)
1226 (declare (type fixnum index))
1229 (when (< index temp)
1231 (let ((key (eval-stack-ref index))
1232 (value (eval-stack-ref (1+ index))))
1233 (if (eq key :allow-other-keys)
1235 (let ((target more-args-start))
1236 (declare (type stack-pointer target))
1237 (dolist (keyword keywords
1240 (cond ((eq (car keyword) key)
1241 (setf (eval-stack-ref target) value)
1242 (when (caddr keyword)
1243 (setf (eval-stack-ref (1+ target))
1249 (incf target))))))))
1250 (when (and bogus-key-p (not allow))
1251 (with-debugger-info (old-component ret-pc old-fp)
1252 (error "unknown keyword: ~S" bogus-key))))
1253 (setf *eval-stack-top* new-sp)))))
1254 (hairy-byte-function-more-args-entry-point xep))))))))
1255 (declare (type pc entry-point))
1256 (invoke-local-entry-point (byte-function-component xep) entry-point
1257 old-component ret-pc old-sp old-fp
1260 (defun do-return (fp num-results)
1261 (declare (type stack-pointer fp) (type index num-results))
1262 (let ((old-component (eval-stack-ref (- fp 4))))
1263 (typecase old-component
1265 ;; returning to more byte-interpreted code
1266 (do-local-return old-component fp num-results))
1268 ;; returning to native code
1269 (let ((old-sp (eval-stack-ref (- fp 2))))
1272 (setf *eval-stack-top* old-sp)
1275 (let ((result (pop-eval-stack)))
1276 (setf *eval-stack-top* old-sp)
1279 (let ((results nil))
1280 (dotimes (i num-results)
1281 (push (pop-eval-stack) results))
1282 (setf *eval-stack-top* old-sp)
1283 (values-list results))))))
1285 ;; ### function end breakpoint?
1286 (error "Function-end breakpoints are not supported.")))))
1288 (defun do-local-return (old-component fp num-results)
1289 (declare (type stack-pointer fp) (type index num-results))
1290 (let ((old-fp (eval-stack-ref (- fp 1)))
1291 (old-sp (eval-stack-ref (- fp 2)))
1292 (old-pc (eval-stack-ref (- fp 3))))
1293 (declare (type (signed-byte 25) old-pc))
1295 ;; wants single value
1296 (let ((result (if (zerop num-results)
1298 (eval-stack-ref (- *eval-stack-top*
1300 (setf *eval-stack-top* old-sp)
1301 (push-eval-stack result)
1302 (byte-interpret old-component old-pc old-fp))
1303 ;; wants multiple values
1305 (eval-stack-copy old-sp
1306 (- *eval-stack-top* num-results)
1308 (setf *eval-stack-top* (+ old-sp num-results))
1309 (push-eval-stack num-results)
1310 (byte-interpret old-component (- old-pc) old-fp)))))