Optimize MAKE-ARRAY on unknown element-type.

Reimplement %vector-widetag-and-n-bits without using subtypep,
providing an order of magnitude speed up.

Out of line make-array :element-type 'character also caused to cons
twice larger than needed vectors on x86-64.
(Though that wasted space was reclaimed after GC).

Closes lp#1004501.

diff --git a/NEWS b/NEWS
index ab625a0..e42e100 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -9,8 +9,10 @@ changes relative to sbcl-1.1.14:
     execution.  The previous behaviour can be obtained by instead setting that
     variable to :greedy.  Thanks again to Google for their support, and, more
     crucially, to Alexandra Barchunova for her hard work.
-  * optimization: make-array with known element-type and unkown dimensions is
+  * optimization: make-array with known element-type and unknown dimensions is
     much faster.
+  * optimization: make-array with unknown element-type is faster as well.
+    (lp#1004501)
   * enhancement: sb-ext:save-lisp-and-die on Windows now accepts
     :application-type argument, which can be :console or :gui. :gui allows
     having GUI applications without an automatically appearing console window.

diff --git a/src/code/array.lisp b/src/code/array.lisp
index e367539..7701a7f 100644 (file)
--- a/src/code/array.lisp
+++ b/src/code/array.lisp
@@ -70,41 +70,188 @@
                          ,@(cdr spec)))
                      specs))))
 
