;;;; the byte code interpreter
+;;; FIXME: should really be in SB!BYTECODE
(in-package "SB!C")
;;;; This software is part of the SBCL system. See the README file for
(etypecase x
(simple-byte-function
`(function ,(make-list (simple-byte-function-num-args x)
- :initial-element 't)
+ :initial-element t)
*))
(hairy-byte-function
(collect ((res))
(let ((min (hairy-byte-function-min-args x))
(max (hairy-byte-function-max-args x)))
- (dotimes (i min) (res 't))
+ (dotimes (i min) (res t))
(when (> max min)
(res '&optional)
(dotimes (i (- max min))
- (res 't))))
+ (res t))))
(when (hairy-byte-function-rest-arg-p x)
- (res '&rest 't))
+ (res '&rest t))
(ecase (hairy-byte-function-keywords-p x)
((t :allow-others)
(res '&key)
((nil)))
`(function ,(res) *))))))
\f
-;;;; the evaluation stack
+;;;; the 'evaluation stack'
+;;;;
+;;;; (The name dates back to CMU CL, when it was used for the IR1
+;;;; interpreted implementation of EVAL. In SBCL >=0.7.0, it's just
+;;;; the byte interpreter stack.)
-;;; the interpreter's evaluation stack
(defvar *eval-stack* (make-array 100)) ; will grow as needed
-;;; FIXME: This seems to be used by the ordinary (non-byte) interpreter
-;;; too, judging from a crash I had when I removed byte-interp.lisp from
-;;; the cold build sequence. It would probably be clearer to pull the
-;;; shared interpreter machinery out of the byte interpreter and ordinary
-;;; interpreter files and put them into their own file shared-interp.lisp
-;;; or something.
;;; the index of the next free element of the interpreter's evaluation stack
(defvar *eval-stack-top* 0)
-(defmacro current-stack-pointer () '*eval-stack-top*)
-
#!-sb-fluid (declaim (inline eval-stack-ref))
(defun eval-stack-ref (offset)
(declare (type stack-pointer offset))
- (svref sb!eval::*eval-stack* offset))
+ (svref sb!bytecode::*eval-stack* offset))
#!-sb-fluid (declaim (inline (setf eval-stack-ref)))
(defun (setf eval-stack-ref) (new-value offset)
(declare (type stack-pointer offset))
- (setf (svref sb!eval::*eval-stack* offset) new-value))
+ (setf (svref sb!bytecode::*eval-stack* offset) new-value))
(defun push-eval-stack (value)
- (let ((len (length (the simple-vector sb!eval::*eval-stack*)))
- (sp (current-stack-pointer)))
+ (let ((len (length (the simple-vector sb!bytecode::*eval-stack*)))
+ (sp *eval-stack-top*))
(when (= len sp)
(let ((new-stack (make-array (ash len 1))))
- (replace new-stack sb!eval::*eval-stack* :end1 len :end2 len)
- (setf sb!eval::*eval-stack* new-stack)))
- (setf (current-stack-pointer) (1+ sp))
+ (replace new-stack sb!bytecode::*eval-stack* :end1 len :end2 len)
+ (setf sb!bytecode::*eval-stack* new-stack)))
+ (setf *eval-stack-top* (1+ sp))
(setf (eval-stack-ref sp) value)))
(defun allocate-eval-stack (amount)
- (let* ((len (length (the simple-vector sb!eval::*eval-stack*)))
- (sp (current-stack-pointer))
+ (let* ((len (length (the simple-vector sb!bytecode::*eval-stack*)))
+ (sp *eval-stack-top*)
(new-sp (+ sp amount)))
(declare (type index sp new-sp))
(when (>= new-sp len)
(let ((new-stack (make-array (ash new-sp 1))))
- (replace new-stack sb!eval::*eval-stack* :end1 len :end2 len)
- (setf sb!eval::*eval-stack* new-stack)))
- (setf (current-stack-pointer) new-sp)
- (let ((stack sb!eval::*eval-stack*))
- (do ((i sp (1+ i))) ; FIXME: DOTIMES? or just :INITIAL-ELEMENT in MAKE-ARRAY?
+ (replace new-stack sb!bytecode::*eval-stack* :end1 len :end2 len)
+ (setf sb!bytecode::*eval-stack* new-stack)))
+ (setf *eval-stack-top* new-sp)
+ (let ((stack sb!bytecode::*eval-stack*))
+ (do ((i sp (1+ i))) ; FIXME: Use CL:FILL.
((= i new-sp))
- (setf (svref stack i) '#:uninitialized))))
+ (setf (svref stack i) '#:uninitialized-eval-stack-element))))
(values))
(defun pop-eval-stack ()
- (let* ((new-sp (1- (current-stack-pointer)))
+ (let* ((new-sp (1- *eval-stack-top*))
(value (eval-stack-ref new-sp)))
- (setf (current-stack-pointer) new-sp)
+ (setf *eval-stack-top* new-sp)
value))
(defmacro multiple-value-pop-eval-stack ((&rest vars) &body body)
(new-sp-var (gensym "NEW-SP-"))
(decls nil))
(loop
- (unless (and (consp body) (consp (car body)) (eq (caar body) 'declare))
+ (unless (and (consp body)
+ (consp (car body))
+ (eq (caar body) 'declare))
(return))
(push (pop body) decls))
- `(let ((,new-sp-var (- (current-stack-pointer) ,num-vars)))
+ `(let ((,new-sp-var (- *eval-stack-top* ,num-vars)))
(declare (type stack-pointer ,new-sp-var))
(let ,(mapcar #'(lambda (var)
`(,var (eval-stack-ref
(+ ,new-sp-var ,(incf index)))))
vars)
,@(nreverse decls)
- (setf (current-stack-pointer) ,new-sp-var)
+ (setf *eval-stack-top* ,new-sp-var)
,@body))))
-(defun stack-copy (dest src count)
+(defun eval-stack-copy (dest src count)
(declare (type stack-pointer dest src count))
(let ((stack *eval-stack*))
(if (< dest src)
(value (cdr x)))
(setf (svref res value)
(if (and (consp key) (eq (car key) '%fdefinition-marker%))
- (sb!impl::fdefinition-object (cdr key) t)
+ (fdefinition-object (cdr key) t)
key))))
res))
\f
sb!vm:code-trace-table-offset-slot))
(setf (funcallable-instance-function xep)
#'(instance-lambda (&more context count)
- (let ((old-sp (current-stack-pointer)))
+ (let ((old-sp *eval-stack-top*))
(declare (type stack-pointer old-sp))
(dotimes (i count)
(push-eval-stack (%more-arg context i)))
(let ((res (make-byte-closure xep closure-vars)))
(setf (funcallable-instance-function res)
#'(instance-lambda (&more context count)
- (let ((old-sp (current-stack-pointer)))
+ (let ((old-sp *eval-stack-top*))
(declare (type stack-pointer old-sp))
(dotimes (i count)
(push-eval-stack (%more-arg context i)))
\f
;;;; miscellaneous primitive stubs
-(macrolet ((frob (name &optional (args '(x)))
+(macrolet ((def-frob (name &optional (args '(x)))
`(defun ,name ,args (,name ,@args))))
- (frob %CODE-CODE-SIZE)
- (frob %CODE-DEBUG-INFO)
- (frob %CODE-ENTRY-POINTS)
- (frob %FUNCALLABLE-INSTANCE-FUNCTION)
- (frob %FUNCALLABLE-INSTANCE-LAYOUT)
- (frob %FUNCALLABLE-INSTANCE-LEXENV)
- (frob %FUNCTION-NEXT)
- (frob %FUNCTION-SELF)
- (frob %SET-FUNCALLABLE-INSTANCE-FUNCTION (fin new-val)))
+ (def-frob %code-code-size)
+ (def-frob %code-debug-info)
+ (def-frob %code-entry-points)
+ (def-frob %funcallable-instance-function)
+ (def-frob %funcallable-instance-layout)
+ (def-frob %funcallable-instance-lexenv)
+ (def-frob %function-next)
+ (def-frob %function-self)
+ (def-frob %set-funcallable-instance-function (fin new-val)))
\f
;;;; funny functions
(ignore old-pc)
(type pc pc)
(type stack-pointer fp))
- (let ((value (eval-stack-ref (1- (current-stack-pointer)))))
+ (let ((value (eval-stack-ref (1- *eval-stack-top*))))
(push-eval-stack value))
(byte-interpret component pc fp))
(declare (type index src))
(multiple-value-bind (values-above dst)
(grovel (1- remaining-blocks) (1- src))
- (stack-copy dst src block-count)
+ (eval-stack-copy dst src block-count)
(values (+ values-above block-count)
(+ dst block-count))))))))
(multiple-value-bind (total-count end-ptr)
- (grovel (pop-eval-stack) (1- (current-stack-pointer)))
+ (grovel (pop-eval-stack) (1- *eval-stack-top*))
(setf (eval-stack-ref end-ptr) total-count)
- (setf (current-stack-pointer) (1+ end-ptr))))
+ (setf *eval-stack-top* (1+ end-ptr))))
(byte-interpret component pc fp))
(define-xop default-unknown-values (component old-pc pc fp)
(declare (type index desired supplied)
(type fixnum delta))
(cond ((minusp delta)
- (incf (current-stack-pointer) delta))
+ (incf *eval-stack-top* delta))
((plusp delta)
(dotimes (i delta)
(push-eval-stack nil)))))
(type pc pc))
pc)
-;;; This is exactly like THROW, except that the tag is the last thing on
-;;; the stack instead of the first. This is used for RETURN-FROM (hence the
-;;; name).
+;;; This is exactly like THROW, except that the tag is the last thing
+;;; on the stack instead of the first. This is used for RETURN-FROM
+;;; (hence the name).
(define-xop return-from (component old-pc pc fp)
(declare (type code-component component)
(type pc old-pc)
(if (typep type 'structure-class)
(let ((info (layout-info (class-layout type))))
(if (and info (eq (dd-type info) 'structure))
- (let ((pred (dd-predicate info)))
- (if (and pred (fboundp pred))
- (fdefinition pred)
+ (let ((predicate-name (dd-predicate-name info)))
+ (if (and predicate-name (fboundp predicate-name))
+ (fdefinition predicate-name)
type))
type))
type))))
(type pc old-pc pc)
(type stack-pointer fp))
(with-extended-operand (component pc operand new-pc)
- (let ((value (eval-stack-ref (1- (current-stack-pointer))))
+ (let ((value (eval-stack-ref (1- *eval-stack-top*)))
(type (code-header-ref component
(+ operand sb!vm:code-constants-offset))))
(unless (if (functionp type)
(byte-interpret component new-pc fp)))
\f
-;;;; the byte-interpreter
+;;;; the actual byte-interpreter
;;; The various operations are encoded as follows.
;;;
(let ((*byte-trace* nil))
(format *trace-output*
"pc=~D, fp=~D, sp=~D, byte=#b~,'0X, frame:~% ~S~%"
- pc fp (current-stack-pointer) byte
- (subseq sb!eval::*eval-stack* fp (current-stack-pointer))))))
+ pc fp *eval-stack-top* byte
+ (subseq sb!bytecode::*eval-stack* fp *eval-stack-top*)))))
(if (zerop (logand byte #x80))
;; Some stack operation. No matter what, we need the operand,
;; so compute it.
(if (zerop operand)
(let ((operand (pop-eval-stack)))
(declare (type index operand))
- (decf (current-stack-pointer) operand))
- (decf (current-stack-pointer) operand)))))
+ (decf *eval-stack-top* operand))
+ (decf *eval-stack-top* operand)))))
(byte-interpret component new-pc fp))
(if (zerop (logand byte #x40))
;; Some kind of call.
(type (integer 0 #.call-arguments-limit) num-args))
(invoke-local-entry-point component (component-ref-24 component (1+ pc))
component old-pc
- (- (current-stack-pointer) num-args)
+ (- *eval-stack-top* num-args)
old-fp))
(defun do-tail-local-call (component pc fp num-args)
(old-sp (eval-stack-ref (- fp 2)))
(old-pc (eval-stack-ref (- fp 3)))
(old-component (eval-stack-ref (- fp 4)))
- (start-of-args (- (current-stack-pointer) num-args)))
- (stack-copy old-sp start-of-args num-args)
- (setf (current-stack-pointer) (+ old-sp num-args))
+ (start-of-args (- *eval-stack-top* num-args)))
+ (eval-stack-copy old-sp start-of-args num-args)
+ (setf *eval-stack-top* (+ old-sp num-args))
(invoke-local-entry-point component (component-ref-24 component (1+ pc))
old-component old-pc old-sp old-fp)))
(values (component-ref-24 component (1+ target)) (+ target 4))
(values (* byte 2) (1+ target))))
(declare (type pc entry-pc))
- (let ((fp (current-stack-pointer)))
+ (let ((fp *eval-stack-top*))
(allocate-eval-stack stack-frame-size)
(byte-interpret component entry-pc fp))))
;;; Call a function with some arguments popped off of the interpreter
-;;; stack, and restore the SP to the specifier value.
+;;; stack, and restore the SP to the specified value.
(defun byte-apply (function num-args restore-sp)
(declare (type function function) (type index num-args))
- (let ((start (- (current-stack-pointer) num-args)))
+ (let ((start (- *eval-stack-top* num-args)))
(declare (type stack-pointer start))
(macrolet ((frob ()
`(case num-args
((< i start))
(declare (fixnum i))
(push (eval-stack-ref i) args))
- (setf (current-stack-pointer) restore-sp)
+ (setf *eval-stack-top* restore-sp)
(apply function args)))))
(call-1 (n)
(collect ((binds)
(binds `(,dum (eval-stack-ref (+ start ,i))))
(args dum)))
`(let ,(binds)
- (setf (current-stack-pointer) restore-sp)
+ (setf *eval-stack-top* restore-sp)
(funcall function ,@(args))))))
(frob))))
+;;; Note: negative RET-PC is a convention for "we need multiple return
+;;; values".
(defun do-call (old-component call-pc ret-pc old-fp num-args named)
(declare (type code-component old-component)
(type pc call-pc)
(type stack-pointer old-fp)
(type (integer 0 #.call-arguments-limit) num-args)
(type (member t nil) named))
- (let* ((old-sp (- (current-stack-pointer) num-args 1))
+ (let* ((old-sp (- *eval-stack-top* num-args 1))
(fun-or-fdefn (eval-stack-ref old-sp))
(function (if named
(or (fdefn-function fun-or-fdefn)
(type stack-pointer fp)
(type (integer 0 #.call-arguments-limit) num-args)
(type (member t nil) named))
- (let* ((start-of-args (- (current-stack-pointer) num-args))
+ (let* ((start-of-args (- *eval-stack-top* num-args))
(fun-or-fdefn (eval-stack-ref (1- start-of-args)))
(function (if named
(or (fdefn-function fun-or-fdefn)
(type function function))
(typecase function
(byte-function
- (stack-copy old-sp start-of-args num-args)
- (setf (current-stack-pointer) (+ old-sp num-args))
+ (eval-stack-copy old-sp start-of-args num-args)
+ (setf *eval-stack-top* (+ old-sp num-args))
(invoke-xep old-component old-pc old-sp old-fp num-args function))
(byte-closure
- (stack-copy old-sp start-of-args num-args)
- (setf (current-stack-pointer) (+ old-sp num-args))
+ (eval-stack-copy old-sp start-of-args num-args)
+ (setf *eval-stack-top* (+ old-sp num-args))
(invoke-xep old-component old-pc old-sp old-fp num-args
(byte-closure-function function)
(byte-closure-data function)))
(*byte-trace* nil)
(*print-level* sb!debug:*debug-print-level*)
(*print-length* sb!debug:*debug-print-length*)
- (sp (current-stack-pointer)))
+ (sp *eval-stack-top*))
(format *trace-output*
"~&INVOKE-XEP: ocode= ~S[~D]~% ~
osp= ~D, ofp= ~D, nargs= ~D, SP= ~D:~% ~
(error "too many arguments")))
(t
(let* ((more-args-supplied (- num-args max))
- (sp (current-stack-pointer))
+ (sp *eval-stack-top*)
(more-args-start (- sp more-args-supplied))
(restp (hairy-byte-function-rest-arg-p xep))
(rest (and restp
(cond
((not (hairy-byte-function-keywords-p xep))
(aver restp)
- (setf (current-stack-pointer) (1+ more-args-start))
+ (setf *eval-stack-top* (1+ more-args-start))
(setf (eval-stack-ref more-args-start) rest))
(t
(unless (evenp more-args-supplied)
;; more args currently are. There might be more or
;; fewer. And also, we need to flatten the parsed
;; args with the defaults before we scan the
- ;; keywords. So we copy all the more args to a
+ ;; keywords. So we copy all the &MORE args to a
;; temporary area at the end of the stack.
(let* ((num-more-args
(hairy-byte-function-num-more-args xep))
(declare (type index temp)
(type stack-pointer new-sp temp-sp))
(allocate-eval-stack (- temp-sp sp))
- (stack-copy temp more-args-start more-args-supplied)
+ (eval-stack-copy temp more-args-start more-args-supplied)
(when restp
(setf (eval-stack-ref more-args-start) rest)
(incf more-args-start))
(when (and bogus-key-p (not allow))
(with-debugger-info (old-component ret-pc old-fp)
(error "unknown keyword: ~S" bogus-key))))
- (setf (current-stack-pointer) new-sp)))))
+ (setf *eval-stack-top* new-sp)))))
(hairy-byte-function-more-args-entry-point xep))))))))
(declare (type pc entry-point))
(invoke-local-entry-point (byte-function-component xep) entry-point
(let ((old-sp (eval-stack-ref (- fp 2))))
(case num-results
(0
- (setf (current-stack-pointer) old-sp)
+ (setf *eval-stack-top* old-sp)
(values))
(1
(let ((result (pop-eval-stack)))
- (setf (current-stack-pointer) old-sp)
+ (setf *eval-stack-top* old-sp)
result))
(t
(let ((results nil))
(dotimes (i num-results)
(push (pop-eval-stack) results))
- (setf (current-stack-pointer) old-sp)
+ (setf *eval-stack-top* old-sp)
(values-list results))))))
(t
;; ### function end breakpoint?
;; wants single value
(let ((result (if (zerop num-results)
nil
- (eval-stack-ref (- (current-stack-pointer)
+ (eval-stack-ref (- *eval-stack-top*
num-results)))))
- (setf (current-stack-pointer) old-sp)
+ (setf *eval-stack-top* old-sp)
(push-eval-stack result)
(byte-interpret old-component old-pc old-fp))
;; wants multiple values
(progn
- (stack-copy old-sp (- (current-stack-pointer) num-results)
- num-results)
- (setf (current-stack-pointer) (+ old-sp num-results))
+ (eval-stack-copy old-sp
+ (- *eval-stack-top* num-results)
+ num-results)
+ (setf *eval-stack-top* (+ old-sp num-results))
(push-eval-stack num-results)
(byte-interpret old-component (- old-pc) old-fp)))))
projects / sbcl.git / blobdiff