X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fglobaldb.lisp;h=69c579c04c6e2d7c80de70f793d9bfe94700b16e;hb=5745b5a5b2e3b967bf3876b4306f31b3c78495fa;hp=6a8fa7b5133765a89568a7752e2ad07b626076ee;hpb=31f072311935e32751508ecf824905c6b58a1d95;p=sbcl.git diff --git a/src/compiler/globaldb.lisp b/src/compiler/globaldb.lisp index 6a8fa7b..69c579c 100644 --- a/src/compiler/globaldb.lisp +++ b/src/compiler/globaldb.lisp @@ -118,7 +118,7 @@ #-no-ansi-print-object (:print-object (lambda (x s) (print-unreadable-object (x s :type t) - (prin1 (class-info-name x))))) + (prin1 (class-info-name x) s)))) (:copier nil)) ;; name of this class (name nil :type keyword :read-only t) @@ -302,16 +302,15 @@ (new-type-info (make-type-info :name ',type :class class-info - :number new-type-number))) + :number new-type-number + :type ',type-spec))) (setf (aref *info-types* new-type-number) new-type-info) (push new-type-info (class-info-types class-info))))) - ;; Arrange for TYPE-INFO-DEFAULT and TYPE-INFO-TYPE to be set - ;; at cold load time. (They can't very well be set at - ;; cross-compile time, since they differ between the - ;; cross-compiler and the target. The DEFAULT slot values - ;; differ because they're compiled closures, and the TYPE slot - ;; values differ in the use of SB!XC symbols instead of CL - ;; symbols.) + ;; Arrange for TYPE-INFO-DEFAULT and + ;; TYPE-INFO-VALIDATE-FUNCTION to be set at cold load + ;; time. (They can't very well be set at cross-compile time, + ;; since they differ between host and target and are + ;; host-compiled closures.) (push `(let ((type-info (type-info-or-lose ,',class ,',type))) (setf (type-info-validate-function type-info) ,',validate-function) @@ -326,8 +325,7 @@ ;; NIL) instead of full-blown (LAMBDA (X) NIL). (lambda (name) (declare (ignorable name)) - ,',default)) - (setf (type-info-type type-info) ',',type-spec)) + ,',default))) *!reversed-type-info-init-forms*)) ',type)) @@ -335,11 +333,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 @@ -351,7 +344,6 @@ ;;;; generic interfaces -;;; FIXME: used only in this file, needn't be in runtime (defmacro do-info ((env &key (name (gensym)) (class (gensym)) (type (gensym)) (type-number (gensym)) (value (gensym)) known-volatile) &body body) @@ -434,57 +426,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. @@ -513,12 +455,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) @@ -540,12 +476,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) @@ -558,9 +493,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)) @@ -581,15 +516,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 @@ -647,11 +580,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) @@ -699,12 +632,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) @@ -714,33 +641,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 @@ -748,7 +668,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)))) @@ -784,9 +703,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) @@ -839,8 +755,9 @@ (&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)) - (let ((info (type-info-or-lose class type))) + (if (and (keywordp class) (keywordp type)) + (let (#+sb-xc-host (sb!xc:*gensym-counter* sb!xc:*gensym-counter*) + (info (type-info-or-lose class type))) (with-unique-names (value foundp) `(multiple-value-bind (,value ,foundp) (get-info-value ,name @@ -849,11 +766,9 @@ (declare (type ,(type-info-type info) ,value)) (values ,value ,foundp)))) whole)) -(defun (setf info) (new-value - class - type - name - &optional (env-list nil env-list-p)) + +(defun (setf info) + (new-value class type name &optional (env-list nil env-list-p)) (let* ((info (type-info-or-lose class type)) (tin (type-info-number info))) (when (type-info-validate-function info) @@ -867,25 +782,18 @@ 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 - (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)) + ;; 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 (keywordp class) (keywordp type)) (let* ((info (type-info-or-lose class type)) (tin (type-info-number info))) (if env-list-p @@ -895,9 +803,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) @@ -931,8 +838,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 @@ -956,16 +861,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 @@ -975,44 +874,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 @@ -1045,7 +926,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 @@ -1062,15 +943,18 @@ ;;; where this information came from: ;;; :ASSUMED = from uses of the object ;;; :DEFINED = from examination of the definition +;;; :DEFINED-METHOD = implicit, incremental declaration by CLOS. ;;; :DECLARED = from a declaration -;;; :DEFINED trumps :ASSUMED, and :DECLARED trumps :DEFINED. +;;; :DEFINED trumps :ASSUMED, :DEFINED-METHOD trumps :DEFINED, +;;; and :DECLARED trumps :DEFINED-METHOD. ;;; :DEFINED and :ASSUMED are useful for issuing compile-time warnings, -;;; and :DECLARED is useful for ANSIly specializing code which -;;; implements the function, or which uses the function's return values. +;;; :DEFINED-METHOD and :DECLARED are useful for ANSIly specializing +;;; code which implements the function, or which uses the function's +;;; return values. (define-info-type :class :function :type :where-from - :type-spec (member :declared :assumed :defined) + :type-spec (member :declared :defined-method :assumed :defined) :default ;; Again (as in DEFINE-INFO-TYPE :CLASS :FUNCTION :TYPE :KIND) it's ;; not clear how to generalize the FBOUNDP expression to the @@ -1150,14 +1034,14 @@ (define-info-type :class :function - :type :documentation - :type-spec (or string null) + :type :definition + :type-spec (or fdefn null) :default nil) (define-info-type :class :function - :type :definition - :type-spec (or fdefn null) + :type :structure-accessor + :type-spec (or defstruct-description null) :default nil) ;;;; definitions for other miscellaneous information @@ -1168,10 +1052,16 @@ (define-info-type :class :variable :type :kind - :type-spec (member :special :constant :macro :global :alien) - :default (if (symbol-self-evaluating-p name) + :type-spec (member :special :constant :macro :global :alien :unknown) + :default (if (typep name '(or boolean keyword)) :constant - :global)) + :unknown)) + +(define-info-type + :class :variable + :type :always-bound + :type-spec boolean + :default nil) ;;; the declared type for this variable (define-info-type @@ -1187,21 +1077,14 @@ :type-spec (member :declared :assumed :defined) :default :assumed) -;;; the Lisp object which is the value of this constant, if known +;;; We only need a mechanism different from the +;;; usual SYMBOL-VALUE for the cross compiler. +#+sb-xc-host (define-info-type :class :variable - :type :constant-value + :type :xc-constant-value :type-spec t - ;; CMU CL used to return two values for (INFO :VARIABLE :CONSTANT-VALUE ..). - ;; Now we don't: it was the last remaining multiple-value return from - ;; the INFO system, and bringing it down to one value lets us simplify - ;; things, especially simplifying the declaration of return types. - ;; Software which used to check the second value (for "is it defined - ;; as a constant?") should check (EQL (INFO :VARIABLE :KIND ..) :CONSTANT) - ;; instead. - :default (if (symbol-self-evaluating-p name) - name - (bug "constant lookup of nonconstant ~S" name))) + :default nil) ;;; the macro-expansion for symbol-macros (define-info-type @@ -1272,17 +1155,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 @@ -1291,6 +1163,19 @@ :default (let ((class (find-classoid name nil))) (when class (classoid-layout class)))) +;;; DEFTYPE lambda-list +(define-info-type + :class :type + :type :lambda-list + :type-spec list + :default nil) + +(define-info-type + :class :type + :type :source-location + :type-spec t + :default nil) + (define-info-class :typed-structure) (define-info-type :class :typed-structure @@ -1314,6 +1199,10 @@ (when (info :type :kind name) (error 'declaration-type-conflict-error :format-arguments (list name))))) +(define-info-type + :class :declaration + :type :handler + :type-spec (or function null)) (define-info-class :alien-type) (define-info-type @@ -1411,14 +1300,14 @@ (!cold-init-forms (/show0 "beginning *INFO-CLASSES* init, calling MAKE-HASH-TABLE") (setf *info-classes* - (make-hash-table :test 'eq :size #.(hash-table-size *info-classes*))) + (make-hash-table :test 'eq :size #.(* 2 (hash-table-count *info-classes*)))) (/show0 "done with MAKE-HASH-TABLE in *INFO-CLASSES* init") (dolist (class-info-name '#.(let ((result nil)) (maphash (lambda (key value) (declare (ignore value)) (push key result)) *info-classes*) - result)) + (sort result #'string<))) (let ((class-info (make-class-info class-info-name))) (setf (gethash class-info-name *info-classes*) class-info))) @@ -1444,7 +1333,14 @@ (list (type-info-name info-type) (class-info-name (type-info-class info-type)) (type-info-number info-type) - (type-info-type info-type)))) + ;; KLUDGE: for repeatable xc fasls, to + ;; avoid different cross-compiler + ;; treatment of equal constants here we + ;; COPY-TREE, which is not in general a + ;; valid identity transformation + ;; [e.g. on (EQL (FOO))] but is OK for + ;; all the types we use here. + (copy-tree (type-info-type info-type))))) *info-types*))) (/show0 "done with *INFO-TYPES* initialization"))