src/compiler/generic/vm-array.lisp

   1 ;;;; this file centralizes information about the array types
   2 ;;;; implemented by the system, where previously such information was
   3 ;;;; spread over several files.
   4
   5 ;;;; This software is part of the SBCL system. See the README file for
   6 ;;;; more information.
   7 ;;;;
   8 ;;;; This software is derived from the CMU CL system, which was
   9 ;;;; written at Carnegie Mellon University and released into the
  10 ;;;; public domain. The software is in the public domain and is
  11 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  12 ;;;; files for more information.
  13
  14 (in-package "SB!VM")
  15
  16 (defstruct (specialized-array-element-type-properties
  17             (:conc-name saetp-)
  18             (:constructor
  19              !make-saetp
  20              (specifier
  21               initial-element-default
  22               n-bits
  23               primitive-type-name
  24               &key (n-pad-elements 0) complex-typecode fixnum-p
  25               &aux (typecode
  26                     (symbol-value (symbolicate primitive-type-name "-WIDETAG")))))
  27             (:copier nil))
  28   ;; the element specifier, e.g. BASE-CHAR or (UNSIGNED-BYTE 4)
  29   ;; TYPE-SPECIFIER is too general - this doesn't allow CLASS/CLASSOID.
  30   (specifier (missing-arg) :type (or symbol list) :read-only t)
  31   ;; the element type, e.g. #<BUILT-IN-CLASS BASE-CHAR (sealed)> or
  32   ;; #<SB-KERNEL:NUMERIC-TYPE (UNSIGNED-BYTE 4)>
  33   (ctype nil :type (or ctype null))
  34   ;; true if the elements are tagged fixnums
  35   (fixnum-p nil :type boolean :read-only t)
  36   ;; what we get when the low-level vector-creation logic zeroes all
  37   ;; the bits (which also serves as the default value of MAKE-ARRAY's
  38   ;; :INITIAL-ELEMENT keyword)
  39   (initial-element-default (missing-arg) :read-only t)
  40   ;; how many bits per element
  41   (n-bits (missing-arg) :type index :read-only t)
  42   ;; the low-level type code (aka "widetag")
  43   (typecode (missing-arg) :type index :read-only t)
  44   ;; if an integer, a typecode corresponding to a complex vector
  45   ;; specialized on this element type.
  46   (complex-typecode nil :type (or index null) :read-only t)
  47   ;; the name of the primitive type of data vectors specialized on
  48   ;; this type
  49   (primitive-type-name (missing-arg) :type symbol :read-only t)
  50   ;; the number of extra elements we use at the end of the array for
  51   ;; low level hackery (e.g., one element for arrays of BASE-CHAR,
  52   ;; which is used for a fixed #\NULL so that when we call out to C
  53   ;; we don't need to cons a new copy)
  54   (n-pad-elements (missing-arg) :type index :read-only t))
  55
  56 ;; Simulate DEFINE-LOAD-TIME-GLOBAL - always bound in the image
  57 ;; but not eval'd in the compiler.
  58 (defglobal *specialized-array-element-type-properties* nil)
  59 (setq *specialized-array-element-type-properties*
  60   (map 'simple-vector
  61        (lambda (args)
  62          (apply #'!make-saetp args))
  63        `(;; Erm.  Yeah.  There aren't a lot of things that make sense
  64          ;; for an initial element for (ARRAY NIL). -- CSR, 2002-03-07
  65          (nil #:mu 0 simple-array-nil
  66               :complex-typecode #.complex-vector-nil-widetag)
  67          #!-sb-unicode
  68          (character ,(code-char 0) 8 simple-base-string
  69                     ;; (SIMPLE-BASE-STRINGs are stored with an extra
  70                     ;; trailing #\NULL for convenience in calling out
  71                     ;; to C.)
  72                     :n-pad-elements 1
  73                     :complex-typecode #.complex-base-string-widetag)
  74          #!+sb-unicode
  75          (base-char ,(code-char 0) 8 simple-base-string
  76                     ;; (SIMPLE-BASE-STRINGs are stored with an extra
  77                     ;; trailing #\NULL for convenience in calling out
  78                     ;; to C.)
  79                     :n-pad-elements 1
  80                     :complex-typecode #.complex-base-string-widetag)
  81          #!+sb-unicode
  82          (character ,(code-char 0) 32 simple-character-string
  83                     :n-pad-elements 1
  84                     :complex-typecode #.complex-character-string-widetag)
  85          (single-float 0.0f0 32 simple-array-single-float)
  86          (double-float 0.0d0 64 simple-array-double-float)
  87          (bit 0 1 simple-bit-vector
  88               :complex-typecode #.complex-bit-vector-widetag)
  89          ;; KLUDGE: The fact that these UNSIGNED-BYTE entries come
  90          ;; before their SIGNED-BYTE partners is significant in the
  91          ;; implementation of the compiler; some of the cross-compiler
  92          ;; code (see e.g. COERCE-TO-SMALLEST-ELTYPE in
  93          ;; src/compiler/debug-dump.lisp) attempts to create an array
  94          ;; specialized on (UNSIGNED-BYTE FOO), where FOO could be 7;
  95          ;; (UNSIGNED-BYTE 7) is SUBTYPEP (SIGNED-BYTE 8), so if we're
  96          ;; not careful we could get the wrong specialized array when
  97          ;; we try to FIND-IF, below. -- CSR, 2002-07-08
  98          ((unsigned-byte 2) 0 2 simple-array-unsigned-byte-2)
  99          ((unsigned-byte 4) 0 4 simple-array-unsigned-byte-4)
 100          ((unsigned-byte 7) 0 8 simple-array-unsigned-byte-7)
 101          ((unsigned-byte 8) 0 8 simple-array-unsigned-byte-8)
 102          ((unsigned-byte 15) 0 16 simple-array-unsigned-byte-15)
 103          ((unsigned-byte 16) 0 16 simple-array-unsigned-byte-16)
 104          #!-64-bit
 105          ((unsigned-byte #.n-positive-fixnum-bits)
 106           0 32 simple-array-unsigned-fixnum
 107           :fixnum-p t)
 108          ((unsigned-byte 31) 0 32 simple-array-unsigned-byte-31)
 109          ((unsigned-byte 32) 0 32 simple-array-unsigned-byte-32)
 110          #!+64-bit
 111          ((unsigned-byte #.n-positive-fixnum-bits)
 112           0 64 simple-array-unsigned-fixnum
 113           :fixnum-p t)
 114          #!+64-bit
 115          ((unsigned-byte 63) 0 64 simple-array-unsigned-byte-63)
 116          #!+64-bit
 117          ((unsigned-byte 64) 0 64 simple-array-unsigned-byte-64)
 118          ((signed-byte 8) 0 8 simple-array-signed-byte-8)
 119          ((signed-byte 16) 0 16 simple-array-signed-byte-16)
 120          ;; KLUDGE: See the comment in PRIMITIVE-TYPE-AUX,
 121          ;; compiler/generic/primtype.lisp, for why this is FIXNUM and
 122          ;; not (SIGNED-BYTE 30)
 123          #!-64-bit
 124          (fixnum 0 32 simple-array-fixnum :fixnum-p t)
 125          ((signed-byte 32) 0 32 simple-array-signed-byte-32)
 126          ;; KLUDGE: see above KLUDGE for the 32-bit case
 127          #!+64-bit
 128          (fixnum 0 64 simple-array-fixnum :fixnum-p t)
 129          #!+64-bit
 130          ((signed-byte 64) 0 64 simple-array-signed-byte-64)
 131          ((complex single-float) #C(0.0f0 0.0f0) 64
 132           simple-array-complex-single-float)
 133          ((complex double-float) #C(0.0d0 0.0d0) 128
 134           simple-array-complex-double-float)
 135          #!+long-float
 136          ((complex long-float) #C(0.0l0 0.0l0) #!+x86 192 #!+sparc 256
 137           simple-array-complex-long-float)
 138          (t 0 #.n-word-bits simple-vector))))
 139
 140 ;; The compiler can see that the number of types that must be present in a
 141 ;; union of arrays to convert (OR (array t1) ... (array tN)) to (ARRAY *)
 142 ;; is a constant if (LENGTH *SPECIALIZED-ARRAY-ELEMENT-TYPE-PROPERTIES*) is
 143 ;; a constant. So proclaim the type of the global var. This works because
 144 ;; the compiler doesn't retroactively try to check the initializer of NIL.
 145 #-sb-xc-host
 146 (declaim (type (simple-vector
 147                 #.(length *specialized-array-element-type-properties*))
 148                *specialized-array-element-type-properties*))
 149
 150 (defun valid-bit-bash-saetp-p (saetp)
 151   ;; BIT-BASHing isn't allowed on simple vectors that contain pointers
 152   (and (not (eq t (saetp-specifier saetp)))
 153        ;; Disallowing (VECTOR NIL) also means that we won't transform
 154        ;; sequence functions into bit-bashing code and we let the
 155        ;; generic sequence functions signal errors if necessary.
 156        (not (zerop (saetp-n-bits saetp)))
 157        ;; Due to limitations with the current BIT-BASHing code, we can't
 158        ;; BIT-BASH reliably on arrays whose element types are larger
 159        ;; than the word size.
 160        (<= (saetp-n-bits saetp) n-word-bits)))
 161
 162 #+sb-xc-host
 163 (defvar sb!kernel::*specialized-array-element-types*
 164   (map 'list
 165        #'saetp-specifier
 166        *specialized-array-element-type-properties*))
 167
 168 #-sb-xc-host
 169 (!defglobal sb!kernel::*specialized-array-element-types*
 170             '#.sb!kernel::*specialized-array-element-types*)
 171
 172 (defvar *vector-without-complex-typecode-infos*
 173   #+sb-xc-host
 174   (loop for saetp across *specialized-array-element-type-properties*
 175         for specifier = (saetp-specifier saetp)
 176         unless (saetp-complex-typecode saetp)
 177         collect (list (if (atom specifier)
 178                           (intern (format nil "VECTOR-~A-P" specifier))
 179                           ;; at the moment, all specialized array
 180                           ;; specifiers are either atoms or
 181                           ;; two-element lists.
 182                           (intern (format nil "VECTOR-~A-~A-P" (car specifier) (cadr specifier))))
 183                       specifier))
 184   #-sb-xc-host
 185   '#.*vector-without-complex-typecode-infos*)
 186
 187 ;;; Return the shift amount needed to turn length into bits
 188 (defun saetp-n-bits-shift (saetp)
 189   (max (1- (integer-length (saetp-n-bits saetp)))
 190        0)) ;; because of NIL
 191
 192 (in-package "SB!C")
 193
 194 (defun find-saetp (element-type)
 195   (find element-type sb!vm:*specialized-array-element-type-properties*
 196         :key #'sb!vm:saetp-specifier :test #'equal))
 197
 198 (defun find-saetp-by-ctype (ctype)
 199   (find ctype sb!vm:*specialized-array-element-type-properties*
 200         :key #'sb!vm:saetp-ctype :test #'csubtypep))