X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fbyte-interp.lisp;h=563b66c503009fc735b84f3b7f8136597c47184b;hb=416152f084604094445a758ff399871132dff2bd;hp=36177ae01b6efe6a76a51c7fdab555a75003f9b6;hpb=99ad0a384664dc98af26245a33f11619ec0854ad;p=sbcl.git

diff --git a/src/code/byte-interp.lisp b/src/code/byte-interp.lisp
index 36177ae..563b66c 100644
--- a/src/code/byte-interp.lisp
+++ b/src/code/byte-interp.lisp
@@ -1,5 +1,6 @@
 ;;;; 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
@@ -27,19 +28,19 @@
    (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)
@@ -50,62 +51,57 @@
 	  ((nil)))
 	`(function ,(res) *))))))
 
-;;;; 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)
@@ -115,20 +111,22 @@
 	(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)
@@ -232,7 +230,7 @@
 	    (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))
 
@@ -244,7 +242,7 @@
 			     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)))
@@ -257,7 +255,7 @@
   (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)))
@@ -299,9 +297,8 @@
 ;;; implement suitable code as jump tables.
 (defmacro expand-into-inlines ()
   #+nil (declare (optimize (inhibit-warnings 3)))
-  (iterate build-dispatch
-	   ((bit 4)
-	    (base 0))
+  (named-let build-dispatch ((bit 4)
+			     (base 0))
     (if (minusp bit)
 	(let ((info (svref *inline-functions* base)))
 	  (if info
@@ -383,12 +380,6 @@
 (defun %byte-special-unbind ()
   (sb!sys:%primitive unbind)
   (values))
-
-;;; obsolete...
-#!-sb-fluid (declaim (inline cons-unique-tag))
-(defun cons-unique-tag ()
-  (list '#:%unique-tag%))
-;;; FIXME: Delete this once the system is working.
 
 ;;;; two-arg function stubs
 ;;;;
@@ -405,20 +396,6 @@
 (defun two-arg-string< (x y) (string= x y))
 (defun two-arg-string> (x y) (string= x y))
 
-;;;; miscellaneous primitive stubs
-
-(macrolet ((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)))
-
 ;;;; funny functions
 
 ;;; (used both by the byte interpreter and by the IR1 interpreter)
@@ -490,7 +467,7 @@
 	   (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))
 
@@ -503,7 +480,7 @@
 	 (closure-vars (make-array num-closure-vars)))
     (declare (type index num-closure-vars)
 	     (type simple-vector closure-vars))
-    (iterate frob ((index (1- num-closure-vars)))
+    (named-let frob ((index (1- num-closure-vars)))
       (unless (minusp index)
 	(setf (svref closure-vars index) (pop-eval-stack))
 	(frob (1- index))))
@@ -528,13 +505,13 @@
 		     (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)
@@ -548,7 +525,7 @@
     (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)))))
@@ -625,9 +602,9 @@
 	   (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)
@@ -757,9 +734,9 @@
 	(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))))
@@ -773,7 +750,7 @@
 	   (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)
@@ -788,7 +765,7 @@
 
     (byte-interpret component new-pc fp)))
 
-;;;; the byte-interpreter
+;;;; the actual byte-interpreter
 
 ;;; The various operations are encoded as follows.
 ;;;
@@ -845,8 +822,8 @@
       (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.
@@ -878,8 +855,8 @@
 		    (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.
@@ -968,7 +945,7 @@
 	   (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)
@@ -979,9 +956,9 @@
 	(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)))
 
@@ -992,7 +969,7 @@
 	   (type stack-pointer old-sp old-fp)
 	   (type (or null simple-vector) closure-vars))
   (when closure-vars
-    (iterate more ((index (1- (length closure-vars))))
+    (named-let more ((index (1- (length closure-vars))))
       (unless (minusp index)
 	(push-eval-stack (svref closure-vars index))
 	(more (1- index)))))
@@ -1006,15 +983,15 @@
 	    (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
@@ -1028,7 +1005,7 @@
 			   ((< 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)
@@ -1038,10 +1015,12 @@
 		       (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)
@@ -1049,7 +1028,7 @@
 	   (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)
@@ -1092,7 +1071,7 @@
 	   (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)
@@ -1110,12 +1089,12 @@
 	     (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)))
@@ -1161,7 +1140,7 @@
 	  (*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:~%  ~
@@ -1191,7 +1170,7 @@
 		 (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
@@ -1205,19 +1184,20 @@
 			  (type stack-pointer more-args-start))
 		 (cond
 		  ((not (hairy-byte-function-keywords-p xep))
-		   (assert restp)
-		   (setf (current-stack-pointer) (1+ more-args-start))
+		   (aver restp)
+		   (setf *eval-stack-top* (1+ more-args-start))
 		   (setf (eval-stack-ref more-args-start) rest))
 		  (t
 		   (unless (evenp more-args-supplied)
 		     (with-debugger-info (old-component ret-pc old-fp)
-		       (error "odd number of keyword arguments")))
-		   ;; If there are keyword args, then we need to leave the
-		   ;; defaulted and supplied-p values where the 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 temporary area at the end of the stack.
+		       (error "odd number of &KEY arguments")))
+		   ;; If there are &KEY args, then we need to leave
+		   ;; the defaulted and supplied-p values where the
+		   ;; 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
+		   ;; temporary area at the end of the stack.
 		   (let* ((num-more-args
 			   (hairy-byte-function-num-more-args xep))
 			  (new-sp (+ more-args-start num-more-args))
@@ -1227,7 +1207,7 @@
 		     (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))
@@ -1270,7 +1250,7 @@
 		       (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
@@ -1289,17 +1269,17 @@
        (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?
@@ -1315,16 +1295,17 @@
 	;; 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)))))