From 39ca94ec421224c78cb01f7d2d7b49321c66a2d4 Mon Sep 17 00:00:00 2001 From: William Harold Newman Date: Fri, 27 Apr 2001 19:11:34 +0000 Subject: [PATCH] 0.6.11.43: MNA warm init byte-compilation patch (sbcl-devel 2001-04-14); except that I didn't clobber the DEFKNOWNs for funcallable instance accessors fixed the byte-compile-time warning problem in describe.lisp by redefining SB-PCL::GET-SLOTS-OR-NIL as a function merged pcl/fin.lisp into pcl/low.lisp in order to unscrew some assumed-to-be-function-but-then-defined-as-macro problems, and because now that our PCL is SBCL-specific pcl/fin.lisp stuff can mostly wither away anyway inlined CLOS-SLOTS-REF and (SETF CLOS-SLOTS-REF) deleted DOCTOR-DFUN-FOR-THE-DEBUGGER and RECORD-DEFINITION --- src/code/describe.lisp | 4 ++ src/code/inspect.lisp | 3 + src/cold/warm.lisp | 2 +- src/compiler/generic/vm-fndb.lisp | 7 ++ src/pcl/boot.lisp | 22 ++++-- src/pcl/describe.lisp | 3 + src/pcl/dfun.lisp | 14 ++-- src/pcl/fin.lisp | 105 ---------------------------- src/pcl/low.lisp | 139 +++++++++++++++++++++++++------------ src/pcl/methods.lisp | 11 ++- version.lisp-expr | 2 +- 11 files changed, 145 insertions(+), 167 deletions(-) delete mode 100644 src/pcl/fin.lisp diff --git a/src/code/describe.lisp b/src/code/describe.lisp index e926472..ad2b039 100644 --- a/src/code/describe.lisp +++ b/src/code/describe.lisp @@ -11,6 +11,10 @@ ;;;; files for more information. (in-package "SB-IMPL") + +;; byte-compile this file +(declaim (optimize (speed 0) (safety 1))) + (defvar *describe-indentation-step* 3 #+sb-doc diff --git a/src/code/inspect.lisp b/src/code/inspect.lisp index 52f08e3..8d75975 100644 --- a/src/code/inspect.lisp +++ b/src/code/inspect.lisp @@ -11,6 +11,9 @@ (in-package "SB-IMPL") +;; byte-compile this file +(declaim (optimize (speed 0) (safety 1))) + ;;; The inspector views LISP objects as being composed of parts. A ;;; list, for example, would be divided into its members, and a ;;; instance into its slots. These parts are stored in a list. The diff --git a/src/cold/warm.lisp b/src/cold/warm.lisp index e2c7635..751e447 100644 --- a/src/cold/warm.lisp +++ b/src/cold/warm.lisp @@ -161,7 +161,7 @@ "src/pcl/macros" "src/pcl/compiler-support" "src/pcl/low" - "src/pcl/fin" + ;; "src/pcl/fin" merged into "src/pcl/low" in 0.6.11.43 "src/pcl/defclass" "src/pcl/defs" "src/pcl/fngen" diff --git a/src/compiler/generic/vm-fndb.lisp b/src/compiler/generic/vm-fndb.lisp index 8ed1ba1..1464c0a 100644 --- a/src/compiler/generic/vm-fndb.lisp +++ b/src/compiler/generic/vm-fndb.lisp @@ -292,6 +292,13 @@ (defknown %make-funcallable-instance (index layout) function (unsafe)) +;;; FIXME/REMOVEME: MNA patched these like this, but I don't +;;; understand why, so I mutated them back to see what goes wrong. +;;;-(defknown %funcallable-instance-info (function index) t (flushable)) +;;;-(defknown %set-funcallable-instance-info (function index t) t (unsafe)) +;;;+(defknown %funcallable-instance-info ((or function cons) index) t (flushable)) +;;;+(defknown %set-funcallable-instance-info ((or function cons) index t) t (unsafe)) +;;; (defknown %funcallable-instance-info (function index) t (flushable)) (defknown %set-funcallable-instance-info (function index t) t (unsafe)) diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index e05b509..9249bde 100644 --- a/src/pcl/boot.lisp +++ b/src/pcl/boot.lisp @@ -806,7 +806,22 @@ bootstrapping. (unless (constantp restp) (error "The RESTP argument is not constant.")) (setq restp (eval restp)) - `(progn + `(locally + + ;; In sbcl-0.6.11.43, the compiler would issue bogus warnings + ;; about type mismatches in unreachable code when we + ;; macroexpanded the GET-SLOTS-OR-NIL expressions here and + ;; byte-compiled the code. GET-SLOTS-OR-NIL is now an inline + ;; function instead of a macro, which seems sufficient to solve + ;; the problem all by itself (probably because of some quirk in + ;; the relative order of expansion and type inference) but we + ;; also use overkill by NOTINLINEing GET-SLOTS-OR-NIL, because it + ;; looks as though (1) inlining isn't that much of a win anyway, + ;; and (2a) once you miss the FAST-METHOD-CALL clause you're + ;; going to be slow anyway, but (2b) code bloat still hurts even + ;; when it's off the critical path. + (declare (notinline get-slots-or-nil)) + (trace-emf-call ,emf ,restp (list ,@required-args+rest-arg)) (cond ((typep ,emf 'fast-method-call) (invoke-fast-method-call ,emf ,@required-args+rest-arg)) @@ -963,8 +978,8 @@ bootstrapping. (null closurep) (null applyp)) `(let () ,@body)) - ((and (null closurep) - (null applyp)) + ((and (null closurep) + (null applyp)) ;; OK to use MACROLET, and all args are mandatory ;; (else APPLYP would be true). `(call-next-method-bind @@ -1190,7 +1205,6 @@ bootstrapping. (let ((method-spec (or (getf initargs ':method-spec) (make-method-spec name quals specls)))) (setf (getf initargs ':method-spec) method-spec) - (record-definition 'method method-spec) (load-defmethod-internal class name quals specls ll initargs pv-table-symbol))) diff --git a/src/pcl/describe.lisp b/src/pcl/describe.lisp index 998d45c..0356fe6 100644 --- a/src/pcl/describe.lisp +++ b/src/pcl/describe.lisp @@ -26,6 +26,9 @@ (in-package "SB-PCL") +;; byte-compile this file +(declaim (optimize (speed 0) (safety 1))) + (defmethod slots-to-inspect ((class slot-class) (object slot-object)) (class-slots class)) diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp index 3ea280f..8a44336 100644 --- a/src/pcl/dfun.lisp +++ b/src/pcl/dfun.lisp @@ -972,8 +972,7 @@ And so, we are saved. (declare (ignore nreq applyp nkeys)) (with-dfun-wrappers (args metatypes) (dfun-wrappers invalid-wrapper-p wrappers classes types) - (error "The function ~S requires at least ~D arguments" - gf (length metatypes)) + (error-need-at-least-n-args gf (length metatypes)) (multiple-value-bind (emf methods accessor-type index) (cache-miss-values-internal gf arg-info wrappers classes types state) @@ -1507,14 +1506,9 @@ And so, we are saved. (generic-function-name generic-function))) (ocache (gf-dfun-cache generic-function))) (set-dfun generic-function dfun cache info) - (let* ((dfun (if early-p - (or dfun (make-initial-dfun generic-function)) - (compute-discriminating-function generic-function))) - (info (gf-dfun-info generic-function))) - (unless (eq 'default-method-only (type-of info)) - (setq dfun (doctor-dfun-for-the-debugger - generic-function - dfun))) + (let ((dfun (if early-p + (or dfun (make-initial-dfun generic-function)) + (compute-discriminating-function generic-function)))) (set-funcallable-instance-function generic-function dfun) (set-function-name generic-function gf-name) (when (and ocache (not (eq ocache cache))) (free-cache ocache)) diff --git a/src/pcl/fin.lisp b/src/pcl/fin.lisp deleted file mode 100644 index 2c18c69..0000000 --- a/src/pcl/fin.lisp +++ /dev/null @@ -1,105 +0,0 @@ -;;;; This software is part of the SBCL system. See the README file for -;;;; more information. - -;;;; This software is derived from software originally released by Xerox -;;;; Corporation. Copyright and release statements follow. Later modifications -;;;; to the software are in the public domain and are provided with -;;;; absolutely no warranty. See the COPYING and CREDITS files for more -;;;; information. - -;;;; copyright information from original PCL sources: -;;;; -;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. -;;;; All rights reserved. -;;;; -;;;; Use and copying of this software and preparation of derivative works based -;;;; upon this software are permitted. Any distribution of this software or -;;;; derivative works must comply with all applicable United States export -;;;; control laws. -;;;; -;;;; This software is made available AS IS, and Xerox Corporation makes no -;;;; warranty about the software, its performance or its conformity to any -;;;; specification. - -(in-package "SB-PCL") - -;;; Each implementation must provide the following functions and macros: -;;; -;;; ALLOCATE-FUNCALLABLE-INSTANCE-1 () -;;; should create and return a new funcallable instance. The -;;; funcallable-instance-data slots must be initialized to NIL. -;;; This is called by allocate-funcallable-instance and by the -;;; bootstrapping code. -;;; -;;; FUNCALLABLE-INSTANCE-P (x) -;;; the obvious predicate. This should be an INLINE function. It -;;; must be funcallable, but it would be nice if it compiled open. -;;; -;;; SET-FUNCALLABLE-INSTANCE-FUNCTION (fin new-value) -;;; change the fin so that when it is funcalled, the new-value -;;; function is called. Note that it is legal for new-value -;;; to be copied before it is installed in the fin, specifically -;;; there is no accessor for a FIN's function so this function -;;; does not have to preserve the actual new value. The new-value -;;; argument can be any funcallable thing, a closure, lambda -;;; compiled code etc. This function must coerce those values -;;; if necessary. -;;; NOTE: new-value is almost always a compiled closure. This -;;; is the important case to optimize. -;;; -;;; FUNCALLABLE-INSTANCE-DATA-1 (fin data-name) -;;; should return the value of the data named data-name in the fin. -;;; data-name is one of the symbols in the list which is the value -;;; of funcallable-instance-data. Since data-name is almost always -;;; a quoted symbol and funcallable-instance-data is a constant, it -;;; is possible (and worthwhile) to optimize the computation of -;;; data-name's offset in the data part of the fin. -;;; This must be SETF'able. - -;;;; implementation of funcallable instances for CMU Common Lisp - -(defstruct (pcl-funcallable-instance - (:alternate-metaclass sb-kernel:funcallable-instance - sb-kernel:random-pcl-class - sb-kernel:make-random-pcl-class) - (:type sb-kernel:funcallable-structure) - (:constructor allocate-funcallable-instance-1 ()) - (:copier nil) - (:conc-name nil)) - ;; Note: The PCL wrapper is in the layout slot. - - ;; PCL data vector. - (pcl-funcallable-instance-slots nil) - ;; The debug-name for this function. - (funcallable-instance-name nil)) - -(import 'sb-kernel:funcallable-instance-p) - -;;; Set the function that is called when FIN is called. -(defun set-funcallable-instance-function (fin new-value) - (declare (type function new-value)) - (aver (funcallable-instance-p fin)) - (setf (sb-kernel:funcallable-instance-function fin) new-value)) - -;;; This "works" on non-PCL FINs, which allows us to weaken -;;; FUNCALLABLE-INSTANCE-P to return true for all FINs. This is also -;;; necessary for bootstrapping to work, since the layouts for early GFs are -;;; not initially initialized. -(defmacro funcallable-instance-data-1 (fin slot) - (ecase (eval slot) - (wrapper `(sb-kernel:%funcallable-instance-layout ,fin)) - (slots `(sb-kernel:%funcallable-instance-info ,fin 0)))) - -;;;; slightly higher-level stuff built on the implementation-dependent stuff - -(defmacro fsc-instance-p (fin) - `(funcallable-instance-p ,fin)) - -(defmacro fsc-instance-class (fin) - `(wrapper-class (funcallable-instance-data-1 ,fin 'wrapper))) - -(defmacro fsc-instance-wrapper (fin) - `(funcallable-instance-data-1 ,fin 'wrapper)) - -(defmacro fsc-instance-slots (fin) - `(funcallable-instance-data-1 ,fin 'slots)) diff --git a/src/pcl/low.lisp b/src/pcl/low.lisp index e9539ec..099e48c 100644 --- a/src/pcl/low.lisp +++ b/src/pcl/low.lisp @@ -46,6 +46,52 @@ (declare (fixnum ,var)) ,@body)) +;;;; PCL's view of funcallable instances + +(defstruct (pcl-funcallable-instance + (:alternate-metaclass sb-kernel:funcallable-instance + sb-kernel:random-pcl-class + sb-kernel:make-random-pcl-class) + (:type sb-kernel:funcallable-structure) + (:constructor allocate-funcallable-instance-1 ()) + (:copier nil) + (:conc-name nil)) + ;; Note: The PCL wrapper is in the layout slot. + + ;; PCL data vector. + (pcl-funcallable-instance-slots nil) + ;; The debug-name for this function. + (funcallable-instance-name nil)) + +(import 'sb-kernel:funcallable-instance-p) + +;;; This "works" on non-PCL FINs, which allows us to weaken +;;; FUNCALLABLE-INSTANCE-P to return true for all FINs. This is also +;;; necessary for bootstrapping to work, since the layouts for early +;;; GFs are not initially initialized. +(defmacro funcallable-instance-data-1 (fin slot) + (ecase (eval slot) + (wrapper `(sb-kernel:%funcallable-instance-layout ,fin)) + (slots `(sb-kernel:%funcallable-instance-info ,fin 0)))) + +;;; FIXME: Now that we no longer try to make our CLOS implementation +;;; portable to other implementations of Common Lisp, all the +;;; funcallable instance wrapper logic here can go away in favor +;;; of direct calls to native SBCL funcallable instance operations. +(defun set-funcallable-instance-function (fin new-value) + (declare (type function new-value)) + (aver (funcallable-instance-p fin)) + (setf (sb-kernel:funcallable-instance-function fin) new-value)) +(defmacro fsc-instance-p (fin) + `(funcallable-instance-p ,fin)) +(defmacro fsc-instance-class (fin) + `(wrapper-class (funcallable-instance-data-1 ,fin 'wrapper))) +(defmacro fsc-instance-wrapper (fin) + `(funcallable-instance-data-1 ,fin 'wrapper)) +(defmacro fsc-instance-slots (fin) + `(funcallable-instance-data-1 ,fin 'slots)) + +(declaim (inline clos-slots-ref (setf clos-slots-ref))) (declaim (ftype (function (simple-vector index) t) clos-slots-ref)) (defun clos-slots-ref (slots index) (svref slots index)) @@ -61,11 +107,6 @@ (defmacro std-instance-p (x) `(sb-kernel:%instancep ,x)) -(defmacro get-slots (inst) - `(cond ((std-instance-p ,inst) (std-instance-slots ,inst)) - ((fsc-instance-p ,inst) (fsc-instance-slots ,inst)) - (t (error "What kind of instance is this?")))) - ;; a temporary definition used for debugging the bootstrap #+sb-show (defun print-std-instance (instance stream depth) @@ -77,16 +118,21 @@ (eq class (find-class 'built-in-class nil))) (princ (early-class-name instance) stream))))) -;;; This is the value that we stick into a slot to tell us that it is unbound. -;;; It may seem gross, but for performance reasons, we make this an interned -;;; symbol. That means that the fast check to see whether a slot is unbound is -;;; to say (EQ '..SLOT-UNBOUND..). That is considerably faster than -;;; looking at the value of a special variable. Be careful, there are places in -;;; the code which actually use ..slot-unbound.. rather than this variable. So -;;; much for modularity.. +;;; This is the value that we stick into a slot to tell us that it is +;;; unbound. It may seem gross, but for performance reasons, we make +;;; this an interned symbol. That means that the fast check to see +;;; whether a slot is unbound is to say (EQ '..SLOT-UNBOUND..). +;;; That is considerably faster than looking at the value of a special +;;; variable. Be careful, there are places in the code which actually +;;; use ..SLOT-UNBOUND.. rather than this variable. So much for +;;; modularity.. ;;; -;;; FIXME: Now that we're tightly integrated into SBCL, we could use the -;;; SBCL built-in unbound value token instead. +;;; FIXME: Now that we're tightly integrated into SBCL, we could use +;;; the SBCL built-in unbound value token instead. Perhaps if we did +;;; so it would be a good idea to define collections of CLOS slots as +;;; a new type of heap object, instead of using bare SIMPLE-VECTOR, in +;;; order to avoid problems (in the debugger if nowhere else) with +;;; SIMPLE-VECTORs some of whose elements are unbound tokens. (defconstant +slot-unbound+ '..slot-unbound..) (defmacro %allocate-static-slot-storage--class (no-of-slots) @@ -95,21 +141,21 @@ (defmacro std-instance-class (instance) `(wrapper-class* (std-instance-wrapper ,instance))) - -;;; When given a function should give this function the name . -;;; Note that is sometimes a list. Some lisps get the upset -;;; in the tummy when they start thinking about functions which have -;;; lists as names. To deal with that there is set-function-name-intern -;;; which takes a list spec for a function name and turns it into a symbol -;;; if need be. +;;; When given a function should give this function the name +;;; NEW-NAME. Note that NEW-NAME is sometimes a list. Some lisps +;;; get the upset in the tummy when they start thinking about +;;; functions which have lists as names. To deal with that there is +;;; SET-FUNCTION-NAME-INTERN which takes a list spec for a function +;;; name and turns it into a symbol if need be. ;;; -;;; When given a funcallable instance, set-function-name MUST side-effect -;;; that FIN to give it the name. When given any other kind of function -;;; set-function-name is allowed to return new function which is the 'same' -;;; except that it has the name. +;;; When given a funcallable instance, SET-FUNCTION-NAME *must* +;;; side-effect that FIN to give it the name. When given any other +;;; kind of function SET-FUNCTION-NAME is allowed to return a new +;;; function which is "the same" except that it has the 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.) +;;; 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.) (defun set-function-name (fcn new-name) #+sb-doc "Set the name of a compiled function object. Return the function." @@ -150,7 +196,7 @@ (let ((header (sb-kernel:%closure-function fcn))) (setf (sb-c::%function-name header) new-name)) - ;; Maybe add better scheme here someday. + ;; XXX Maybe add better scheme here someday. fcn))) (defun intern-function-name (name) @@ -175,12 +221,6 @@ (eval-when (:load-toplevel) (compile-iis-functions t)))) -(defun record-definition (type spec &rest args) - (declare (ignore type spec args)) - ()) - -(defun doctor-dfun-for-the-debugger (gf dfun) (declare (ignore gf)) dfun) - ;;; This definition is for interpreted code. (defun pcl-instance-p (x) (typep (sb-kernel:layout-of x) 'wrapper)) @@ -201,6 +241,21 @@ (defmacro std-instance-slots (x) `(sb-kernel:%instance-ref ,x 1)) (defmacro std-instance-wrapper (x) `(sb-kernel:%instance-layout ,x)) +;;; FIXME: These functions are called every place we do a +;;; CALL-NEXT-METHOD, and probably other places too. It's likely worth +;;; selectively optimizing them with DEFTRANSFORMs and stuff, rather +;;; than just indiscriminately expanding them inline everywhere. +(declaim (inline get-slots get-slots-or-nil)) +(declaim (ftype (function (t) simple-vector) get-slots)) +(declaim (ftype (function (t) (or simple-vector null)) get-slots-or-nil)) +(defun get-slots (instance) + (if (std-instance-p instance) + (std-instance-slots instance) + (fsc-instance-slots instance))) +(defun get-slots-or-nil (instance) + (when (pcl-instance-p instance) + (get-slots instance))) + (defmacro built-in-or-structure-wrapper (x) `(sb-kernel:layout-of ,x)) (defmacro get-wrapper (inst) @@ -209,22 +264,20 @@ (aver (typep ,wrapper 'wrapper)) ,wrapper))) -;;; FIXME: could be an inline function (like many other things around -;;; here) +;;; FIXME: could be an inline function or ordinary function (like many +;;; other things around here) (defmacro get-instance-wrapper-or-nil (inst) (once-only ((wrapper `(wrapper-of ,inst))) `(if (typep ,wrapper 'wrapper) ,wrapper nil))) - -(defmacro get-slots-or-nil (inst) - (once-only ((n-inst inst)) - `(when (pcl-instance-p ,n-inst) - (if (std-instance-p ,n-inst) - (std-instance-slots ,n-inst) - (fsc-instance-slots ,n-inst))))) ;;;; structure-instance stuff +;;;; +;;;; FIXME: Now that the code is SBCL-only, this extra layer of +;;;; abstraction around our native structure representation doesn't +;;;; seem to add anything useful, and could probably go away. + ;;; The definition of STRUCTURE-TYPE-P was moved to early-low.lisp. (defun get-structure-dd (type) diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp index 93717ec..a95c72e 100644 --- a/src/pcl/methods.lisp +++ b/src/pcl/methods.lisp @@ -603,6 +603,12 @@ t))) #'(lambda (&rest args) (funcall mf args nil)))) + +(defun error-need-at-least-n-args (function n) + (error "~@" + function + n)) + (defun types-from-arguments (generic-function arguments &optional type-modifier) (multiple-value-bind (nreq applyp metatypes nkeys arg-info) @@ -612,9 +618,8 @@ (dotimes-fixnum (i nreq) i (unless arguments - (error "The function ~S requires at least ~D arguments" - (generic-function-name generic-function) - nreq)) + (error-need-at-least-n-args (generic-function-name generic-function) + nreq)) (let ((arg (pop arguments))) (push (if type-modifier `(,type-modifier ,arg) arg) types-rev))) (values (nreverse types-rev) arg-info)))) diff --git a/version.lisp-expr b/version.lisp-expr index 580c534..1a06f06 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -15,4 +15,4 @@ ;;; versions, and a string like "0.6.5.12" is used for versions which ;;; aren't released but correspond only to CVS tags or snapshots. -"0.6.11.42" +"0.6.11.43" -- 1.7.10.4