[Sbcl-commits] master: Interned ctypes allow a few simplifications to PRIMITIVE-TYPE-AUX.

[Douglas K. <sn...@us...>]

The branch "master" has been updated in SBCL:
       via  9a1a40b50a3c68a70ea33f8d526956302cbc1943 (commit)
      from  c79427ea45219c8c7a96cec1c4398aafbf2bef41 (commit)

- Log -----------------------------------------------------------------
commit 9a1a40b50a3c68a70ea33f8d526956302cbc1943
Author: Douglas Katzman <do...@go...>
Date:   Sat Feb 28 00:24:12 2015 -0500

    Interned ctypes allow a few simplifications to PRIMITIVE-TYPE-AUX.
---
 src/compiler/generic/primtype.lisp |   32 ++++++++++++++------------------
 src/compiler/generic/vm-array.lisp |   10 ----------
 2 files changed, 14 insertions(+), 28 deletions(-)

diff --git a/src/compiler/generic/primtype.lisp b/src/compiler/generic/primtype.lisp
index 03e3e96..756f488 100644
--- a/src/compiler/generic/primtype.lisp
+++ b/src/compiler/generic/primtype.lisp
@@ -289,19 +289,18 @@
              (t
               (any)))))
         (array-type
-         (if (array-type-complexp type)
+         (if (or (array-type-complexp type)
+                 (not (singleton-p (array-type-dimensions type))))
              (any)
-             (let* ((dims (array-type-dimensions type))
-                    (etype (array-type-specialized-element-type type))
-                    (type-spec (type-specifier etype))
-                    ;; FIXME: We're _WHAT_?  Testing for type equality
-                    ;; with a specifier and #'EQUAL?  *BOGGLE*.  --
-                    ;; CSR, 2003-06-24
-                    (ptype (cdr (assoc type-spec *simple-array-primitive-types*
-                                       :test #'equal))))
-               (if (and (consp dims) (null (rest dims)) ptype)
-                   (values (primitive-type-or-lose ptype)
-                           (eq (first dims) '*))
+             ;; EQ is ok to compare by because all CTYPEs representing
+             ;; array specializations are interned objects.
+             (let ((saetp (find (array-type-specialized-element-type type)
+                                *specialized-array-element-type-properties*
+                                :key #'saetp-ctype :test #'eq)))
+               (if saetp
+                   (values (primitive-type-or-lose
+                            (saetp-primitive-type-name saetp))
+                           (eq (first (array-type-dimensions type)) '*))
                    (any)))))
         (union-type
          (if (type= type (specifier-type 'list))
@@ -372,12 +371,9 @@
            ((extended-sequence) (any))
            ((nil) (any))))
         (character-set-type
-         (let ((pairs (character-set-type-pairs type)))
-           (if (and (= (length pairs) 1)
-                    (= (caar pairs) 0)
-                    (= (cdar pairs) (1- sb!xc:char-code-limit)))
-               (exactly character)
-               (part-of character))))
+         (if (eq type sb!kernel::*character-type*)
+             (exactly character)
+             (part-of character)))
         #!+sb-simd-pack
         (simd-pack-type
          (let ((eltypes (simd-pack-type-element-type type)))
diff --git a/src/compiler/generic/vm-array.lisp b/src/compiler/generic/vm-array.lisp
index fa5c35d..a69392b 100644
--- a/src/compiler/generic/vm-array.lisp
+++ b/src/compiler/generic/vm-array.lisp
@@ -199,16 +199,6 @@
   (setf sb!kernel::*specialized-array-element-types*
         '#.sb!kernel::*specialized-array-element-types*))
 
-(defvar *simple-array-primitive-types*
-  (map 'list
-       (lambda (saetp)
-         (cons (saetp-specifier saetp)
-               (saetp-primitive-type-name saetp)))
-       *specialized-array-element-type-properties*)
-  #!+sb-doc
-  "An alist for mapping simple array element types to their
-corresponding primitive types.")
-
 (defvar *vector-without-complex-typecode-infos*
   #+sb-xc-host
   (loop for saetp across *specialized-array-element-type-properties*

-----------------------------------------------------------------------


hooks/post-receive
-- 
SBCL