X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fdlisp.lisp;h=27f601c7e89c725c4d51aa58209f00c59b24aafc;hb=c1d63b850fe9528036f8ae715088384e81d880cc;hp=e0d23e75cf1faa9fbb312aaa0ec5fccced1cbb29;hpb=e3932d9a8cf3b8d2272cf75d1c40173af48747be;p=sbcl.git diff --git a/src/pcl/dlisp.lisp b/src/pcl/dlisp.lisp index e0d23e7..27f601c 100644 --- a/src/pcl/dlisp.lisp +++ b/src/pcl/dlisp.lisp @@ -22,12 +22,88 @@ ;;;; specification. (in-package "SB-PCL") - -;;; This file is (almost) functionally equivalent to dlap.lisp, but -;;; easier to read. -;;; Might generate faster code, too, depending on the compiler and -;;; whether an implementation-specific lap assembler was used. + +;;;; some support stuff for getting a hold of symbols that we need when +;;;; building the discriminator codes. It's OK for these to be interned +;;;; symbols because we don't capture any user code in the scope in which +;;;; these symbols are bound. + +(declaim (list *dfun-arg-symbols*)) +(defvar *dfun-arg-symbols* '(.ARG0. .ARG1. .ARG2. .ARG3.)) + +(defun dfun-arg-symbol (arg-number) + (or (nth arg-number *dfun-arg-symbols*) + (format-symbol *pcl-package* ".ARG~A." arg-number))) + +(declaim (list *slot-vector-symbols*)) +(defvar *slot-vector-symbols* '(.SLOTS0. .SLOTS1. .SLOTS2. .SLOTS3.)) + +(defun slot-vector-symbol (arg-number) + (or (nth arg-number *slot-vector-symbols*) + (format-symbol *pcl-package* ".SLOTS~A." arg-number))) + +(declaim (inline make-dfun-required-args)) +(defun make-dfun-required-args (count) + (declare (type index count)) + (let (result) + (dotimes (i count (nreverse result)) + (push (dfun-arg-symbol i) result)))) + +(defun make-dfun-lambda-list (nargs applyp) + (let ((required (make-dfun-required-args nargs))) + (if applyp + (nconc required + ;; Use &MORE arguments to avoid consing up an &REST list + ;; that we might not need at all. See MAKE-EMF-CALL and + ;; INVOKE-EFFECTIVE-METHOD-FUNCTION for the other + ;; pieces. + '(&more .dfun-more-context. .dfun-more-count.)) + required))) + +(defun make-dlap-lambda-list (nargs applyp) + (let* ((required (make-dfun-required-args nargs)) + (lambda-list (if applyp + (append required '(&more .more-context. .more-count.)) + required))) + ;; Return the full lambda list, the required arguments, a form + ;; that will generate a rest-list, and a list of the &MORE + ;; parameters used. + (values lambda-list + required + (when applyp + '((sb-c::%listify-rest-args + .more-context. + (the (and unsigned-byte fixnum) + .more-count.)))) + (when applyp + '(.more-context. .more-count.))))) + +(defun make-emf-call (nargs applyp fn-variable &optional emf-type) + (let ((required (make-dfun-required-args nargs))) + `(,(if (eq emf-type 'fast-method-call) + 'invoke-effective-method-function-fast + 'invoke-effective-method-function) + ,fn-variable + ,applyp + :required-args ,required + ;; INVOKE-EFFECTIVE-METHOD-FUNCTION will decide whether to use + ;; the :REST-ARG version or the :MORE-ARG version depending on + ;; the type of the EMF. + :rest-arg ,(if applyp + ;; Creates a list from the &MORE arguments. + '((sb-c::%listify-rest-args + .dfun-more-context. + (the (and unsigned-byte fixnum) + .dfun-more-count.))) + nil) + :more-arg ,(when applyp + '(.dfun-more-context. .dfun-more-count.))))) + +(defun make-fast-method-call-lambda-list (nargs applyp) + (list* '.pv. '.next-method-call. (make-dfun-lambda-list nargs applyp))) + +;;; Emitting various accessors. (defun emit-one-class-reader (class-slot-p) (emit-reader/writer :reader 1 class-slot-p)) @@ -85,27 +161,10 @@ ;;; FIXME: What do these variables mean? (defvar *precompiling-lap* nil) -(defvar *emit-function-p* t) - -;;; FIXME: This variable is motivated by Gerd Moellman's observation, -;;; in <867kga1wra.fsf@gerd.free-bsd.org> on cmucl-imp 2002-10-22, -;;; that the functions returned from EMIT-xxx-FUNCTION can cause an -;;; order-of-magnitude slowdown. We include this variable for now, -;;; but maybe its effect should rather be controlled by compilation -;;; policy if there is a noticeable space difference between the -;;; branches, or else maybe the EMIT-xxx-FUNCTION branches should be -;;; deleted. It's not clear to me how all of this works, though, so -;;; until proper benchmarks are done it's probably safest simply to -;;; have this pseudo-constant to hide code. -- CSR, 2003-02-14 -(defvar *optimize-cache-functions-p* t) (defun emit-default-only (metatypes applyp) - (unless *optimize-cache-functions-p* - (when (and (null *precompiling-lap*) *emit-function-p*) - (return-from emit-default-only - (emit-default-only-function metatypes applyp)))) (multiple-value-bind (lambda-list args rest-arg more-arg) - (make-dlap-lambda-list metatypes applyp) + (make-dlap-lambda-list (length metatypes) applyp) (generating-lisp '(emf) lambda-list `(invoke-effective-method-function emf @@ -137,17 +196,10 @@ ;;; FSC-INSTANCE-P returns true on funcallable structures as well as ;;; PCL fins. (defun emit-reader/writer (reader/writer 1-or-2-class class-slot-p) - (unless *optimize-cache-functions-p* - (when (and (null *precompiling-lap*) *emit-function-p*) - (return-from emit-reader/writer - (emit-reader/writer-function - reader/writer 1-or-2-class class-slot-p)))) (let ((instance nil) (arglist ()) (closure-variables ()) - (field +first-wrapper-cache-number-index+) (read-form (emit-slot-read-form class-slot-p 'index 'slots))) - ;;we need some field to do the fast obsolete check (ecase reader/writer ((:reader :boundp) (setq instance (dfun-arg-symbol 0) @@ -173,7 +225,7 @@ (fsc-instance-wrapper ,instance))))) (block access (when (and wrapper - (/= (wrapper-cache-number-vector-ref wrapper ,field) 0) + (not (zerop (layout-clos-hash wrapper))) ,@(if (eql 1 1-or-2-class) `((eq wrapper wrapper-0)) `((or (eq wrapper wrapper-0) @@ -185,7 +237,7 @@ (return-from access value))))) (:boundp `((let ((value ,read-form)) - (return-from access (not (eq value +slot-unbound+)))))) + (return-from access (not (eq value +slot-unbound+)))))) (:writer `((return-from access (setf ,read-form ,(car arglist))))))) (funcall miss-fn ,@arglist)))))) @@ -210,19 +262,13 @@ (:writer `(setf ,read-form ,(car arglist)))))) (defmacro emit-reader/writer-macro (reader/writer 1-or-2-class class-slot-p) - (let ((*emit-function-p* nil) - (*precompiling-lap* t)) + (let ((*precompiling-lap* t)) (values (emit-reader/writer reader/writer 1-or-2-class class-slot-p)))) (defun emit-one-or-n-index-reader/writer (reader/writer cached-index-p class-slot-p) - (unless *optimize-cache-functions-p* - (when (and (null *precompiling-lap*) *emit-function-p*) - (return-from emit-one-or-n-index-reader/writer - (emit-one-or-n-index-reader/writer-function - reader/writer cached-index-p class-slot-p)))) (multiple-value-bind (arglist metatypes) (ecase reader/writer ((:reader :boundp) @@ -235,7 +281,7 @@ arglist `(let (,@(unless class-slot-p '(slots)) ,@(when cached-index-p '(index))) - ,(emit-dlap arglist metatypes + ,(emit-dlap 'cache arglist metatypes (emit-slot-access reader/writer class-slot-p 'slots 'index 'miss-fn arglist) `(funcall miss-fn ,@arglist) @@ -244,8 +290,7 @@ (defmacro emit-one-or-n-index-reader/writer-macro (reader/writer cached-index-p class-slot-p) - (let ((*emit-function-p* nil) - (*precompiling-lap* t)) + (let ((*precompiling-lap* t)) (values (emit-one-or-n-index-reader/writer reader/writer cached-index-p @@ -260,19 +305,13 @@ `(funcall ,miss-fn ,@args))) (defun emit-checking-or-caching (cached-emf-p return-value-p metatypes applyp) - (unless *optimize-cache-functions-p* - (when (and (null *precompiling-lap*) *emit-function-p*) - (return-from emit-checking-or-caching - (emit-checking-or-caching-function - cached-emf-p return-value-p metatypes applyp)))) (multiple-value-bind (lambda-list args rest-arg more-arg) - (make-dlap-lambda-list metatypes applyp) + (make-dlap-lambda-list (length metatypes) applyp) (generating-lisp `(cache ,@(unless cached-emf-p '(emf)) miss-fn) lambda-list `(let (,@(when cached-emf-p '(emf))) - ,(emit-dlap args - metatypes + ,(emit-dlap 'cache args metatypes (if return-value-p (if cached-emf-p 'emf t) `(invoke-effective-method-function @@ -287,13 +326,14 @@ return-value-p metatypes applyp) - (let ((*emit-function-p* nil) - (*precompiling-lap* t)) + (let ((*precompiling-lap* t)) (values (emit-checking-or-caching cached-emf-p return-value-p metatypes applyp)))) -(defun emit-dlap (args metatypes hit miss value-reg &optional slot-regs) +(defun emit-dlap (cache-var args metatypes hit-form miss-form value-var + &optional slot-vars) (let* ((index -1) + (miss-tag (gensym "MISSED")) (wrapper-bindings (mapcan (lambda (arg mt) (unless (eq mt t) (incf index) @@ -301,176 +341,61 @@ "WRAPPER-~D" index) ,(emit-fetch-wrapper - mt arg 'miss (pop slot-regs)))))) + mt arg miss-tag (pop slot-vars)))))) args metatypes)) - (wrappers (mapcar #'car wrapper-bindings))) + (wrapper-vars (mapcar #'car wrapper-bindings))) (declare (fixnum index)) - (unless wrappers (error "Every metatype is T.")) - `(block dfun - (tagbody - (let ((field (cache-field cache)) - (cache-vector (cache-vector cache)) - (mask (cache-mask cache)) - (size (cache-size cache)) - (overflow (cache-overflow cache)) - ,@wrapper-bindings) - (declare (fixnum size field mask)) - ,(cond ((cdr wrappers) - (emit-greater-than-1-dlap wrappers 'miss value-reg)) - (value-reg - (emit-1-t-dlap (car wrappers) 'miss value-reg)) - (t - (emit-1-nil-dlap (car wrappers) 'miss))) - (return-from dfun ,hit)) - miss - (return-from dfun ,miss))))) - -(defun emit-1-nil-dlap (wrapper miss-label) - `(let* ((primary ,(emit-1-wrapper-compute-primary-cache-location wrapper - miss-label)) - (location primary)) - (declare (fixnum primary location)) - (block search - (loop (when (eq ,wrapper (cache-vector-ref cache-vector location)) - (return-from search nil)) - (setq location (the fixnum (+ location 1))) - (when (= location size) - (setq location 0)) - (when (= location primary) - (dolist (entry overflow) - (when (eq (car entry) ,wrapper) - (return-from search nil))) - (go ,miss-label)))))) - -(defmacro get-cache-vector-lock-count (cache-vector) - `(let ((lock-count (cache-vector-lock-count ,cache-vector))) - (unless (typep lock-count 'fixnum) - (error "My cache got freed somehow.")) - (the fixnum lock-count))) - -(defun emit-1-t-dlap (wrapper miss-label value) - `(let ((primary ,(emit-1-wrapper-compute-primary-cache-location wrapper - miss-label)) - (initial-lock-count (get-cache-vector-lock-count cache-vector))) - (declare (fixnum primary initial-lock-count)) - (let ((location primary)) - (declare (fixnum location)) - (block search - (loop (when (eq ,wrapper (cache-vector-ref cache-vector location)) - (setq ,value (cache-vector-ref cache-vector (1+ location))) - (return-from search nil)) - (setq location (the fixnum (+ location 2))) - (when (= location size) - (setq location 0)) - (when (= location primary) - (dolist (entry overflow) - (when (eq (car entry) ,wrapper) - (setq ,value (cdr entry)) - (return-from search nil))) - (go ,miss-label)))) - (unless (= initial-lock-count - (get-cache-vector-lock-count cache-vector)) - (go ,miss-label))))) - -(defun emit-greater-than-1-dlap (wrappers miss-label value) - (declare (type list wrappers)) - (let ((cache-line-size (compute-line-size (+ (length wrappers) - (if value 1 0))))) - `(let ((primary 0) - (size-1 (the fixnum (- size 1)))) - (declare (fixnum primary size-1)) - ,(emit-n-wrapper-compute-primary-cache-location wrappers miss-label) - (let ((initial-lock-count (get-cache-vector-lock-count cache-vector))) - (declare (fixnum initial-lock-count)) - (let ((location primary) - (next-location 0)) - (declare (fixnum location next-location)) - (block search - (loop (setq next-location - (the fixnum (+ location ,cache-line-size))) - (when (and ,@(mapcar - (lambda (wrapper) - `(eq ,wrapper - (cache-vector-ref - cache-vector - (setq location - (the fixnum (+ location 1)))))) - wrappers)) - ,@(when value - `((setq location (the fixnum (+ location 1))) - (setq ,value (cache-vector-ref cache-vector - location)))) - (return-from search nil)) - (setq location next-location) - (when (= location size-1) - (setq location 0)) - (when (= location primary) - (dolist (entry overflow) - (let ((entry-wrappers (car entry))) - (when (and ,@(mapcar (lambda (wrapper) - `(eq ,wrapper - (pop entry-wrappers))) - wrappers)) - ,@(when value - `((setq ,value (cdr entry)))) - (return-from search nil)))) - (go ,miss-label)))) - (unless (= initial-lock-count - (get-cache-vector-lock-count cache-vector)) - (go ,miss-label))))))) - -(defun emit-1-wrapper-compute-primary-cache-location (wrapper miss-label) - `(let ((wrapper-cache-no (wrapper-cache-number-vector-ref ,wrapper field))) - (declare (fixnum wrapper-cache-no)) - (when (zerop wrapper-cache-no) (go ,miss-label)) - ,(let ((form `(logand mask wrapper-cache-no))) - `(the fixnum ,form)))) - -(defun emit-n-wrapper-compute-primary-cache-location (wrappers miss-label) - (declare (type list wrappers)) - ;; This returns 1 less that the actual location. - `(progn - ,@(let ((adds 0) (len (length wrappers))) - (declare (fixnum adds len)) - (mapcar (lambda (wrapper) - `(let ((wrapper-cache-no (wrapper-cache-number-vector-ref - ,wrapper field))) - (declare (fixnum wrapper-cache-no)) - (when (zerop wrapper-cache-no) (go ,miss-label)) - (setq primary (the fixnum (+ primary wrapper-cache-no))) - ,@(progn - (incf adds) - (when (or (zerop (mod adds - wrapper-cache-number-adds-ok)) - (eql adds len)) - `((setq primary - ,(let ((form `(logand primary mask))) - `(the fixnum ,form)))))))) - wrappers)))) - -;;; CMU17 (and SBCL) note: Since STD-INSTANCE-P is weakened in the -;;; CMU/SBCL approach of using funcallable instances, that branch may -;;; run on non-pcl instances (structures). The result will be the -;;; non-wrapper layout for the structure, which will cause a miss. The -;;; "slots" will be whatever the first slot is, but will be ignored. -;;; Similarly, FSC-INSTANCE-P returns true on funcallable structures -;;; as well as PCL fins. -(defun emit-fetch-wrapper (metatype argument miss-label &optional slot) + (unless wrapper-vars + (error "Every metatype is T.")) + `(prog () + (return + (let ,wrapper-bindings + ,(emit-cache-lookup cache-var wrapper-vars miss-tag value-var) + ,hit-form)) + ,miss-tag + (return ,miss-form)))) + +(defun emit-fetch-wrapper (metatype argument miss-tag &optional slot) (ecase metatype ((standard-instance) - `(cond ((std-instance-p ,argument) - ,@(when slot `((setq ,slot (std-instance-slots ,argument)))) - (std-instance-wrapper ,argument)) - ((fsc-instance-p ,argument) - ,@(when slot `((setq ,slot (fsc-instance-slots ,argument)))) - (fsc-instance-wrapper ,argument)) - (t - (go ,miss-label)))) - (class - (when slot (error "can't do a slot reg for this metatype")) + ;; This branch may run on non-pcl instances (structures). The + ;; result will be the non-wrapper layout for the structure, which + ;; will cause a miss. Since refencing the structure is rather iffy + ;; if it should have no slots, or only raw slots, we use FOR-STD-CLASS-P + ;; to ensure that we have a wrapper. + ;; + ;; FIXME: If we unify layouts and wrappers we can use + ;; instance-slots-layout instead of for-std-class-p, as if there + ;; are no layouts there are no slots to worry about. + (with-unique-names (wrapper) + `(cond + ((std-instance-p ,argument) + (let ((,wrapper (std-instance-wrapper ,argument))) + ,@(when slot + `((when (layout-for-std-class-p ,wrapper) + (setq ,slot (std-instance-slots ,argument))))) + ,wrapper)) + ((fsc-instance-p ,argument) + (let ((,wrapper (fsc-instance-wrapper ,argument))) + ,@(when slot + `((when (layout-for-std-class-p ,wrapper) + (setq ,slot (fsc-instance-slots ,argument))))) + ,wrapper)) + (t (go ,miss-tag))))) + ;; Sep92 PCL used to distinguish between some of these cases (and + ;; spuriously exclude others). Since in SBCL + ;; WRAPPER-OF/LAYOUT-OF/BUILT-IN-OR-STRUCTURE-WRAPPER are all + ;; equivalent and inlined to each other, we can collapse some + ;; spurious differences. + ((class built-in-instance structure-instance condition-instance) + (when slot + (bug "SLOT requested for metatype ~S, but it isnt' going to happen." + metatype)) `(wrapper-of ,argument)) - ((built-in-instance structure-instance) - (when slot (error "can't do a slot reg for this metatype")) - `(built-in-or-structure-wrapper - ,argument)))) - + ;; a metatype of NIL should never be seen here, as NIL is only in + ;; the metatypes before a generic function is fully initialized. + ;; T should never be seen because we never need to get a wrapper + ;; to do dispatch if all methods have T as the respective + ;; specializer. + ((t nil) + (bug "~@" metatype 'emit-fetch-wrapper))))