X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fglobaldb.lisp;h=bb75e1501f3adee1d72949bd229308d2328f50cb;hb=4f7161165647d655392713a0d95c951e4e1749ea;hp=c20344735ba7eda43f645f34c64bd73f43b6bcc7;hpb=d604a358d8e5eb5587989e0a4f1d31dbe6ac5ffe;p=sbcl.git diff --git a/src/compiler/globaldb.lisp b/src/compiler/globaldb.lisp index c203447..bb75e15 100644 --- a/src/compiler/globaldb.lisp +++ b/src/compiler/globaldb.lisp @@ -180,7 +180,7 @@ (declaim (hash-table *info-classes*)) #-sb-xc ; as per KLUDGE note above (eval-when (:compile-toplevel :execute) - (setf *info-classes* (make-hash-table))) + (setf *info-classes* (make-hash-table :test #'eq))) ;;; If NAME is the name of a type in CLASS, then return the TYPE-INFO, ;;; otherwise NIL. @@ -197,8 +197,14 @@ #+sb-xc (/noshow0 "entering CLASS-INFO-OR-LOSE, CLASS=..") #+sb-xc (/nohexstr class) (prog1 - (or (gethash class *info-classes*) - (error "~S is not a defined info class." class)) + (flet ((lookup (class) + (or (gethash class *info-classes*) + (error "~S is not a defined info class." class)))) + (if (symbolp class) + (or (get class 'class-info-or-lose-cache) + (setf (get class 'class-info-or-lose-cache) + (lookup class))) + (lookup class))) #+sb-xc (/noshow0 "returning from CLASS-INFO-OR-LOSE"))) (declaim (ftype (function (keyword keyword) type-info) type-info-or-lose)) (defun type-info-or-lose (class type) @@ -329,11 +335,6 @@ ;;;; generic info environments -;;; Note: the CACHE-NAME slot is deliberately not shared for -;;; bootstrapping reasons. If we access with accessors for the exact -;;; type, then the inline type check will win. If the inline check -;;; didn't win, we would try to use the type system before it was -;;; properly initialized. (defstruct (info-env (:constructor nil) (:copier nil)) ;; some string describing what is in this environment, for @@ -428,57 +429,7 @@ ) ; EVAL-WHEN -;;;; INFO cache -;;;; We use a hash cache to cache name X type => value for the current -;;;; value of *INFO-ENVIRONMENT*. This is in addition to the -;;;; per-environment caching of name => types. - -;;; The value of *INFO-ENVIRONMENT* that has cached values. -;;; *INFO-ENVIRONMENT* should never be destructively modified, so if -;;; it is EQ to this, then the cache is valid. -(defvar *cached-info-environment*) -(!cold-init-forms - (setf *cached-info-environment* nil)) - -;;; the hash function used for the INFO cache -#!-sb-fluid (declaim (inline info-cache-hash)) -(defun info-cache-hash (name type) - (logand - (the fixnum - (logxor (globaldb-sxhashoid name) - (ash (the fixnum type) 7))) - #x3FF)) - -(!cold-init-forms - (/show0 "before initialization of INFO hash cache")) -(define-hash-cache info ((name eq) (type eq)) - :values 2 - :hash-function info-cache-hash - :hash-bits 10 - :default (values nil :empty) - :init-wrapper !cold-init-forms) -(!cold-init-forms - (/show0 "clearing INFO hash cache") - (info-cache-clear) - (/show0 "done clearing INFO hash cache")) - -;;; If the info cache is invalid, then clear it. -#!-sb-fluid (declaim (inline clear-invalid-info-cache)) -(defun clear-invalid-info-cache () - ;; Unless the cache is valid.. - (unless (eq *info-environment* *cached-info-environment*) - (;; In the target Lisp, this should be done without interrupts, - ;; but in the host Lisp when cross-compiling, we don't need to - ;; sweat it, since no affected-by-GC hashes should be used when - ;; running under the host Lisp (since that's non-portable) and - ;; since only one thread should be used when running under the - ;; host Lisp (because multiple threads are non-portable too). - #-sb-xc-host without-interrupts - #+sb-xc-host progn - (info-cache-clear) - (setq *cached-info-environment* *info-environment*)))) - ;;;; compact info environments ;;; The upper limit on the size of the ENTRIES vector in a COMPACT-INFO-ENV. @@ -507,12 +458,6 @@ (defstruct (compact-info-env (:include info-env) #-sb-xc-host (:pure :substructure) (:copier nil)) - ;; If this value is EQ to the name we want to look up, then the - ;; cache hit function can be called instead of the lookup function. - (cache-name 0) - ;; The index in ENTRIES for the CACHE-NAME, or NIL if that name has - ;; no entries. - (cache-index nil :type (or compact-info-entries-index null)) ;; hashtable of the names in this environment. If a bucket is ;; unused, it is 0. (table (missing-arg) :type simple-vector) @@ -534,12 +479,11 @@ (def!constant compact-info-entry-last (ash 1 type-number-bits)) ;;; Return the value of the type corresponding to NUMBER for the -;;; currently cached name in ENV. -#!-sb-fluid (declaim (inline compact-info-cache-hit)) -(defun compact-info-cache-hit (env number) +;;; index INDEX in ENV. +#!-sb-fluid (declaim (inline compact-info-lookup-index)) +(defun compact-info-lookup-index (env number index) (declare (type compact-info-env env) (type type-number number)) - (let ((entries-info (compact-info-env-entries-info env)) - (index (compact-info-env-cache-index env))) + (let ((entries-info (compact-info-env-entries-info env))) (if index (do ((index index (1+ index))) (nil) @@ -552,9 +496,9 @@ (return (values nil nil))))) (values nil nil)))) -;;; Encache NAME in the compact environment ENV. HASH is the +;;; Look up NAME in the compact environment ENV. HASH is the ;;; GLOBALDB-SXHASHOID of NAME. -(defun compact-info-lookup (env name hash) +(defun compact-info-lookup (env name hash number) (declare (type compact-info-env env) (type (integer 0 #.sb!xc:most-positive-fixnum) hash)) (let* ((table (compact-info-env-table env)) @@ -575,15 +519,13 @@ (when (eql entry 0) (return nil)) (when (,test entry name) - (return (aref (compact-info-env-index env) - probe))))))) - (setf (compact-info-env-cache-index env) - (if (symbolp name) - (lookup eq) - (lookup equal))) - (setf (compact-info-env-cache-name env) name))) - - (values)) + (return (compact-info-lookup-index + env + number + (aref (compact-info-env-index env) probe)))))))) + (if (symbolp name) + (lookup eq) + (lookup equal))))) ;;; the exact density (modulo rounding) of the hashtable in a compact ;;; info environment in names/bucket @@ -641,11 +583,11 @@ :element-type 'compact-info-entry)) (sorted (sort (names) #+sb-xc-host #'< - ;; (This MAKE-FIXNUM hack implements - ;; pointer comparison, as explained above.) + ;; POINTER-HASH hack implements pointer + ;; comparison, as explained above. #-sb-xc-host (lambda (x y) - (< (%primitive make-fixnum x) - (%primitive make-fixnum y)))))) + (< (pointer-hash x) + (pointer-hash y)))))) (/show0 "done making/sorting vectors in COMPACT-INFO-ENVIRONMENT") (let ((entries-idx 0)) (dolist (types sorted) @@ -693,12 +635,6 @@ ;;; taking the GLOBALDB-SXHASHOID of the NAME modulo the table size. (defstruct (volatile-info-env (:include info-env) (:copier nil)) - ;; If this value is EQ to the name we want to look up, then the - ;; cache hit function can be called instead of the lookup function. - (cache-name 0) - ;; the alist translating type numbers to values for the currently - ;; cached name - (cache-types nil :type list) ;; vector of alists of alists of the form: ;; ((Name . ((Type-Number . Value) ...) ...) (table (missing-arg) :type simple-vector) @@ -708,33 +644,26 @@ ;; the number of names at which we should grow the table and rehash (threshold 0 :type index)) -;;; Just like COMPACT-INFO-CACHE-HIT, only do it on a volatile environment. -#!-sb-fluid (declaim (inline volatile-info-cache-hit)) -(defun volatile-info-cache-hit (env number) - (declare (type volatile-info-env env) (type type-number number)) - (dolist (type (volatile-info-env-cache-types env) (values nil nil)) - (when (eql (car type) number) - (return (values (cdr type) t))))) - ;;; Just like COMPACT-INFO-LOOKUP, only do it on a volatile environment. -(defun volatile-info-lookup (env name hash) +(defun volatile-info-lookup (env name hash number) (declare (type volatile-info-env env) (type (integer 0 #.sb!xc:most-positive-fixnum) hash)) (let ((table (volatile-info-env-table env))) (macrolet ((lookup (test) `(dolist (entry (svref table (mod hash (length table))) ()) (when (,test (car entry) name) - (return (cdr entry)))))) - (setf (volatile-info-env-cache-types env) - (if (symbolp name) - (lookup eq) - (lookup equal))) - (setf (volatile-info-env-cache-name env) name))) - (values)) + (dolist (type (cdr entry)) + (when (eql (car type) number) + (return-from volatile-info-lookup + (values (cdr type) t)))) + (return-from volatile-info-lookup + (values nil nil)))))) + (if (symbolp name) + (lookup eq) + (lookup equal))))) ;;; Given a volatile environment ENV, bind TABLE-VAR the environment's table -;;; and INDEX-VAR to the index of NAME's bucket in the table. We also flush -;;; the cache so that things will be consistent if body modifies something. +;;; and INDEX-VAR to the index of NAME's bucket in the table. (eval-when (:compile-toplevel :execute) (#+sb-xc-host cl:defmacro #-sb-xc-host sb!xc:defmacro @@ -742,7 +671,6 @@ (once-only ((n-name name) (n-env env)) `(progn - (setf (volatile-info-env-cache-name ,n-env) 0) (let* ((,table-var (volatile-info-env-table ,n-env)) (,index-var (mod (globaldb-sxhashoid ,n-name) (length ,table-var)))) @@ -778,9 +706,6 @@ (let ((name (uncross name0))) (when (eql name 0) (error "0 is not a legal INFO name.")) - ;; We don't enter the value in the cache because we don't know that this - ;; info-environment is part of *cached-info-environment*. - (info-cache-enter name type nil :empty) (with-info-bucket (table index name env) (let ((types (if (symbolp name) (assoc name (svref table index) :test #'eq) @@ -833,7 +758,7 @@ (&whole whole class type name &optional (env-list nil env-list-p)) ;; Constant CLASS and TYPE is an overwhelmingly common special case, ;; and we can implement it much more efficiently than the general case. - (if (and (constantp class) (constantp type)) + (if (and (keywordp class) (keywordp type)) (let ((info (type-info-or-lose class type))) (with-unique-names (value foundp) `(multiple-value-bind (,value ,foundp) @@ -843,6 +768,7 @@ (declare (type ,(type-info-type info) ,value)) (values ,value ,foundp)))) whole)) + (defun (setf info) (new-value class type @@ -861,25 +787,23 @@ tin new-value))) new-value) -;;; FIXME: We'd like to do this, but Python doesn't support -;;; compiler macros and it's hard to change it so that it does. -;;; It might make more sense to just convert INFO :FOO :BAR into -;;; an ordinary function, so that instead of calling INFO :FOO :BAR -;;; you call e.g. INFO%FOO%BAR. Then dynamic linking could be handled -;;; by the ordinary Lisp mechanisms and we wouldn't have to maintain -;;; all this cruft.. -#| #!-sb-fluid (progn + ;; Not all xc hosts are happy about SETF compiler macros: CMUCL 19 + ;; does not accept them at all, and older SBCLs give a full warning. + ;; So the easy thing is to hide this optimization from all xc hosts. + #-sb-xc-host (define-compiler-macro (setf info) (&whole whole - new-value - class - type - name - &optional (env-list nil env-list-p)) - ;; Constant CLASS and TYPE is an overwhelmingly common special case, and we - ;; can resolve it much more efficiently than the general case. - (if (and (constantp class) (constantp type)) + new-value + class + type + name + &optional (env-list nil + env-list-p)) + ;; Constant CLASS and TYPE is an overwhelmingly common special case, + ;; and we can resolve it much more efficiently than the general + ;; case. + (if (and (keywordp class) (keywordp type)) (let* ((info (type-info-or-lose class type)) (tin (type-info-number info))) (if env-list-p @@ -889,9 +813,8 @@ (get-write-info-env ,env-list)) `(set-info-value ,name ,tin - ,new-value))) - whole))) -|# + ,new-value)))) + whole)) ;;; the maximum density of the hashtable in a volatile env (in ;;; names/bucket) @@ -925,8 +848,6 @@ whole)) (defun clear-info-value (name type) (declare (type type-number type) (inline assoc)) - (clear-invalid-info-cache) - (info-cache-enter name type nil :empty) (with-info-bucket (table index name (get-write-info-env)) (let ((types (assoc name (svref table index) :test #'equal))) (when (and types @@ -950,16 +871,10 @@ ;;;; GET-INFO-VALUE -;;; Check whether the name and type is in our cache, if so return it. -;;; Otherwise, search for the value and encache it. -;;; -;;; Return the value from the first environment which has it defined, -;;; or return the default if none does. We have a cache for the last -;;; name looked up in each environment. We don't compute the hash -;;; until the first time the cache misses. When the cache does miss, -;;; we invalidate it before calling the lookup routine to eliminate -;;; the possibility of the cache being partially updated if the lookup -;;; is interrupted. +;;; Return the value of NAME / TYPE from the first environment where +;;; has it defined, or return the default if none does. We used to +;;; do a lot of complicated caching here, but that was removed for +;;; thread-safety reasons. (defun get-info-value (name0 type &optional (env-list nil env-list-p)) (declare (type type-number type)) ;; sanity check: If we have screwed up initialization somehow, then @@ -969,44 +884,26 @@ ;; sbcl-0.pre7.x.) (aver (aref *info-types* type)) (let ((name (uncross name0))) - (flet ((lookup-ignoring-global-cache (env-list) + (flet ((lookup (env-list) (let ((hash nil)) (dolist (env env-list - (multiple-value-bind (val winp) - (funcall (type-info-default - (svref *info-types* type)) - name) - (values val winp))) - (macrolet ((frob (lookup cache slot) + (multiple-value-bind (val winp) + (funcall (type-info-default + (svref *info-types* type)) + name) + (values val winp))) + (macrolet ((frob (lookup) `(progn - (unless (eq name (,slot env)) - (unless hash - (setq hash (globaldb-sxhashoid name))) - (setf (,slot env) 0) - (,lookup env name hash)) + (setq hash (globaldb-sxhashoid name)) (multiple-value-bind (value winp) - (,cache env type) + (,lookup env name hash type) (when winp (return (values value t))))))) (etypecase env - (volatile-info-env (frob - volatile-info-lookup - volatile-info-cache-hit - volatile-info-env-cache-name)) - (compact-info-env (frob - compact-info-lookup - compact-info-cache-hit - compact-info-env-cache-name)))))))) - (cond (env-list-p - (lookup-ignoring-global-cache env-list)) - (t - (clear-invalid-info-cache) - (multiple-value-bind (val winp) (info-cache-lookup name type) - (if (eq winp :empty) - (multiple-value-bind (val winp) - (lookup-ignoring-global-cache *info-environment*) - (info-cache-enter name type val winp) - (values val winp)) - (values val winp)))))))) + (volatile-info-env (frob volatile-info-lookup)) + (compact-info-env (frob compact-info-lookup)))))))) + (if env-list-p + (lookup env-list) + (lookup *info-environment*))))) ;;;; definitions for function information @@ -1039,7 +936,7 @@ :default #+sb-xc-host (specifier-type 'function) #-sb-xc-host (if (fboundp name) - (extract-fun-type (fdefinition name)) + (specifier-type (sb!impl::%fun-type (fdefinition name))) (specifier-type 'function))) ;;; the ASSUMED-TYPE for this function, if we have to infer the type @@ -1153,6 +1050,12 @@ :type :definition :type-spec (or fdefn null) :default nil) + +(define-info-type + :class :function + :type :structure-accessor + :type-spec (or defstruct-description null) + :default nil) ;;;; definitions for other miscellaneous information @@ -1266,17 +1169,6 @@ :type-spec (or ctype null) :default nil) -;;; If this is a class name, then the value is a cons (NAME . CLASS), -;;; where CLASS may be null if the class hasn't been defined yet. Note -;;; that for built-in classes, the kind may be :PRIMITIVE and not -;;; :INSTANCE. The name is in the cons so that we can signal a -;;; meaningful error if we only have the cons. -(define-info-type - :class :type - :type :classoid - :type-spec (or sb!kernel::classoid-cell null) - :default nil) - ;;; layout for this type being used by the compiler (define-info-type :class :type @@ -1370,6 +1262,33 @@ :type-spec list :default ()) +;;; Used to record the source location of definitions. +(define-info-class :source-location) + +(define-info-type + :class :source-location + :type :variable + :type-spec t + :default nil) + +(define-info-type + :class :source-location + :type :constant + :type-spec t + :default nil) + +(define-info-type + :class :source-location + :type :typed-structure + :type-spec t + :default nil) + +(define-info-type + :class :source-location + :type :symbol-macro + :type-spec t + :default nil) + #!-sb-fluid (declaim (freeze-type info-env)) ;;; Now that we have finished initializing *INFO-CLASSES* and @@ -1378,7 +1297,7 @@ (!cold-init-forms (/show0 "beginning *INFO-CLASSES* init, calling MAKE-HASH-TABLE") (setf *info-classes* - (make-hash-table :size #.(hash-table-size *info-classes*))) + (make-hash-table :test 'eq :size #.(hash-table-size *info-classes*))) (/show0 "done with MAKE-HASH-TABLE in *INFO-CLASSES* init") (dolist (class-info-name '#.(let ((result nil)) (maphash (lambda (key value)