From 18c24dead69f58c0511f4198aede54609004ccc8 Mon Sep 17 00:00:00 2001 From: Douglas Katzman Date: Thu, 8 Oct 2015 00:04:01 -0400 Subject: [PATCH] Simplify access to the canonical array types vector. --- src/code/early-type.lisp | 112 ++++++++++++++++++++--------------------------- src/code/late-type.lisp | 2 + src/code/type-class.lisp | 29 +++++++----- 3 files changed, 67 insertions(+), 76 deletions(-) diff --git a/src/code/early-type.lisp b/src/code/early-type.lisp index 97731c12d..e0634ed17 100644 --- a/src/code/early-type.lisp +++ b/src/code/early-type.lisp @@ -548,61 +548,49 @@ ;; and 2 ctype objects for unknown-rank arrays, one each for simple ;; and maybe-simple. (Unknown rank, known-non-simple isn't important) (defglobal *canonical-array-ctypes* -1) -(defconstant +canon-array-ctype-hash-divisor+ 37) ; arbitrary-ish (defun !intern-important-array-type-instances () ;; Having made the canonical numeric and character ctypes ;; representing the points in the type lattice for which there ;; are array specializations, we can make the canonical array types. - (let* ((element-types - (list* - *universal-type* *wild-type* *empty-type* - *character-type* - #!+sb-unicode *base-char-type* - ;; FIXME: This one is can't be used by MAKE-ARRAY-TYPE? - #!+sb-unicode *extended-char-type* - *real-ffloat-type* *complex-ffloat-type* - *real-dfloat-type* *complex-dfloat-type* - (delete - nil - ;; Possibly could use the SAETP-IMPORTANCE as sort criterion - ;; so that collisions in a bucket place the more important - ;; array type first. - (mapcar - (lambda (x) - (cond ((typep x '(cons (eql unsigned-byte))) - (aref *unsigned-byte-n-types* (cadr x))) - ((eq x 'bit) - (aref *unsigned-byte-n-types* 1)) - ((typep x '(cons (eql signed-byte))) - ;; 1- because there is no such thing as (signed-byte 0) - (aref *signed-byte-n-types* (1- (cadr x)))) - ;; FIXNUM is its own thing, why? See comment in vm-array - ;; saying to "See the comment in PRIMITIVE-TYPE-AUX" - ((eq x 'fixnum) ; One good kludge deserves another. - (aref *signed-byte-n-types* (1- sb!vm:n-fixnum-bits))))) - '#.*specialized-array-element-types*)))) - (n (length element-types)) - (data-vector (make-array (* 5 n))) - (index 0) - (hashtable (make-array +canon-array-ctype-hash-divisor+ - :initial-element nil))) - ;; This is a compact binned table. A full-blown hashtable is unneeded. - #-sb-xc (aver (< (/ n (length hashtable)) 80/100)) ; assert reasonable load - (flet ((make-it (dims complexp type) - (setf (aref data-vector (prog1 index (incf index))) - (mark-ctype-interned - (%make-array-type dims complexp type type))))) - (dolist (element-type element-types) - (let ((bin (mod (type-hash-value element-type) - +canon-array-ctype-hash-divisor+))) - (setf (aref hashtable bin) - (nconc (aref hashtable bin) (list (cons element-type index)))) - (make-it '(*) nil element-type) - (make-it '(*) :maybe element-type) - (make-it '(*) t element-type) - (make-it '* nil element-type) - (make-it '* :maybe element-type)))) - (setq *canonical-array-ctypes* (cons data-vector hashtable)))) + (setq *canonical-array-ctypes* (make-array (* 32 5))) + (labels ((make-1 (type-index dims complexp type) + (setf (!ctype-saetp-index type) type-index) + (mark-ctype-interned (%make-array-type dims complexp type type))) + (make-all (element-type type-index) + (replace *canonical-array-ctypes* + (list (make-1 type-index '(*) nil element-type) + (make-1 type-index '(*) :maybe element-type) + (make-1 type-index '(*) t element-type) + (make-1 type-index '* nil element-type) + (make-1 type-index '* :maybe element-type)) + :start1 (* type-index 5)))) + (let ((index 0)) + (dolist (x '#.*specialized-array-element-types*) + (make-all + (cond ((typep x '(cons (eql unsigned-byte))) + (aref *unsigned-byte-n-types* (cadr x))) + ((eq x 'bit) (aref *unsigned-byte-n-types* 1)) + ((typep x '(cons (eql signed-byte))) + ;; 1- because there is no such thing as (signed-byte 0) + (aref *signed-byte-n-types* (1- (cadr x)))) + ;; FIXNUM is its own thing, why? See comment in vm-array + ;; saying to "See the comment in PRIMITIVE-TYPE-AUX" + ((eq x 'fixnum) ; One good kludge deserves another. + (aref *signed-byte-n-types* (1- sb!vm:n-fixnum-bits))) + ((eq x 'single-float) *real-ffloat-type*) + ((eq x 'double-float) *real-dfloat-type*) + ((equal x '(complex single-float)) *complex-ffloat-type*) + ((equal x '(complex double-float)) *complex-dfloat-type*) + ((eq x 'character) *character-type*) + #!+sb-unicode ((eq x 'base-char) *base-char-type*) + ((eq x t) *universal-type*) + ((null x) *empty-type*)) + index) + (incf index)) + ;; Index 31 is available to store *WILD-TYPE* + ;; because there are fewer than 32 array widetags. + (aver (< index 31)) + (make-all *wild-type* 31)))) (declaim (ftype (sfunction (t &key (:complexp t) (:element-type t) @@ -610,21 +598,15 @@ ctype) make-array-type)) (defun make-array-type (dimensions &key (complexp :maybe) element-type (specialized-element-type *wild-type*)) - (or (and (eq element-type specialized-element-type) + (if (and (eq element-type specialized-element-type) (or (and (eq dimensions '*) (neq complexp t)) - (typep dimensions '(cons (eql *) null))) - (let ((table *canonical-array-ctypes*)) - (dolist (cell (svref (cdr table) - (mod (type-hash-value element-type) - +canon-array-ctype-hash-divisor+))) - (when (eq (car cell) element-type) - (return - (truly-the ctype - (svref (car table) - (+ (cdr cell) - (if (listp dimensions) 0 3) - (ecase complexp - ((nil) 0) ((:maybe) 1) ((t) 2)))))))))) + (typep dimensions '(cons (eql *) null)))) + (let ((res (svref *canonical-array-ctypes* + (+ (* (!ctype-saetp-index element-type) 5) + (if (listp dimensions) 0 3) + (ecase complexp ((nil) 0) ((:maybe) 1) ((t) 2)))))) + (aver (eq (array-type-element-type res) element-type)) + res) (%make-array-type dimensions complexp element-type specialized-element-type))) diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index 5d4e0c5f5..c1b1b4af6 100644 --- a/src/code/late-type.lisp +++ b/src/code/late-type.lisp @@ -822,6 +822,8 @@ (values t t)) ;; If args are not EQ, but both allow TYPE= optimization, ;; and at least one is interned, then return no and certainty. + ;; Most of the interned CTYPEs admit this optimization, + ;; NUMERIC and MEMBER types do as well. ((and (minusp (logior (type-hash-value type1) (type-hash-value type2))) (logtest (logand (type-hash-value type1) (type-hash-value type2)) +type-admits-type=-optimization+)) diff --git a/src/code/type-class.lisp b/src/code/type-class.lisp index 992f2eb14..36685423d 100644 --- a/src/code/type-class.lisp +++ b/src/code/type-class.lisp @@ -216,7 +216,7 @@ ;; Each CTYPE instance (incl. subtypes thereof) has a random opaque hash value. ;; Hashes are mixed together to form a lookup key in the memoization wrappers ;; for most operations in CTYPES. This works because CTYPEs are immutable. -;; But 2 bits are "stolen" from the hash to use as flag bits. +;; But some bits are "stolen" from the hash as flag bits. ;; The sign bit indicates that the object is the *only* object representing ;; its type-specifier - it is an "interned" object. ;; The next highest bit indicates that the object, if compared for TYPE= @@ -226,6 +226,17 @@ (defconstant +ctype-hash-mask+ (ldb (byte (1- sb!vm:n-positive-fixnum-bits) 0) -1)) +;;; When comparing two ctypes, if this bit is 1 in each and they are not EQ, +;;; and at least one is interned, then they are not TYPE=. +(defconstant +type-admits-type=-optimization+ + (ash 1 (- sb!vm:n-positive-fixnum-bits 1))) + +;;; Represent an index into *SPECIALIZED-ARRAY-ELEMENT-TYPE-PROPERTIES* +;;; if applicable. For types which are not array specializations, +;;; the bits are arbitrary. +(defmacro !ctype-saetp-index (x) + `(ldb (byte 5 ,(- sb!vm:n-positive-fixnum-bits 6)) (type-hash-value ,x))) + (def!struct (ctype (:conc-name type-) (:constructor nil) (:make-load-form-fun make-type-load-form) @@ -258,16 +269,12 @@ ;; be a read/write slot? :read-only nil)) -;; Set the sign bit (the "interned" bit) of the hash-value of OBJ to 1. -;; This is an indicator that the object is the unique internal representation -;; of any ctype that is TYPE= to this object. -;; Everything starts out assumed non-unique. -;; The hash-cache logic (a/k/a memoization) tends to ignore high bits when -;; creating cache keys because the mixing function is XOR and the caches -;; are power-of-2 sizes. Lkewise making the low bits non-random is bad -;; for cache distribution. -(defconstant +type-admits-type=-optimization+ - (ash 1 (- sb!vm:n-positive-fixnum-bits 1))) ; highest bit in fixnum +;;; The "interned" bit indicates uniqueness of the internal representation of +;;; any specifier that parses to this object. +;;; Not all interned types admit TYPE= optimization. As one example: +;;; (type= (specifier-type '(array (unsigned-byte 6) (*))) +;;; (specifier-type '(array (unsigned-byte 7) (*)))) => T and T +;;; because we preserve the difference in spelling of the two types. (defun mark-ctype-interned (obj) (setf (type-hash-value obj) (logior sb!xc:most-negative-fixnum -- 2.11.4.GIT