X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fglobaldb.lisp;h=242445e85d180ed5a1faa7766d3661b229c5a9e8;hb=2d3cb6dba6461e98744eca2a1df4f770cea468ca;hp=e100a5fb8298594f8d3f65ef96dba69baeef98d5;hpb=3bd7a97d1b11a2b0aee086ef211cae807f3dfc35;p=sbcl.git diff --git a/src/compiler/globaldb.lisp b/src/compiler/globaldb.lisp index e100a5f..242445e 100644 --- a/src/compiler/globaldb.lisp +++ b/src/compiler/globaldb.lisp @@ -84,8 +84,7 @@ (defun primify (x) (declare (type unsigned-byte x)) (do ((n (logior x 1) (+ n 2))) - ((sb!sys:positive-primep n) - n))) + ((positive-primep n) n))) ;;;; info classes, info types, and type numbers, part I: what's needed ;;;; not only at compile time but also at run time @@ -100,7 +99,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 @@ -131,11 +131,19 @@ ;;; a map from type numbers to TYPE-INFO objects. There is one type ;;; number for each defined CLASS/TYPE pair. ;;; -;;; We build its value at compile time (with calls to +;;; We build its value at build-the-cross-compiler time (with calls to ;;; DEFINE-INFO-TYPE), then generate code to recreate the compile time ;;; value, and arrange for that code to be called in cold load. +;;; KLUDGE: We don't try to reset its value when cross-compiling the +;;; compiler, since that creates too many bootstrapping problems, +;;; instead just reusing the built-in-the-cross-compiler version, +;;; which is theoretically a little bit ugly but pretty safe in +;;; practice because the cross-compiler is as close to the target +;;; compiler as we can make it, i.e. identical in most ways, including +;;; this one. -- WHN 2001-08-19 (defvar *info-types*) (declaim (type simple-vector *info-types*)) +#-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))) @@ -145,17 +153,17 @@ (: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) ;; a function called when there is no information of this type @@ -166,8 +174,12 @@ ;;; We build the value for this at compile time (with calls to ;;; DEFINE-INFO-CLASS), then generate code to recreate the compile time ;;; value, and arrange for that code to be called in cold load. +;;; KLUDGE: Just as for *INFO-TYPES*, we don't try to rebuild this +;;; when cross-compiling, but instead just reuse the cross-compiler's +;;; version for the target compiler. -- WHN 2001-08-19 (defvar *info-classes*) (declaim (hash-table *info-classes*)) +#-sb-xc ; as per KLUDGE note above (eval-when (:compile-toplevel :execute) (setf *info-classes* (make-hash-table))) @@ -253,24 +265,22 @@ ;;; cold load time. (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. +;;; ;;; 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 ;;; 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)) default) - #!+sb-doc - "Define-Info-Type Class Type default Type-Spec - 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. If the - default evaluates to something with the second value true, then the second - value of Info will also be true." (declare (type keyword class type)) `(progn (eval-when (:compile-toplevel :execute) @@ -326,7 +336,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))) @@ -470,7 +480,7 @@ ;;;; 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) +(def!constant compact-info-env-entries-bits 16) (deftype compact-info-entries-index () `(unsigned-byte ,compact-info-env-entries-bits)) ;;; the type of the values in COMPACT-INFO-ENTRIES-INFO @@ -491,27 +501,26 @@ (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) - ;; 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 (*)))) - -(defconstant compact-info-entry-type-mask (ldb (byte type-number-bits 0) -1)) -(defconstant 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. + (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 (missing-arg) :type (simple-array compact-info-entry (*)))) + +(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. #!-sb-fluid (declaim (inline compact-info-cache-hit)) (defun compact-info-cache-hit (env number) (declare (type compact-info-env env) (type type-number number)) @@ -529,8 +538,8 @@ (return (values nil nil))))) (values nil nil)))) -;;; Encache Name in the compact environment Env. Hash is the -;;; GLOBALDB-SXHASHOID of Name. +;;; 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)) (let* ((table (compact-info-env-table env)) @@ -542,7 +551,7 @@ `(do ((probe (rem hash len) (let ((new (+ probe hash2))) (declare (type index new)) - ;; same as (mod new len), but faster. + ;; same as (MOD NEW LEN), but faster. (if (>= new len) (the index (- new len)) new)))) @@ -563,7 +572,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. @@ -677,7 +686,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) @@ -708,8 +717,8 @@ (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 @@ -791,15 +800,15 @@ ;;; 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)) - #!+sb-doc - "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." - ;; 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. + ;; 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. (let ((info (type-info-or-lose class type))) (if env-list-p (get-info-value name (type-info-number info) env-list) @@ -807,14 +816,18 @@ #!-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 resolve it much more efficiently than the general case. + ;; 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))) - `(the ,(type-info-type info) - (get-info-value ,name - ,(type-info-number info) - ,@(when env-list-p `(,env-list))))) + (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 @@ -824,13 +837,13 @@ (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))) + (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. @@ -869,7 +882,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")) @@ -880,11 +893,11 @@ :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 - "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." (let ((info (type-info-or-lose class type))) (clear-info-value name (type-info-number info)))) #!-sb-fluid @@ -925,14 +938,21 @@ ;;; 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 possiblity of the cache being partially -;;; updated if the lookup is interrupted. +;;; 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)) (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 + ;; get an info value, and then we'd be out of luck. (This happened, + ;; and was confusing to debug, when rewriting EVAL-WHEN in + ;; sbcl-0.pre7.x.) + (aver (aref *info-types* type)) (let ((name (uncross name0))) (flet ((lookup-ignoring-global-cache (env-list) (let ((hash nil)) @@ -952,11 +972,15 @@ (multiple-value-bind (value winp) (,cache env type) (when winp (return (values value t))))))) - (if (typep env 'volatile-info-env) - (frob volatile-info-lookup volatile-info-cache-hit - volatile-info-env-cache-name) - (frob compact-info-lookup compact-info-cache-hit - compact-info-env-cache-name))))))) + (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 @@ -1000,7 +1024,7 @@ :default #+sb-xc-host (specifier-type 'function) #-sb-xc-host (if (fboundp name) - (extract-function-type (fdefinition name)) + (extract-fun-type (fdefinition name)) (specifier-type 'function))) ;;; the ASSUMED-TYPE for this function, if we have to infer the type @@ -1009,10 +1033,10 @@ :class :function :type :assumed-type ;; FIXME: The type-spec really should be - ;; (or approximate-function-type null)). + ;; (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 @@ -1033,11 +1057,31 @@ #+sb-xc-host :assumed #-sb-xc-host (if (fboundp name) :defined :assumed)) -;;; lambda used for inline expansion of this function +;;; something which can be decoded into the inline expansion of the +;;; function, or NIL if there is none +;;; +;;; 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. +;;; (SETF (INFO :FUNCTION :INLINE-EXPANSION-DESIGNATOR 'FOO) +;;; '(LAMBDA (X) (+ X 1))) +;;; This is the ordinary way, the natural way of representing e.g. +;;; (DECLAIM (INLINE FOO)) +;;; (DEFUN FOO (X) (+ X 1)) +;;; * The value in INFO can be a closure which returns the lambda +;;; expression, e.g. +;;; (SETF (INFO :FUNCTION :INLINE-EXPANSION-DESIGNATOR 'BAR-LEFT-CHILD) +;;; (LAMBDA () +;;; '(LAMBDA (BAR) (BAR-REF BAR 3)))) +;;; This twisty way of storing values is supported in order to +;;; allow structure slot accessors, and perhaps later other +;;; stereotyped functions, to be represented compactly. (define-info-type :class :function - :type :inline-expansion - :type-spec list) + :type :inline-expansion-designator + :type-spec (or list function) + :default nil) ;;; This specifies whether this function may be expanded inline. If ;;; null, we don't care. @@ -1075,28 +1119,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 a slot accessor or setter, then this is the class -;;; that it accesses slots of. -(define-info-type - :class :function - :type :accessor-for - :type-spec (or sb!xc:class null) - :default nil) - -;;; 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 @@ -1108,7 +1136,7 @@ (define-info-type :class :function :type :definition - :type-spec t + :type-spec (or fdefn null) :default nil) ;;;; definitions for other miscellaneous information @@ -1119,11 +1147,10 @@ (define-info-type :class :variable :type :kind - :type-spec (member :special :constant :global :alien) - :default (if (or (eq (symbol-package name) *keyword-package*) - (member name '(t nil))) - :constant - :global)) + :type-spec (member :special :constant :macro :global :alien) + :default (if (symbol-self-evaluating-p name) + :constant + :global)) ;;; the declared type for this variable (define-info-type @@ -1144,9 +1171,23 @@ :class :variable :type :constant-value :type-spec t - :default (if (boundp name) - (values (symbol-value name) t) - (values nil nil))) + ;; 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))) + +;;; the macro-expansion for symbol-macros +(define-info-type + :class :variable + :type :macro-expansion + :type-spec t + :default nil) (define-info-type :class :variable @@ -1163,11 +1204,14 @@ (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) + :type-spec (member :primitive :defined :instance + :forthcoming-defclass-type nil) :default nil) ;;; the expander function for a defined type @@ -1204,12 +1248,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 @@ -1217,8 +1261,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