;;;; specification.
(in-package "SB-PCL")
-
-(sb-int:file-comment
- "$Header$")
\f
(defmacro instance-slot-index (wrapper slot-name)
`(let ((pos 0))
(defvar *slot-name-lists-inner* (make-hash-table :test 'equal))
(defvar *slot-name-lists-outer* (make-hash-table :test 'equal))
-;entries in this are lists of (table . pv-offset-list)
+;;; Entries in this are lists of (table . pv-offset-list).
(defvar *pv-key-to-pv-table-table* (make-hash-table :test 'equal))
(defun intern-pv-table (&key slot-name-lists call-list)
(defvar *pv-table-cache-update-info* nil)
-;called by:
-;(method shared-initialize :after (structure-class t))
-;update-slots
(defun update-pv-table-cache-info (class)
(let ((slot-names-for-pv-table-update nil)
(new-icui nil))
(optimize-writer slots parameter gf-name form)))))
(unless (and (consp (cadr form))
(eq 'instance-accessor-parameter (caadr form)))
- (or #||
- (cond ((and (= len 2) (symbolp fname))
- (let ((gf-name (gethash fname *gf-declared-reader-table*)))
- (when gf-name
- (maybe-optimize-reader))))
- ((= len 3)
- (let ((gf-name (gethash fname *gf-declared-writer-table*)))
- (when gf-name
- (maybe-optimize-writer)))))
- ||#
- (when (and (eq *boot-state* 'complete)
- (generic-function-p gf))
- (let ((methods (generic-function-methods gf)))
- (when methods
- (let* ((gf-name (generic-function-name gf))
- (arg-info (gf-arg-info gf))
- (metatypes (arg-info-metatypes arg-info))
- (nreq (length metatypes))
- (applyp (arg-info-applyp arg-info)))
- (when (null applyp)
- (cond ((= nreq 1)
- (when (some #'standard-reader-method-p methods)
- (maybe-optimize-reader)))
- ((and (= nreq 2)
- (consp gf-name)
- (eq (car gf-name) 'setf))
- (when (some #'standard-writer-method-p methods)
- (maybe-optimize-writer))))))))))))))
+ (when (and (eq *boot-state* 'complete)
+ (generic-function-p gf))
+ (let ((methods (generic-function-methods gf)))
+ (when methods
+ (let* ((gf-name (generic-function-name gf))
+ (arg-info (gf-arg-info gf))
+ (metatypes (arg-info-metatypes arg-info))
+ (nreq (length metatypes))
+ (applyp (arg-info-applyp arg-info)))
+ (when (null applyp)
+ (cond ((= nreq 1)
+ (when (some #'standard-reader-method-p methods)
+ (maybe-optimize-reader)))
+ ((and (= nreq 2)
+ (consp gf-name)
+ (eq (car gf-name) 'setf))
+ (when (some #'standard-writer-method-p methods)
+ (maybe-optimize-writer)))))))))))))
(defun optimize-generic-function-call (form
required-parameters
(declare (ignore required-parameters env slots calls))
(or (and (eq (car form) 'make-instance)
(expand-make-instance-form form))
- #||
- (maybe-expand-accessor-form form required-parameters slots env)
- (let* ((fname (car form))
- (len (length form))
- (gf (if (symbolp fname)
- (and (fboundp fname)
- (unencapsulated-fdefinition fname))
- (and (gboundp fname)
- (gdefinition fname))))
- (gf-name (and (fsc-instance-p gf)
- (if (early-gf-p gf)
- (early-gf-name gf)
- (generic-function-name gf)))))
- (when gf-name
- (multiple-value-bind (nreq restp)
- (get-generic-function-info gf)
- (optimize-gf-call slots calls form nreq restp env))))
- ||#
form))
\f
(defun can-optimize-access (form required-parameters env)
(slot-name (eval (caddr form)))) ; known to be constant
(can-optimize-access1 var required-parameters env type slot-name)))
-;;; FIXME: This looks like an internal helper function for CAN-OPTIMIZE-ACCESS,
-;;; and it is used that way, but
-;;; it's also called bare from several places in the code. Perhaps
-;;; the two functions should be renamed fo CAN-OPTIMIZE-ACCESS-FOR-FORM
-;;; and CAN-OPTIMIZE-ACCESS-FOR-VAR. If so, I'd just as soon use keyword
+;;; FIXME: This looks like an internal helper function for
+;;; CAN-OPTIMIZE-ACCESS, and it is used that way, but it's also called
+;;; bare from several places in the code. Perhaps the two functions
+;;; should be renamed CAN-OPTIMIZE-ACCESS-FOR-FORM and
+;;; CAN-OPTIMIZE-ACCESS-FOR-VAR. If so, I'd just as soon use keyword
;;; args instead of optional ones, too.
(defun can-optimize-access1 (var required-parameters env
&optional type slot-name)
(when (and (consp var) (eq 'the (car var)))
- ;; FIXME: We should assert list of length 3 here. Or maybe we should just
- ;; define EXTRACT-THE, replace the whole
+ ;; FIXME: We should assert list of length 3 here. Or maybe we
+ ;; should just define EXTRACT-THE, replace the whole
;; (WHEN ..)
;; form with
;; (AWHEN (EXTRACT-THE VAR)
;; (SETF VAR IT))
- ;; and then use EXTRACT-THE similarly to clean up the other tests against
- ;; 'THE scattered through the PCL code.
+ ;; and then use EXTRACT-THE similarly to clean up the other tests
+ ;; against 'THE scattered through the PCL code.
(setq var (caddr var)))
(when (symbolp var)
- (let* ((rebound? (caddr (variable-declaration 'variable-rebinding
+ (let* ((rebound? (caddr (variable-declaration '%variable-rebinding
var
env)))
(parameter-or-nil (car (memq (or rebound? var)
required-parameters))))
(when parameter-or-nil
- (let* ((class-name (caddr (variable-declaration 'class
+ (let* ((class-name (caddr (variable-declaration '%class
parameter-or-nil
env)))
(class (find-class class-name nil)))
(defun optimize-slot-boundp (slots sparameter form)
(if sparameter
(destructuring-bind
- ;; FIXME: In CMU CL ca. 19991205, this binding list had a fourth
- ;; element in it, NEW-VALUE. It's hard to see how that could possibly
- ;; be right, since SLOT-BOUNDP has no NEW-VALUE. Since it was causing
- ;; a failure in building PCL for SBCL, so I changed it to match the
- ;; definition of SLOT-BOUNDP (and also to match the list used in the
- ;; similar OPTIMIZE-SLOT-VALUE, above). However, I'm weirded out by
- ;; this, since this is old code which has worked for ages to build
- ;; PCL for CMU CL, so it's hard to see why it should need a patch
- ;; like this in order to build PCL for SBCL. I'd like to return to
- ;; this and find a test case which exercises this function both in
- ;; CMU CL, to see whether it's really a previously-unexercised bug or
- ;; whether I've misunderstood something (and, presumably, patched it
- ;; wrong).
+ ;; FIXME: In CMU CL ca. 19991205, this binding list had a
+ ;; fourth element in it, NEW-VALUE. It's hard to see how
+ ;; that could possibly be right, since SLOT-BOUNDP has no
+ ;; NEW-VALUE. Since it was causing a failure in building PCL
+ ;; for SBCL, so I changed it to match the definition of
+ ;; SLOT-BOUNDP (and also to match the list used in the
+ ;; similar OPTIMIZE-SLOT-VALUE, above). However, I'm weirded
+ ;; out by this, since this is old code which has worked for
+ ;; ages to build PCL for CMU CL, so it's hard to see why it
+ ;; should need a patch like this in order to build PCL for
+ ;; SBCL. I'd like to return to this and find a test case
+ ;; which exercises this function both in CMU CL, to see
+ ;; whether it's really a previously-unexercised bug or
+ ;; whether I've misunderstood something (and, presumably,
+ ;; patched it wrong).
(slot-boundp-symbol instance slot-name-form)
form
(declare (ignore slot-boundp-symbol instance))
(optimize-accessor-call slots :write sparameter gf-name new-value))
form))
-;;; The SLOTS argument is an alist, the CAR of each entry is the name of
-;;; a required parameter to the function. The alist is in order, so the
-;;; position of an entry in the alist corresponds to the argument's position
-;;; in the lambda list.
+;;; The SLOTS argument is an alist, the CAR of each entry is the name
+;;; of a required parameter to the function. The alist is in order, so
+;;; the position of an entry in the alist corresponds to the
+;;; argument's position in the lambda list.
(defun optimize-instance-access (slots
read/write
sparameter
(eq (car form) 'the))
(setq form (caddr form)))
(or (and (symbolp form)
- (let* ((rebound? (caddr (variable-declaration 'variable-rebinding
+ (let* ((rebound? (caddr (variable-declaration '%variable-rebinding
form env)))
(parameter-or-nil (car (assq (or rebound? form) slots))))
(when parameter-or-nil
*unspecific-arg*)))
(defun optimize-gf-call (slots calls gf-call-form nreq restp env)
- (unless (eq (car gf-call-form) 'make-instance) ; needs more work
+ (unless (eq (car gf-call-form) 'make-instance) ; XXX needs more work
(let* ((args (cdr gf-call-form))
(all-args-p (eq (car gf-call-form) 'make-instance))
(non-required-args (nthcdr nreq args))
(define-walker-template instance-accessor-parameter)
(defmacro instance-accessor-parameter (x) x)
-;; It is safe for these two functions to be wrong.
-;; They just try to guess what the most likely case will be.
+;;; It is safe for these two functions to be wrong. They just try to
+;;; guess what the most likely case will be.
(defun generate-fast-class-slot-access-p (class-form slot-name-form)
(let ((class (and (constantp class-form) (eval class-form)))
(slot-name (and (constantp slot-name-form) (eval slot-name-form))))
(standard-class-p class)
(not (eq class *the-class-t*)) ; shouldn't happen, though.
(let ((slotd (find-slot-definition class slot-name)))
- (and slotd (skip-optimize-slot-value-by-class-p class slot-name type))))))
+ (and slotd (skip-optimize-slot-value-by-class-p class
+ slot-name
+ type))))))
(defun skip-optimize-slot-value-by-class-p (class slot-name type)
(let ((slotd (find-slot-definition class slot-name)))
(let ((,index (pvref ,pv ,pv-offset)))
(setq ,value (typecase ,index
,@(when (or (null type) (eq type ':instance))
- `((fixnum (%instance-ref ,slots ,index))))
+ `((fixnum (clos-slots-ref ,slots ,index))))
,@(when (or (null type) (eq type ':class))
`((cons (cdr ,index))))
- (t ',*slot-unbound*)))
- (if (eq ,value ',*slot-unbound*)
+ (t +slot-unbound+)))
+ (if (eq ,value +slot-unbound+)
,default
,value))))))
(let ((,index (pvref ,pv ,pv-offset)))
(typecase ,index
,@(when (or (null type) (eq type ':instance))
- `((fixnum (setf (%instance-ref ,slots ,index) ,new-value))))
+ `((fixnum (setf (clos-slots-ref ,slots ,index)
+ ,new-value))))
,@(when (or (null type) (eq type ':class))
`((cons (setf (cdr ,index) ,new-value))))
(t ,default)))))))
(let ((,index (pvref ,pv ,pv-offset)))
(typecase ,index
,@(when (or (null type) (eq type ':instance))
- `((fixnum (not (eq (%instance-ref ,slots ,index)
- ',*slot-unbound*)))))
+ `((fixnum (not (and ,slots
+ (eq (clos-slots-ref ,slots ,index)
+ +slot-unbound+))))))
,@(when (or (null type) (eq type ':class))
- `((cons (not (eq (cdr ,index) ',*slot-unbound*)))))
+ `((cons (not (eq (cdr ,index) +slot-unbound+)))))
(t ,default)))))))
(defmacro instance-boundp (pv-offset parameter position slot-name class)
;;; This magic function has quite a job to do indeed.
;;;
-;;; The careful reader will recall that <slots> contains all of the optimized
-;;; slot access forms produced by OPTIMIZE-INSTANCE-ACCESS. Each of these is
-;;; a call to either INSTANCE-READ or INSTANCE-WRITE.
+;;; The careful reader will recall that <slots> contains all of the
+;;; optimized slot access forms produced by OPTIMIZE-INSTANCE-ACCESS.
+;;; Each of these is a call to either INSTANCE-READ or INSTANCE-WRITE.
;;;
-;;; At the time these calls were produced, the first argument was specified as
-;;; the symbol .PV-OFFSET.; what we have to do now is convert those pv-offset
-;;; arguments into the actual number that is the correct offset into the pv.
+;;; At the time these calls were produced, the first argument was
+;;; specified as the symbol .PV-OFFSET.; what we have to do now is
+;;; convert those pv-offset arguments into the actual number that is
+;;; the correct offset into the pv.
;;;
-;;; But first, oh but first, we sort <slots> a bit so that for each argument we
-;;; have the slots in alphabetical order. This canonicalizes the PV-TABLE's a
-;;; bit and will hopefully lead to having fewer PV's floating around. Even if
-;;; the gain is only modest, it costs nothing.
+;;; But first, oh but first, we sort <slots> a bit so that for each
+;;; argument we have the slots in alphabetical order. This
+;;; canonicalizes the PV-TABLE's a bit and will hopefully lead to
+;;; having fewer PV's floating around. Even if the gain is only
+;;; modest, it costs nothing.
(defun slot-name-lists-from-slots (slots calls)
(multiple-value-bind (slots calls) (mutate-slots-and-calls slots calls)
(let* ((slot-name-lists
(symbol-or-cons-lessp (car a) (car b))))))))
(defun sort-slots (slots)
- (mapcar #'(lambda (parameter-entry)
- (cons (car parameter-entry)
- (sort (cdr parameter-entry) ;slot entries
- #'symbol-or-cons-lessp
- :key #'car)))
+ (mapcar (lambda (parameter-entry)
+ (cons (car parameter-entry)
+ (sort (cdr parameter-entry) ;slot entries
+ #'symbol-or-cons-lessp
+ :key #'car)))
slots))
(defun sort-calls (calls)
(sort calls #'symbol-or-cons-lessp :key #'car))
\f
-;;; This needs to work in terms of metatypes and also needs to work for
-;;; automatically generated reader and writer functions.
-;;; -- Automatically generated reader and writer functions use this stuff too.
+;;;; This needs to work in terms of metatypes and also needs to work
+;;;; for automatically generated reader and writer functions.
+;;;; Automatically generated reader and writer functions use this
+;;;; stuff too.
(defmacro pv-binding ((required-parameters slot-name-lists pv-table-symbol)
&body body)
slot-vars pv-parameters))
,@body)))
-;This gets used only when the default make-method-lambda is overriden.
+;;; This gets used only when the default MAKE-METHOD-LAMBDA is overridden.
(defmacro pv-env ((pv calls pv-table-symbol pv-parameters)
&rest forms)
`(let* ((.pv-table. ,pv-table-symbol)
,@forms))
(defvar *non-variable-declarations*
- ;; FIXME: VALUES was in this list, conditionalized with #+CMU, but
- ;; I don't *think* CMU CL had, or SBCL has, VALUES declarations. If
- ;; SBCL doesn't have 'em, VALUES should probably be removed from this list.
- '(values method-name method-lambda-list
+ ;; FIXME: VALUES was in this list, conditionalized with #+CMU, but I
+ ;; don't *think* CMU CL had, or SBCL has, VALUES declarations. If
+ ;; SBCL doesn't have 'em, VALUES should probably be removed from
+ ;; this list.
+ '(values %method-name %method-lambda-list
optimize ftype inline notinline))
(defvar *variable-declarations-with-argument*
- '(class
+ '(%class
type))
(defvar *variable-declarations-without-argument*
- '(ignore ignorable special dynamic-extent
+ '(ignore
+ ignorable special dynamic-extent
+ ;; FIXME: Possibly this entire list and variable could go away.
+ ;; If not, certainly we should remove all these built-in typenames
+ ;; from the list, and replace them with a test for "is it a type
+ ;; name?" (CLTL1 allowed only built-in type names as declarations,
+ ;; but ANSI CL allows any type name as a declaration.)
array atom base-char bignum bit bit-vector character compiled-function
complex cons double-float extended-char
fixnum float function hash-table integer
stream string symbol t unsigned-byte vector))
(defun split-declarations (body args calls-next-method-p)
- (let ((inner-decls nil) (outer-decls nil) decl)
+ (let ((inner-decls nil)
+ (outer-decls nil)
+ decl)
(loop (when (null body) (return nil))
(setq decl (car body))
(unless (and (consp decl)
(dname (list (pop form)))
(inners nil) (outers nil))
(unless (or arg-p non-arg-p)
- ;; FIXME: This warning should probably go away now
- ;; that we're not trying to be portable between
- ;; different CLTL1 hosts the way PCL was.
+ ;; FIXME: This warning, and perhaps the
+ ;; various *VARIABLE-DECLARATIONS-FOO* and/or
+ ;; *NON-VARIABLE-DECLARATIONS* variables,
+ ;; could probably go away now that we're not
+ ;; trying to be portable between different
+ ;; CLTL1 hosts the way PCL was. (Note that to
+ ;; do this right, we need to be able to handle
+ ;; user-defined (DECLAIM (DECLARATION FOO))
+ ;; stuff.)
(warn "The declaration ~S is not understood by ~S.~@
Please put ~S on one of the lists ~S,~%~S, or~%~S.~@
(Assuming it is a variable declaration without argument)."
(setq dname (append dname (list (pop form)))))
(dolist (var form)
(if (member var args)
- ;; Quietly remove IGNORE declarations on args when
- ;; a next-method is involved, to prevent compiler
- ;; warns about ignored args being read.
- (unless (and calls-next-method-p
- (eq (car dname) 'ignore))
+ ;; Quietly remove IGNORE declarations on
+ ;; args when a next-method is involved, to
+ ;; prevent compiler warns about ignored
+ ;; args being read.
+ (unless (and calls-next-method-p
+ (eq (car dname) 'ignore))
(push var outers))
(push var inners)))
(when outers
(append req-args (list rest-arg))
req-args)))
`(list* :fast-function
- #'(lambda (.pv-cell. .next-method-call. ,@args+rest-arg)
- ,@outer-decls
- .pv-cell. .next-method-call.
- (macrolet ((pv-env ((pv calls pv-table-symbol pv-parameters)
- &rest forms)
- (declare (ignore pv-table-symbol pv-parameters))
- `(let ((,pv (car .pv-cell.))
- (,calls (cdr .pv-cell.)))
- (declare ,(make-pv-type-declaration pv)
- ,(make-calls-type-declaration calls))
- ,pv ,calls
- ,@forms)))
- (fast-lexical-method-functions
- (,(car lmf-params) .next-method-call. ,req-args ,rest-arg
- ,@(cdddr lmf-params))
- ,@inner-decls
- ,@body)))
+ (lambda (.pv-cell. .next-method-call. ,@args+rest-arg)
+ (declare (ignorable .pv-cell. .next-method-call.))
+ ,@outer-decls
+ (macrolet ((pv-env ((pv calls pv-table-symbol pv-parameters)
+ &rest forms)
+ (declare (ignore pv-table-symbol pv-parameters))
+ `(let ((,pv (car .pv-cell.))
+ (,calls (cdr .pv-cell.)))
+ (declare ,(make-pv-type-declaration pv)
+ ,(make-calls-type-declaration calls))
+ ,pv ,calls
+ ,@forms)))
+ (fast-lexical-method-functions
+ (,(car lmf-params) .next-method-call. ,req-args ,rest-arg
+ ,@(cdddr lmf-params))
+ ,@inner-decls
+ ,@body)))
',initargs))))
-;;; Use arrays and hash tables and the fngen stuff to make this much better. It
-;;; doesn't really matter, though, because a function returned by this will get
-;;; called only when the user explicitly funcalls a result of method-function.
-;;; BUT, this is needed to make early methods work.
+;;; Use arrays and hash tables and the fngen stuff to make this much
+;;; better. It doesn't really matter, though, because a function
+;;; returned by this will get called only when the user explicitly
+;;; funcalls a result of method-function. BUT, this is needed to make
+;;; early methods work.
(defun method-function-from-fast-function (fmf)
(declare (type function fmf))
(let* ((method-function nil) (pv-table nil)
projects / sbcl.git / blobdiff