- (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)))))
+ (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)))))
- (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)))))
+ (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)))))
- (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))
+ (setf (type-info-type type-info) ',',type-spec))
+ *!reversed-type-info-init-forms*))
- (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))))))))))))))
- (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))))))))))
- (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))))
+ (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))))
- `(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)))))))
+ `(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)))))))
;; 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
;; 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 #'<
+ ;; (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))))))
- (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)))))))))
+ (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)))))))))
- (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))))
+ (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))))
- (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))))))))
+ (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))))))))
- (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))))))))
+ (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))))))))
- (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)
+ (type-info-type info-type))))
+ *info-types*)))