X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fglobaldb.lisp;h=b7d8630d68248836a7cf1b3a5a7cc070eda9f6c3;hb=16a6592367eec7c5e9da668ec42fd260e7705b0c;hp=175cf6ad0fd4a532093a4838cfe54447d6f34eaf;hpb=012fbee7176df4472ef4add1a7df558d762bc4f6;p=sbcl.git diff --git a/src/compiler/globaldb.lisp b/src/compiler/globaldb.lisp index 175cf6a..b7d8630 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 @@ -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. ;;; @@ -99,7 +96,8 @@ ;;; At run time, we represent the type of info that we want by a small ;;; non-negative integer. -(defconstant type-number-bits 6) +(eval-when (:compile-toplevel :load-toplevel :execute) + (def!constant type-number-bits 6)) (deftype type-number () `(unsigned-byte ,type-number-bits)) ;;; Why do we suppress the :COMPILE-TOPLEVEL situation here when we're @@ -152,21 +150,23 @@ (:print-object (lambda (x s) (print-unreadable-object (x s) (format s - "~S ~S, Number = ~D" + "~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 (required-argument) :type keyword) + (name (missing-arg) :type keyword) ;; this type's class - (class (required-argument) :type class-info) + (class (missing-arg) :type class-info) ;; a number that uniquely identifies this type (and implicitly its class) - (number (required-argument) :type type-number) + (number (missing-arg) :type type-number) ;; a type specifier which info of this type must satisfy - (type nil :type t) + (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 ;;; @@ -262,7 +262,7 @@ ;;; 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 @@ -276,9 +276,10 @@ ;;; calls to %DEFINE-INFO-TYPE must use the same type number. (#+sb-xc-host defmacro #-sb-xc-host sb!xc:defmacro - define-info-type (&key (class (required-argument)) - (type (required-argument)) - (type-spec (required-argument)) + define-info-type (&key (class (missing-arg)) + (type (missing-arg)) + (type-spec (missing-arg)) + (validate-function) default) (declare (type keyword class type)) `(progn @@ -306,6 +307,8 @@ ;; values differ in the use of SB!XC symbols instead of CL ;; symbols.) (push `(let ((type-info (type-info-or-lose ,',class ,',type))) + (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 @@ -319,7 +322,7 @@ (declare (ignorable name)) ,',default)) (setf (type-info-type type-info) ',',type-spec)) - *reversed-type-info-init-forms*)) + *!reversed-type-info-init-forms*)) ',type)) ) ; EVAL-WHEN @@ -335,7 +338,7 @@ (:copier nil)) ;; some string describing what is in this environment, for ;; printing/debugging purposes only - (name (required-argument) :type string)) + (name (missing-arg) :type string)) (def!method print-object ((x info-env) stream) (print-unreadable-object (x stream :type t) (prin1 (info-env-name x) stream))) @@ -359,7 +362,7 @@ ,(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 @@ -374,7 +377,7 @@ (n-info-types '*info-types*)) `(dotimes (,n-index (length ,n-table)) (declare (type index ,n-index)) - (block ,PUNT + (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) @@ -396,7 +399,7 @@ ,@body (unless (zerop (logand ,n-info compact-info-entry-last)) - (return-from ,PUNT)))))))))))))) + (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 @@ -479,7 +482,19 @@ ;;;; compact info environments ;;; The upper limit on the size of the ENTRIES vector in a COMPACT-INFO-ENV. -(defconstant 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 @@ -500,25 +515,23 @@ (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 (required-argument) :type simple-vector) + (table (missing-arg) :type simple-vector) ;; an indirection vector parallel to TABLE, translating indices in ;; TABLE to the start of the ENTRIES for that name. Unused entries ;; are undefined. - (index (required-argument) - :type (simple-array compact-info-entries-index (*))) + (index (missing-arg) :type (simple-array compact-info-entries-index (*))) ;; a vector contining in contiguous ranges the values of for all the ;; types of info for each name. - (entries (required-argument) :type simple-vector) + (entries (missing-arg) :type simple-vector) ;; a vector parallel to ENTRIES, indicating the type number for the ;; value stored in that location and whether this location is the ;; last type of info stored for this name. The type number is in the ;; low TYPE-NUMBER-BITS bits, and the next bit is set if this is the ;; last entry. - (entries-info (required-argument) - :type (simple-array compact-info-entry (*)))) + (entries-info (missing-arg) :type (simple-array compact-info-entry (*)))) -(defconstant compact-info-entry-type-mask (ldb (byte type-number-bits 0) -1)) -(defconstant compact-info-entry-last (ash 1 type-number-bits)) +(def!constant compact-info-entry-type-mask (ldb (byte type-number-bits 0) -1)) +(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. @@ -542,7 +555,8 @@ ;;; Encache 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)) + (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)) @@ -573,7 +587,7 @@ ;;; the exact density (modulo rounding) of the hashtable in a compact ;;; info environment in names/bucket -(defconstant compact-info-environment-density 65) +(def!constant compact-info-environment-density 65) ;;; Return a new compact info environment that holds the same ;;; information as ENV. @@ -687,7 +701,7 @@ (cache-types nil :type list) ;; vector of alists of alists of the form: ;; ((Name . ((Type-Number . Value) ...) ...) - (table (required-argument) :type simple-vector) + (table (missing-arg) :type simple-vector) ;; the number of distinct names currently in this table. Each name ;; may have multiple entries, since there can be many types of info. (count 0 :type index) @@ -704,7 +718,8 @@ ;;; 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)) + (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))) ()) @@ -715,11 +730,10 @@ (lookup eq) (lookup equal))) (setf (volatile-info-env-cache-name env) name))) - (values)) -;;; 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 +;;; 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. (eval-when (:compile-toplevel :execute) (#+sb-xc-host cl:defmacro @@ -820,15 +834,14 @@ ;; 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))) + (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 @@ -837,14 +850,16 @@ &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) + (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))) + (set-info-value name + tin + new-value + (get-write-info-env env-list)) + (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. @@ -883,7 +898,7 @@ ;;; ;;; FIXME: actually seems to be measured in percent, should be ;;; converted to be measured in names/bucket -(defconstant volatile-info-environment-density 50) +(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")) @@ -898,7 +913,6 @@ ;;; 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 @@ -1037,7 +1051,7 @@ ;; (or approximate-fun-type null)). ;; It was changed to T as a hopefully-temporary hack while getting ;; cold init problems untangled. - :type-spec t) + :type-spec t) ;;; where this information came from: ;;; :ASSUMED = from uses of the object @@ -1120,20 +1134,12 @@ :type :ir1-convert :type-spec (or function null)) -;;; a function which gets a chance to do stuff to the IR1 for any call -;;; to this function. -(define-info-type - :class :function - :type :ir1-transform - :type-spec (or function null)) - -;;; If a function is "known" to the compiler, then this is a -;;; FUNCTION-INFO structure containing the info used to special-case -;;; compilation. +;;; If a function is "known" to the compiler, then this is a FUN-INFO +;;; structure containing the info used to special-case compilation. (define-info-type :class :function :type :info - :type-spec (or function-info null) + :type-spec (or fun-info null) :default nil) (define-info-type @@ -1145,7 +1151,7 @@ (define-info-type :class :function :type :definition - :type-spec t + :type-spec (or fdefn null) :default nil) ;;;; definitions for other miscellaneous information @@ -1156,7 +1162,7 @@ (define-info-type :class :variable :type :kind - :type-spec (member :special :constant :global :alien) + :type-spec (member :special :constant :macro :global :alien) :default (if (symbol-self-evaluating-p name) :constant :global)) @@ -1189,8 +1195,14 @@ ;; instead. :default (if (symbol-self-evaluating-p name) name - (error "internal error: constant lookup of nonconstant ~S" - name))) + (bug "constant lookup of nonconstant ~S" name))) + +;;; the macro-expansion for symbol-macros +(define-info-type + :class :variable + :type :macro-expansion + :type-spec t + :default nil) (define-info-type :class :variable @@ -1207,12 +1219,21 @@ (define-info-class :type) ;;; the kind of type described. We return :INSTANCE for standard types -;;; that are implemented as structures. +;;; that are implemented as structures. For PCL classes, that have +;;; only been compiled, but not loaded yet, we return +;;; :FORTHCOMING-DEFCLASS-TYPE. (define-info-type :class :type :type :kind - :type-spec (member :primitive :defined :instance nil) - :default nil) + :type-spec (member :primitive :defined :instance + :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 @@ -1248,12 +1269,12 @@ ;;; 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 the name is in the cons so that we can signal a +;;; :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 :class - :type-spec (or sb!kernel::class-cell null) + :type :classoid + :type-spec (or sb!kernel::classoid-cell null) :default nil) ;;; layout for this type being used by the compiler @@ -1261,8 +1282,8 @@ :class :type :type :compiler-layout :type-spec (or layout null) - :default (let ((class (sb!xc:find-class name nil))) - (when class (class-layout class)))) + :default (let ((class (find-classoid name nil))) + (when class (classoid-layout class)))) (define-info-class :typed-structure) (define-info-type @@ -1270,12 +1291,23 @@ :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-class :alien-type) (define-info-type @@ -1387,7 +1419,7 @@ ;;; we can set their DEFAULT and TYPE slots. (macrolet ((frob () `(!cold-init-forms - ,@(reverse *reversed-type-info-init-forms*)))) + ,@(reverse *!reversed-type-info-init-forms*)))) (frob)) ;;;; a hack for detecting