1 ;;;; the byte code interpreter
8 ;;;; This software is part of the SBCL system. See the README file for
11 ;;;; This software is derived from the CMU CL system, which was
12 ;;;; written at Carnegie Mellon University and released into the
13 ;;;; public domain. The software is in the public domain and is
14 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
15 ;;;; files for more information.
17 ;;; We need at least this level of DEBUGness in order for the local
18 ;;; declaration in WITH-DEBUGGER-INFO to take effect.
20 ;;; FIXME: This will cause source code location information to be
21 ;;; compiled into the executable, which will probably cause problems
22 ;;; for users running without the sources and/or without the
23 ;;; build-the-system readtable.
24 (declaim (optimize (debug 2)))
26 ;;; Return a function type approximating the type of a byte-compiled
27 ;;; function. We really only capture the arg signature.
28 (defun byte-function-type (x)
32 `(function ,(make-list (simple-byte-function-num-args x)
37 (let ((min (hairy-byte-function-min-args x))
38 (max (hairy-byte-function-max-args x)))
39 (dotimes (i min) (res 't))
42 (dotimes (i (- max min))
44 (when (hairy-byte-function-rest-arg-p x)
46 (ecase (hairy-byte-function-keywords-p x)
49 (dolist (key (hairy-byte-function-keywords x))
50 (res `(,(car key) t)))
51 (when (eql (hairy-byte-function-keywords-p x) :allow-others)
52 (res '&allow-other-keys)))
54 `(function ,(res) *))))))
56 ;;;; the evaluation stack
58 ;;; the interpreter's evaluation stack
59 (defvar *eval-stack* (make-array 100)) ; will grow as needed
60 ;;; FIXME: This seems to be used by the ordinary (non-byte) interpreter
61 ;;; too, judging from a crash I had when I removed byte-interp.lisp from
62 ;;; the cold build sequence. It would probably be clearer to pull the
63 ;;; shared interpreter machinery out of the byte interpreter and ordinary
64 ;;; interpreter files and put them into their own file shared-interp.lisp
67 ;;; the index of the next free element of the interpreter's evaluation stack
68 (defvar *eval-stack-top* 0)
70 (defmacro current-stack-pointer () '*eval-stack-top*)
72 #!-sb-fluid (declaim (inline eval-stack-ref))
73 (defun eval-stack-ref (offset)
74 (declare (type stack-pointer offset))
75 (svref sb!eval::*eval-stack* offset))
77 #!-sb-fluid (declaim (inline (setf eval-stack-ref)))
78 (defun (setf eval-stack-ref) (new-value offset)
79 (declare (type stack-pointer offset))
80 (setf (svref sb!eval::*eval-stack* offset) new-value))
82 (defun push-eval-stack (value)
83 (let ((len (length (the simple-vector sb!eval::*eval-stack*)))
84 (sp (current-stack-pointer)))
86 (let ((new-stack (make-array (ash len 1))))
87 (replace new-stack sb!eval::*eval-stack* :end1 len :end2 len)
88 (setf sb!eval::*eval-stack* new-stack)))
89 (setf (current-stack-pointer) (1+ sp))
90 (setf (eval-stack-ref sp) value)))
92 (defun allocate-eval-stack (amount)
93 (let* ((len (length (the simple-vector sb!eval::*eval-stack*)))
94 (sp (current-stack-pointer))
95 (new-sp (+ sp amount)))
96 (declare (type index sp new-sp))
98 (let ((new-stack (make-array (ash new-sp 1))))
99 (replace new-stack sb!eval::*eval-stack* :end1 len :end2 len)
100 (setf sb!eval::*eval-stack* new-stack)))
101 (setf (current-stack-pointer) new-sp)
102 (let ((stack sb!eval::*eval-stack*))
103 (do ((i sp (1+ i))) ; FIXME: DOTIMES? or just :INITIAL-ELEMENT in MAKE-ARRAY?
105 (setf (svref stack i) '#:uninitialized))))
108 (defun pop-eval-stack ()
109 (let* ((new-sp (1- (current-stack-pointer)))
110 (value (eval-stack-ref new-sp)))
111 (setf (current-stack-pointer) new-sp)
114 (defmacro multiple-value-pop-eval-stack ((&rest vars) &body body)
115 #+nil (declare (optimize (inhibit-warnings 3)))
116 (let ((num-vars (length vars))
118 (new-sp-var (gensym "NEW-SP-"))
121 (unless (and (consp body) (consp (car body)) (eq (caar body) 'declare))
123 (push (pop body) decls))
124 `(let ((,new-sp-var (- (current-stack-pointer) ,num-vars)))
125 (declare (type stack-pointer ,new-sp-var))
126 (let ,(mapcar #'(lambda (var)
127 `(,var (eval-stack-ref
128 (+ ,new-sp-var ,(incf index)))))
131 (setf (current-stack-pointer) ,new-sp-var)
134 (defun stack-copy (dest src count)
135 (declare (type stack-pointer dest src count))
136 (let ((stack *eval-stack*))
139 (setf (svref stack dest) (svref stack src))
142 (do ((si (1- (+ src count))
144 (di (1- (+ dest count))
147 (declare (fixnum si di))
148 (setf (svref stack di) (svref stack si)))))
151 ;;;; component access magic
153 #!-sb-fluid (declaim (inline component-ref))
154 (defun component-ref (component pc)
155 (declare (type code-component component)
157 (sap-ref-8 (code-instructions component) pc))
159 #!-sb-fluid (declaim (inline (setf component-ref)))
160 (defun (setf component-ref) (value component pc)
161 (declare (type (unsigned-byte 8) value)
162 (type code-component component)
164 (setf (sap-ref-8 (code-instructions component) pc) value))
166 #!-sb-fluid (declaim (inline component-ref-signed))
167 (defun component-ref-signed (component pc)
168 (let ((byte (component-ref component pc)))
170 (logior (ash -1 8) byte)
173 #!-sb-fluid (declaim (inline component-ref-24))
174 (defun component-ref-24 (component pc)
175 (logior (ash (component-ref component pc) 16)
176 (ash (component-ref component (1+ pc)) 8)
177 (component-ref component (+ pc 2))))
179 ;;;; debugging support
181 ;;; This macro binds three magic variables. When the debugger notices that
182 ;;; these three variables are bound, it makes a byte-code frame out of the
183 ;;; supplied information instead of a compiled frame. We set each var in
184 ;;; addition to binding it so the compiler doens't optimize away the binding.
185 (defmacro with-debugger-info ((component pc fp) &body body)
186 `(let ((%byte-interp-component ,component)
187 (%byte-interp-pc ,pc)
188 (%byte-interp-fp ,fp))
189 ;; FIXME: This will cause source code location information to be compiled
190 ;; into the executable, which will probably cause problems for users
191 ;; running without the sources and/or without the build-the-system
193 (declare (optimize (debug 3)))
194 (setf %byte-interp-component %byte-interp-component)
195 (setf %byte-interp-pc %byte-interp-pc)
196 (setf %byte-interp-fp %byte-interp-fp)
199 (defun byte-install-breakpoint (component pc)
200 (declare (type code-component component)
202 (values (unsigned-byte 8)))
203 (let ((orig (component-ref component pc)))
204 (setf (component-ref component pc)
206 (xop-index-or-lose 'breakpoint)))
209 (defun byte-remove-breakpoint (component pc orig)
210 (declare (type code-component component)
212 (type (unsigned-byte 8) orig)
213 (values (unsigned-byte 8)))
214 (setf (component-ref component pc) orig))
216 (defun byte-skip-breakpoint (component pc fp orig)
217 (declare (type code-component component)
219 (type stack-pointer fp)
220 (type (unsigned-byte 8) orig))
221 (byte-interpret-byte component fp pc orig))
223 ;;;; system constants
225 ;;; a table mapping system constant indices to run-time values. We don't
226 ;;; reference the compiler variable at load time, since the interpreter is
228 (defparameter *system-constants*
229 (let ((res (make-array 256)))
230 (dolist (x '#.(collect ((res))
231 (dohash (key value *system-constant-codes*)
232 (res (cons key value)))
236 (setf (svref res value)
237 (if (and (consp key) (eq (car key) '%fdefinition-marker%))
238 (sb!impl::fdefinition-object (cdr key) t)
242 ;;;; byte compiled function constructors/extractors
244 (defun initialize-byte-compiled-function (xep)
245 (declare (type byte-function xep))
246 (push xep (code-header-ref (byte-function-component xep)
247 sb!vm:code-trace-table-offset-slot))
248 (setf (funcallable-instance-function xep)
249 #'(instance-lambda (&more context count)
250 (let ((old-sp (current-stack-pointer)))
251 (declare (type stack-pointer old-sp))
253 (push-eval-stack (%more-arg context i)))
254 (invoke-xep nil 0 old-sp 0 count xep))))
257 (defun make-byte-compiled-closure (xep closure-vars)
258 (declare (type byte-function xep)
259 (type simple-vector closure-vars))
260 (let ((res (make-byte-closure xep closure-vars)))
261 (setf (funcallable-instance-function res)
262 #'(instance-lambda (&more context count)
263 (let ((old-sp (current-stack-pointer)))
264 (declare (type stack-pointer old-sp))
266 (push-eval-stack (%more-arg context i)))
267 (invoke-xep nil 0 old-sp 0 count
268 (byte-closure-function res)
269 (byte-closure-data res)))))
274 ;;; (The idea here seems to be to make sure it's at least 100,
275 ;;; in order to be able to compile the 32+ inline functions
276 ;;; in EXPAND-INTO-INLINES as intended. -- WHN 19991206)
277 (eval-when (:compile-toplevel :execute)
278 (setq sb!ext:*inline-expansion-limit* 100))
280 ;;; FIXME: This doesn't seem to be needed in the target Lisp, only
281 ;;; at build-the-system time.
283 ;;; KLUDGE: This expands into code a la
284 ;;; (IF (ZEROP (LOGAND BYTE 16))
285 ;;; (IF (ZEROP (LOGAND BYTE 8))
286 ;;; (IF (ZEROP (LOGAND BYTE 4))
287 ;;; (IF (ZEROP (LOGAND BYTE 2))
288 ;;; (IF (ZEROP (LOGAND BYTE 1))
289 ;;; (ERROR "Unknown inline function, id=~D" 0)
290 ;;; (ERROR "Unknown inline function, id=~D" 1))
291 ;;; (IF (ZEROP (LOGAND BYTE 1))
292 ;;; (ERROR "Unknown inline function, id=~D" 2)
293 ;;; (ERROR "Unknown inline function, id=~D" 3)))
294 ;;; (IF (ZEROP (LOGAND BYTE 2))
296 ;;; That's probably more efficient than doing a function call (even a
297 ;;; local function call) for every byte interpreted, but I doubt it's
298 ;;; as fast as doing a jump through a table of sixteen addresses.
299 ;;; Perhaps it would be good to recode this as a straightforward
300 ;;; CASE statement and redirect the cleverness previously devoted to
301 ;;; this code to an optimizer for CASE which is smart enough to
302 ;;; implement suitable code as jump tables.
303 (defmacro expand-into-inlines ()
304 #+nil (declare (optimize (inhibit-warnings 3)))
305 (iterate build-dispatch
309 (let ((info (svref *inline-functions* base)))
311 (let* ((spec (type-specifier
312 (inline-function-info-type info)))
313 (arg-types (second spec))
314 (result-type (third spec))
315 (args (make-gensym-list (length arg-types)))
318 (,(inline-function-info-interpreter-function info)
320 `(multiple-value-pop-eval-stack ,args
321 (declare ,@(mapcar #'(lambda (type var)
324 ,(if (and (consp result-type)
325 (eq (car result-type) 'values))
326 (let ((results (make-gensym-list
327 (length (cdr result-type)))))
328 `(multiple-value-bind ,results ,func
329 ,@(mapcar #'(lambda (res)
330 `(push-eval-stack ,res))
332 `(push-eval-stack ,func))))
333 `(error "unknown inline function, id=~D" ,base)))
334 `(if (zerop (logand byte ,(ash 1 bit)))
335 ,(build-dispatch (1- bit) base)
336 ,(build-dispatch (1- bit) (+ base (ash 1 bit)))))))
338 #!-sb-fluid (declaim (inline value-cell-setf))
339 (defun value-cell-setf (value cell)
340 (value-cell-set cell value)
343 #!-sb-fluid (declaim (inline setf-symbol-value))
344 (defun setf-symbol-value (value symbol)
345 (setf (symbol-value symbol) value))
347 #!-sb-fluid (declaim (inline %setf-instance-ref))
348 (defun %setf-instance-ref (new-value instance index)
349 (setf (%instance-ref instance index) new-value))
351 (eval-when (:compile-toplevel)
353 (sb!xc:defmacro %byte-symbol-value (x)
356 (with-debugger-info (component pc fp)
357 (error "unbound variable: ~S" x)))
360 (sb!xc:defmacro %byte-car (x)
363 (with-debugger-info (component pc fp)
364 (error 'simple-type-error :item x :expected-type 'list
365 :format-control "non-list argument to CAR: ~S"
366 :format-arguments (list x))))
369 (sb!xc:defmacro %byte-cdr (x)
372 (with-debugger-info (component pc fp)
373 (error 'simple-type-error :item x :expected-type 'list
374 :format-control "non-list argument to CDR: ~S"
375 :format-arguments (list x))))
380 #!-sb-fluid (declaim (inline %byte-special-bind))
381 (defun %byte-special-bind (value symbol)
382 (sb!sys:%primitive bind value symbol)
385 #!-sb-fluid (declaim (inline %byte-special-unbind))
386 (defun %byte-special-unbind ()
387 (sb!sys:%primitive unbind)
391 #!-sb-fluid (declaim (inline cons-unique-tag))
392 (defun cons-unique-tag ()
393 (list '#:%unique-tag%))
394 ;;; FIXME: Delete this once the system is working.
396 ;;;; two-arg function stubs
398 ;;;; We have two-arg versions of some n-ary functions that are normally
401 (defun two-arg-char= (x y) (char= x y))
402 (defun two-arg-char< (x y) (char< x y))
403 (defun two-arg-char> (x y) (char> x y))
404 (defun two-arg-char-equal (x y) (char-equal x y))
405 (defun two-arg-char-lessp (x y) (char-lessp x y))
406 (defun two-arg-char-greaterp (x y) (char-greaterp x y))
407 (defun two-arg-string= (x y) (string= x y))
408 (defun two-arg-string< (x y) (string= x y))
409 (defun two-arg-string> (x y) (string= x y))
411 ;;;; miscellaneous primitive stubs
413 (macrolet ((frob (name &optional (args '(x)))
414 `(defun ,name ,args (,name ,@args))))
415 (frob %CODE-CODE-SIZE)
416 (frob %CODE-DEBUG-INFO)
417 (frob %CODE-ENTRY-POINTS)
418 (frob %FUNCALLABLE-INSTANCE-FUNCTION)
419 (frob %FUNCALLABLE-INSTANCE-LAYOUT)
420 (frob %FUNCALLABLE-INSTANCE-LEXENV)
421 (frob %FUNCTION-NEXT)
422 (frob %FUNCTION-SELF)
423 (frob %SET-FUNCALLABLE-INSTANCE-FUNCTION (fin new-val)))
427 ;;; (used both by the byte interpreter and by the IR1 interpreter)
428 (defun %progv (vars vals fun)
434 ;;; Extension operations (XOPs) are various magic things that the byte
435 ;;; interpreter needs to do, but can't be represented as a function call.
436 ;;; When the byte interpreter encounters an XOP in the byte stream, it
437 ;;; tail-calls the corresponding XOP routine extracted from *byte-xops*.
438 ;;; The XOP routine can do whatever it wants, probably re-invoking the
439 ;;; byte interpreter.
441 ;;; Fetch an 8/24 bit operand out of the code stream.
442 (eval-when (:compile-toplevel :execute)
443 (sb!xc:defmacro with-extended-operand ((component pc operand new-pc)
445 (once-only ((n-component component)
447 `(multiple-value-bind (,operand ,new-pc)
448 (let ((,operand (component-ref ,n-component ,n-pc)))
449 (if (= ,operand #xff)
450 (values (component-ref-24 ,n-component (1+ ,n-pc))
452 (values ,operand (1+ ,n-pc))))
453 (declare (type index ,operand ,new-pc))
456 ;;; If a real XOP hasn't been defined, this gets invoked and signals an
457 ;;; error. This shouldn't happen in normal operation.
458 (defun undefined-xop (component old-pc pc fp)
459 (declare (ignore component old-pc pc fp))
460 (error "undefined XOP"))
462 ;;; a simple vector of the XOP functions
463 (declaim (type (simple-vector 256) *byte-xops*))
465 (make-array 256 :initial-element #'undefined-xop))
467 ;;; Define a XOP function and install it in *BYTE-XOPS*.
468 (eval-when (:compile-toplevel :execute)
469 (sb!xc:defmacro define-xop (name lambda-list &body body)
470 (let ((defun-name (symbolicate "BYTE-" name "-XOP")))
472 (defun ,defun-name ,lambda-list
474 (setf (aref *byte-xops* ,(xop-index-or-lose name)) #',defun-name)
477 ;;; This is spliced in by the debugger in order to implement breakpoints.
478 (define-xop breakpoint (component old-pc pc fp)
479 (declare (type code-component component)
482 (type stack-pointer fp))
483 ;; Invoke the debugger.
484 (with-debugger-info (component old-pc fp)
485 (sb!di::handle-breakpoint component old-pc fp))
486 ;; Retry the breakpoint XOP in case it was replaced with the original
487 ;; displaced byte-code.
488 (byte-interpret component old-pc fp))
490 ;;; This just duplicates whatever is on the top of the stack.
491 (define-xop dup (component old-pc pc fp)
492 (declare (type code-component component)
495 (type stack-pointer fp))
496 (let ((value (eval-stack-ref (1- (current-stack-pointer)))))
497 (push-eval-stack value))
498 (byte-interpret component pc fp))
500 (define-xop make-closure (component old-pc pc fp)
501 (declare (type code-component component)
504 (type stack-pointer fp))
505 (let* ((num-closure-vars (pop-eval-stack))
506 (closure-vars (make-array num-closure-vars)))
507 (declare (type index num-closure-vars)
508 (type simple-vector closure-vars))
509 (iterate frob ((index (1- num-closure-vars)))
510 (unless (minusp index)
511 (setf (svref closure-vars index) (pop-eval-stack))
513 (push-eval-stack (make-byte-compiled-closure (pop-eval-stack)
515 (byte-interpret component pc fp))
517 (define-xop merge-unknown-values (component old-pc pc fp)
518 (declare (type code-component component)
521 (type stack-pointer fp))
522 (labels ((grovel (remaining-blocks block-count-ptr)
523 (declare (type index remaining-blocks)
524 (type stack-pointer block-count-ptr))
525 (declare (values index stack-pointer))
526 (let ((block-count (eval-stack-ref block-count-ptr)))
527 (declare (type index block-count))
528 (if (= remaining-blocks 1)
529 (values block-count block-count-ptr)
530 (let ((src (- block-count-ptr block-count)))
531 (declare (type index src))
532 (multiple-value-bind (values-above dst)
533 (grovel (1- remaining-blocks) (1- src))
534 (stack-copy dst src block-count)
535 (values (+ values-above block-count)
536 (+ dst block-count))))))))
537 (multiple-value-bind (total-count end-ptr)
538 (grovel (pop-eval-stack) (1- (current-stack-pointer)))
539 (setf (eval-stack-ref end-ptr) total-count)
540 (setf (current-stack-pointer) (1+ end-ptr))))
541 (byte-interpret component pc fp))
543 (define-xop default-unknown-values (component old-pc pc fp)
544 (declare (type code-component component)
547 (type stack-pointer fp))
548 (let* ((desired (pop-eval-stack))
549 (supplied (pop-eval-stack))
550 (delta (- desired supplied)))
551 (declare (type index desired supplied)
553 (cond ((minusp delta)
554 (incf (current-stack-pointer) delta))
557 (push-eval-stack nil)))))
558 (byte-interpret component pc fp))
560 ;;; %THROW is compiled down into this xop. The stack contains the tag, the
561 ;;; values, and then a count of the values. We special case various small
562 ;;; numbers of values to keep from consing if we can help it.
564 ;;; Basically, we just extract the values and the tag and then do a throw.
565 ;;; The native compiler will convert this throw into whatever is necessary
566 ;;; to throw, so we don't have to duplicate all that cruft.
567 (define-xop throw (component old-pc pc fp)
568 (declare (type code-component component)
571 (type stack-pointer fp))
572 (let ((num-results (pop-eval-stack)))
573 (declare (type index num-results))
576 (let ((tag (pop-eval-stack)))
577 (with-debugger-info (component old-pc fp)
578 (throw tag (values)))))
580 (multiple-value-pop-eval-stack
582 (with-debugger-info (component old-pc fp)
583 (throw tag result))))
585 (multiple-value-pop-eval-stack
586 (tag result0 result1)
587 (with-debugger-info (component old-pc fp)
588 (throw tag (values result0 result1)))))
591 (dotimes (i num-results)
592 (push (pop-eval-stack) results))
593 (let ((tag (pop-eval-stack)))
594 (with-debugger-info (component old-pc fp)
595 (throw tag (values-list results)))))))))
597 ;;; This is used for both CATCHes and BLOCKs that are closed over. We
598 ;;; establish a catcher for the supplied tag (from the stack top), and
599 ;;; recursivly enter the byte interpreter. If the byte interpreter exits,
600 ;;; it must have been because of a BREAKUP (see below), so we branch (by
601 ;;; tail-calling the byte interpreter) to the pc returned by BREAKUP.
602 ;;; If we are thrown to, then we branch to the address encoded in the 3 bytes
603 ;;; following the catch XOP.
604 (define-xop catch (component old-pc pc fp)
605 (declare (type code-component component)
608 (type stack-pointer fp))
609 (let ((new-pc (block nil
612 (catch (pop-eval-stack)
613 (return (byte-interpret component (+ pc 3) fp))))))
614 (let ((num-results 0))
615 (declare (type index num-results))
616 (dolist (result results)
617 (push-eval-stack result)
619 (push-eval-stack num-results))
620 (component-ref-24 component pc)))))
621 (byte-interpret component new-pc fp)))
623 ;;; Blow out of the dynamically nested CATCH or TAGBODY. We just return the
624 ;;; pc following the BREAKUP XOP and the drop-through code in CATCH or
625 ;;; TAGBODY will do the correct thing.
626 (define-xop breakup (component old-pc pc fp)
627 (declare (ignore component old-pc fp)
631 ;;; This is exactly like THROW, except that the tag is the last thing on
632 ;;; the stack instead of the first. This is used for RETURN-FROM (hence the
634 (define-xop return-from (component old-pc pc fp)
635 (declare (type code-component component)
638 (type stack-pointer fp))
639 (let ((tag (pop-eval-stack))
640 (num-results (pop-eval-stack)))
641 (declare (type index num-results))
644 (with-debugger-info (component old-pc fp)
645 (throw tag (values))))
647 (let ((value (pop-eval-stack)))
648 (with-debugger-info (component old-pc fp)
651 (multiple-value-pop-eval-stack
653 (with-debugger-info (component old-pc fp)
654 (throw tag (values result0 result1)))))
657 (dotimes (i num-results)
658 (push (pop-eval-stack) results))
659 (with-debugger-info (component old-pc fp)
660 (throw tag (values-list results))))))))
662 ;;; Similar to CATCH, except for TAGBODY. One significant difference is that
663 ;;; when thrown to, we don't want to leave the dynamic extent of the tagbody
664 ;;; so we loop around and re-enter the catcher. We keep looping until BREAKUP
665 ;;; is used to blow out. When that happens, we just branch to the pc supplied
667 (define-xop tagbody (component old-pc pc fp)
668 (declare (type code-component component)
671 (type stack-pointer fp))
672 (let* ((tag (pop-eval-stack))
677 (return (byte-interpret component pc fp))))))))
678 (byte-interpret component new-pc fp)))
680 ;;; Yup, you guessed it. This XOP implements GO. There are no values to
681 ;;; pass, so we don't have to mess with them, and multiple exits can all be
682 ;;; using the same tag so we have to pass the pc we want to go to.
683 (define-xop go (component old-pc pc fp)
684 (declare (type code-component component)
686 (type stack-pointer fp))
687 (let ((tag (pop-eval-stack))
688 (new-pc (component-ref-24 component pc)))
689 (with-debugger-info (component old-pc fp)
690 (throw tag new-pc))))
692 ;;; UNWIND-PROTECTs are handled significantly different in the byte
693 ;;; compiler and the native compiler. Basically, we just use the
694 ;;; native compiler's UNWIND-PROTECT, and let it worry about
695 ;;; continuing the unwind.
696 (define-xop unwind-protect (component old-pc pc fp)
697 (declare (type code-component component)
700 (type stack-pointer fp))
703 (setf new-pc (byte-interpret component (+ pc 3) fp))
705 ;; The cleanup function expects 3 values to be one the stack, so
706 ;; we have to put something there.
707 (push-eval-stack nil)
708 (push-eval-stack nil)
709 (push-eval-stack nil)
710 ;; Now run the cleanup code.
711 (byte-interpret component (component-ref-24 component pc) fp)))
712 (byte-interpret component new-pc fp)))
714 (define-xop fdefn-function-or-lose (component old-pc pc fp)
715 (let* ((fdefn (pop-eval-stack))
716 (fun (fdefn-function fdefn)))
717 (declare (type fdefn fdefn))
719 (push-eval-stack fun)
720 (byte-interpret component pc fp))
722 (with-debugger-info (component old-pc fp)
723 (error 'undefined-function :name (fdefn-name fdefn)))))))
725 ;;; This is used to insert placeholder arguments for unused arguments
727 (define-xop push-n-under (component old-pc pc fp)
728 (declare (ignore old-pc))
729 (with-extended-operand (component pc howmany new-pc)
730 (let ((val (pop-eval-stack)))
731 (allocate-eval-stack howmany)
732 (push-eval-stack val))
733 (byte-interpret component new-pc fp)))
737 ;;; These two hashtables map between type specifiers and type
738 ;;; predicate functions that test those types. They are initialized
739 ;;; according to the standard type predicates of the target system.
740 (defvar *byte-type-predicates* (make-hash-table :test 'equal))
741 (defvar *byte-predicate-types* (make-hash-table :test 'eq))
743 (loop for (type predicate) in
744 '#.(loop for (type . predicate) in
745 *backend-type-predicates*
746 collect `(,(type-specifier type) ,predicate))
748 (let ((fun (fdefinition predicate)))
749 (setf (gethash type *byte-type-predicates*) fun)
750 (setf (gethash fun *byte-predicate-types*) type)))
752 ;;; This is called by the loader to convert a type specifier into a
753 ;;; type predicate (as used by the TYPE-CHECK XOP.) If it is a
754 ;;; structure type with a predicate or has a predefined predicate,
755 ;;; then return the predicate function, otherwise return the CTYPE
756 ;;; structure for the type.
757 (defun load-type-predicate (desc)
758 (or (gethash desc *byte-type-predicates*)
759 (let ((type (specifier-type desc)))
760 (if (typep type 'structure-class)
761 (let ((info (layout-info (class-layout type))))
762 (if (and info (eq (dd-type info) 'structure))
763 (let ((pred (dd-predicate info)))
764 (if (and pred (fboundp pred))
770 ;;; Check the type of the value on the top of the stack. The type is
771 ;;; designated by an entry in the constants. If the value is a
772 ;;; function, then it is called as a type predicate. Otherwise, the
773 ;;; value is a CTYPE object, and we call %TYPEP on it.
774 (define-xop type-check (component old-pc pc fp)
775 (declare (type code-component component)
777 (type stack-pointer fp))
778 (with-extended-operand (component pc operand new-pc)
779 (let ((value (eval-stack-ref (1- (current-stack-pointer))))
780 (type (code-header-ref component
781 (+ operand sb!vm:code-constants-offset))))
782 (unless (if (functionp type)
785 (with-debugger-info (component old-pc fp)
788 :expected-type (if (functionp type)
789 (gethash type *byte-predicate-types*)
790 (type-specifier type))))))
792 (byte-interpret component new-pc fp)))
794 ;;;; the byte-interpreter
796 ;;; The various operations are encoded as follows.
798 ;;; 0000xxxx push-local op
799 ;;; 0001xxxx push-arg op [push-local, but negative]
800 ;;; 0010xxxx push-constant op
801 ;;; 0011xxxx push-system-constant op
802 ;;; 0100xxxx push-int op
803 ;;; 0101xxxx push-neg-int op
804 ;;; 0110xxxx pop-local op
805 ;;; 0111xxxx pop-n op
807 ;;; 1001nxxx tail-call op
808 ;;; 1010nxxx multiple-call op
809 ;;; 10110xxx local-call
810 ;;; 10111xxx local-tail-call
811 ;;; 11000xxx local-multiple-call
815 ;;; 1101010r if-false
819 ;;; to various inline functions.
822 ;;; This encoding is rather hard wired into BYTE-INTERPRET due to the
823 ;;; binary dispatch tree.
825 (defvar *byte-trace* nil)
827 ;;; the main entry point to the byte interpreter
828 (defun byte-interpret (component pc fp)
829 (declare (type code-component component)
831 (type stack-pointer fp))
832 (byte-interpret-byte component pc fp (component-ref component pc)))
834 ;;; This is separated from BYTE-INTERPRET in order to let us continue
835 ;;; from a breakpoint without having to replace the breakpoint with
836 ;;; the original instruction and arrange to somehow put the breakpoint
837 ;;; back after executing the instruction. We just leave the breakpoint
838 ;;; there, and call this function with the byte that the breakpoint
840 (defun byte-interpret-byte (component pc fp byte)
841 (declare (type code-component component)
843 (type stack-pointer fp)
844 (type (unsigned-byte 8) byte))
846 #+nil (declare (optimize (inhibit-warnings 3)))
848 (let ((*byte-trace* nil))
849 (format *trace-output*
850 "pc=~D, fp=~D, sp=~D, byte=#b~,'0X, frame:~% ~S~%"
851 pc fp (current-stack-pointer) byte
852 (subseq sb!eval::*eval-stack* fp (current-stack-pointer))))))
853 (if (zerop (logand byte #x80))
854 ;; Some stack operation. No matter what, we need the operand,
856 (multiple-value-bind (operand new-pc)
857 (let ((operand (logand byte #xf)))
859 (let ((operand (component-ref component (1+ pc))))
861 (values (component-ref-24 component (+ pc 2))
863 (values operand (+ pc 2))))
864 (values operand (1+ pc))))
865 (if (zerop (logand byte #x40))
866 (push-eval-stack (if (zerop (logand byte #x20))
867 (if (zerop (logand byte #x10))
868 (eval-stack-ref (+ fp operand))
869 (eval-stack-ref (- fp operand 5)))
870 (if (zerop (logand byte #x10))
873 (+ operand sb!vm:code-constants-offset))
874 (svref *system-constants* operand))))
875 (if (zerop (logand byte #x20))
876 (push-eval-stack (if (zerop (logand byte #x10))
879 (if (zerop (logand byte #x10))
880 (setf (eval-stack-ref (+ fp operand)) (pop-eval-stack))
882 (let ((operand (pop-eval-stack)))
883 (declare (type index operand))
884 (decf (current-stack-pointer) operand))
885 (decf (current-stack-pointer) operand)))))
886 (byte-interpret component new-pc fp))
887 (if (zerop (logand byte #x40))
888 ;; Some kind of call.
889 (let ((args (let ((args (logand byte #x07)))
893 (if (zerop (logand byte #x20))
894 (let ((named (not (zerop (logand byte #x08)))))
895 (if (zerop (logand byte #x10))
896 ;; Call for single value.
897 (do-call component pc (1+ pc) fp args named)
899 (do-tail-call component pc fp args named)))
900 (if (zerop (logand byte #x10))
901 ;; Call for multiple-values.
902 (do-call component pc (- (1+ pc)) fp args
903 (not (zerop (logand byte #x08))))
904 (if (zerop (logand byte #x08))
906 (do-local-call component pc (+ pc 4) fp args)
908 (do-tail-local-call component pc fp args)))))
909 (if (zerop (logand byte #x20))
910 ;; local-multiple-call, Return, branch, or Xop.
911 (if (zerop (logand byte #x10))
912 ;; local-multiple-call or return.
913 (if (zerop (logand byte #x08))
914 ;; Local-multiple-call.
915 (do-local-call component pc (- (+ pc 4)) fp
916 (let ((args (logand byte #x07)))
922 (let ((num-results (logand byte #x7)))
923 (if (= num-results 7)
926 (do-return fp num-results)))
928 (if (zerop (logand byte #x08))
930 (if (if (zerop (logand byte #x04))
931 (if (zerop (logand byte #x02))
934 (if (zerop (logand byte #x02))
935 (not (pop-eval-stack))
936 (multiple-value-pop-eval-stack
942 (if (zerop (logand byte #x01))
943 (component-ref-24 component (1+ pc))
945 (component-ref-signed component (1+ pc))))
948 (byte-interpret component
949 (if (zerop (logand byte #x01))
954 (multiple-value-bind (sub-code new-pc)
955 (let ((operand (logand byte #x7)))
957 (values (component-ref component (+ pc 1))
959 (values operand (1+ pc))))
960 (funcall (the function (svref *byte-xops* sub-code))
961 component pc new-pc fp))))
962 ;; some miscellaneous inline function
964 (expand-into-inlines)
965 (byte-interpret component (1+ pc) fp))))))
967 (defun do-local-call (component pc old-pc old-fp num-args)
968 (declare (type pc pc)
969 (type return-pc old-pc)
970 (type stack-pointer old-fp)
971 (type (integer 0 #.call-arguments-limit) num-args))
972 (invoke-local-entry-point component (component-ref-24 component (1+ pc))
974 (- (current-stack-pointer) num-args)
977 (defun do-tail-local-call (component pc fp num-args)
978 (declare (type code-component component) (type pc pc)
979 (type stack-pointer fp)
980 (type index num-args))
981 (let ((old-fp (eval-stack-ref (- fp 1)))
982 (old-sp (eval-stack-ref (- fp 2)))
983 (old-pc (eval-stack-ref (- fp 3)))
984 (old-component (eval-stack-ref (- fp 4)))
985 (start-of-args (- (current-stack-pointer) num-args)))
986 (stack-copy old-sp start-of-args num-args)
987 (setf (current-stack-pointer) (+ old-sp num-args))
988 (invoke-local-entry-point component (component-ref-24 component (1+ pc))
989 old-component old-pc old-sp old-fp)))
991 (defun invoke-local-entry-point (component target old-component old-pc old-sp
992 old-fp &optional closure-vars)
993 (declare (type pc target)
994 (type return-pc old-pc)
995 (type stack-pointer old-sp old-fp)
996 (type (or null simple-vector) closure-vars))
998 (iterate more ((index (1- (length closure-vars))))
999 (unless (minusp index)
1000 (push-eval-stack (svref closure-vars index))
1001 (more (1- index)))))
1002 (push-eval-stack old-component)
1003 (push-eval-stack old-pc)
1004 (push-eval-stack old-sp)
1005 (push-eval-stack old-fp)
1006 (multiple-value-bind (stack-frame-size entry-pc)
1007 (let ((byte (component-ref component target)))
1009 (values (component-ref-24 component (1+ target)) (+ target 4))
1010 (values (* byte 2) (1+ target))))
1011 (declare (type pc entry-pc))
1012 (let ((fp (current-stack-pointer)))
1013 (allocate-eval-stack stack-frame-size)
1014 (byte-interpret component entry-pc fp))))
1016 ;;; Call a function with some arguments popped off of the interpreter
1017 ;;; stack, and restore the SP to the specifier value.
1018 (defun byte-apply (function num-args restore-sp)
1019 (declare (function function) (type index num-args))
1020 (let ((start (- (current-stack-pointer) num-args)))
1021 (declare (type stack-pointer start))
1024 ,@(loop for n below 8
1025 collect `(,n (call-1 ,n)))
1028 (end (+ start num-args)))
1029 (declare (type stack-pointer end))
1030 (do ((i (1- end) (1- i)))
1032 (declare (fixnum i))
1033 (push (eval-stack-ref i) args))
1034 (setf (current-stack-pointer) restore-sp)
1035 (apply function args)))))
1040 (let ((dum (gensym)))
1041 (binds `(,dum (eval-stack-ref (+ start ,i))))
1044 (setf (current-stack-pointer) restore-sp)
1045 (funcall function ,@(args))))))
1048 (defun do-call (old-component call-pc ret-pc old-fp num-args named)
1049 (declare (type code-component old-component)
1051 (type return-pc ret-pc)
1052 (type stack-pointer old-fp)
1053 (type (integer 0 #.call-arguments-limit) num-args)
1054 (type (member t nil) named))
1055 (let* ((old-sp (- (current-stack-pointer) num-args 1))
1056 (fun-or-fdefn (eval-stack-ref old-sp))
1058 (or (fdefn-function fun-or-fdefn)
1059 (with-debugger-info (old-component call-pc old-fp)
1060 (error 'undefined-function
1061 :name (fdefn-name fun-or-fdefn))))
1063 (declare (type stack-pointer old-sp)
1064 (type (or function fdefn) fun-or-fdefn)
1065 (type function function))
1068 (invoke-xep old-component ret-pc old-sp old-fp num-args function))
1070 (invoke-xep old-component ret-pc old-sp old-fp num-args
1071 (byte-closure-function function)
1072 (byte-closure-data function)))
1074 (cond ((minusp ret-pc)
1075 (let* ((ret-pc (- ret-pc))
1077 (multiple-value-list
1079 (old-component ret-pc old-fp)
1080 (byte-apply function num-args old-sp)))))
1081 (dolist (result results)
1082 (push-eval-stack result))
1083 (push-eval-stack (length results))
1084 (byte-interpret old-component ret-pc old-fp)))
1088 (old-component ret-pc old-fp)
1089 (byte-apply function num-args old-sp)))
1090 (byte-interpret old-component ret-pc old-fp)))))))
1092 (defun do-tail-call (component pc fp num-args named)
1093 (declare (type code-component component)
1095 (type stack-pointer fp)
1096 (type (integer 0 #.call-arguments-limit) num-args)
1097 (type (member t nil) named))
1098 (let* ((start-of-args (- (current-stack-pointer) num-args))
1099 (fun-or-fdefn (eval-stack-ref (1- start-of-args)))
1101 (or (fdefn-function fun-or-fdefn)
1102 (with-debugger-info (component pc fp)
1103 (error 'undefined-function
1104 :name (fdefn-name fun-or-fdefn))))
1106 (old-fp (eval-stack-ref (- fp 1)))
1107 (old-sp (eval-stack-ref (- fp 2)))
1108 (old-pc (eval-stack-ref (- fp 3)))
1109 (old-component (eval-stack-ref (- fp 4))))
1110 (declare (type stack-pointer old-fp old-sp start-of-args)
1111 (type return-pc old-pc)
1112 (type (or fdefn function) fun-or-fdefn)
1113 (type function function))
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 function))
1120 (stack-copy old-sp start-of-args num-args)
1121 (setf (current-stack-pointer) (+ old-sp num-args))
1122 (invoke-xep old-component old-pc old-sp old-fp num-args
1123 (byte-closure-function function)
1124 (byte-closure-data function)))
1126 ;; We are tail-calling native code.
1127 (cond ((null old-component)
1128 ;; We were called by native code.
1129 (byte-apply function num-args old-sp))
1131 ;; We were called for multiple values. So return multiple
1133 (let* ((old-pc (- old-pc))
1135 (multiple-value-list
1137 (old-component old-pc old-fp)
1138 (byte-apply function num-args old-sp)))))
1139 (dolist (result results)
1140 (push-eval-stack result))
1141 (push-eval-stack (length results))
1142 (byte-interpret old-component old-pc old-fp)))
1144 ;; We were called for one value. So return one value.
1147 (old-component old-pc old-fp)
1148 (byte-apply function num-args old-sp)))
1149 (byte-interpret old-component old-pc old-fp)))))))
1151 (defvar *byte-trace-calls* nil)
1153 (defun invoke-xep (old-component ret-pc old-sp old-fp num-args xep
1154 &optional closure-vars)
1155 (declare (type (or null code-component) old-component)
1156 (type index num-args)
1157 (type return-pc ret-pc)
1158 (type stack-pointer old-sp old-fp)
1159 (type byte-function xep)
1160 (type (or null simple-vector) closure-vars))
1161 ;; FIXME: Perhaps BYTE-TRACE-CALLS stuff should be conditional on SB-SHOW.
1162 (when *byte-trace-calls*
1163 (let ((*byte-trace-calls* nil)
1165 (*print-level* sb!debug:*debug-print-level*)
1166 (*print-length* sb!debug:*debug-print-length*)
1167 (sp (current-stack-pointer)))
1168 (format *trace-output*
1169 "~&INVOKE-XEP: ocode= ~S[~D]~% ~
1170 osp= ~D, ofp= ~D, nargs= ~D, SP= ~D:~% ~
1171 Fun= ~S ~@[~S~]~% Args= ~S~%"
1172 old-component ret-pc old-sp old-fp num-args sp
1173 xep closure-vars (subseq *eval-stack* (- sp num-args) sp))
1174 (force-output *trace-output*)))
1178 ((typep xep 'simple-byte-function)
1179 (unless (eql (simple-byte-function-num-args xep) num-args)
1180 (with-debugger-info (old-component ret-pc old-fp)
1181 (error "wrong number of arguments")))
1182 (simple-byte-function-entry-point xep))
1184 (let ((min (hairy-byte-function-min-args xep))
1185 (max (hairy-byte-function-max-args xep)))
1188 (with-debugger-info (old-component ret-pc old-fp)
1189 (error "not enough arguments")))
1191 (nth (- num-args min) (hairy-byte-function-entry-points xep)))
1192 ((null (hairy-byte-function-more-args-entry-point xep))
1193 (with-debugger-info (old-component ret-pc old-fp)
1194 (error "too many arguments")))
1196 (let* ((more-args-supplied (- num-args max))
1197 (sp (current-stack-pointer))
1198 (more-args-start (- sp more-args-supplied))
1199 (restp (hairy-byte-function-rest-arg-p xep))
1201 (do ((index (1- sp) (1- index))
1203 (cons (eval-stack-ref index)
1205 ((< index more-args-start) result)
1206 (declare (fixnum index))))))
1207 (declare (type index more-args-supplied)
1208 (type stack-pointer more-args-start))
1210 ((not (hairy-byte-function-keywords-p xep))
1212 (setf (current-stack-pointer) (1+ more-args-start))
1213 (setf (eval-stack-ref more-args-start) rest))
1215 (unless (evenp more-args-supplied)
1216 (with-debugger-info (old-component ret-pc old-fp)
1217 (error "odd number of keyword arguments")))
1218 ;; If there are keyword args, then we need to leave the
1219 ;; defaulted and supplied-p values where the more args
1220 ;; currently are. There might be more or fewer. And also,
1221 ;; we need to flatten the parsed args with the defaults
1222 ;; before we scan the keywords. So we copy all the more
1223 ;; args to a temporary area at the end of the stack.
1224 (let* ((num-more-args
1225 (hairy-byte-function-num-more-args xep))
1226 (new-sp (+ more-args-start num-more-args))
1227 (temp (max sp new-sp))
1228 (temp-sp (+ temp more-args-supplied))
1229 (keywords (hairy-byte-function-keywords xep)))
1230 (declare (type index temp)
1231 (type stack-pointer new-sp temp-sp))
1232 (allocate-eval-stack (- temp-sp sp))
1233 (stack-copy temp more-args-start more-args-supplied)
1235 (setf (eval-stack-ref more-args-start) rest)
1236 (incf more-args-start))
1237 (let ((index more-args-start))
1238 (dolist (keyword keywords)
1239 (setf (eval-stack-ref index) (cadr keyword))
1241 (when (caddr keyword)
1242 (setf (eval-stack-ref index) nil)
1244 (let ((index temp-sp)
1245 (allow (eq (hairy-byte-function-keywords-p xep)
1249 (declare (type fixnum index))
1252 (when (< index temp)
1254 (let ((key (eval-stack-ref index))
1255 (value (eval-stack-ref (1+ index))))
1256 (if (eq key :allow-other-keys)
1258 (let ((target more-args-start))
1259 (declare (type stack-pointer target))
1260 (dolist (keyword keywords
1263 (cond ((eq (car keyword) key)
1264 (setf (eval-stack-ref target) value)
1265 (when (caddr keyword)
1266 (setf (eval-stack-ref (1+ target))
1272 (incf target))))))))
1273 (when (and bogus-key-p (not allow))
1274 (with-debugger-info (old-component ret-pc old-fp)
1275 (error "unknown keyword: ~S" bogus-key))))
1276 (setf (current-stack-pointer) new-sp)))))
1277 (hairy-byte-function-more-args-entry-point xep))))))))
1278 (declare (type pc entry-point))
1279 (invoke-local-entry-point (byte-function-component xep) entry-point
1280 old-component ret-pc old-sp old-fp
1283 (defun do-return (fp num-results)
1284 (declare (type stack-pointer fp) (type index num-results))
1285 (let ((old-component (eval-stack-ref (- fp 4))))
1286 (typecase old-component
1288 ;; returning to more byte-interpreted code
1289 (do-local-return old-component fp num-results))
1291 ;; returning to native code
1292 (let ((old-sp (eval-stack-ref (- fp 2))))
1295 (setf (current-stack-pointer) old-sp)
1298 (let ((result (pop-eval-stack)))
1299 (setf (current-stack-pointer) old-sp)
1302 (let ((results nil))
1303 (dotimes (i num-results)
1304 (push (pop-eval-stack) results))
1305 (setf (current-stack-pointer) old-sp)
1306 (values-list results))))))
1308 ;; ### function end breakpoint?
1309 (error "Function-end breakpoints are not supported.")))))
1311 (defun do-local-return (old-component fp num-results)
1312 (declare (type stack-pointer fp) (type index num-results))
1313 (let ((old-fp (eval-stack-ref (- fp 1)))
1314 (old-sp (eval-stack-ref (- fp 2)))
1315 (old-pc (eval-stack-ref (- fp 3))))
1316 (declare (type (signed-byte 25) old-pc))
1318 ;; wants single value
1319 (let ((result (if (zerop num-results)
1321 (eval-stack-ref (- (current-stack-pointer)
1323 (setf (current-stack-pointer) old-sp)
1324 (push-eval-stack result)
1325 (byte-interpret old-component old-pc old-fp))
1326 ;; wants multiple values
1328 (stack-copy old-sp (- (current-stack-pointer) num-results)
1330 (setf (current-stack-pointer) (+ old-sp num-results))
1331 (push-eval-stack num-results)
1332 (byte-interpret old-component (- old-pc) old-fp)))))