(sb!int:/show "hello, world!")
;; Do warm init.
- (let ((*print-length* 5)
- (*print-level* 5))
+ (let ((*print-length* 10)
+ (*print-level* 10))
(sb!int:/show "about to LOAD warm.lisp")
(load "src/cold/warm.lisp"))
"ADD-OFFS-NOTE-HOOK" "ADD-OFFS-COMMENT-HOOK"
"DSTATE-CUR-ADDR" "DSTATE-NEXT-ADDR"))
- #!+sb-interpreter
#s(sb-cold:package-data
:name "SB!EVAL"
- :doc "private: the implementation of the IR1 interpreter"
+ :doc "private: originally the implementation of the IR1 interpreter,
+and now that the IR1 interpreter is gone, home to some stuff which is still
+used by the bytecode interpreter"
:use ("CL" "SB!KERNEL" "SB!INT")
- :export (#!+sb-show "*EVAL-STACK-TRACE*"
+ :export #!-sb-interpreter
+ ("INTERNAL-EVAL")
+ #!+sb-interpreter
+ ("INTERNAL-EVAL"
+ #!+sb-show "*EVAL-STACK-TRACE*"
#!+sb-show "*INTERNAL-APPLY-NODE-TRACE*"
- "FLUSH-INTERPRETED-FUNCTION-CACHE" "INTERNAL-EVAL"
+ "FLUSH-INTERPRETED-FUNCTION-CACHE"
"INTERPRETED-FUNCTION"
"INTERPRETED-FUNCTION-ARGLIST"
"INTERPRETED-FUNCTION-CLOSURE"
((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)
;;; to replace FRAME. The interpreted frame points to FRAME.
(defun possibly-an-interpreted-frame (frame up-frame)
(if (or (not frame)
+ #!+sb-interpreter
(not (eq (debug-function-name (frame-debug-function frame))
'sb!eval::internal-apply-loop))
*debugging-interpreter*
(#.sb!vm:closure-header-type
(function-debug-function (%closure-function fun)))
(#.sb!vm:funcallable-instance-header-type
- (cond ((sb!eval:interpreted-function-p fun)
+ (cond #!+sb-interpreter
+ ((sb!eval:interpreted-function-p fun)
(make-interpreted-debug-function
(or (sb!eval::interpreted-function-definition fun)
(sb!eval::convert-interpreted-fun fun))))
(if (indirect-value-cell-p res)
(sb!c:value-cell-ref res)
res)))
+ #!+sb-interpreter
(interpreted-debug-var
(aver (typep frame 'interpreted-frame))
(sb!eval::leaf-value-lambda-var
(if (indirect-value-cell-p current-value)
(sb!c:value-cell-set current-value value)
(set-compiled-debug-var-slot debug-var frame value))))
+ #!+sb-interpreter
(interpreted-debug-var
(aver (typep frame 'interpreted-frame))
(sb!eval::set-leaf-value-lambda-var
;;; ordinary function definition is only appropriate in the target Lisp.
(defun sb!c::%defun (name def doc source)
(declare (ignore source))
- (setf (sb!eval:interpreted-function-name def) name)
+ #!+sb-interpreter (setf (sb!eval:interpreted-function-name def) name)
(ecase (info :function :where-from name)
(:assumed
(setf (info :function :where-from name) :defined)
;;; Interpreted function describing; handles both closure and
;;; non-closure functions. Instead of printing the compiled-from info,
;;; we print the definition.
+#+sb-interpreter
(defun %describe-function-interpreted (x s kind name)
(declare (type stream s))
(multiple-value-bind (exp closure-p dname)
(let ((data (byte-closure-data x)))
(dotimes (i (length data))
(format s "~@:_~S: ~S" i (svref data i))))))
+ #+sb-interpreter
(sb-eval:interpreted-function
(%describe-function-interpreted x s kind name))
(standard-generic-function
(defmacro enforce-type (value type)
(once-only ((value value))
`(unless (typep ,value ',type)
- (%failed-aver-type ,value ',type))))
+ (%failed-enforce-type ,value ',type))))
(defun %failed-enforce-type (value type)
(error 'simple-type-error
:value value
(eval-when (:compile-toplevel :load-toplevel :execute)
-;;; These functions let us create floats from bits with the significand
-;;; uniformly represented as an integer. This is less efficient for double
-;;; floats, but is more convenient when making special values, etc.
+;;; These functions let us create floats from bits with the
+;;; significand uniformly represented as an integer. This is less
+;;; efficient for double floats, but is more convenient when making
+;;; special values, etc.
(defun single-from-bits (sign exp sig)
(declare (type bit sign) (type (unsigned-byte 24) sig)
(type (unsigned-byte 8) exp))
,body))))
`(sb!c::%define-compiler-macro ',name #',def ',lambda-list ,doc)))))
(defun sb!c::%define-compiler-macro (name definition lambda-list doc)
- ;; FIXME: Why does this have to be an interpreted function? Shouldn't
- ;; it get compiled?
- (aver (sb!eval:interpreted-function-p definition))
- (setf (sb!eval:interpreted-function-name definition)
- (format nil "DEFINE-COMPILER-MACRO ~S" name))
- (setf (sb!eval:interpreted-function-arglist definition) lambda-list)
+ #!+sb-interpreter (setf (sb!eval:interpreted-function-name definition)
+ (format nil "DEFINE-COMPILER-MACRO ~S" name))
+ #!+sb-interpreter (setf (sb!eval:interpreted-function-arglist definition)
+ lambda-list)
(sb!c::%%define-compiler-macro name definition doc))
(defun sb!c::%%define-compiler-macro (name definition doc)
(setf (sb!xc:compiler-macro-function name) definition)
(values (fdefinition x) t))))
(function x)
(t (values (fdefinition x) t)))
- (if (sb-eval:interpreted-function-p res)
+ (if (or #+sb-interpreter (sb-eval:interpreted-function-p res)
+ nil)
(values res named-p (if (sb-eval:interpreted-function-closure res)
:interpreted-closure :interpreted))
(case (sb-kernel:get-type res)
#(#.sb!vm:closure-header-type
#.sb!vm:byte-code-closure-type))
"CLOSURE")
- ((sb!eval::interpreted-function-p object)
+ (#!+sb-interpreter
+ (sb!eval::interpreted-function-p object)
(or (sb!eval::interpreted-function-%name object)
(sb!eval:interpreted-function-lambda-expression
object)))
saved core is loaded."
#!+mp (sb!mp::shutdown-multi-processing)
+ #!+sb-interpreter
(when (fboundp 'sb!eval:flush-interpreted-function-cache)
(sb!eval:flush-interpreted-function-cache))
;; FIXME: What is this for? Explain.
;;;; anyway). In that environment, a stub no-op version of this
;;;; function is used.
(defun try-to-rename-interpreted-function-as-macro (f name lambda-list)
- (aver (sb!eval:interpreted-function-p f))
- (setf (sb!eval:interpreted-function-name f)
- (format nil "DEFMACRO ~S" name)
- (sb!eval:interpreted-function-arglist f)
- lambda-list)
+ #!+sb-interpreter (setf (sb!eval:interpreted-function-name f)
+ (format nil "DEFMACRO ~S" name)
+ (sb!eval:interpreted-function-arglist f)
+ lambda-list)
(values))
\f
;;;; EVAL and friends
(and (consp name)
(eq (car name) 'setf)))
(fdefinition name)
- (sb!eval:make-interpreted-function name))))
+ #!+sb-interpreter
+ (sb!eval:make-interpreted-function name)
+ #!-sb-interpreter
+ (sb!eval:internal-eval original-exp))))
(quote
(unless (= args 1)
(error "wrong number of args to QUOTE:~% ~S" exp))
(collect ((args))
(dolist (arg (rest exp))
(args (eval arg)))
+ #!-sb-interpreter
+ (apply (symbol-function name) (args))
+ #!+sb-interpreter
(if sb!eval::*already-evaled-this*
(let ((sb!eval::*already-evaled-this* nil))
(apply (symbol-function name) (args)))
;;; inline expansion.
(defun function-lambda-expression (fun)
(declare (type function fun))
- (if (sb!eval:interpreted-function-p fun)
- (sb!eval:interpreted-function-lambda-expression fun)
- (let* ((fun (%function-self fun))
- (name (%function-name fun))
- (code (sb!di::function-code-header fun))
- (info (sb!kernel:%code-debug-info code)))
- (if info
- (let ((source (first (sb!c::compiled-debug-info-source info))))
- (cond ((and (eq (sb!c::debug-source-from source) :lisp)
- (eq (sb!c::debug-source-info source) fun))
- (values (second (svref (sb!c::debug-source-name source) 0))
- nil name))
- ((stringp name)
- (values nil t name))
- (t
- (let ((exp (info :function :inline-expansion name)))
- (if exp
- (values exp nil name)
- (values nil t name))))))
- (values nil t name)))))
+ (cond #!+sb-interpreter
+ ((sb!eval:interpreted-function-p fun)
+ (sb!eval:interpreted-function-lambda-expression fun))
+ (t
+ (let* ((fun (%function-self fun))
+ (name (%function-name fun))
+ (code (sb!di::function-code-header fun))
+ (info (sb!kernel:%code-debug-info code)))
+ (if info
+ (let ((source (first (sb!c::compiled-debug-info-source info))))
+ (cond ((and (eq (sb!c::debug-source-from source) :lisp)
+ (eq (sb!c::debug-source-info source) fun))
+ (values (second (svref (sb!c::debug-source-name source) 0))
+ nil name))
+ ((stringp name)
+ (values nil t name))
+ (t
+ (let ((exp (info :function :inline-expansion name)))
+ (if exp
+ (values exp nil name)
+ (values nil t name))))))
+ (values nil t name))))))
;;; Like FIND-IF, only we do it on a compiled closure's environment.
(defun find-if-in-closure (test fun)
(sb!c::byte-function-name x))
(byte-closure
(sb!c::byte-function-name (byte-closure-function x)))
+ #!+sb-interpreter
(sb!eval:interpreted-function
(multiple-value-bind (exp closure-p dname)
(sb!eval:interpreted-function-lambda-expression x)
;;; Pull the type specifier out of a function object.
(defun extract-function-type (fun)
- (if (sb!eval:interpreted-function-p fun)
- (sb!eval:interpreted-function-type fun)
- (typecase fun
- (byte-function (byte-function-type fun))
- (byte-closure (byte-function-type (byte-closure-function fun)))
+ (cond #!+sb-interpreter
+ ((sb!eval:interpreted-function-p fun)
+ (sb!eval:interpreted-function-type fun))
(t
- (specifier-type (%function-type (%closure-function fun)))))))
+ (typecase fun
+ (byte-function (byte-function-type fun))
+ (byte-closure (byte-function-type (byte-closure-function fun)))
+ (t
+ (specifier-type (%function-type (%closure-function fun))))))))
\f
;;;; miscellaneous interfaces
;;; Try to compile the closure arg to %TIME if it is interpreted.
(defun massage-time-function (fun)
(cond
+ #!+sb-interpreter
((sb!eval:interpreted-function-p fun)
(multiple-value-bind (def env-p) (function-lambda-expression fun)
(declare (ignore def))
(in-package "SB!C")
+;;; ANSI limits on compilation
+(defconstant sb!xc:call-arguments-limit most-positive-fixnum
+ #!+sb-doc
+ "The exclusive upper bound on the number of arguments which may be passed
+ to a function, including &REST args.")
+(defconstant sb!xc:lambda-parameters-limit most-positive-fixnum
+ #!+sb-doc
+ "The exclusive upper bound on the number of parameters which may be specifed
+ in a given lambda list. This is actually the limit on required and &OPTIONAL
+ parameters. With &KEY and &AUX you can get more.")
+(defconstant sb!xc:multiple-values-limit most-positive-fixnum
+ #!+sb-doc
+ "The exclusive upper bound on the number of multiple VALUES that you can
+ return.")
+
;;; FIXME: Shouldn't SB!C::&MORE be in this list?
(defconstant-eqx sb!xc:lambda-list-keywords
'(&optional &rest &key &aux &body &whole &allow-other-keys &environment)
;;; The list of INTERPRETED-FUNCTIONS that have translated definitions.
(defvar *interpreted-function-cache* nil)
(declaim (type list *interpreted-function-cache*))
+\f
+;;;; eval stack stuff
;;; Setting this causes the stack operations to dump a trace.
-#+!sb-show
+#!+sb-show
(defvar *eval-stack-trace* nil)
;;; Push value on *EVAL-STACK*, growing the stack if necessary. This
(defun eval-stack-push (value)
(let ((len (length (the simple-vector *eval-stack*))))
(when (= len *eval-stack-top*)
- #+!sb-show (when *eval-stack-trace*
+ #!+sb-show (when *eval-stack-trace*
(format t "[PUSH: growing stack.]~%"))
(let ((new-stack (make-array (ash len 1))))
(replace new-stack *eval-stack* :end1 len :end2 len)
(setf *eval-stack* new-stack))))
(let ((top *eval-stack-top*))
- #+!sb-show (when *eval-stack-trace* (format t "pushing ~D.~%" top))
+ #!+sb-show (when *eval-stack-trace* (format t "pushing ~D.~%" top))
(incf *eval-stack-top*)
(setf (svref *eval-stack* top) value)))
(error "attempt to pop empty eval stack"))
(let* ((new-top (1- *eval-stack-top*))
(value (svref *eval-stack* new-top)))
- #+!sb-show (when *eval-stack-trace*
+ #!+sb-show (when *eval-stack-trace*
(format t "popping ~D --> ~S.~%" new-top value))
(setf *eval-stack-top* new-top)
value))
(defun eval-stack-extend (n)
(let ((len (length (the simple-vector *eval-stack*))))
(when (> (+ n *eval-stack-top*) len)
- #+!sb-show (when *eval-stack-trace*
+ #!+sb-show (when *eval-stack-trace*
(format t "[EXTEND: growing stack.]~%"))
(let ((new-stack (make-array (+ n (ash len 1)))))
(replace new-stack *eval-stack* :end1 len :end2 len)
(setf *eval-stack* new-stack))))
(let ((new-top (+ *eval-stack-top* n)))
- #+!sb-show (when *eval-stack-trace*
+ #!+sb-show (when *eval-stack-trace*
(format t "extending to ~D.~%" new-top))
(do ((i *eval-stack-top* (1+ i)))
((= i new-top))
;;; the antithesis of EVAL-STACK-EXTEND
(defun eval-stack-shrink (n)
- #+!sb-show (when *eval-stack-trace*
+ #!+sb-show (when *eval-stack-trace*
(format t "shrinking to ~D.~%" (- *eval-stack-top* n)))
(decf *eval-stack-top* n))
;;; This is used to shrink the stack back to a previous frame pointer.
(defun eval-stack-reset-top (ptr)
- #+!sb-show (when *eval-stack-trace*
+ #!+sb-show (when *eval-stack-trace*
(format t "setting top to ~D.~%" ptr))
(setf *eval-stack-top* ptr))
deprecated-names)))
(let* ((do-eval (and (intersection '(compile :compile-toplevel) situations)
- (not sb!eval::*already-evaled-this*)))
+ #!+sb-interpreter (not sb!eval::*already-evaled-this*)))
+ #!+sb-interpreter
(sb!eval::*already-evaled-this* t))
(when do-eval
(in-package "SB!C")
-(defconstant sb!xc:call-arguments-limit most-positive-fixnum
- #!+sb-doc
- "The exclusive upper bound on the number of arguments which may be passed
- to a function, including &REST args.")
-(defconstant sb!xc:lambda-parameters-limit most-positive-fixnum
- #!+sb-doc
- "The exclusive upper bound on the number of parameters which may be specifed
- in a given lambda list. This is actually the limit on required and &OPTIONAL
- parameters. With &KEY and &AUX you can get more.")
-(defconstant sb!xc:multiple-values-limit most-positive-fixnum
- #!+sb-doc
- "The exclusive upper bound on the number of multiple VALUES that you can
- return.")
-
;;; FIXME: Doesn't this belong somewhere else, like early-c.lisp?
(declaim (special *constants* *free-variables* *component-being-compiled*
*code-vector* *next-location* *result-fixups*
(and (listp thing)
(eq (car thing) 'setf)))
(compiled-function-or-lose (fdefinition thing) thing))
+ #!+sb-interpreter
((sb!eval:interpreted-function-p thing)
(compile-function-lambda-expr thing))
((functionp thing)
;;; could be made less viciously brittle when SB-FLUID.)
;;; (Or perhaps just define a macro
;;; (DEFMACRO PKG (NAME)
-;;; #!-SB-FLUID (FIND-PACKAGE NAME)
-;;; #!+SB-FLUID `(FIND-PACKAGE ,NAME))
+;;; #-SB-FLUID (FIND-PACKAGE NAME)
+;;; #+SB-FLUID `(FIND-PACKAGE ,NAME))
;;; and use that to replace all three variables.)
(defvar *pcl-package* (find-package "SB-PCL"))
(defvar *slot-accessor-name-package* (find-package "SB-SLOT-ACCESSOR-NAME"))
;;; In all cases, SET-FUNCTION-NAME must return the new (or same)
;;; function. (Unlike other functions to set stuff, it does not return
;;; the new value.)
+;;;
+;;; FIXME: A similar operation is done in
+;;; TRY-TO-RENAME-INTERPRETED-FUNCTION-AS-MACRO. The code should be
+;;; shared.
(defun set-function-name (fcn new-name)
#+sb-doc
"Set the name of a compiled function object. Return the function."
(typep fcn 'generic-function)
(eq (class-of fcn) *the-class-standard-generic-function*))
(setf (sb-kernel:%funcallable-instance-info fcn 1) new-name)
- (typecase fcn
+ (etypecase fcn
(sb-kernel:byte-closure
(set-function-name (sb-kernel:byte-closure-function fcn)
new-name))
(sb-kernel:byte-function
(setf (sb-kernel:byte-function-name fcn) new-name))
+ #+sb-interpreter
(sb-eval:interpreted-function
(setf (sb-eval:interpreted-function-name fcn) new-name))))
fcn)
;;; four numeric fields, is used for versions which aren't released
;;; but correspond only to CVS tags or snapshots.
-"0.pre7.13"
+"0.pre7.14"
projects / sbcl.git / commitdiff