X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fglobaldb.lisp;h=aa9f8b8bb45cbc2124b3afcea7677a69a53ee7b1;hb=8e4ec430504f0f563280be26034af590dff50d34;hp=e55bc34d5d81f1b908461124c8d1f03e36eb5990;hpb=4cb16425e2ffce3f70ad6ca10f0cde4f1545fa9d;p=sbcl.git diff --git a/src/compiler/globaldb.lisp b/src/compiler/globaldb.lisp index e55bc34..aa9f8b8 100644 --- a/src/compiler/globaldb.lisp +++ b/src/compiler/globaldb.lisp @@ -118,7 +118,7 @@ #-no-ansi-print-object (:print-object (lambda (x s) (print-unreadable-object (x s :type t) - (prin1 (class-info-name x))))) + (prin1 (class-info-name x) s)))) (:copier nil)) ;; name of this class (name nil :type keyword :read-only t) @@ -302,16 +302,15 @@ (new-type-info (make-type-info :name ',type :class class-info - :number new-type-number))) + :number new-type-number + :type ',type-spec))) (setf (aref *info-types* new-type-number) new-type-info) (push new-type-info (class-info-types class-info))))) - ;; Arrange for TYPE-INFO-DEFAULT and TYPE-INFO-TYPE to be set - ;; at cold load time. (They can't very well be set at - ;; cross-compile time, since they differ between the - ;; cross-compiler and the target. The DEFAULT slot values - ;; differ because they're compiled closures, and the TYPE slot - ;; values differ in the use of SB!XC symbols instead of CL - ;; symbols.) + ;; Arrange for TYPE-INFO-DEFAULT and + ;; TYPE-INFO-VALIDATE-FUNCTION to be set at cold load + ;; time. (They can't very well be set at cross-compile time, + ;; since they differ between host and target and are + ;; host-compiled closures.) (push `(let ((type-info (type-info-or-lose ,',class ,',type))) (setf (type-info-validate-function type-info) ,',validate-function) @@ -326,8 +325,7 @@ ;; NIL) instead of full-blown (LAMBDA (X) NIL). (lambda (name) (declare (ignorable name)) - ,',default)) - (setf (type-info-type type-info) ',',type-spec)) + ,',default))) *!reversed-type-info-init-forms*)) ',type)) @@ -346,7 +344,6 @@ ;;;; generic interfaces -;;; FIXME: used only in this file, needn't be in runtime (defmacro do-info ((env &key (name (gensym)) (class (gensym)) (type (gensym)) (type-number (gensym)) (value (gensym)) known-volatile) &body body) @@ -699,138 +696,62 @@ ;;; ;;; We return the new value so that this can be conveniently used in a ;;; SETF function. -(defun set-info-value (name0 type new-value - &optional (env (get-write-info-env))) - (declare (type type-number type) (type volatile-info-env env) - (inline assoc)) +(defun set-info-value (name0 type new-value) (let ((name (uncross name0))) (when (eql name 0) (error "0 is not a legal INFO name.")) - (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 (keywordp class) (keywordp type)) - (let ((info (type-info-or-lose class type))) - (with-unique-names (value foundp) - `(multiple-value-bind (,value ,foundp) - (get-info-value ,name - ,(type-info-number info) - ,@(when env-list-p `(,env-list))) - (declare (type ,(type-info-type info) ,value)) - (values ,value ,foundp)))) - whole)) - -(defun (setf info) (new-value - class - type - name - &optional (env-list nil env-list-p)) + (get-info-value name (type-info-number info)))) + +(defun (setf info) + (new-value class type name) (let* ((info (type-info-or-lose class type)) - (tin (type-info-number info))) - (when (type-info-validate-function info) - (funcall (type-info-validate-function info) name new-value)) - (if env-list-p - (set-info-value name - tin - new-value - (get-write-info-env env-list)) - (set-info-value name - tin - new-value))) + (tin (type-info-number info)) + (validate (type-info-validate-function info))) + (when validate + (funcall validate name new-value)) + (set-info-value name + tin + new-value)) new-value) -#!-sb-fluid -(progn - ;; Not all xc hosts are happy about SETF compiler macros: CMUCL 19 - ;; does not accept them at all, and older SBCLs give a full warning. - ;; So the easy thing is to hide this optimization from all xc hosts. - #-sb-xc-host - (define-compiler-macro (setf info) (&whole whole - new-value - class - type - name - &optional (env-list nil - env-list-p)) - ;; Constant CLASS and TYPE is an overwhelmingly common special case, - ;; and we can resolve it much more efficiently than the general - ;; case. - (if (and (keywordp class) (keywordp type)) - (let* ((info (type-info-or-lose class type)) - (tin (type-info-number info))) - (if env-list-p - `(set-info-value ,name - ,tin - ,new-value - (get-write-info-env ,env-list)) - `(set-info-value ,name - ,tin - ,new-value)))) - whole)) - -;;; the maximum density of the hashtable in a volatile env (in -;;; names/bucket) -;;; -;;; FIXME: actually seems to be measured in percent, should be -;;; converted to be measured in names/bucket -(def!constant volatile-info-environment-density 50) - -;;; Make a new volatile environment of the specified size. -(defun make-info-environment (&key (size 42) (name "Unknown")) - (declare (type (integer 1) size)) - (let ((table-size (primify (truncate (* size 100) - volatile-info-environment-density)))) - (make-volatile-info-env :name name - :table (make-array table-size :initial-element nil) - :threshold size))) ;;; Clear the information of the specified TYPE and CLASS for NAME in ;;; the current environment, allowing any inherited info to become @@ -838,14 +759,7 @@ (defun clear-info (class type name) (let ((info (type-info-or-lose class type))) (clear-info-value name (type-info-number info)))) -#!-sb-fluid -(define-compiler-macro clear-info (&whole whole class type name) - ;; Constant CLASS and TYPE is an overwhelmingly common special case, and - ;; we can resolve it much more efficiently than the general case. - (if (and (keywordp class) (keywordp type)) - (let ((info (type-info-or-lose class type))) - `(clear-info-value ,name ,(type-info-number info))) - whole)) + (defun clear-info-value (name type) (declare (type type-number type) (inline assoc)) (with-info-bucket (table index name (get-write-info-env)) @@ -855,6 +769,22 @@ (setf (cdr types) (delete type (cdr types) :key #'car)) t)))) + +;;; the maximum density of the hashtable in a volatile env (in +;;; names/bucket) +;;; +;;; FIXME: actually seems to be measured in percent, should be +;;; converted to be measured in names/bucket +(def!constant volatile-info-environment-density 50) + +;;; Make a new volatile environment of the specified size. +(defun make-info-environment (&key (size 42) (name "Unknown")) + (declare (type (integer 1) size)) + (let ((table-size (primify (truncate (* size 100) + volatile-info-environment-density)))) + (make-volatile-info-env :name name + :table (make-array table-size :initial-element nil) + :threshold size))) ;;;; *INFO-ENVIRONMENT* @@ -875,7 +805,7 @@ ;;; has it defined, or return the default if none does. We used to ;;; do a lot of complicated caching here, but that was removed for ;;; thread-safety reasons. -(defun get-info-value (name0 type &optional (env-list nil env-list-p)) +(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 @@ -885,25 +815,21 @@ (aver (aref *info-types* type)) (let ((name (uncross name0))) (flet ((lookup (env-list) - (let ((hash nil)) - (dolist (env env-list - (multiple-value-bind (val winp) - (funcall (type-info-default - (svref *info-types* type)) - name) - (values val winp))) - (macrolet ((frob (lookup) - `(progn - (setq 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)))))))) - (if env-list-p - (lookup env-list) - (lookup *info-environment*))))) + (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 @@ -936,7 +862,8 @@ :default #+sb-xc-host (specifier-type 'function) #-sb-xc-host (if (fboundp name) - (specifier-type (sb!impl::%fun-type (fdefinition name))) + (handler-bind ((style-warning #'muffle-warning)) + (specifier-type (sb!impl::%fun-type (fdefinition name)))) (specifier-type 'function))) ;;; the ASSUMED-TYPE for this function, if we have to infer the type @@ -953,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 @@ -1041,12 +971,6 @@ (define-info-type :class :function - :type :documentation - :type-spec (or string null) - :default nil) - -(define-info-type - :class :function :type :definition :type-spec (or fdefn null) :default nil) @@ -1065,10 +989,22 @@ (define-info-type :class :variable :type :kind - :type-spec (member :special :constant :macro :global :alien) - :default (if (symbol-self-evaluating-p name) + :type-spec (member :special :constant :macro :global :alien :unknown) + :default (if (typep name '(or boolean keyword)) :constant - :global)) + :unknown)) + +(define-info-type + :class :variable + :type :always-bound + :type-spec boolean + :default nil) + +(define-info-type + :class :variable + :type :deprecated + :type-spec t + :default nil) ;;; the declared type for this variable (define-info-type @@ -1084,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 @@ -1169,17 +1098,6 @@ :type-spec (or ctype null) :default nil) -;;; If this is a class name, then the value is a cons (NAME . CLASS), -;;; where CLASS may be null if the class hasn't been defined yet. Note -;;; that for built-in classes, the kind may be :PRIMITIVE and not -;;; :INSTANCE. The name is in the cons so that we can signal a -;;; meaningful error if we only have the cons. -(define-info-type - :class :type - :type :classoid - :type-spec (or sb!kernel::classoid-cell null) - :default nil) - ;;; layout for this type being used by the compiler (define-info-type :class :type @@ -1188,6 +1106,19 @@ :default (let ((class (find-classoid name nil))) (when class (classoid-layout class)))) +;;; DEFTYPE lambda-list +(define-info-type + :class :type + :type :lambda-list + :type-spec list + :default nil) + +(define-info-type + :class :type + :type :source-location + :type-spec t + :default nil) + (define-info-class :typed-structure) (define-info-type :class :typed-structure @@ -1211,6 +1142,10 @@ (when (info :type :kind name) (error 'declaration-type-conflict-error :format-arguments (list name))))) +(define-info-type + :class :declaration + :type :handler + :type-spec (or function null)) (define-info-class :alien-type) (define-info-type @@ -1308,14 +1243,14 @@ (!cold-init-forms (/show0 "beginning *INFO-CLASSES* init, calling MAKE-HASH-TABLE") (setf *info-classes* - (make-hash-table :test 'eq :size #.(hash-table-size *info-classes*))) + (make-hash-table :test 'eq :size #.(* 2 (hash-table-count *info-classes*)))) (/show0 "done with MAKE-HASH-TABLE in *INFO-CLASSES* init") (dolist (class-info-name '#.(let ((result nil)) (maphash (lambda (key value) (declare (ignore value)) (push key result)) *info-classes*) - result)) + (sort result #'string<))) (let ((class-info (make-class-info class-info-name))) (setf (gethash class-info-name *info-classes*) class-info))) @@ -1341,7 +1276,14 @@ (list (type-info-name info-type) (class-info-name (type-info-class info-type)) (type-info-number info-type) - (type-info-type info-type)))) + ;; KLUDGE: for repeatable xc fasls, to + ;; avoid different cross-compiler + ;; treatment of equal constants here we + ;; COPY-TREE, which is not in general a + ;; valid identity transformation + ;; [e.g. on (EQL (FOO))] but is OK for + ;; all the types we use here. + (copy-tree (type-info-type info-type))))) *info-types*))) (/show0 "done with *INFO-TYPES* initialization")) @@ -1352,6 +1294,58 @@ ,@(reverse *!reversed-type-info-init-forms*)))) (frob)) +;;; Source transforms / compiler macros for INFO functions. +;;; +;;; When building the XC, we give it a source transform, so that it can +;;; compile INFO calls in the target efficiently; we also give it a compiler +;;; macro, so that at least those INFO calls compiled after this file can be +;;; efficient. (Host compiler-macros do not fire when compiling the target, +;;; and source transforms don't fire when building the XC, so we need both.) +;;; +;;; Target needs just one, since there compiler macros and source-transforms +;;; are equivalent. +(macrolet ((def (name lambda-list form) + (aver (member 'class lambda-list)) + (aver (member 'type lambda-list)) + `(progn + #+sb-xc-host + (define-source-transform ,name ,lambda-list + (if (and (keywordp class) (keywordp type)) + ,form + (values nil t))) + (define-compiler-macro ,name ,(append '(&whole .whole.) lambda-list) + (if (and (keywordp class) (keywordp type)) + ,form + .whole.))))) + + (def info (class type name) + (let (#+sb-xc-host (sb!xc:*gensym-counter* sb!xc:*gensym-counter*) + (info (type-info-or-lose class type))) + (with-unique-names (value foundp) + `(multiple-value-bind (,value ,foundp) + (get-info-value ,name ,(type-info-number info)) + (declare (type ,(type-info-type info) ,value)) + (values ,value ,foundp))))) + + (def (setf info) (new-value class type name) + (let* (#+sb-xc-host (sb!xc:*gensym-counter* sb!xc:*gensym-counter*) + (info (type-info-or-lose class type)) + (tin (type-info-number info)) + (validate (type-info-validate-function info))) + (with-unique-names (new check) + `(let ((,new ,new-value) + ,@(when validate + `((,check (type-info-validate-function (svref *info-types* ,tin)))))) + ,@(when validate + `((funcall ,check ',name ,new))) + (set-info-value ,name + ,tin + ,new))))) + + (def clear-info (class type name) + (let ((info (type-info-or-lose class type))) + `(clear-info-value ,name ,(type-info-number info))))) + ;;;; a hack for detecting ;;;; (DEFUN FOO (X Y) ;;;; ..