+(defun %integer-vector-widetag-and-n-bits (signed high)
+  (let ((unsigned-table
+          #.(let ((map (make-array (1+ sb!vm:n-word-bits))))
+              (loop for saetp across
+                    (reverse sb!vm:*specialized-array-element-type-properties*)
+                    for ctype = (sb!vm:saetp-ctype saetp)
+                    when (and (numeric-type-p ctype)
+                              (eq (numeric-type-class ctype) 'integer)
+                              (zerop (numeric-type-low ctype)))
+                    do (fill map (cons (sb!vm:saetp-typecode saetp)
+                                       (sb!vm:saetp-n-bits saetp))
+                             :end (1+ (integer-length (numeric-type-high ctype)))))
+              map))
+        (signed-table
+          #.(let ((map (make-array (1+ sb!vm:n-word-bits))))
+              (loop for saetp across
+                    (reverse sb!vm:*specialized-array-element-type-properties*)
+                    for ctype = (sb!vm:saetp-ctype saetp)
+                    when (and (numeric-type-p ctype)
+                              (eq (numeric-type-class ctype) 'integer)
+                              (minusp (numeric-type-low ctype)))
+                    do (fill map (cons (sb!vm:saetp-typecode saetp)
+                                       (sb!vm:saetp-n-bits saetp))
+                             :end (+ (integer-length (numeric-type-high ctype)) 2)))
+              map)))
+    (cond ((> high sb!vm:n-word-bits)
+           (values #.sb!vm:simple-vector-widetag #.sb!vm:n-word-bits))
+          (signed
+           (let ((x (aref signed-table high)))
+             (values (car x) (cdr x))))
+          (t
+           (let ((x (aref unsigned-table high)))
+             (values (car x) (cdr x)))))))
+
 ;;; These functions are used in the implementation of MAKE-ARRAY for
 ;;; complex arrays. There are lots of transforms to simplify
 ;;; MAKE-ARRAY for various easy cases, but not for all reasonable
 ;;; cases, so e.g. as of sbcl-0.6.6 we still make full calls to
-;;; MAKE-ARRAY for any non-simple array. Thus, there's some value to
-;;; making this somewhat efficient, at least not doing full calls to
-;;; SUBTYPEP in the easy cases.
+;;; MAKE-ARRAY for any non-simple array.
 (defun %vector-widetag-and-n-bits (type)
-  (case type
-    ;; Pick off some easy common cases.
-    ;;
-    ;; (Perhaps we should make a much more exhaustive table of easy
-    ;; common cases here. Or perhaps the effort would be better spent
-    ;; on smarter compiler transforms which do the calculation once
-    ;; and for all in any reasonable user programs.)
-    ((t)
-     (values #.sb!vm:simple-vector-widetag #.sb!vm:n-word-bits))
-    ((base-char standard-char #!-sb-unicode character)
-     (values #.sb!vm:simple-base-string-widetag #.sb!vm:n-byte-bits))
-    #!+sb-unicode
-    ((character)
-     (values #.sb!vm:simple-character-string-widetag #.sb!vm:n-word-bits))
-    ((bit)
-     (values #.sb!vm:simple-bit-vector-widetag 1))
-    ;; OK, we have to wade into SUBTYPEPing after all.
-    (t
-     (unless *type-system-initialized*
-       (bug "SUBTYPEP dispatch for MAKE-ARRAY before the type system is ready"))
-     #.`(pick-vector-type type
-         ,@(map 'list
-                (lambda (saetp)
-                  `(,(sb!vm:saetp-specifier saetp)
-                    (values ,(sb!vm:saetp-typecode saetp)
-                            ,(sb!vm:saetp-n-bits saetp))))
-                sb!vm:*specialized-array-element-type-properties*)))))
+  (flet ((ill-type ()
+           (error "Invalid type specifier: ~s" type)))
+    (macrolet ((with-parameters ((arg-type &key (min-length 0))
+                                 (&rest args) &body body)
+                 (let ((type-sym (gensym)))
+                   `(let (,@(loop for arg in args
+                                  collect `(,arg '*)))
+                      (declare (ignorable ,@args))
+                      (when ,(if (plusp min-length)
+                                 t
+                                 '(consp type))
+                        (let ((,type-sym (cdr type)))
+                          (unless (proper-list-of-length-p ,type-sym ,min-length ,(length args))
+                            (ill-type))
+                          (block nil
+                            ,@(loop for arg in args
+                                    for i from 0
+                                    collect
+                                    `(if ,type-sym
+                                         (let ((value (pop ,type-sym)))
+                                           (if (or ,(if (>= i min-length)
+                                                        `(eq value '*))
+                                                   (typep value ',arg-type))
+                                               (setf ,arg value)
+                                               (ill-type)))
+                                         (return))))))
+                      ,@body)))
+               (result (widetag)
+                 (let ((value (symbol-value widetag)))
+                   `(values ,value
+                            ,(sb!vm:saetp-n-bits
+                              (find value
+                                    sb!vm:*specialized-array-element-type-properties*
+                                    :key #'sb!vm:saetp-typecode))))))
+      (let* ((consp (consp type))
+             (type-name (if consp
+                            (car type)
+                            type)))
+        (case type-name
+          ((t)
+           (when consp
+             (ill-type))
+           (result sb!vm:simple-vector-widetag))
+          ((base-char standard-char #!-sb-unicode character)
+           (when consp
+             (ill-type))
+           (result sb!vm:simple-base-string-widetag))
+          #!+sb-unicode
+          (character
+           (when consp
+             (ill-type))
+           (result sb!vm:simple-character-string-widetag))
+          (bit
+           (when consp
+             (ill-type))
+           (result sb!vm:simple-bit-vector-widetag))
+          (fixnum
+           (when consp
+             (ill-type))
+           (result sb!vm:simple-array-fixnum-widetag))
+          (unsigned-byte
+           (with-parameters ((integer 1)) (high)
+             (if (eq high '*)
+                 (result sb!vm:simple-vector-widetag)
+                 (%integer-vector-widetag-and-n-bits nil high))))
+          (signed-byte
+           (with-parameters ((integer 1)) (high)
+             (if (eq high '*)
+                 (result sb!vm:simple-vector-widetag)
+                 (%integer-vector-widetag-and-n-bits t high))))
+          (double-float
+           (with-parameters (double-float) (low high)
+             (if (and (not (eq low '*))
+                      (not (eq high '*))
+                      (> low high))
+                 (result sb!vm:simple-array-nil-widetag)
+                 (result sb!vm:simple-array-double-float-widetag))))
+          (single-float
+           (with-parameters (single-float) (low high)
+             (if (and (not (eq low '*))
+                      (not (eq high '*))
+                      (> low high))
+                 (result sb!vm:simple-array-nil-widetag)
+                 (result sb!vm:simple-array-single-float-widetag))))
+          (mod
+           (with-parameters ((integer 1) :min-length 1) (n)
+             (%integer-vector-widetag-and-n-bits nil (integer-length (1- n)))))
+          #!+long-float
+          (long-float
+           (with-parameters (long-float) (low high)
+             (if (and (not (eq low '*))
+                      (not (eq high '*))
+                      (> low high))
+                 (result sb!vm:simple-array-nil-widetag)
+                 (result sb!vm:simple-array-long-float-widetag))))
+          (integer
+           (with-parameters (integer) (low high)
+             (cond ((or (eq high '*)
+                        (eq low '*))
+                    (result sb!vm:simple-vector-widetag))
+                   ((> low high)
+                    (result sb!vm:simple-array-nil-widetag))
+                   (t
+                    (if (minusp low)
+                        (%integer-vector-widetag-and-n-bits
+                         t
+                         (1+ (max (integer-length low) (integer-length high))))
+                        (%integer-vector-widetag-and-n-bits
+                         nil
+                         (max (integer-length low) (integer-length high))))))))
+          (complex
+           (with-parameters (t) (subtype)
+             (if (eq type '*)
+                 (result sb!vm:simple-vector-widetag)
+                 (let ((ctype (specifier-type type)))
+                   (if (eq ctype *empty-type*)
+                       (result sb!vm:simple-array-nil-widetag)
+                       (case (numeric-type-format ctype)
+                         (double-float
+                          (result
+                           sb!vm:simple-array-complex-double-float-widetag))
+                         (single-float
+                          (result
+                           sb!vm:simple-array-complex-single-float-widetag))
+                         #!+long-float
+                         (long-float
+                          (result
+                           sb!vm:simple-array-complex-long-float-widetag))
+                         (t
+                          (result sb!vm:simple-vector-widetag))))))))
+          ((nil)
+           (result sb!vm:simple-array-nil-widetag))
+          (t
+           (block nil
+             (let ((expansion
+                     (type-specifier
+                      (handler-case (specifier-type type)
+                        (parse-unknown-type ()
+                          (return (result sb!vm:simple-vector-widetag)))))))
+               (if (equal expansion type)
+                   (result sb!vm:simple-vector-widetag)
+                   (%vector-widetag-and-n-bits expansion))))))))))
 
 (defun %complex-vector-widetag (widetag)
   (macrolet ((make-case ()

diff --git a/src/code/early-type.lisp b/src/code/early-type.lisp
index de364eb..f3db7a3 100644 (file)
--- a/src/code/early-type.lisp
+++ b/src/code/early-type.lisp
@@ -595,10 +595,9 @@
             (when (and (atom spec)
                        (member spec '(and or not member eql satisfies values)))
               (error "The symbol ~S is not valid as a type specifier." spec))
-            (let* ((lspec (if (atom spec) (list spec) spec))
-                   (fun (info :type :translator (car lspec))))
+            (let ((fun (info :type :translator (if (consp spec) (car spec) spec))))
               (cond (fun
-                     (funcall fun lspec))
+                     (funcall fun (if (atom spec) (list spec) spec)))
                     ((or (and (consp spec) (symbolp (car spec))
                               (not (info :type :builtin (car spec))))
                          (and (symbolp spec) (not (info :type :builtin spec))))
@@ -652,7 +651,7 @@ expansion happened."
                ;; b) so (EQUAL (TYPEXPAND 'STRING) (TYPEXPAND-ALL 'STRING))
                (values nil nil))
               ((symbolp spec)
-               (values (info :type :expander spec) (list spec)))
+               (values (info :type :expander spec) spec))
               ((and (consp spec) (symbolp (car spec)) (info :type :builtin (car spec)))
                ;; see above
                (values nil nil))
@@ -660,7 +659,10 @@ expansion happened."
                (values (info :type :expander (car spec)) spec))
               (t nil)))
     (if expander
-        (values (funcall expander lspec) t)
+        (values (funcall expander (if (symbolp lspec)
+                                      (list lspec)
+                                      lspec))
+                t)
         (values type-specifier nil))))
 
 (defun typexpand (type-specifier &optional env)

diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index 577c434..dc092ed 100644 (file)
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -3281,7 +3281,9 @@
     (ctu:assert-no-consing (funcall f))))
 
 (with-test (:name :array-type-predicates)
-  (dolist (et sb-kernel::*specialized-array-element-types*)
+  (dolist (et (list* '(integer -1 200) '(integer -256 1)
+                     '(integer 0 128)
+                     sb-kernel::*specialized-array-element-types*))
     (when et
       (let* ((v (make-array 3 :element-type et))
              (fun (compile nil `(lambda ()