X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fearly-extensions.lisp;h=d8d0d638ebfd59774f94309f0d685b85c112765a;hb=d147d512602d761a2dcdfded506dd1a8f9a140dc;hp=e84e46f93d9f18351c53f2bd87cb865d873f37e4;hpb=993d5b779638756473181dda8d928d33038d4cc3;p=sbcl.git diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp index e84e46f..d8d0d63 100644 --- a/src/code/early-extensions.lisp +++ b/src/code/early-extensions.lisp @@ -93,49 +93,48 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (defvar *profile-hash-cache* nil)) -;;; :INIT-WRAPPER is set to COLD-INIT-FORMS in type system definitions -;;; so that caches will be created before top-level forms run. +;;; a flag for whether it's too early in cold init to use caches so +;;; that we have a better chance of recovering so that we have a +;;; better chance of getting the system running so that we have a +;;; better chance of diagnosing the problem which caused us to use the +;;; caches too early +#!+sb-show +(defvar *hash-caches-initialized-p*) + +;;; Define a hash cache that associates some number of argument values +;;; with a result value. The TEST-FUNCTION paired with each ARG-NAME +;;; is used to compare the value for that arg in a cache entry with a +;;; supplied arg. The TEST-FUNCTION must not error when passed NIL as +;;; its first arg, but need not return any particular value. +;;; TEST-FUNCTION may be any thing that can be placed in CAR position. +;;; +;;; NAME is used to define these functions: +;;; -CACHE-LOOKUP Arg* +;;; See whether there is an entry for the specified ARGs in the +;;; cache. If not present, the :DEFAULT keyword (default NIL) +;;; determines the result(s). +;;; -CACHE-ENTER Arg* Value* +;;; Encache the association of the specified args with VALUE. +;;; -CACHE-CLEAR +;;; Reinitialize the cache, invalidating all entries and allowing +;;; the arguments and result values to be GC'd. +;;; +;;; These other keywords are defined: +;;; :HASH-BITS +;;; The size of the cache as a power of 2. +;;; :HASH-FUNCTION function +;;; Some thing that can be placed in CAR position which will compute +;;; a value between 0 and (1- (expt 2 )). +;;; :VALUES +;;; the number of return values cached for each function call +;;; :INIT-WRAPPER +;;; The code for initializing the cache is wrapped in a form with +;;; the specified name. (:INIT-WRAPPER is set to COLD-INIT-FORMS +;;; in type system definitions so that caches will be created +;;; before top-level forms run.) (defmacro define-hash-cache (name args &key hash-function hash-bits default (init-wrapper 'progn) (values 1)) - #!+sb-doc - "DEFINE-HASH-CACHE Name ({(Arg-Name Test-Function)}*) {Key Value}* - Define a hash cache that associates some number of argument values to a - result value. The Test-Function paired with each Arg-Name is used to compare - the value for that arg in a cache entry with a supplied arg. The - Test-Function must not error when passed NIL as its first arg, but need not - return any particular value. Test-Function may be any thing that can be - placed in CAR position. - - Name is used to define these functions: - - -CACHE-LOOKUP Arg* - See whether there is an entry for the specified Args in the cache. If - not present, the :DEFAULT keyword (default NIL) determines the result(s). - - -CACHE-ENTER Arg* Value* - Encache the association of the specified args with Value. - - -CACHE-CLEAR - Reinitialize the cache, invalidating all entries and allowing the - arguments and result values to be GC'd. - - These other keywords are defined: - - :HASH-BITS - The size of the cache as a power of 2. - - :HASH-FUNCTION function - Some thing that can be placed in CAR position which will compute a value - between 0 and (1- (expt 2 )). - - :VALUES - The number of values cached. - - :INIT-WRAPPER - The code for initializing the cache is wrapped in a form with the - specified name. Default PROGN." - (let* ((var-name (symbolicate "*" name "-CACHE-VECTOR*")) (nargs (length args)) (entry-size (+ nargs values)) @@ -233,6 +232,7 @@ (inits `(unless (boundp ',var-name) (setq ,var-name (make-array ,total-size)))) + #!+sb-show (inits `(setq *hash-caches-initialized-p* t)) `(progn (defvar ,var-name) @@ -242,13 +242,11 @@ ,@(forms) ',name)))) +;;; some syntactic sugar for defining a function whose values are +;;; cached by DEFINE-HASH-CACHE (defmacro defun-cached ((name &rest options &key (values 1) default &allow-other-keys) args &body body-decls-doc) - #!+sb-doc - "DEFUN-CACHED (Name {Key Value}*) ({(Arg-Name Test-Function)}*) Form* - Some syntactic sugar for defining a function whose values are cached by - DEFINE-HASH-CACHE." (let ((default-values (if (and (consp default) (eq (car default) 'values)) (cdr default) (list default))) @@ -262,17 +260,32 @@ (defun ,name ,arg-names ,@decls ,doc - (multiple-value-bind ,(values-names) - (,(symbolicate name "-CACHE-LOOKUP") ,@arg-names) - (if (and ,@(mapcar #'(lambda (val def) - `(eq ,val ,def)) - (values-names) default-values)) - (multiple-value-bind ,(values-names) - (progn ,@body) - (,(symbolicate name "-CACHE-ENTER") ,@arg-names - ,@(values-names)) - (values ,@(values-names))) - (values ,@(values-names)))))))))) + (cond #!+sb-show + ((not (boundp '*hash-caches-initialized-p*)) + ;; This shouldn't happen, but it did happen to me + ;; when revising the type system, and it's a lot + ;; easier to figure out what what's going on with + ;; that kind of problem if the system can be kept + ;; alive until cold boot is complete. The recovery + ;; mechanism should definitely be conditional on + ;; some debugging feature (e.g. SB-SHOW) because + ;; it's big, duplicating all the BODY code. -- WHN + (/show0 ,name " too early in cold init, uncached") + (/show0 ,(first arg-names) "=..") + (/hexstr ,(first arg-names)) + ,@body) + (t + (multiple-value-bind ,(values-names) + (,(symbolicate name "-CACHE-LOOKUP") ,@arg-names) + (if (and ,@(mapcar (lambda (val def) + `(eq ,val ,def)) + (values-names) default-values)) + (multiple-value-bind ,(values-names) + (progn ,@body) + (,(symbolicate name "-CACHE-ENTER") ,@arg-names + ,@(values-names)) + (values ,@(values-names))) + (values ,@(values-names)))))))))))) ;;;; package idioms @@ -356,6 +369,53 @@ ;; a constant as long as the new value is EQL to the old ;; value.) )) + +;;; Return a function like FUN, but expecting its (two) arguments in +;;; the opposite order that FUN does. +(declaim (inline swapped-args-fun)) +(defun swapped-args-fun (fun) + (declare (type function fun)) + (lambda (x y) + (funcall fun y x))) + +;;; like CL:ASSERT, but lighter-weight +;;; +;;; (As of sbcl-0.6.11.20, we were using some 400 calls to CL:ASSERT +;;; in SBCL. The CL:ASSERT restarts and whatnot expand into a +;;; significant amount of code when you multiply them by 400, so +;;; replacing them with this should reduce the size of the system +;;; by enough to be worthwhile.) +(defmacro aver (expr) + `(unless ,expr + (%failed-aver ,(let ((*package* (find-package :keyword))) + (format nil "~S" expr))))) +(defun %failed-aver (expr-as-string) + (error "~@" expr-as-string)) + +;;;; utilities for two-VALUES predicates + +;;; sort of like ANY and EVERY, except: +;;; * We handle two-VALUES predicate functions, as SUBTYPEP does. +;;; (And if the result is uncertain, then we return (VALUES NIL NIL), +;;; as SUBTYPEP does.) +;;; * THING is just an atom, and we apply OP (an arity-2 function) +;;; successively to THING and each element of LIST. +(defun any/type (op thing list) + (declare (type function op)) + (let ((certain? t)) + (dolist (i list (values nil certain?)) + (multiple-value-bind (sub-value sub-certain?) (funcall op thing i) + (if sub-certain? + (when sub-value (return (values t t))) + (setf certain? nil)))))) +(defun every/type (op thing list) + (declare (type function op)) + (let ((certain? t)) + (dolist (i list (if certain? (values t t) (values nil nil))) + (multiple-value-bind (sub-value sub-certain?) (funcall op thing i) + (if sub-certain? + (unless sub-value (return (values nil t))) + (setf certain? nil)))))) ;;;; DEFPRINTER @@ -394,7 +454,7 @@ ;;; keywords are defined: ;;; ;;; :PRIN1 Print the value of the expression instead of the slot value. -;;; :PRINC Like :PRIN1, only princ the value +;;; :PRINC Like :PRIN1, only PRINC the value ;;; :TEST Only print something if the test is true. ;;; ;;; If no printing thing is specified then the slot value is printed @@ -459,4 +519,4 @@ (if x x (cons y y))) -|# \ No newline at end of file +|#