X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Flow.lisp;h=871b1705c12749779fad7e07a0c27e3a46477a8a;hb=8160f3ac81fff66563276cfbc7546d43891dae5c;hp=dbe1094eaf5097b684b6646819854d45b4272b4c;hpb=416152f084604094445a758ff399871132dff2bd;p=sbcl.git diff --git a/src/pcl/low.lisp b/src/pcl/low.lisp index dbe1094..871b170 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 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)) +(!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 funcallable-instance + :metaclass-name random-pcl-classoid + :metaclass-constructor make-random-pcl-classoid + :dd-type 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) (declare (type function new-value)) (aver (funcallable-instance-p fin)) - (setf (sb-kernel:funcallable-instance-function fin) new-value)) + (setf (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)) + `(%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)) + `(%funcallable-instance-info ,fin 0)) +(defmacro fsc-instance-hash (fin) + `(%funcallable-instance-info ,fin 3)) (declaim (inline clos-slots-ref (setf clos-slots-ref))) (declaim (ftype (function (simple-vector index) t) clos-slots-ref)) @@ -105,7 +129,7 @@ ;;; few uses of (OR STD-INSTANCE-P FSC-INSTANCE-P) are changed to ;;; PCL-INSTANCE-P. (defmacro std-instance-p (x) - `(sb-kernel:%instancep ,x)) + `(%instancep ,x)) ;; a temporary definition used for debugging the bootstrap #+sb-show @@ -145,42 +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) - (error 'simple-type-error - :datum fcn - :expected-type 'generic-function - :format-control "internal error: unexpected function type") - ;; FIXME: byte compiler to go away completely - #| - (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))) - |# - ) + (setf (%funcallable-instance-info fcn 1) new-name) + (bug "unanticipated function type")) fcn) (t ;; pw-- This seems wrong and causes trouble. Tests show @@ -199,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 (%closure-fun fcn))) + (setf (%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*) @@ -219,33 +230,45 @@ (defmacro precompile-random-code-segments (&optional system) `(progn (eval-when (:compile-toplevel) - (update-dispatch-dfuns) - (compile-iis-functions nil)) + (update-dispatch-dfuns)) (precompile-function-generators ,system) (precompile-dfun-constructors ,system) - (precompile-iis-functions ,system) - (eval-when (:load-toplevel) - (compile-iis-functions t)))) + (precompile-ctors))) ;;; This definition is for interpreted code. (defun pcl-instance-p (x) - (typep (sb-kernel:layout-of x) 'wrapper)) + (typep (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 - sb-kernel:make-standard-class)) + (:alternate-metaclass instance + cl:standard-class + make-standard-class)) (slots nil)) +|# +(!defstruct-with-alternate-metaclass standard-instance + :slot-names (slots hash-code) + :boa-constructor %make-standard-instance + :superclass-name instance + :metaclass-name standard-classoid + :metaclass-constructor make-standard-classoid + :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)) +(defmacro std-instance-slots (x) `(%instance-ref ,x 1)) +(defmacro std-instance-wrapper (x) `(%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) `(%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 @@ -259,10 +282,14 @@ (std-instance-slots instance) (fsc-instance-slots instance))) (defun get-slots-or-nil (instance) + ;; Suppress 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))) -(defmacro built-in-or-structure-wrapper (x) `(sb-kernel:layout-of ,x)) +(defmacro built-in-or-structure-wrapper (x) `(layout-of ,x)) (defmacro get-wrapper (inst) (once-only ((wrapper `(wrapper-of ,inst))) @@ -278,6 +305,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 @@ -287,10 +328,10 @@ ;;; The definition of STRUCTURE-TYPE-P was moved to early-low.lisp. (defun get-structure-dd (type) - (sb-kernel:layout-info (sb-kernel:class-layout (cl:find-class type)))) + (layout-info (classoid-layout (find-classoid type)))) (defun structure-type-included-type-name (type) - (let ((include (sb-kernel::dd-include (get-structure-dd type)))) + (let ((include (dd-include (get-structure-dd type)))) (if (consp include) (car include) include))) @@ -298,24 +339,24 @@ (defun structure-type-slot-description-list (type) (nthcdr (length (let ((include (structure-type-included-type-name type))) (and include - (sb-kernel:dd-slots (get-structure-dd include))))) - (sb-kernel:dd-slots (get-structure-dd type)))) + (dd-slots (get-structure-dd include))))) + (dd-slots (get-structure-dd type)))) (defun structure-slotd-name (slotd) - (sb-kernel:dsd-name slotd)) + (dsd-name slotd)) (defun structure-slotd-accessor-symbol (slotd) - (sb-kernel:dsd-accessor-name slotd)) + (dsd-accessor-name slotd)) (defun structure-slotd-reader-function (slotd) - (fdefinition (sb-kernel:dsd-accessor-name slotd))) + (fdefinition (dsd-accessor-name slotd))) (defun structure-slotd-writer-function (slotd) - (unless (sb-kernel:dsd-read-only slotd) - (fdefinition `(setf ,(sb-kernel:dsd-accessor-name slotd))))) + (unless (dsd-read-only slotd) + (fdefinition `(setf ,(dsd-accessor-name slotd))))) (defun structure-slotd-type (slotd) - (sb-kernel:dsd-type slotd)) + (dsd-type slotd)) (defun structure-slotd-init-form (slotd) - (sb-kernel::dsd-default slotd)) + (dsd-default slotd))