X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=inline;f=src%2Fcompiler%2Fgeneric%2Fvm-array.lisp;h=9f677ef00ac84ef6e22d348c1070b3e675d34b45;hb=HEAD;hp=e0925e5a862648dd362250a03666fb5fd6430468;hpb=8cbd7fc0f27222a778ce61bae7d943a5081362cc;p=sbcl.git

diff --git a/src/compiler/generic/vm-array.lisp b/src/compiler/generic/vm-array.lisp
index e0925e5..9f677ef 100644
--- a/src/compiler/generic/vm-array.lisp
+++ b/src/compiler/generic/vm-array.lisp
@@ -21,7 +21,7 @@
               initial-element-default
               n-bits
               primitive-type-name
-              &key (n-pad-elements 0) complex-typecode (importance 0)
+              &key (n-pad-elements 0) complex-typecode (importance 0) fixnum-p
               &aux (typecode
                     (symbol-value (symbolicate primitive-type-name "-WIDETAG")))))
             (:copier nil))
@@ -30,6 +30,8 @@
   ;; the element type, e.g. #<BUILT-IN-CLASS BASE-CHAR (sealed)> or
   ;; #<SB-KERNEL:NUMERIC-TYPE (UNSIGNED-BYTE 4)>
   (ctype nil :type (or ctype null))
+  ;; true if the elements are tagged fixnums
+  (fixnum-p nil :type boolean :read-only t)
   ;; what we get when the low-level vector-creation logic zeroes all
   ;; the bits (which also serves as the default value of MAKE-ARRAY's
   ;; :INITIAL-ELEMENT keyword)
@@ -49,10 +51,9 @@
   ;; which is used for a fixed #\NULL so that when we call out to C
   ;; we don't need to cons a new copy)
   (n-pad-elements (missing-arg) :type index :read-only t)
-  ;; the relative importance of this array type.  Used for determining
-  ;; the order of the TYPECASE in HAIRY-DATA-VECTOR-{REF,SET}.  High
-  ;; positive numbers are near the top; low negative numbers near the
-  ;; bottom.
+  ;; the relative importance of this array type.  Previously used for
+  ;; determining the order of the TYPECASE in
+  ;; HAIRY-DATA-VECTOR-{REF,SET}; currently (as of 2013-09-18) unused.
   (importance (missing-arg) :type fixnum :read-only t))
 
 (defparameter *specialized-array-element-type-properties*
@@ -114,15 +115,19 @@
          ((unsigned-byte 16) 0 16 simple-array-unsigned-byte-16
           :importance 12)
          #!+#.(cl:if (cl:= 32 sb!vm:n-word-bits) '(and) '(or))
-         ((unsigned-byte 29) 0 32 simple-array-unsigned-byte-29
-          :importance 8)
+         ((unsigned-byte #.sb!vm:n-positive-fixnum-bits)
+          0 32 simple-array-unsigned-fixnum
+          :importance 8
+          :fixnum-p t)
          ((unsigned-byte 31) 0 32 simple-array-unsigned-byte-31
           :importance 11)
          ((unsigned-byte 32) 0 32 simple-array-unsigned-byte-32
           :importance 11)
          #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
-         ((unsigned-byte 60) 0 64 simple-array-unsigned-byte-60
-          :importance 8)
+         ((unsigned-byte #.sb!vm:n-positive-fixnum-bits)
+          0 64 simple-array-unsigned-fixnum
+          :importance 8
+          :fixnum-p t)
          #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
          ((unsigned-byte 63) 0 64 simple-array-unsigned-byte-63
           :importance 9)
@@ -137,14 +142,16 @@
          ;; compiler/generic/primtype.lisp, for why this is FIXNUM and
          ;; not (SIGNED-BYTE 30)
          #!+#.(cl:if (cl:= 32 sb!vm:n-word-bits) '(and) '(or))
-         (fixnum 0 32 simple-array-signed-byte-30
-          :importance 8)
+         (fixnum 0 32 simple-array-fixnum
+          :importance 8
+          :fixnum-p t)
          ((signed-byte 32) 0 32 simple-array-signed-byte-32
           :importance 7)
          ;; KLUDGE: see above KLUDGE for the 32-bit case
          #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
-         (fixnum 0 64 simple-array-signed-byte-61
-          :importance 8)
+         (fixnum 0 64 simple-array-fixnum
+          :importance 8
+          :fixnum-p t)
          #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
          ((signed-byte 64) 0 64 simple-array-signed-byte-64
           :importance 7)
@@ -160,6 +167,18 @@
           :importance 1)
          (t 0 #.sb!vm:n-word-bits simple-vector :importance 18))))
 
+(defun valid-bit-bash-saetp-p (saetp)
+  ;; BIT-BASHing isn't allowed on simple vectors that contain pointers
+  (and (not (eq t (sb!vm:saetp-specifier saetp)))
+       ;; Disallowing (VECTOR NIL) also means that we won't transform
+       ;; sequence functions into bit-bashing code and we let the
+       ;; generic sequence functions signal errors if necessary.
+       (not (zerop (sb!vm:saetp-n-bits saetp)))
+       ;; Due to limitations with the current BIT-BASHing code, we can't
+       ;; BIT-BASH reliably on arrays whose element types are larger
+       ;; than the word size.
+       (<= (sb!vm:saetp-n-bits saetp) sb!vm:n-word-bits)))
+
 (defvar sb!kernel::*specialized-array-element-types*
   (map 'list
        #'saetp-specifier
@@ -180,8 +199,27 @@
   "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*
+        for specifier = (saetp-specifier saetp)
+        unless (saetp-complex-typecode saetp)
+        collect (list (if (atom specifier)
+                          (intern (format nil "VECTOR-~A-P" specifier))
+                          ;; at the moment, all specialized array
+                          ;; specifiers are either atoms or
+                          ;; two-element lists.
+                          (intern (format nil "VECTOR-~A-~A-P" (car specifier) (cadr specifier))))
+                      specifier))
+  #-sb-xc-host
+  '#.*vector-without-complex-typecode-infos*)
+
 (in-package "SB!C")
 
 (defun find-saetp (element-type)
   (find element-type sb!vm:*specialized-array-element-type-properties*
         :key #'sb!vm:saetp-specifier :test #'equal))
+
+(defun find-saetp-by-ctype (ctype)
+  (find ctype sb!vm:*specialized-array-element-type-properties*
+        :key #'sb!vm:saetp-ctype :test #'csubtypep))