X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fglobaldb.lisp;h=d20e894e3d811932617bc0fe4b6aced9865dfb17;hb=6dc30bee17d029acf6bb6da730f03e63b2a01948;hp=bb75e1501f3adee1d72949bd229308d2328f50cb;hpb=4f7161165647d655392713a0d95c951e4e1749ea;p=sbcl.git diff --git a/src/compiler/globaldb.lisp b/src/compiler/globaldb.lisp index bb75e15..d20e894 100644 --- a/src/compiler/globaldb.lisp +++ b/src/compiler/globaldb.lisp @@ -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)) @@ -759,7 +757,8 @@ ;; 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))) + (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 @@ -769,11 +768,8 @@ (values ,value ,foundp)))) whole)) -(defun (setf info) (new-value - class - type - name - &optional (env-list nil env-list-p)) +(defun (setf info) + (new-value class type name &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) @@ -793,13 +789,8 @@ ;; 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)) + (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. @@ -953,15 +944,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 +1035,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 +1053,16 @@ (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) ;;; the declared type for this variable (define-info-type @@ -1084,21 +1078,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 @@ -1177,6 +1164,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 @@ -1297,14 +1297,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))) @@ -1330,7 +1330,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"))