X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fglobaldb.lisp;h=aa9f8b8bb45cbc2124b3afcea7677a69a53ee7b1;hb=eda83f00e869193cb69826be5fa1086b95d12ff7;hp=242445e85d180ed5a1faa7766d3661b229c5a9e8;hpb=2d3cb6dba6461e98744eca2a1df4f770cea468ca;p=sbcl.git diff --git a/src/compiler/globaldb.lisp b/src/compiler/globaldb.lisp index 242445e..aa9f8b8 100644 --- a/src/compiler/globaldb.lisp +++ b/src/compiler/globaldb.lisp @@ -32,11 +32,7 @@ (declaim (special *universal-type*)) ;;; This is sorta semantically equivalent to SXHASH, but optimized for -;;; legal function names. Note: semantically equivalent does *not* -;;; mean that it always returns the same value as SXHASH, just that it -;;; satisfies the formal definition of SXHASH. The ``sorta'' is -;;; because SYMBOL-HASH will not necessarily return the same value in -;;; different lisp images. +;;; legal function names. ;;; ;;; Why optimize? We want to avoid the fully-general TYPECASE in ordinary ;;; SXHASH, because @@ -46,9 +42,9 @@ ;;; 2. This function is in a potential bottleneck for the compiler, ;;; and avoiding the general TYPECASE lets us improve performance ;;; because -;;; 2a. the general TYPECASE is intrinsically slow, and -;;; 2b. the general TYPECASE is too big for us to easily afford -;;; to inline it, so it brings with it a full function call. +;;; 2a. the general TYPECASE is intrinsically slow, and +;;; 2b. the general TYPECASE is too big for us to easily afford +;;; to inline it, so it brings with it a full function call. ;;; ;;; Why not specialize instead of optimize? (I.e. why fall through to ;;; general SXHASH as a last resort?) Because the INFO database is used @@ -58,18 +54,19 @@ ;;; aren't used too early in cold boot for SXHASH to run). #!-sb-fluid (declaim (inline globaldb-sxhashoid)) (defun globaldb-sxhashoid (x) - (cond #-sb-xc-host ; (SYMBOL-HASH doesn't exist on cross-compilation host.) - ((symbolp x) - (symbol-hash x)) - #-sb-xc-host ; (SYMBOL-HASH doesn't exist on cross-compilation host.) - ((and (listp x) - (eq (first x) 'setf) - (let ((rest (rest x))) - (and (symbolp (car rest)) - (null (cdr rest))))) - (logxor (symbol-hash (second x)) - 110680597)) - (t (sxhash x)))) + (logand sb!xc:most-positive-fixnum + (cond ((symbolp x) (sxhash x)) + ((and (listp x) + (eq (first x) 'setf) + (let ((rest (rest x))) + (and (symbolp (car rest)) + (null (cdr rest))))) + ;; We need to declare the type of the value we're feeding to + ;; SXHASH so that the DEFTRANSFORM on symbols kicks in. + (let ((symbol (second x))) + (declare (symbol symbol)) + (logxor (sxhash symbol) 110680597))) + (t (sxhash x))))) ;;; Given any non-negative integer, return a prime number >= to it. ;;; @@ -117,12 +114,12 @@ (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) (defstruct (class-info - (:constructor make-class-info (name)) - #-no-ansi-print-object - (:print-object (lambda (x s) - (print-unreadable-object (x s :type t) - (prin1 (class-info-name x))))) - (:copier nil)) + (:constructor make-class-info (name)) + #-no-ansi-print-object + (:print-object (lambda (x s) + (print-unreadable-object (x s :type t) + (prin1 (class-info-name x) s)))) + (:copier nil)) ;; name of this class (name nil :type keyword :read-only t) ;; list of Type-Info structures for each type in this class @@ -146,18 +143,18 @@ #-sb-xc ; as per KLUDGE note above (eval-when (:compile-toplevel :execute) (setf *info-types* - (make-array (ash 1 type-number-bits) :initial-element nil))) + (make-array (ash 1 type-number-bits) :initial-element nil))) (defstruct (type-info - #-no-ansi-print-object - (:print-object (lambda (x s) - (print-unreadable-object (x s) - (format s - "~S ~S, Number = ~W" - (class-info-name (type-info-class x)) - (type-info-name x) - (type-info-number x))))) - (:copier nil)) + #-no-ansi-print-object + (:print-object (lambda (x s) + (print-unreadable-object (x s) + (format s + "~S ~S, Number = ~W" + (class-info-name (type-info-class x)) + (type-info-name x) + (type-info-number x))))) + (:copier nil)) ;; the name of this type (name (missing-arg) :type keyword) ;; this type's class @@ -167,7 +164,9 @@ ;; a type specifier which info of this type must satisfy (type nil :type t) ;; a function called when there is no information of this type - (default (lambda () (error "type not defined yet")) :type function)) + (default (lambda () (error "type not defined yet")) :type function) + ;; called by (SETF INFO) before calling SET-INFO-VALUE + (validate-function nil :type (or function null))) ;;; a map from class names to CLASS-INFO structures ;;; @@ -181,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. @@ -198,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) @@ -208,7 +213,7 @@ #+sb-xc (/nohexstr type) (prog1 (or (find-type-info type (class-info-or-lose class)) - (error "~S is not a defined info type." type)) + (error "~S is not a defined info type." type)) #+sb-xc (/noshow0 "returning from TYPE-INFO-OR-LOSE"))) ) ; EVAL-WHEN @@ -242,7 +247,7 @@ ;; those data structures.) (eval-when (:compile-toplevel :execute) (unless (gethash ,class *info-classes*) - (setf (gethash ,class *info-classes*) (make-class-info ,class)))) + (setf (gethash ,class *info-classes*) (make-class-info ,class)))) ,class)) ;;; Find a type number not already in use by looking for a null entry @@ -263,14 +268,14 @@ ;;; order in which the TYPE-INFO-creation forms are generated doesn't ;;; match the relative order in which the forms need to be executed at ;;; cold load time. -(defparameter *reversed-type-info-init-forms* nil) +(defparameter *!reversed-type-info-init-forms* nil) ;;; Define a new type of global information for CLASS. TYPE is the ;;; name of the type, DEFAULT is the value for that type when it ;;; hasn't been set, and TYPE-SPEC is a type specifier which values of ;;; the type must satisfy. The default expression is evaluated each ;;; time the information is needed, with NAME bound to the name for -;;; which the information is being looked up. +;;; which the information is being looked up. ;;; ;;; The main thing we do is determine the type's number. We need to do ;;; this at macroexpansion time, since both the COMPILE and LOAD time @@ -278,9 +283,10 @@ (#+sb-xc-host defmacro #-sb-xc-host sb!xc:defmacro define-info-type (&key (class (missing-arg)) - (type (missing-arg)) - (type-spec (missing-arg)) - default) + (type (missing-arg)) + (type-spec (missing-arg)) + (validate-function) + default) (declare (type keyword class type)) `(progn (eval-when (:compile-toplevel :execute) @@ -290,50 +296,45 @@ ;; looks at the compile time state and generates code to ;; replicate it at cold load time. (let* ((class-info (class-info-or-lose ',class)) - (old-type-info (find-type-info ',type class-info))) - (unless old-type-info - (let* ((new-type-number (find-unused-type-number)) - (new-type-info - (make-type-info :name ',type - :class class-info - :number new-type-number))) - (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.) + (old-type-info (find-type-info ',type class-info))) + (unless old-type-info + (let* ((new-type-number (find-unused-type-number)) + (new-type-info + (make-type-info :name ',type + :class class-info + :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-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-default type-info) - ;; FIXME: This code is sort of nasty. It would - ;; be cleaner if DEFAULT accepted a real - ;; function, instead of accepting a statement - ;; which will be turned into a lambda assuming - ;; that the argument name is NAME. It might - ;; even be more microefficient, too, since many - ;; DEFAULTs could be implemented as (CONSTANTLY - ;; NIL) instead of full-blown (LAMBDA (X) NIL). - (lambda (name) - (declare (ignorable name)) - ,',default)) - (setf (type-info-type type-info) ',',type-spec)) - *reversed-type-info-init-forms*)) + (setf (type-info-validate-function type-info) + ,',validate-function) + (setf (type-info-default type-info) + ;; FIXME: This code is sort of nasty. It would + ;; be cleaner if DEFAULT accepted a real + ;; function, instead of accepting a statement + ;; which will be turned into a lambda assuming + ;; that the argument name is NAME. It might + ;; even be more microefficient, too, since many + ;; DEFAULTs could be implemented as (CONSTANTLY + ;; NIL) instead of full-blown (LAMBDA (X) NIL). + (lambda (name) + (declare (ignorable name)) + ,',default))) + *!reversed-type-info-init-forms*)) ',type)) ) ; EVAL-WHEN ;;;; 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)) + (:copier nil)) ;; some string describing what is in this environment, for ;; printing/debugging purposes only (name (missing-arg) :type string)) @@ -343,10 +344,9 @@ ;;;; 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) + (type-number (gensym)) (value (gensym)) known-volatile) + &body body) #!+sb-doc "DO-INFO (Env &Key Name Class Type Value) Form* Iterate over all the values stored in the Info-Env Env. Name is bound to @@ -354,133 +354,95 @@ (represented as keywords), and Value is bound to the entry's value." (once-only ((n-env env)) (if known-volatile - (do-volatile-info name class type type-number value n-env body) - `(if (typep ,n-env 'volatile-info-env) - ,(do-volatile-info name class type type-number value n-env body) - ,(do-compact-info name class type type-number value - n-env body))))) + (do-volatile-info name class type type-number value n-env body) + `(if (typep ,n-env 'volatile-info-env) + ,(do-volatile-info name class type type-number value n-env body) + ,(do-compact-info name class type type-number value + n-env body))))) -(eval-when (:compile-toplevel :load-toplevel :execute) +(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) ;;; Return code to iterate over a compact info environment. (defun do-compact-info (name-var class-var type-var type-number-var value-var - n-env body) + n-env body) (let ((n-index (gensym)) - (n-type (gensym)) - (punt (gensym))) + (n-type (gensym)) + (punt (gensym))) (once-only ((n-table `(compact-info-env-table ,n-env)) - (n-entries-index `(compact-info-env-index ,n-env)) - (n-entries `(compact-info-env-entries ,n-env)) - (n-entries-info `(compact-info-env-entries-info ,n-env)) - (n-info-types '*info-types*)) + (n-entries-index `(compact-info-env-index ,n-env)) + (n-entries `(compact-info-env-entries ,n-env)) + (n-entries-info `(compact-info-env-entries-info ,n-env)) + (n-info-types '*info-types*)) `(dotimes (,n-index (length ,n-table)) - (declare (type index ,n-index)) - (block ,PUNT - (let ((,name-var (svref ,n-table ,n-index))) - (unless (eql ,name-var 0) - (do-anonymous ((,n-type (aref ,n-entries-index ,n-index) - (1+ ,n-type))) - (nil) - (declare (type index ,n-type)) - ,(once-only ((n-info `(aref ,n-entries-info ,n-type))) - `(let ((,type-number-var - (logand ,n-info compact-info-entry-type-mask))) - ,(once-only ((n-type-info - `(svref ,n-info-types - ,type-number-var))) - `(let ((,type-var (type-info-name ,n-type-info)) - (,class-var (class-info-name - (type-info-class ,n-type-info))) - (,value-var (svref ,n-entries ,n-type))) - (declare (ignorable ,type-var ,class-var - ,value-var)) - ,@body - (unless (zerop (logand ,n-info - compact-info-entry-last)) - (return-from ,PUNT)))))))))))))) + (declare (type index ,n-index)) + (block ,punt + (let ((,name-var (svref ,n-table ,n-index))) + (unless (eql ,name-var 0) + (do-anonymous ((,n-type (aref ,n-entries-index ,n-index) + (1+ ,n-type))) + (nil) + (declare (type index ,n-type)) + ,(once-only ((n-info `(aref ,n-entries-info ,n-type))) + `(let ((,type-number-var + (logand ,n-info compact-info-entry-type-mask))) + ,(once-only ((n-type-info + `(svref ,n-info-types + ,type-number-var))) + `(let ((,type-var (type-info-name ,n-type-info)) + (,class-var (class-info-name + (type-info-class ,n-type-info))) + (,value-var (svref ,n-entries ,n-type))) + (declare (ignorable ,type-var ,class-var + ,value-var)) + ,@body + (unless (zerop (logand ,n-info + compact-info-entry-last)) + (return-from ,punt)))))))))))))) ;;; Return code to iterate over a volatile info environment. (defun do-volatile-info (name-var class-var type-var type-number-var value-var - n-env body) + n-env body) (let ((n-index (gensym)) (n-names (gensym)) (n-types (gensym))) (once-only ((n-table `(volatile-info-env-table ,n-env)) - (n-info-types '*info-types*)) + (n-info-types '*info-types*)) `(dotimes (,n-index (length ,n-table)) - (declare (type index ,n-index)) - (do-anonymous ((,n-names (svref ,n-table ,n-index) - (cdr ,n-names))) - ((null ,n-names)) - (let ((,name-var (caar ,n-names))) - (declare (ignorable ,name-var)) - (do-anonymous ((,n-types (cdar ,n-names) (cdr ,n-types))) - ((null ,n-types)) - (let ((,type-number-var (caar ,n-types))) - ,(once-only ((n-type `(svref ,n-info-types - ,type-number-var))) - `(let ((,type-var (type-info-name ,n-type)) - (,class-var (class-info-name - (type-info-class ,n-type))) - (,value-var (cdar ,n-types))) - (declare (ignorable ,type-var ,class-var ,value-var)) - ,@body)))))))))) + (declare (type index ,n-index)) + (do-anonymous ((,n-names (svref ,n-table ,n-index) + (cdr ,n-names))) + ((null ,n-names)) + (let ((,name-var (caar ,n-names))) + (declare (ignorable ,name-var)) + (do-anonymous ((,n-types (cdar ,n-names) (cdr ,n-types))) + ((null ,n-types)) + (let ((,type-number-var (caar ,n-types))) + ,(once-only ((n-type `(svref ,n-info-types + ,type-number-var))) + `(let ((,type-var (type-info-name ,n-type)) + (,class-var (class-info-name + (type-info-class ,n-type))) + (,value-var (cdar ,n-types))) + (declare (ignorable ,type-var ,class-var ,value-var)) + ,@body)))))))))) ) ; 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. -(def!constant compact-info-env-entries-bits 16) +;;; +;;; "Why (U-B 28)?", you might wonder. Originally this was (U-B 16), +;;; presumably to ensure that the arrays of :ELEMENT-TYPE +;;; COMPACT-INFO-ENTRIES-INDEX could use a more space-efficient representation. +;;; It turns out that a environment of of only 65536 entries is insufficient in +;;; the modern world (see message from Cyrus Harmon to sbcl-devel, "Subject: +;;; purify failure when compact-info-env-entries-bits is too small"). Using +;;; (U-B 28) instead of (U-B 29) is to avoid the need for bignum overflow +;;; checks, a probably pointless micro-optimization. Hardcoding the amount of +;;; bits instead of deriving it from SB!VM::N-WORD-BITS is done to allow +;;; use of a more efficient array representation on 64-bit platforms. +;;; -- JES, 2005-04-06 +(def!constant compact-info-env-entries-bits 28) (deftype compact-info-entries-index () `(unsigned-byte ,compact-info-env-entries-bits)) ;;; the type of the values in COMPACT-INFO-ENTRIES-INFO @@ -491,14 +453,8 @@ ;;; indirect through a parallel vector to find the index in the ;;; ENTRIES at which the entries for a given name starts. (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)) + #-sb-xc-host (:pure :substructure) + (:copier nil)) ;; hashtable of the names in this environment. If a bucket is ;; unused, it is 0. (table (missing-arg) :type simple-vector) @@ -520,55 +476,53 @@ (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) - (declare (type index index)) - (let ((info (aref entries-info index))) - (when (= (logand info compact-info-entry-type-mask) number) - (return (values (svref (compact-info-env-entries env) index) - t))) - (unless (zerop (logand compact-info-entry-last info)) - (return (values nil nil))))) - (values nil nil)))) - -;;; Encache NAME in the compact environment ENV. HASH is the + (do ((index index (1+ index))) + (nil) + (declare (type index index)) + (let ((info (aref entries-info index))) + (when (= (logand info compact-info-entry-type-mask) number) + (return (values (svref (compact-info-env-entries env) index) + t))) + (unless (zerop (logand compact-info-entry-last info)) + (return (values nil nil))))) + (values nil nil)))) + +;;; Look up NAME in the compact environment ENV. HASH is the ;;; GLOBALDB-SXHASHOID of NAME. -(defun compact-info-lookup (env name hash) - (declare (type compact-info-env env) (type index 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)) - (len (length table)) - (len-2 (- len 2)) - (hash2 (- len-2 (rem hash len-2)))) + (len (length table)) + (len-2 (- len 2)) + (hash2 (- len-2 (rem hash len-2)))) (declare (type index len-2 hash2)) (macrolet ((lookup (test) - `(do ((probe (rem hash len) - (let ((new (+ probe hash2))) - (declare (type index new)) - ;; same as (MOD NEW LEN), but faster. - (if (>= new len) - (the index (- new len)) - new)))) - (nil) - (let ((entry (svref table probe))) - (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)) + `(do ((probe (rem hash len) + (let ((new (+ probe hash2))) + (declare (type index new)) + ;; same as (MOD NEW LEN), but faster. + (if (>= new len) + (the index (- new len)) + new)))) + (nil) + (let ((entry (svref table probe))) + (when (eql entry 0) + (return nil)) + (when (,test entry name) + (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 @@ -578,8 +532,8 @@ ;;; information as ENV. (defun compact-info-environment (env &key (name (info-env-name env))) (let ((name-count 0) - (prev-name 0) - (entry-count 0)) + (prev-name 0) + (entry-count 0)) (/show0 "before COLLECT in COMPACT-INFO-ENVIRONMENT") ;; Iterate over the environment once to find out how many names @@ -591,99 +545,93 @@ (/show0 "at head of COLLECT in COMPACT-INFO-ENVIRONMENT") (let ((types ())) - (do-info (env :name name :type-number num :value value) - (/noshow0 "at head of DO-INFO in COMPACT-INFO-ENVIRONMENT") - (unless (eq name prev-name) + (do-info (env :name name :type-number num :value value) + (/noshow0 "at head of DO-INFO in COMPACT-INFO-ENVIRONMENT") + (unless (eq name prev-name) (/noshow0 "not (EQ NAME PREV-NAME) case") - (incf name-count) - (unless (eql prev-name 0) - (names (cons prev-name types))) - (setq prev-name name) - (setq types ())) - (incf entry-count) - (push (cons num value) types)) - (unless (eql prev-name 0) + (incf name-count) + (unless (eql prev-name 0) + (names (cons prev-name types))) + (setq prev-name name) + (setq types ())) + (incf entry-count) + (push (cons num value) types)) + (unless (eql prev-name 0) (/show0 "not (EQL PREV-NAME 0) case") - (names (cons prev-name types)))) + (names (cons prev-name types)))) ;; Now that we know how big the environment is, we can build ;; a table to represent it. - ;; + ;; ;; When building the table, we sort the entries by pointer ;; comparison in an attempt to preserve any VM locality present ;; in the original load order, rather than randomizing with the ;; original hash function. (/show0 "about to make/sort vectors in COMPACT-INFO-ENVIRONMENT") (let* ((table-size (primify - (+ (truncate (* name-count 100) - compact-info-environment-density) - 3))) - (table (make-array table-size :initial-element 0)) - (index (make-array table-size - :element-type 'compact-info-entries-index)) - (entries (make-array entry-count)) - (entries-info (make-array entry-count - :element-type 'compact-info-entry)) - (sorted (sort (names) - #+sb-xc-host #'< - ;; (This MAKE-FIXNUM hack implements - ;; pointer comparison, as explained above.) - #-sb-xc-host (lambda (x y) - (< (%primitive make-fixnum x) - (%primitive make-fixnum y)))))) - (/show0 "done making/sorting vectors in COMPACT-INFO-ENVIRONMENT") - (let ((entries-idx 0)) - (dolist (types sorted) - (let* ((name (first types)) - (hash (globaldb-sxhashoid name)) - (len-2 (- table-size 2)) - (hash2 (- len-2 (rem hash len-2)))) - (do ((probe (rem hash table-size) - (rem (+ probe hash2) table-size))) - (nil) - (let ((entry (svref table probe))) - (when (eql entry 0) - (setf (svref table probe) name) - (setf (aref index probe) entries-idx) - (return)) - (aver (not (equal entry name)))))) - - (unless (zerop entries-idx) - (setf (aref entries-info (1- entries-idx)) - (logior (aref entries-info (1- entries-idx)) - compact-info-entry-last))) - - (loop for (num . value) in (rest types) do - (setf (aref entries-info entries-idx) num) - (setf (aref entries entries-idx) value) - (incf entries-idx))) - (/show0 "done w/ DOLIST (TYPES SORTED) in COMPACT-INFO-ENVIRONMENT") - - (unless (zerop entry-count) - (/show0 "nonZEROP ENTRY-COUNT") - (setf (aref entries-info (1- entry-count)) - (logior (aref entries-info (1- entry-count)) - compact-info-entry-last))) - - (/show0 "falling through to MAKE-COMPACT-INFO-ENV") - (make-compact-info-env :name name - :table table - :index index - :entries entries - :entries-info entries-info)))))) + (+ (truncate (* name-count 100) + compact-info-environment-density) + 3))) + (table (make-array table-size :initial-element 0)) + (index (make-array table-size + :element-type 'compact-info-entries-index)) + (entries (make-array entry-count)) + (entries-info (make-array entry-count + :element-type 'compact-info-entry)) + (sorted (sort (names) + #+sb-xc-host #'< + ;; POINTER-HASH hack implements pointer + ;; comparison, as explained above. + #-sb-xc-host (lambda (x y) + (< (pointer-hash x) + (pointer-hash y)))))) + (/show0 "done making/sorting vectors in COMPACT-INFO-ENVIRONMENT") + (let ((entries-idx 0)) + (dolist (types sorted) + (let* ((name (first types)) + (hash (globaldb-sxhashoid name)) + (len-2 (- table-size 2)) + (hash2 (- len-2 (rem hash len-2)))) + (do ((probe (rem hash table-size) + (rem (+ probe hash2) table-size))) + (nil) + (let ((entry (svref table probe))) + (when (eql entry 0) + (setf (svref table probe) name) + (setf (aref index probe) entries-idx) + (return)) + (aver (not (equal entry name)))))) + + (unless (zerop entries-idx) + (setf (aref entries-info (1- entries-idx)) + (logior (aref entries-info (1- entries-idx)) + compact-info-entry-last))) + + (loop for (num . value) in (rest types) do + (setf (aref entries-info entries-idx) num) + (setf (aref entries entries-idx) value) + (incf entries-idx))) + (/show0 "done w/ DOLIST (TYPES SORTED) in COMPACT-INFO-ENVIRONMENT") + + (unless (zerop entry-count) + (/show0 "nonZEROP ENTRY-COUNT") + (setf (aref entries-info (1- entry-count)) + (logior (aref entries-info (1- entry-count)) + compact-info-entry-last))) + + (/show0 "falling through to MAKE-COMPACT-INFO-ENV") + (make-compact-info-env :name name + :table table + :index index + :entries entries + :entries-info entries-info)))))) ;;;; volatile environments ;;; This is a closed hashtable, with the bucket being computed by ;;; 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) + (:copier nil)) ;; vector of alists of alists of the form: ;; ((Name . ((Type-Number . Value) ...) ...) (table (missing-arg) :type simple-vector) @@ -693,45 +641,37 @@ ;; 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) - (declare (type volatile-info-env env) (type index 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 (entry (svref table (mod hash (length table))) ()) + (when (,test (car entry) name) + (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 with-info-bucket ((table-var index-var name env) &body body) (once-only ((n-name name) - (n-env env)) + (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)))) - ,@body))))) + (let* ((,table-var (volatile-info-env-table ,n-env)) + (,index-var (mod (globaldb-sxhashoid ,n-name) + (length ,table-var)))) + ,@body))))) ;;; Get the info environment that we use for write/modification operations. ;;; This is always the first environment in the list, and must be a @@ -756,126 +696,79 @@ ;;; ;;; 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)) - (value (gensym "VALUE")) - (foundp (gensym "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))) - (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))) -|# + +;;; Clear the information of the specified TYPE and CLASS for NAME in +;;; the current environment, allowing any inherited info to become +;;; visible. We return true if there was any info. +(defun clear-info (class type name) + (let ((info (type-info-or-lose class type))) + (clear-info-value name (type-info-number info)))) + +(defun clear-info-value (name type) + (declare (type type-number type) (inline assoc)) + (with-info-bucket (table index name (get-write-info-env)) + (let ((types (assoc name (svref table index) :test #'equal))) + (when (and types + (assoc type (cdr types))) + (setf (cdr types) + (delete type (cdr types) :key #'car)) + t)))) ;;; the maximum density of the hashtable in a volatile env (in ;;; names/bucket) @@ -888,37 +781,10 @@ (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)))) + 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 -;;; visible. We return true if there was any info. -(defun clear-info (class type name) - #!+sb-doc - (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 - (assoc type (cdr types))) - (setf (cdr types) - (delete type (cdr types) :key #'car)) - t)))) + :table (make-array table-size :initial-element nil) + :threshold size))) ;;;; *INFO-ENVIRONMENT* @@ -928,24 +794,18 @@ (declaim (type list *info-environment*)) (!cold-init-forms (setq *info-environment* - (list (make-info-environment :name "initial global"))) + (list (make-info-environment :name "initial global"))) (/show0 "done setting *INFO-ENVIRONMENT*")) ;;; FIXME: should perhaps be *INFO-ENV-LIST*. And rename ;;; all FOO-INFO-ENVIRONMENT-BAR stuff to FOO-INFO-ENV-BAR. ;;;; 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 @@ -954,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 @@ -1024,8 +862,9 @@ :default #+sb-xc-host (specifier-type 'function) #-sb-xc-host (if (fboundp name) - (extract-fun-type (fdefinition name)) - (specifier-type 'function))) + (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 ;;; due to not having a declaration or definition @@ -1041,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 @@ -1063,7 +905,7 @@ ;;; To inline a function, we want a lambda expression, e.g. ;;; '(LAMBDA (X) (+ X 1)). That can be encoded here in one of two ;;; ways. -;;; * The value in INFO can be the lambda expression itself, e.g. +;;; * The value in INFO can be the lambda expression itself, e.g. ;;; (SETF (INFO :FUNCTION :INLINE-EXPANSION-DESIGNATOR 'FOO) ;;; '(LAMBDA (X) (+ X 1))) ;;; This is the ordinary way, the natural way of representing e.g. @@ -1129,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 @@ -1147,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) - :constant - :global)) + :type-spec (member :special :constant :macro :global :alien :unknown) + :default (if (typep name '(or boolean keyword)) + :constant + :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 @@ -1166,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 @@ -1211,8 +1058,14 @@ :class :type :type :kind :type-spec (member :primitive :defined :instance - :forthcoming-defclass-type nil) - :default nil) + :forthcoming-defclass-type nil) + :default nil + :validate-function (lambda (name new-value) + (declare (ignore new-value) + (notinline info)) + (when (info :declaration :recognized name) + (error 'declaration-type-conflict-error + :format-arguments (list name))))) ;;; the expander function for a defined type (define-info-type @@ -1245,24 +1098,26 @@ :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 :type :compiler-layout :type-spec (or layout null) :default (let ((class (find-classoid name nil))) - (when class (classoid-layout class)))) + (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 @@ -1270,12 +1125,27 @@ :type :info :type-spec t :default nil) +(define-info-type + :class :typed-structure + :type :documentation + :type-spec (or string null) + :default nil) (define-info-class :declaration) (define-info-type :class :declaration :type :recognized - :type-spec boolean) + :type-spec boolean + :validate-function (lambda (name new-value) + (declare (ignore new-value) + (notinline info)) + (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 @@ -1338,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 @@ -1346,50 +1243,109 @@ (!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)) + (maphash (lambda (key value) + (declare (ignore value)) + (push key result)) + *info-classes*) + (sort result #'string<))) (let ((class-info (make-class-info class-info-name))) (setf (gethash class-info-name *info-classes*) - class-info))) + class-info))) (/show0 "done with *INFO-CLASSES* initialization") (/show0 "beginning *INFO-TYPES* initialization") (setf *info-types* - (map 'vector - (lambda (x) - (/show0 "in LAMBDA (X), X=..") - (/hexstr x) - (when x - (let* ((class-info (class-info-or-lose (second x))) - (type-info (make-type-info :name (first x) - :class class-info - :number (third x) - :type (fourth x)))) - (/show0 "got CLASS-INFO in LAMBDA (X)") - (push type-info (class-info-types class-info)) - type-info))) - '#.(map 'list - (lambda (info-type) - (when info-type - (list (type-info-name info-type) - (class-info-name (type-info-class info-type)) - (type-info-number info-type) - (type-info-type info-type)))) - *info-types*))) + (map 'vector + (lambda (x) + (/show0 "in LAMBDA (X), X=..") + (/hexstr x) + (when x + (let* ((class-info (class-info-or-lose (second x))) + (type-info (make-type-info :name (first x) + :class class-info + :number (third x) + :type (fourth x)))) + (/show0 "got CLASS-INFO in LAMBDA (X)") + (push type-info (class-info-types class-info)) + type-info))) + '#.(map 'list + (lambda (info-type) + (when info-type + (list (type-info-name info-type) + (class-info-name (type-info-class info-type)) + (type-info-number 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")) ;;; At cold load time, after the INFO-TYPE objects have been created, ;;; we can set their DEFAULT and TYPE slots. (macrolet ((frob () - `(!cold-init-forms - ,@(reverse *reversed-type-info-init-forms*)))) + `(!cold-init-forms + ,@(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) ;;;; ..