X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fdlisp.lisp;h=6b388e431cd0bbca3320f1f16e4fbd8e945e88bd;hb=f3f677703e37f5a335b3be7fa64f7748ad969517;hp=da57d578b35017248e337ae81ae895d8b03a8206;hpb=2716573f357f204c5f546d1d34d285dd24ff43a1;p=sbcl.git diff --git a/src/pcl/dlisp.lisp b/src/pcl/dlisp.lisp index da57d57..6b388e4 100644 --- a/src/pcl/dlisp.lisp +++ b/src/pcl/dlisp.lisp @@ -23,21 +23,27 @@ (in-package "SB-PCL") -;;; This file is (almost) functionally equivalent to dlap.lisp, but easier to -;;; read. +;;; 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. +;;; Might generate faster code, too, depending on the compiler and +;;; whether an implementation-specific lap assembler was used. (defun emit-one-class-reader (class-slot-p) (emit-reader/writer :reader 1 class-slot-p)) +(defun emit-one-class-boundp (class-slot-p) + (emit-reader/writer :boundp 1 class-slot-p)) + (defun emit-one-class-writer (class-slot-p) (emit-reader/writer :writer 1 class-slot-p)) (defun emit-two-class-reader (class-slot-p) (emit-reader/writer :reader 2 class-slot-p)) +(defun emit-two-class-boundp (class-slot-p) + (emit-reader/writer :boundp 2 class-slot-p)) + (defun emit-two-class-writer (class-slot-p) (emit-reader/writer :writer 2 class-slot-p)) @@ -46,12 +52,18 @@ (defun emit-one-index-readers (class-slot-p) (emit-one-or-n-index-reader/writer :reader nil class-slot-p)) +(defun emit-one-index-boundps (class-slot-p) + (emit-one-or-n-index-reader/writer :boundp nil class-slot-p)) + (defun emit-one-index-writers (class-slot-p) (emit-one-or-n-index-reader/writer :writer nil class-slot-p)) (defun emit-n-n-readers () (emit-one-or-n-index-reader/writer :reader t nil)) +(defun emit-n-n-boundps () + (emit-one-or-n-index-reader/writer :boundp t nil)) + (defun emit-n-n-writers () (emit-one-or-n-index-reader/writer :writer t nil)) @@ -71,25 +83,36 @@ ;;; -------------------------------- +;;; 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) - (when (and (null *precompiling-lap*) *emit-function-p*) - (return-from emit-default-only - (emit-default-only-function 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)))) (let* ((dlap-lambda-list (make-dlap-lambda-list metatypes applyp)) (args (remove '&rest dlap-lambda-list)) (restl (when applyp '(.lap-rest-arg.)))) (generating-lisp '(emf) dlap-lambda-list - `(invoke-effective-method-function emf ,applyp ,@args ,@restl)))) - -(defmacro emit-default-only-macro (metatypes applyp) - (let ((*emit-function-p* nil) - (*precompiling-lap* t)) - (values - (emit-default-only metatypes applyp)))) + `(invoke-effective-method-function emf + ,applyp + ,@args + ,@restl)))) ;;; -------------------------------- @@ -100,70 +123,80 @@ (lambda `(lambda ,closure-variables ,@(when (member 'miss-fn closure-variables) `((declare (type function miss-fn)))) - #'(sb-kernel:instance-lambda ,args + #'(instance-lambda ,args (let () (declare #.*optimize-speed*) ,form))))) (values (if *precompiling-lap* `#',lambda - (compile-lambda lambda)) + (compile nil lambda)) nil))) ;;; note on implementation for CMU 17 and later (including SBCL): -;;; Since std-instance-p is weakened, that branch may run on non-pcl +;;; Since STD-INSTANCE-P is weakened, 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 +;;; 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) - (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))) + (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)) - (readp (eq reader/writer :reader)) + (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 (setq instance (dfun-arg-symbol 0) - arglist (list instance))) + ((:reader :boundp) + (setq instance (dfun-arg-symbol 0) + arglist (list instance))) (:writer (setq instance (dfun-arg-symbol 1) arglist (list (dfun-arg-symbol 0) instance)))) (ecase 1-or-2-class (1 (setq closure-variables '(wrapper-0 index miss-fn))) (2 (setq closure-variables '(wrapper-0 wrapper-1 index miss-fn)))) - (generating-lisp closure-variables - arglist - `(let* (,@(unless class-slot-p `((slots nil))) + (generating-lisp + closure-variables + arglist + `(let* (,@(unless class-slot-p `((slots nil))) (wrapper (cond ((std-instance-p ,instance) ,@(unless class-slot-p - `((setq slots (std-instance-slots ,instance)))) + `((setq slots + (std-instance-slots ,instance)))) (std-instance-wrapper ,instance)) ((fsc-instance-p ,instance) ,@(unless class-slot-p - `((setq slots (fsc-instance-slots ,instance)))) + `((setq slots + (fsc-instance-slots ,instance)))) (fsc-instance-wrapper ,instance))))) - (block access - (when (and wrapper - (/= (wrapper-cache-number-vector-ref wrapper ,field) 0) - ,@(if (eql 1 1-or-2-class) - `((eq wrapper wrapper-0)) - `((or (eq wrapper wrapper-0) - (eq wrapper wrapper-1))))) - ,@(if readp - `((let ((value ,read-form)) - (unless (eq value +slot-unbound+) - (return-from access value)))) - `((return-from access (setf ,read-form ,(car arglist)))))) - (funcall miss-fn ,@arglist)))))) + (block access + (when (and wrapper + (/= (wrapper-cache-number-vector-ref wrapper ,field) 0) + ,@(if (eql 1 1-or-2-class) + `((eq wrapper wrapper-0)) + `((or (eq wrapper wrapper-0) + (eq wrapper wrapper-1))))) + ,@(ecase reader/writer + (:reader + `((let ((value ,read-form)) + (unless (eq value +slot-unbound+) + (return-from access value))))) + (:boundp + `((let ((value ,read-form)) + (return-from access (not (eq value +slot-unbound+)))))) + (:writer + `((return-from access (setf ,read-form ,(car arglist))))))) + (funcall miss-fn ,@arglist)))))) (defun emit-slot-read-form (class-slot-p index slots) (if class-slot-p `(cdr ,index) - `(%instance-ref ,slots ,index))) + `(clos-slots-ref ,slots ,index))) (defun emit-boundp-check (value-form miss-fn arglist) `(let ((value ,value-form)) @@ -171,10 +204,12 @@ (funcall ,miss-fn ,@arglist) value))) -(defun emit-slot-access (reader/writer class-slot-p slots index miss-fn arglist) +(defun emit-slot-access (reader/writer class-slot-p slots + index miss-fn arglist) (let ((read-form (emit-slot-read-form class-slot-p index slots))) (ecase reader/writer (:reader (emit-boundp-check read-form miss-fn arglist)) + (:boundp `(not (eq ,read-form +slot-unbound+))) (:writer `(setf ,read-form ,(car arglist)))))) (defmacro emit-reader/writer-macro (reader/writer 1-or-2-class class-slot-p) @@ -183,34 +218,41 @@ (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) - (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))) +(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 (values (list (dfun-arg-symbol 0)) - '(standard-instance))) + ((:reader :boundp) + (values (list (dfun-arg-symbol 0)) + '(standard-instance))) (:writer (values (list (dfun-arg-symbol 0) (dfun-arg-symbol 1)) '(t standard-instance)))) - (generating-lisp `(cache ,@(unless cached-index-p '(index)) miss-fn) - arglist - `(let (,@(unless class-slot-p '(slots)) - ,@(when cached-index-p '(index))) - ,(emit-dlap arglist metatypes - (emit-slot-access reader/writer class-slot-p - 'slots 'index 'miss-fn arglist) - `(funcall miss-fn ,@arglist) - (when cached-index-p 'index) - (unless class-slot-p '(slots))))))) + (generating-lisp + `(cache ,@(unless cached-index-p '(index)) miss-fn) + arglist + `(let (,@(unless class-slot-p '(slots)) + ,@(when cached-index-p '(index))) + ,(emit-dlap arglist metatypes + (emit-slot-access reader/writer class-slot-p + 'slots 'index 'miss-fn arglist) + `(funcall miss-fn ,@arglist) + (when cached-index-p 'index) + (unless class-slot-p '(slots))))))) (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)) (values - (emit-one-or-n-index-reader/writer reader/writer cached-index-p class-slot-p)))) + (emit-one-or-n-index-reader/writer reader/writer + cached-index-p + class-slot-p)))) (defun emit-miss (miss-fn args &optional applyp) (let ((restl (when applyp '(.lap-rest-arg.)))) @@ -219,26 +261,31 @@ `(funcall ,miss-fn ,@args ,@restl)))) (defun emit-checking-or-caching (cached-emf-p return-value-p metatypes applyp) - (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))) + (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)))) (let* ((dlap-lambda-list (make-dlap-lambda-list metatypes applyp)) (args (remove '&rest dlap-lambda-list)) (restl (when applyp '(.lap-rest-arg.)))) - (generating-lisp `(cache ,@(unless cached-emf-p '(emf)) miss-fn) - dlap-lambda-list - `(let (,@(when cached-emf-p '(emf))) - ,(emit-dlap args - metatypes - (if return-value-p - (if cached-emf-p 'emf t) - `(invoke-effective-method-function emf ,applyp - ,@args ,@restl)) - (emit-miss 'miss-fn args applyp) - (when cached-emf-p 'emf)))))) - -(defmacro emit-checking-or-caching-macro (cached-emf-p return-value-p metatypes applyp) + (generating-lisp + `(cache ,@(unless cached-emf-p '(emf)) miss-fn) + dlap-lambda-list + `(let (,@(when cached-emf-p '(emf))) + ,(emit-dlap args + metatypes + (if return-value-p + (if cached-emf-p 'emf t) + `(invoke-effective-method-function + emf ,applyp ,@args ,@restl)) + (emit-miss 'miss-fn args applyp) + (when cached-emf-p 'emf)))))) + +(defmacro emit-checking-or-caching-macro (cached-emf-p + return-value-p + metatypes + applyp) (let ((*emit-function-p* nil) (*precompiling-lap* t)) (values @@ -246,15 +293,14 @@ (defun emit-dlap (args metatypes hit miss value-reg &optional slot-regs) (let* ((index -1) - (wrapper-bindings (mapcan #'(lambda (arg mt) - (unless (eq mt 't) - (incf index) - `((,(intern (format nil - "WRAPPER-~D" - index) - *pcl-package*) - ,(emit-fetch-wrapper mt arg 'miss - (pop slot-regs)))))) + (wrapper-bindings (mapcan (lambda (arg mt) + (unless (eq mt t) + (incf index) + `((,(format-symbol *pcl-package* + "WRAPPER-~D" + index) + ,(emit-fetch-wrapper + mt arg 'miss (pop slot-regs)))))) args metatypes)) (wrappers (mapcar #'car wrapper-bindings))) (declare (fixnum index)) @@ -279,7 +325,8 @@ (return-from dfun ,miss))))) (defun emit-1-nil-dlap (wrapper miss-label) - `(let* ((primary ,(emit-1-wrapper-compute-primary-cache-location wrapper miss-label)) + `(let* ((primary ,(emit-1-wrapper-compute-primary-cache-location wrapper + miss-label)) (location primary)) (declare (fixnum primary location)) (block search @@ -301,7 +348,8 @@ (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)) + `(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)) @@ -325,26 +373,32 @@ (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)))) + (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)) + (let ((location primary) + (next-location 0)) (declare (fixnum location next-location)) (block search - (loop (setq next-location (the fixnum (+ location ,cache-line-size))) + (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)))))) + (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)))) + (setq ,value (cache-vector-ref cache-vector + location)))) (return-from search nil)) (setq location next-location) (when (= location size-1) @@ -352,8 +406,9 @@ (when (= location primary) (dolist (entry overflow) (let ((entry-wrappers (car entry))) - (when (and ,@(mapcar #'(lambda (wrapper) - `(eq ,wrapper (pop entry-wrappers))) + (when (and ,@(mapcar (lambda (wrapper) + `(eq ,wrapper + (pop entry-wrappers))) wrappers)) ,@(when value `((setq ,value (cdr entry)))) @@ -376,27 +431,29 @@ `(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)))))))) + (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. +;;; 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) (ecase metatype ((standard-instance)