From 2d0b882f9eabffe5e2d32c0e2e7ab06c96f4fea3 Mon Sep 17 00:00:00 2001 From: William Harold Newman Date: Thu, 29 Mar 2001 01:50:35 +0000 Subject: [PATCH] 0.6.11.30: MNA source cleanups (sbcl-devel 2001-03-29), including Raymond Toy's float trap patch (cmucl-imp 2001-03-28) commented out unused stuff in dfun.lisp --- src/code/cold-init.lisp | 1 - src/code/dyncount.lisp | 1 - src/code/float-trap.lisp | 10 ++- src/code/gc.lisp | 28 +++---- src/code/purify.lisp | 3 +- src/code/stream.lisp | 2 +- src/code/string.lisp | 4 +- src/code/toplevel.lisp | 4 +- src/code/x86-vm.lisp | 1 + src/compiler/eval-comp.lisp | 2 +- src/compiler/eval.lisp | 7 +- src/pcl/dfun.lisp | 191 +++++++++++++++++++++++-------------------- tests/stress-gc.sh | 2 +- version.lisp-expr | 2 +- 14 files changed, 130 insertions(+), 128 deletions(-) diff --git a/src/code/cold-init.lisp b/src/code/cold-init.lisp index 22330f4..72d26fc 100644 --- a/src/code/cold-init.lisp +++ b/src/code/cold-init.lisp @@ -90,7 +90,6 @@ ;; !UNIX-COLD-INIT. And *TYPE-SYSTEM-INITIALIZED* could be changed to ;; *TYPE-SYSTEM-INITIALIZED-WHEN-BOUND* so that it doesn't need to ;; be explicitly set in order to be meaningful. - (setf *gc-verbose* nil) (setf *gc-notify-stream* nil) (setf *before-gc-hooks* nil) (setf *after-gc-hooks* nil) diff --git a/src/code/dyncount.lisp b/src/code/dyncount.lisp index 16ad8bc..d14727b 100644 --- a/src/code/dyncount.lisp +++ b/src/code/dyncount.lisp @@ -532,7 +532,6 @@ comments from CMU CL: (compared (if compare (compare-stats compensated compare) compensated)) - (*gc-verbose* nil) (*gc-notify-stream* nil)) (multiple-value-bind (total-count total-cost) (cost-summary compensated) (multiple-value-bind (compare-total-count compare-total-cost) diff --git a/src/code/float-trap.lisp b/src/code/float-trap.lisp index 39293ab..6c1b5c5 100644 --- a/src/code/float-trap.lisp +++ b/src/code/float-trap.lisp @@ -128,6 +128,7 @@ ;;; Signal the appropriate condition when we get a floating-point error. (defun sigfpe-handler (signal info context) (declare (ignore signal info)) + (declare (ignore context)) ; stub! (declare (type system-area-pointer context)) ;; FIXME: The find-the-detailed-problem code below went stale with ;; the big switchover to POSIX signal handling and signal contexts @@ -174,15 +175,16 @@ (trap-mask (dpb (lognot (float-trap-mask traps)) float-traps-byte #xffffffff)) (exception-mask (dpb (lognot (sb!vm::float-trap-mask traps)) - float-sticky-bits #xffffffff))) - `(let ((orig-modes (floating-point-modes))) + float-sticky-bits #xffffffff)) + (orig-modes (gensym))) + `(let ((,orig-modes (floating-point-modes))) (unwind-protect (progn (setf (floating-point-modes) - (logand orig-modes ,(logand trap-mask exception-mask))) + (logand ,orig-modes ,(logand trap-mask exception-mask))) ,@body) ;; Restore the original traps and exceptions. (setf (floating-point-modes) - (logior (logand orig-modes ,(logior traps exceptions)) + (logior (logand ,orig-modes ,(logior traps exceptions)) (logand (floating-point-modes) ,(logand trap-mask exception-mask)))))))) diff --git a/src/code/gc.lisp b/src/code/gc.lisp index 020eab8..c833068 100644 --- a/src/code/gc.lisp +++ b/src/code/gc.lisp @@ -153,10 +153,6 @@ usage. The function should return NIL if garbage collection should continue and non-NIL if it should be inhibited. Use with caution.") -(defvar *gc-verbose* nil ; (actually initialized in cold init) - #!+sb-doc - "Should low-level GC functions produce verbose diagnostic output?") - (defvar *gc-notify-stream* nil ; (actually initialized in cold init) #!+sb-doc "When non-NIL, this must be a STREAM; and the functions bound to @@ -264,15 +260,13 @@ (warn "(FUNCALL ~S~{ ~S~}) lost:~%~A" ',function ',args cond) nil)))) -;;; SUB-GC decides when and if to do a garbage collection. The -;;; VERBOSE-P flag controls whether or not the notify functions are -;;; called. The FORCE-P flags controls if a GC should occur even if +;;; SUB-GC decides when and if to do a garbage collection. +;;; The FORCE-P flags controls if a GC should occur even if ;;; the dynamic usage is not greater than *GC-TRIGGER*. ;;; ;;; For GENCGC all generations < GEN will be GC'ed. ;;; -;;; FIXME: The VERBOSE-P stuff is no longer used. -(defun sub-gc (&key (verbose-p *gc-verbose*) force-p #!+gencgc (gen 0)) +(defun sub-gc (&key force-p #!+gencgc (gen 0)) (/show0 "entering SUB-GC") (unless *already-maybe-gcing* (/show0 "not *ALREADY-MAYBE-GCING*") @@ -414,20 +408,18 @@ ;;; KLUDGE: GC shouldn't have different parameters depending on what ;;; garbage collector we use. -- WHN 19991020 #!-gencgc -(defun gc (&optional (verbose-p *gc-verbose*)) +(defun gc () #!+sb-doc - "Initiates a garbage collection. VERBOSE-P controls - whether or not GC statistics are printed." - (sub-gc :verbose-p verbose-p :force-p t)) + "Initiates a garbage collection." + (sub-gc :force-p t)) #!+gencgc -(defun gc (&key (verbose *gc-verbose*) (gen 0) (full nil)) +(defun gc (&key (gen 0) (full nil)) #!+sb-doc - "Initiates a garbage collection. VERBOSE controls whether or not GC - statistics are printed. GEN controls the number of generations to garbage - collect." + "Initiates a garbage collection. + GEN controls the number of generations to garbage collect." ;; FIXME: The bare 6 here (corresponding to a bare 6 in ;; the gencgc.c sources) is nasty. - (sub-gc :verbose-p verbose :force-p t :gen (if full 6 gen))) + (sub-gc :force-p t :gen (if full 6 gen))) ;;;; auxiliary functions diff --git a/src/code/purify.lisp b/src/code/purify.lisp index 21317bf..f4d0811 100644 --- a/src/code/purify.lisp +++ b/src/code/purify.lisp @@ -59,6 +59,5 @@ #'(lambda (notify-stream &rest ignore) (declare (ignore ignore)) (write-line "done]" notify-stream)))) - #!-gencgc (gc t) - #!+gencgc (gc :verbose t)) + (gc)) nil) diff --git a/src/code/stream.lisp b/src/code/stream.lisp index a179402..4e66f41 100644 --- a/src/code/stream.lisp +++ b/src/code/stream.lisp @@ -318,7 +318,7 @@ (stream *standard-input*) (eof-error-p t) eof-value recursive-p) - + (declare (ignore recursive-p)) (let ((stream (in-synonym-of stream))) (if (lisp-stream-p stream) (let ((char (read-char stream eof-error-p eof-value))) diff --git a/src/code/string.lisp b/src/code/string.lisp index 0482f5d..10e5dcd 100644 --- a/src/code/string.lisp +++ b/src/code/string.lisp @@ -83,7 +83,7 @@ (setf (schar string index) new-el)) (defun string=* (string1 string2 start1 end1 start2 end2) - (with-two-strings string1 string2 start1 end1 offset1 start2 end2 + (with-two-strings string1 string2 start1 end1 nil start2 end2 (not (%sp-string-compare string1 start1 end1 string2 start2 end2)))) (defun string/=* (string1 string2 start1 end1 start2 end2) @@ -217,7 +217,7 @@ start2, end1 and end2, compares characters in string1 to characters in string2 (using char-equal)." (declare (fixnum start1 start2)) - (with-two-strings string1 string2 start1 end1 offset1 start2 end2 + (with-two-strings string1 string2 start1 end1 nil start2 end2 (let ((slen1 (- (the fixnum end1) start1)) (slen2 (- (the fixnum end2) start2))) (declare (fixnum slen1 slen2)) diff --git a/src/code/toplevel.lisp b/src/code/toplevel.lisp index 087a71a..cd1c923 100644 --- a/src/code/toplevel.lisp +++ b/src/code/toplevel.lisp @@ -37,7 +37,7 @@ (declaim #!-gengc (special *gc-inhibit* *already-maybe-gcing* - *need-to-collect-garbage* *gc-verbose* + *need-to-collect-garbage* *gc-notify-stream* *before-gc-hooks* *after-gc-hooks* #!+x86 *pseudo-atomic-atomic* @@ -46,7 +46,7 @@ sb!unix::*interrupt-pending* *type-system-initialized*) #!+gengc - (special *gc-verbose* *before-gc-hooks* *after-gc-hooks* + (special *before-gc-hooks* *after-gc-hooks* *gc-notify-stream* *type-system-initialized*)) diff --git a/src/code/x86-vm.lisp b/src/code/x86-vm.lisp index d4ab6bf..c366a8f 100644 --- a/src/code/x86-vm.lisp +++ b/src/code/x86-vm.lisp @@ -237,6 +237,7 @@ ;; POSIXness and (at the Lisp level) opaque signal contexts, ;; this is stubified. It needs to be rewritten as an ;; alien function. + (declare (ignore context)) ; stub! (warn "stub CONTEXT-FLOATING-POINT-MODES") ;; old code for Linux: diff --git a/src/compiler/eval-comp.lisp b/src/compiler/eval-comp.lisp index 825d2d0..3e28146 100644 --- a/src/compiler/eval-comp.lisp +++ b/src/compiler/eval-comp.lisp @@ -35,7 +35,7 @@ ;;; Translate form into the compiler's IR1 and perform environment ;;; analysis. This is sort of a combination of COMPILE-FILE, ;;; SUB-COMPILE-FILE, COMPILE-TOP-LEVEL, and COMPILE-COMPONENT. -(defun compile-for-eval (form quietly) +(defun compile-for-eval (form) (with-ir1-namespace (let* ((*block-compile* nil) (*lexenv* (make-null-lexenv)) diff --git a/src/compiler/eval.lisp b/src/compiler/eval.lisp index 0c8ee1d..855f85a 100644 --- a/src/compiler/eval.lisp +++ b/src/compiler/eval.lisp @@ -132,8 +132,7 @@ (defun convert-interpreted-fun (fun) (declare (type interpreted-function fun)) (let* ((new (interpreted-function-definition - (internal-eval `#',(interpreted-function-lambda fun) - (interpreted-function-converted-once fun))))) + (internal-eval `#',(interpreted-function-lambda fun))))) (setf (interpreted-function-definition fun) new) (setf (interpreted-function-converted-once fun) t) (let ((name (interpreted-function-%name fun))) @@ -577,8 +576,8 @@ ;;; APPLY on it. If *ALREADY-EVALED-THIS* is true, then we bind it to ;;; NIL around the apply to limit the inhibition to the lexical scope ;;; of the EVAL-WHEN. -(defun internal-eval (form &optional quietly) - (let ((res (sb!c:compile-for-eval form quietly))) +(defun internal-eval (form) + (let ((res (sb!c:compile-for-eval form))) (if *already-evaled-this* (let ((*already-evaled-this* nil)) (internal-apply res nil '#())) diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp index 0811d8e..3ea280f 100644 --- a/src/pcl/dfun.lisp +++ b/src/pcl/dfun.lisp @@ -137,10 +137,12 @@ And so, we are saved. (metatypes (car args)) (gfs (when dfun-type (gfs-of-type dfun-type)))) (dolist (gf gfs) - (when (and (equal metatypes (arg-info-metatypes (gf-arg-info gf))) + (when (and (equal metatypes + (arg-info-metatypes (gf-arg-info gf))) (let ((gf-name (generic-function-name gf))) (and (not (eq gf-name 'slot-value-using-class)) - (not (equal gf-name '(setf slot-value-using-class))) + (not (equal gf-name + '(setf slot-value-using-class))) (not (eq gf-name 'slot-boundp-using-class))))) (update-dfun gf))) (setf (second args-entry) constructor) @@ -168,39 +170,39 @@ And so, we are saved. ,(apply (fdefinition (car generator-entry)) (car args-entry))))))))))) -;;; When all the methods of a generic function are automatically generated -;;; reader or writer methods a number of special optimizations are possible. -;;; These are important because of the large number of generic functions of -;;; this type. +;;; When all the methods of a generic function are automatically +;;; generated reader or writer methods a number of special +;;; optimizations are possible. These are important because of the +;;; large number of generic functions of this type. ;;; ;;; There are a number of cases: ;;; ;;; ONE-CLASS-ACCESSOR -;;; In this case, the accessor generic function has only been called -;;; with one class of argument. There is no cache vector, the wrapper -;;; of the one class, and the slot index are stored directly as closure -;;; variables of the discriminating function. This case can convert to -;;; either of the next kind. +;;; In this case, the accessor generic function has only been +;;; called with one class of argument. There is no cache vector, +;;; the wrapper of the one class, and the slot index are stored +;;; directly as closure variables of the discriminating function. +;;; This case can convert to either of the next kind. ;;; ;;; TWO-CLASS-ACCESSOR -;;; Like above, but two classes. This is common enough to do specially. -;;; There is no cache vector. The two classes are stored a separate -;;; closure variables. +;;; Like above, but two classes. This is common enough to do +;;; specially. There is no cache vector. The two classes are +;;; stored a separate closure variables. ;;; ;;; ONE-INDEX-ACCESSOR -;;; In this case, the accessor generic function has seen more than one -;;; class of argument, but the index of the slot is the same for all -;;; the classes that have been seen. A cache vector is used to store -;;; the wrappers that have been seen, the slot index is stored directly -;;; as a closure variable of the discriminating function. This case -;;; can convert to the next kind. +;;; In this case, the accessor generic function has seen more than +;;; one class of argument, but the index of the slot is the same +;;; for all the classes that have been seen. A cache vector is +;;; used to store the wrappers that have been seen, the slot index +;;; is stored directly as a closure variable of the discriminating +;;; function. This case can convert to the next kind. ;;; ;;; N-N-ACCESSOR -;;; This is the most general case. In this case, the accessor generic -;;; function has seen more than one class of argument and more than one -;;; slot index. A cache vector stores the wrappers and corresponding -;;; slot indexes. Because each cache line is more than one element -;;; long, a cache lock count is used. +;;; This is the most general case. In this case, the accessor +;;; generic function has seen more than one class of argument and +;;; more than one slot index. A cache vector stores the wrappers +;;; and corresponding slot indexes. Because each cache line is +;;; more than one element long, a cache lock count is used. (defstruct (dfun-info (:constructor nil) (:copier nil)) (cache nil)) @@ -539,33 +541,9 @@ And so, we are saved. (defparameter *structure-typep-cost* 1) (defparameter *built-in-typep-cost* 0) -;;; The execution time of this version is exponential to some function -;;; of number of gf methods and argument lists. It was taking -;;; literally hours to load the presentation methods from the -;;; cl-http w3p kit. -#+nil -(defun dispatch-dfun-cost (gf) - (generate-discrimination-net-internal - gf (generic-function-methods gf) nil - #'(lambda (methods known-types) - (declare (ignore methods known-types)) - 0) - #'(lambda (position type true-value false-value) - (declare (ignore position)) - (+ (max true-value false-value) - (if (eq 'class (car type)) - (let ((cpl (class-precedence-list (class-of (cadr type))))) - (cond((memq *the-class-built-in-class* cpl) - *built-in-typep-cost*) - ((memq *the-class-structure-class* cpl) - *structure-typep-cost*) - (t - *non-built-in-typep-cost*))) - 0))) - #'identity)) - -;;; This version is from the pcl found in the gcl-2.1 distribution. -;;; Someone added a cost limit so as to keep the execution time controlled +;;; According to comments in the original CMU CL version of PCL, +;;; the cost LIMIT is important to cut off exponential growth for +;;; large numbers of gf methods and argument lists. (defun dispatch-dfun-cost (gf &optional limit) (generate-discrimination-net-internal gf (generic-function-methods gf) nil @@ -672,16 +650,16 @@ And so, we are saved. (invoke-emf ,nemf ,args))) ;;; The dynamically adaptive method lookup algorithm is implemented is -;;; implemented as a kind of state machine. The kinds of discriminating -;;; function is the state, the various kinds of reasons for a cache miss -;;; are the state transitions. +;;; implemented as a kind of state machine. The kinds of +;;; discriminating function is the state, the various kinds of reasons +;;; for a cache miss are the state transitions. ;;; -;;; The code which implements the transitions is all in the miss handlers -;;; for each kind of dfun. Those appear here. +;;; The code which implements the transitions is all in the miss +;;; handlers for each kind of dfun. Those appear here. ;;; -;;; Note that within the states that cache, there are dfun updates which -;;; simply select a new cache or cache field. Those are not considered -;;; as state transitions. +;;; Note that within the states that cache, there are dfun updates +;;; which simply select a new cache or cache field. Those are not +;;; considered as state transitions. (defvar *lazy-dfun-compute-p* t) (defvar *early-p* nil) @@ -954,8 +932,8 @@ And so, we are saved. (dfun-update generic-function #'make-constant-value-dfun ncache)))))))) -;;; Given a generic function and a set of arguments to that generic function, -;;; returns a mess of values. +;;; Given a generic function and a set of arguments to that generic +;;; function, return a mess of values. ;;; ;;; The compiled effective method function for this set of ;;; arguments. @@ -997,7 +975,8 @@ And so, we are saved. (error "The function ~S requires at least ~D arguments" gf (length metatypes)) (multiple-value-bind (emf methods accessor-type index) - (cache-miss-values-internal gf arg-info wrappers classes types state) + (cache-miss-values-internal + gf arg-info wrappers classes types state) (values emf methods dfun-wrappers invalid-wrapper-p @@ -1014,7 +993,8 @@ And so, we are saved. (compute-applicable-methods-using-classes gf classes)) (let ((emf (if (or cam-std-p all-applicable-and-sorted-p) (function-funcall (get-secondary-dispatch-function1 - gf methods types nil (and for-cache-p wrappers) + gf methods types nil (and for-cache-p + wrappers) all-applicable-and-sorted-p) nil (and for-cache-p wrappers)) (default-secondary-dispatch-function gf)))) @@ -1053,8 +1033,10 @@ And so, we are saved. (early-method-standard-accessor-slot-name meth)) (and (member *the-class-std-object* (if early-p - (early-class-precedence-list accessor-class) - (class-precedence-list accessor-class))) + (early-class-precedence-list + accessor-class) + (class-precedence-list + accessor-class))) (if early-p (not (eq *the-class-standard-method* (early-method-class meth))) @@ -1065,7 +1047,8 @@ And so, we are saved. (slotd (and accessor-class (if early-p (dolist (slot (early-class-slotds accessor-class) nil) - (when (eql slot-name (early-slot-definition-name slot)) + (when (eql slot-name + (early-slot-definition-name slot)) (return slot))) (find-slot-definition accessor-class slot-name))))) (when (and slotd @@ -1101,7 +1084,8 @@ And so, we are saved. (so-p (member *the-class-std-object* specl-cpl)) (slot-name (if (consp method) (and (early-method-standard-accessor-p method) - (early-method-standard-accessor-slot-name method)) + (early-method-standard-accessor-slot-name + method)) (accessor-method-slot-name method)))) (when (or (null specl-cpl) (member *the-class-structure-object* specl-cpl)) @@ -1164,8 +1148,10 @@ And so, we are saved. (unless applicable-p (setq definite-p nil)) (push method possibly-applicable-methods)))) (let ((precedence (arg-info-precedence (if (early-gf-p generic-function) - (early-gf-arg-info generic-function) - (gf-arg-info generic-function))))) + (early-gf-arg-info + generic-function) + (gf-arg-info + generic-function))))) (values (sort-applicable-methods precedence (nreverse possibly-applicable-methods) types) @@ -1186,10 +1172,12 @@ And so, we are saved. (flet ((sorter (method1 method2) (dolist (index precedence) (let* ((specl1 (nth index (if (listp method1) - (early-method-specializers method1 t) + (early-method-specializers method1 + t) (method-specializers method1)))) (specl2 (nth index (if (listp method2) - (early-method-specializers method2 t) + (early-method-specializers method2 + t) (method-specializers method2)))) (order (order-specializers specl1 specl2 index compare-classes-function))) @@ -1213,10 +1201,12 @@ And so, we are saved. (t (case (car type1) (class (case (car type2) - (class (funcall compare-classes-function specl1 specl2 index)) + (class (funcall compare-classes-function + specl1 specl2 index)) (t specl2))) (prototype (case (car type2) - (class (funcall compare-classes-function specl1 specl2 index)) + (class (funcall compare-classes-function + specl1 specl2 index)) (t specl2))) (class-eq (case (car type2) (eql specl2) @@ -1247,7 +1237,10 @@ And so, we are saved. (list class2 class1 t) (let ((name1 (class-name class1)) (name2 (class-name class2))) - (if (and name1 name2 (symbolp name1) (symbolp name2) + (if (and name1 + name2 + (symbolp name1) + (symbolp name2) (string< (symbol-name name1) (symbol-name name2))) (list class1 class2 t) @@ -1255,7 +1248,9 @@ And so, we are saved. (push choice choices)) (car choice)))) (loop (funcall function - (sort-methods methods precedence #'compare-classes-function)) + (sort-methods methods + precedence + #'compare-classes-function)) (unless (dolist (c choices nil) (unless (third c) (rotatef (car c) (cadr c)) @@ -1361,12 +1356,13 @@ And so, we are saved. (memq (cadr specl) (if (eq *boot-state* 'complete) (class-precedence-list (cadr type)) - (early-class-precedence-list (cadr type))))))))) + (early-class-precedence-list + (cadr type))))))))) (values pred pred)))) (defun saut-prototype (specl type) (declare (ignore specl type)) - (values nil nil)) ; fix this someday + (values nil nil)) ; XXX original PCL comment: fix this someday (defun saut-eql (specl type) (let ((pred (case (car specl) @@ -1376,14 +1372,15 @@ And so, we are saved. (let ((class (class-of (cadr type)))) (if (eq *boot-state* 'complete) (class-precedence-list class) - (early-class-precedence-list class)))))))) + (early-class-precedence-list + class)))))))) (values pred pred))) (defun specializer-applicable-using-type-p (specl type) (setq specl (type-from-specializer specl)) (when (eq specl t) (return-from specializer-applicable-using-type-p (values t t))) - ;; This is used by c-a-m-u-t and generate-discrimination-net-internal, + ;; This is used by C-A-M-U-T and GENERATE-DISCRIMINATION-NET-INTERNAL, ;; and has only what they need. (if (or (atom type) (eq (car type) t)) (values nil t) @@ -1432,9 +1429,12 @@ And so, we are saved. (not (methods-contain-eql-specializer-p methods))) method-alist wrappers)) -(defun get-secondary-dispatch-function1 (gf methods types method-alist-p wrappers-p - &optional all-applicable-p - (all-sorted-p t) function-p) +(defun get-secondary-dispatch-function1 (gf methods types method-alist-p + wrappers-p + &optional + all-applicable-p + (all-sorted-p t) + function-p) (if (null methods) (if function-p #'(lambda (method-alist wrappers) @@ -1466,20 +1466,24 @@ And so, we are saved. (push (cons akey value) (cdr ht-value)) value))))))) -(defun get-secondary-dispatch-function2 (gf methods types method-alist-p wrappers-p - all-applicable-p all-sorted-p function-p) +(defun get-secondary-dispatch-function2 (gf methods types method-alist-p + wrappers-p all-applicable-p + all-sorted-p function-p) (if (and all-applicable-p all-sorted-p (not function-p)) (if (eq *boot-state* 'complete) (let* ((combin (generic-function-method-combination gf)) (effective (compute-effective-method gf combin methods))) - (make-effective-method-function1 gf effective method-alist-p wrappers-p)) + (make-effective-method-function1 gf effective method-alist-p + wrappers-p)) (let ((effective (standard-compute-effective-method gf nil methods))) - (make-effective-method-function1 gf effective method-alist-p wrappers-p))) + (make-effective-method-function1 gf effective method-alist-p + wrappers-p))) (let ((net (generate-discrimination-net gf methods types all-sorted-p))) (compute-secondary-dispatch-function1 gf net function-p)))) -(defun get-effective-method-function (gf methods &optional method-alist wrappers) +(defun get-effective-method-function (gf methods + &optional method-alist wrappers) (function-funcall (get-secondary-dispatch-function1 gf methods nil (not (null method-alist)) (not (null wrappers)) @@ -1520,6 +1524,11 @@ And so, we are saved. (defvar *dfun-list* nil) (defvar *minimum-cache-size-to-list*) +;;; These functions aren't used in SBCL, or documented anywhere that +;;; I'm aware of, but they look like they might be useful for +;;; debugging or performance tweaking or something, so I've just +;;; commented them out instead of deleting them. -- WHN 2001-03-28 +#| (defun list-dfun (gf) (let* ((sym (type-of (gf-dfun-info gf))) (a (assq sym *dfun-list*))) @@ -1548,7 +1557,7 @@ And so, we are saved. (defun list-large-caches (&optional (*minimum-cache-size-to-list* 130)) (setq *dfun-list* nil) (map-all-generic-functions #'list-large-cache) - (setq *dfun-list* (sort dfun-list #'< :key #'car)) + (setq *dfun-list* (sort *dfun-list* #'< :key #'car)) (mapc #'print *dfun-list*) (values)) @@ -1582,11 +1591,13 @@ And so, we are saved. (format t "~% ~S~%" (caddr type+count+sizes))) *dfun-count*) (values)) +|# (defun gfs-of-type (type) (unless (consp type) (setq type (list type))) (let ((gf-list nil)) (map-all-generic-functions #'(lambda (gf) - (when (memq (type-of (gf-dfun-info gf)) type) + (when (memq (type-of (gf-dfun-info gf)) + type) (push gf gf-list)))) gf-list)) diff --git a/tests/stress-gc.sh b/tests/stress-gc.sh index 728bcae..5984282 100644 --- a/tests/stress-gc.sh +++ b/tests/stress-gc.sh @@ -12,7 +12,7 @@ # more information. sbcl <