X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fglobaldb.lisp;h=aa9f8b8bb45cbc2124b3afcea7677a69a53ee7b1;hb=8e4ec430504f0f563280be26034af590dff50d34;hp=c20344735ba7eda43f645f34c64bd73f43b6bcc7;hpb=d604a358d8e5eb5587989e0a4f1d31dbe6ac5ffe;p=sbcl.git diff --git a/src/compiler/globaldb.lisp b/src/compiler/globaldb.lisp index c203447..aa9f8b8 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) @@ -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) @@ -296,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) @@ -320,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)) @@ -329,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 @@ -345,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) @@ -428,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. @@ -507,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) @@ -534,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) @@ -552,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)) @@ -575,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 @@ -641,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) @@ -693,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) @@ -708,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 @@ -742,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)))) @@ -771,143 +696,62 @@ ;;; ;;; We return the new value so that this can be conveniently used in a ;;; SETF function. -(defun set-info-value (name0 type new-value - &optional (env (get-write-info-env))) - (declare (type type-number type) (type volatile-info-env env) - (inline assoc)) +(defun set-info-value (name0 type new-value) (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) - (assoc name (svref table index) :test #'equal)))) - (cond - (types - (let ((value (assoc type (cdr types)))) - (if value - (setf (cdr value) new-value) - (push (cons type new-value) (cdr types))))) - (t - (push (cons name (list (cons type new-value))) - (svref table index)) - - (let ((count (incf (volatile-info-env-count env)))) - (when (>= count (volatile-info-env-threshold env)) - (let ((new (make-info-environment :size (* count 2)))) - (do-info (env :name entry-name :type-number entry-num - :value entry-val :known-volatile t) - (set-info-value entry-name entry-num entry-val new)) - (fill (volatile-info-env-table env) nil) - (setf (volatile-info-env-table env) - (volatile-info-env-table new)) - (setf (volatile-info-env-threshold env) - (volatile-info-env-threshold new))))))))) + (labels ((set-it (name type new-value env) + (declare (type type-number type) + (type volatile-info-env env)) + (with-info-bucket (table index name env) + (let ((types (if (symbolp name) + (assoc name (svref table index) :test #'eq) + (assoc name (svref table index) :test #'equal)))) + (cond + (types + (let ((value (assoc type (cdr types)))) + (if value + (setf (cdr value) new-value) + (push (cons type new-value) (cdr types))))) + (t + (push (cons name (list (cons type new-value))) + (svref table index)) + + (let ((count (incf (volatile-info-env-count env)))) + (when (>= count (volatile-info-env-threshold env)) + (let ((new (make-info-environment :size (* count 2)))) + (do-info (env :name entry-name :type-number entry-num + :value entry-val :known-volatile t) + (set-it entry-name entry-num entry-val new)) + (fill (volatile-info-env-table env) nil) + (setf (volatile-info-env-table env) + (volatile-info-env-table new)) + (setf (volatile-info-env-threshold env) + (volatile-info-env-threshold new))))))))))) + (set-it name type new-value (get-write-info-env))) new-value)) -;;; FIXME: It should be possible to eliminate the hairy compiler macros below -;;; by declaring INFO and (SETF INFO) inline and making a simple compiler macro -;;; for TYPE-INFO-OR-LOSE. (If we didn't worry about efficiency of the -;;; cross-compiler, we could even do it by just making TYPE-INFO-OR-LOSE -;;; foldable.) - ;;; INFO is the standard way to access the database. It's settable. ;;; ;;; Return the information of the specified TYPE and CLASS for NAME. ;;; The second value returned is true if there is any such information ;;; recorded. If there is no information, the first value returned is ;;; the default and the second value returned is NIL. -(defun info (class type name &optional (env-list nil env-list-p)) - ;; FIXME: At some point check systematically to make sure that the - ;; system doesn't do any full calls to INFO or (SETF INFO), or at - ;; least none in any inner loops. +(defun info (class type name) (let ((info (type-info-or-lose class type))) - (if env-list-p - (get-info-value name (type-info-number info) env-list) - (get-info-value name (type-info-number info))))) -#!-sb-fluid -(define-compiler-macro info - (&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))) - (with-unique-names (value foundp) - `(multiple-value-bind (,value ,foundp) - (get-info-value ,name - ,(type-info-number info) - ,@(when env-list-p `(,env-list))) - (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)) + (get-info-value name (type-info-number info)))) + +(defun (setf info) + (new-value class type name) (let* ((info (type-info-or-lose class type)) - (tin (type-info-number info))) - (when (type-info-validate-function info) - (funcall (type-info-validate-function info) name new-value)) - (if env-list-p - (set-info-value name - tin - new-value - (get-write-info-env env-list)) - (set-info-value name - tin - new-value))) + (tin (type-info-number info)) + (validate (type-info-validate-function info))) + (when validate + (funcall validate name new-value)) + (set-info-value name + 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)) - (let* ((info (type-info-or-lose class type)) - (tin (type-info-number info))) - (if env-list-p - `(set-info-value ,name - ,tin - ,new-value - (get-write-info-env ,env-list)) - `(set-info-value ,name - ,tin - ,new-value))) - whole))) -|# - -;;; the maximum density of the hashtable in a volatile env (in -;;; names/bucket) -;;; -;;; FIXME: actually seems to be measured in percent, should be -;;; converted to be measured in names/bucket -(def!constant volatile-info-environment-density 50) - -;;; Make a new volatile environment of the specified size. -(defun make-info-environment (&key (size 42) (name "Unknown")) - (declare (type (integer 1) size)) - (let ((table-size (primify (truncate (* size 100) - volatile-info-environment-density)))) - (make-volatile-info-env :name name - :table (make-array table-size :initial-element nil) - :threshold size))) ;;; Clear the information of the specified TYPE and CLASS for NAME in ;;; the current environment, allowing any inherited info to become @@ -915,18 +759,9 @@ (defun clear-info (class type name) (let ((info (type-info-or-lose class type))) (clear-info-value name (type-info-number info)))) -#!-sb-fluid -(define-compiler-macro clear-info (&whole whole class type name) - ;; 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))) - `(clear-info-value ,name ,(type-info-number info))) - 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 @@ -934,6 +769,22 @@ (setf (cdr types) (delete type (cdr types) :key #'car)) t)))) + +;;; the maximum density of the hashtable in a volatile env (in +;;; names/bucket) +;;; +;;; FIXME: actually seems to be measured in percent, should be +;;; converted to be measured in names/bucket +(def!constant volatile-info-environment-density 50) + +;;; Make a new volatile environment of the specified size. +(defun make-info-environment (&key (size 42) (name "Unknown")) + (declare (type (integer 1) size)) + (let ((table-size (primify (truncate (* size 100) + volatile-info-environment-density)))) + (make-volatile-info-env :name name + :table (make-array table-size :initial-element nil) + :threshold size))) ;;;; *INFO-ENVIRONMENT* @@ -950,17 +801,11 @@ ;;;; 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. -(defun get-info-value (name0 type &optional (env-list nil env-list-p)) +;;; 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) (declare (type type-number type)) ;; sanity check: If we have screwed up initialization somehow, then ;; *INFO-TYPES* could still be uninitialized at the time we try to @@ -969,44 +814,22 @@ ;; sbcl-0.pre7.x.) (aver (aref *info-types* type)) (let ((name (uncross name0))) - (flet ((lookup-ignoring-global-cache (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) - `(progn - (unless (eq name (,slot env)) - (unless hash - (setq hash (globaldb-sxhashoid name))) - (setf (,slot env) 0) - (,lookup env name hash)) - (multiple-value-bind (value winp) - (,cache env 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)))))))) + (flet ((lookup (env-list) + (dolist (env env-list + (multiple-value-bind (val winp) + (funcall (type-info-default + (svref *info-types* type)) + name) + (values val winp))) + (macrolet ((frob (lookup) + `(let ((hash (globaldb-sxhashoid name))) + (multiple-value-bind (value winp) + (,lookup env name hash type) + (when winp (return (values value t))))))) + (etypecase env + (volatile-info-env (frob volatile-info-lookup)) + (compact-info-env (frob compact-info-lookup))))))) + (lookup *info-environment*)))) ;;;; definitions for function information @@ -1039,7 +862,8 @@ :default #+sb-xc-host (specifier-type 'function) #-sb-xc-host (if (fboundp name) - (extract-fun-type (fdefinition name)) + (handler-bind ((style-warning #'muffle-warning)) + (specifier-type (sb!impl::%fun-type (fdefinition name)))) (specifier-type 'function))) ;;; the ASSUMED-TYPE for this function, if we have to infer the type @@ -1056,15 +880,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 @@ -1144,14 +971,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 @@ -1162,10 +989,22 @@ (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) + +(define-info-type + :class :variable + :type :deprecated + :type-spec t + :default nil) ;;; the declared type for this variable (define-info-type @@ -1181,21 +1020,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 @@ -1266,17 +1098,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 @@ -1285,6 +1106,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 @@ -1308,6 +1142,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 @@ -1370,6 +1208,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,14 +1243,14 @@ (!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 #.(* 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))) @@ -1411,7 +1276,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")) @@ -1422,6 +1294,58 @@ ,@(reverse *!reversed-type-info-init-forms*)))) (frob)) +;;; Source transforms / compiler macros for INFO functions. +;;; +;;; When building the XC, we give it a source transform, so that it can +;;; compile INFO calls in the target efficiently; we also give it a compiler +;;; macro, so that at least those INFO calls compiled after this file can be +;;; efficient. (Host compiler-macros do not fire when compiling the target, +;;; and source transforms don't fire when building the XC, so we need both.) +;;; +;;; Target needs just one, since there compiler macros and source-transforms +;;; are equivalent. +(macrolet ((def (name lambda-list form) + (aver (member 'class lambda-list)) + (aver (member 'type lambda-list)) + `(progn + #+sb-xc-host + (define-source-transform ,name ,lambda-list + (if (and (keywordp class) (keywordp type)) + ,form + (values nil t))) + (define-compiler-macro ,name ,(append '(&whole .whole.) lambda-list) + (if (and (keywordp class) (keywordp type)) + ,form + .whole.))))) + + (def info (class type name) + (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 ,(type-info-number info)) + (declare (type ,(type-info-type info) ,value)) + (values ,value ,foundp))))) + + (def (setf info) (new-value class type name) + (let* (#+sb-xc-host (sb!xc:*gensym-counter* sb!xc:*gensym-counter*) + (info (type-info-or-lose class type)) + (tin (type-info-number info)) + (validate (type-info-validate-function info))) + (with-unique-names (new check) + `(let ((,new ,new-value) + ,@(when validate + `((,check (type-info-validate-function (svref *info-types* ,tin)))))) + ,@(when validate + `((funcall ,check ',name ,new))) + (set-info-value ,name + ,tin + ,new))))) + + (def clear-info (class type name) + (let ((info (type-info-or-lose class type))) + `(clear-info-value ,name ,(type-info-number info))))) + ;;;; a hack for detecting ;;;; (DEFUN FOO (X Y) ;;;; ..