X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Flow.lisp;h=d4a4af51cce1c54924edcda04d5b70b472847907;hb=742e0b2aed0e06a5ac6036c6b576088e3f91208f;hp=98174f3673fb6fb60c711a625f02f21e1b44acdd;hpb=853b48ca4085b8ad9831edb9b06935a0977c0800;p=sbcl.git diff --git a/src/pcl/low.lisp b/src/pcl/low.lisp index 98174f3..d4a4af5 100644 --- a/src/pcl/low.lisp +++ b/src/pcl/low.lisp @@ -38,7 +38,8 @@ (in-package "SB-PCL") (eval-when (:compile-toplevel :load-toplevel :execute) -(defvar *optimize-speed* '(optimize (speed 3) (safety 0))) +(defvar *optimize-speed* + '(optimize (speed 3) (safety 0))) ) ; EVAL-WHEN (defmacro dotimes-fixnum ((var count &optional (result nil)) &body body) @@ -46,50 +47,73 @@ (declare (fixnum ,var)) ,@body)) +;;;; early definition of WRAPPER +;;;; +;;;; Most WRAPPER stuff is defined later, but the DEFSTRUCT itself +;;;; is here early so that things like (TYPEP .. 'WRAPPER) can be +;;;; compiled efficiently. + +;;; Note that for SBCL, as for CMU CL, the WRAPPER of a built-in or +;;; structure class will be some other kind of SB-KERNEL:LAYOUT, but +;;; this shouldn't matter, since the only two slots that WRAPPER adds +;;; are meaningless in those cases. +(defstruct (wrapper + (:include sb-kernel:layout + ;; KLUDGE: In CMU CL, the initialization default + ;; for LAYOUT-INVALID was NIL. In SBCL, that has + ;; changed to :UNINITIALIZED, but PCL code might + ;; still expect NIL for the initialization + ;; default of WRAPPER-INVALID. Instead of trying + ;; to find out, I just overrode the LAYOUT + ;; default here. -- WHN 19991204 + (invalid nil)) + (:conc-name %wrapper-) + (:constructor make-wrapper-internal) + (:copier nil)) + (instance-slots-layout nil :type list) + (class-slots nil :type list)) +#-sb-fluid (declaim (sb-ext:freeze-type wrapper)) + ;;;; 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)) +(sb-kernel:!defstruct-with-alternate-metaclass pcl-funcallable-instance + ;; KLUDGE: Note that neither of these slots is ever accessed by its + ;; accessor name as of sbcl-0.pre7.63. Presumably everything works + ;; by puns based on absolute locations. Fun fun fun.. -- WHN 2001-10-30 + :slot-names (clos-slots name hash-code) + :boa-constructor %make-pcl-funcallable-instance + :superclass-name sb-kernel:funcallable-instance + :metaclass-name sb-kernel:random-pcl-class + :metaclass-constructor sb-kernel:make-random-pcl-class + :dd-type sb-kernel:funcallable-structure + ;; Only internal implementation code will access these, and these + ;; accesses (slot readers in particular) could easily be a + ;; bottleneck, so it seems reasonable to suppress runtime type + ;; checks. + ;; + ;; (Except note KLUDGE above that these accessors aren't used at all + ;; (!) as of sbcl-0.pre7.63, so for now it's academic.) + :runtime-type-checks-p 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) +(defun set-funcallable-instance-fun (fin new-value) (declare (type function new-value)) (aver (funcallable-instance-p fin)) - (setf (sb-kernel:funcallable-instance-function fin) new-value)) + (setf (sb-kernel:funcallable-instance-fun 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)) + `(sb-kernel:%funcallable-instance-layout ,fin)) +;;; FIXME: This seems to bear no relation at all to the CLOS-SLOTS +;;; slot in the FUNCALLABLE-INSTANCE structure, above, which +;;; (bizarrely) seems to be set to the NAME of the +;;; FUNCALLABLE-INSTANCE. At least, the index 1 seems to return the +;;; NAME, and the index 2 NIL. Weird. -- CSR, 2002-11-07 (defmacro fsc-instance-slots (fin) - `(funcallable-instance-data-1 ,fin 'slots)) + `(sb-kernel:%funcallable-instance-info ,fin 0)) +(defmacro fsc-instance-hash (fin) + `(sb-kernel:%funcallable-instance-info ,fin 3)) (declaim (inline clos-slots-ref (setf clos-slots-ref))) (declaim (ftype (function (simple-vector index) t) clos-slots-ref)) @@ -145,36 +169,29 @@ ;;; 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 +;;; SET-FUN-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 a new -;;; function which is "the same" except that it has the name. +;;; When given a funcallable instance, SET-FUN-NAME *must* side-effect +;;; that FIN to give it the name. When given any other kind of +;;; function SET-FUN-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) +;;; In all cases, SET-FUN-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) +(defun set-fun-name (fcn new-name) #+sb-doc "Set the name of a compiled function object. Return the function." (declare (special *boot-state* *the-class-standard-generic-function*)) (cond ((symbolp fcn) - (set-function-name (symbol-function fcn) new-name)) + (set-fun-name (symbol-function fcn) new-name)) ((funcallable-instance-p fcn) (if (if (eq *boot-state* 'complete) (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 - (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-eval:interpreted-function - (setf (sb-eval:interpreted-function-name fcn) new-name)))) + (bug "unanticipated function type")) fcn) (t ;; pw-- This seems wrong and causes trouble. Tests show @@ -193,13 +210,13 @@ ;; it loses some info of potential hacking value. So, ;; lets not do this... #+nil - (let ((header (sb-kernel:%closure-function fcn))) - (setf (sb-kernel:%function-name header) new-name)) + (let ((header (sb-kernel:%closure-fun fcn))) + (setf (sb-kernel:%simple-fun-name header) new-name)) ;; XXX Maybe add better scheme here someday. fcn))) -(defun intern-function-name (name) +(defun intern-fun-name (name) (cond ((symbolp name) name) ((listp name) (intern (let ((*package* *pcl-package*) @@ -225,21 +242,36 @@ (defun pcl-instance-p (x) (typep (sb-kernel:layout-of x) 'wrapper)) -;;; We define this as STANDARD-INSTANCE, since we're going to clobber -;;; the layout with some standard-instance layout as soon as we make -;;; it, and we want the accessor to still be type-correct. +;;; CMU CL comment: +;;; We define this as STANDARD-INSTANCE, since we're going to +;;; clobber the layout with some standard-instance layout as soon as +;;; we make it, and we want the accessor to still be type-correct. +#| (defstruct (standard-instance (:predicate nil) (:constructor %%allocate-instance--class ()) (:copier nil) - (:alternate-metaclass sb-kernel:instance cl:standard-class + (:alternate-metaclass sb-kernel:instance + cl:standard-class sb-kernel:make-standard-class)) (slots nil)) +|# +(sb-kernel:!defstruct-with-alternate-metaclass standard-instance + :slot-names (slots hash-code) + :boa-constructor %make-standard-instance + :superclass-name sb-kernel:instance + :metaclass-name cl:standard-class + :metaclass-constructor sb-kernel:make-standard-class + :dd-type structure + :runtime-type-checks-p nil) ;;; Both of these operations "work" on structures, which allows the above ;;; weakening of STD-INSTANCE-P. (defmacro std-instance-slots (x) `(sb-kernel:%instance-ref ,x 1)) (defmacro std-instance-wrapper (x) `(sb-kernel:%instance-layout ,x)) +;;; KLUDGE: This one doesn't "work" on structures. However, we +;;; ensure, in SXHASH and friends, never to call it on structures. +(defmacro std-instance-hash (x) `(sb-kernel:%instance-ref ,x 2)) ;;; FIXME: These functions are called every place we do a ;;; CALL-NEXT-METHOD, and probably other places too. It's likely worth @@ -253,6 +285,10 @@ (std-instance-slots instance) (fsc-instance-slots instance))) (defun get-slots-or-nil (instance) + ;; Supress a code-deletion note. FIXME: doing the FIXME above, + ;; integrating PCL more with the compiler, would remove the need for + ;; this icky stuff. + (declare (optimize (inhibit-warnings 3))) (when (pcl-instance-p instance) (get-slots instance))) @@ -272,6 +308,20 @@ ,wrapper nil))) +;;;; support for useful hashing of PCL instances +(let ((hash-code 0)) + (declare (fixnum hash-code)) + (defun get-instance-hash-code () + (if (< hash-code most-positive-fixnum) + (incf hash-code) + (setq hash-code 0)))) + +(defun sb-impl::sxhash-instance (x) + (cond + ((std-instance-p x) (std-instance-hash x)) + ((fsc-instance-p x) (fsc-instance-hash x)) + (t (bug "SXHASH-INSTANCE called on some weird thing: ~S" x)))) + ;;;; structure-instance stuff ;;;; ;;;; FIXME: Now that the code is SBCL-only, this extra layer of @@ -299,14 +349,14 @@ (sb-kernel:dsd-name slotd)) (defun structure-slotd-accessor-symbol (slotd) - (sb-kernel:dsd-accessor slotd)) + (sb-kernel:dsd-accessor-name slotd)) (defun structure-slotd-reader-function (slotd) - (fdefinition (sb-kernel:dsd-accessor slotd))) + (fdefinition (sb-kernel:dsd-accessor-name slotd))) (defun structure-slotd-writer-function (slotd) (unless (sb-kernel:dsd-read-only slotd) - (fdefinition `(setf ,(sb-kernel:dsd-accessor slotd))))) + (fdefinition `(setf ,(sb-kernel:dsd-accessor-name slotd))))) (defun structure-slotd-type (slotd) (sb-kernel:dsd-type slotd))