src/code/specializable-array.lisp

   1 ;;;; a hack to suppress array specialization when building under the
   2 ;;;; cross-compiler
   3
   4 ;;;; This software is part of the SBCL system. See the README file for
   5 ;;;; more information.
   6 ;;;;
   7 ;;;; This software is derived from the CMU CL system, which was
   8 ;;;; written at Carnegie Mellon University and released into the
   9 ;;;; public domain. The software is in the public domain and is
  10 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  11 ;;;; files for more information.
  12
  13 (in-package "SB!KERNEL")
  14
  15 ;;; It's hard to dump specialized vectors portably, because ANSI
  16 ;;; doesn't guarantee much about what specialized vectors exist.
  17 ;;; Thus, if we do
  18 ;;;   (MAKE-ARRAY 10 :ELEMENT-TYPE '(UNSIGNED-BYTE 4))
  19 ;;; in the cross-compilation host, we could easily end up with a
  20 ;;; vector of (UNSIGNED-BYTE 8) or of T, and the dumped result would
  21 ;;; reflect this.
  22 ;;;
  23 ;;; To reduce the prominence of this issue in cross-compilation, we
  24 ;;; can use these types, which expands into a specialized vector type when
  25 ;;; building the cross-compiler, and a SIMPLE-VECTOR otherwise.
  26 (deftype specializable (type)
  27   #+sb-xc-host (declare (ignore type))
  28   #+sb-xc-host t
  29   #-sb-xc-host type)
  30 (deftype specializable-vector (element-type)
  31   `(array (specializable ,element-type) 1))
  32
  33 ;;; MAKE-SPECIALIZABLE-ARRAY is MAKE-ARRAY, except that in the interests of
  34 ;;; being able to dump the result without worrying about nonportable
  35 ;;; dependences on what kinds of specialized vectors actually exist in the
  36 ;;; cross-compilation host, any :ELEMENT-TYPE argument is discarded when
  37 ;;; running under the cross-compilation host ANSI Common Lisp.
  38 #+sb-xc-host
  39 (defun make-specializable-array (dimensions
  40                                  &rest rest
  41                                  &key (element-type t)
  42                                  &allow-other-keys)
  43   (apply #'make-array
  44          dimensions
  45          (if (eq element-type t)
  46            rest
  47            (do ((reversed-modified-rest nil))
  48                ((null rest) (nreverse reversed-modified-rest))
  49              (let ((first (pop rest))
  50                    (second (pop rest)))
  51                (when (eq first :element-type)
  52                  (setf second t))
  53                (push first reversed-modified-rest)
  54                (push second reversed-modified-rest))))))
  55 #-sb-xc-host
  56 (declaim #!-sb-fluid (inline make-specializable-array))
  57 #-sb-xc-host
  58 (defun make-specializable-array (&rest rest) (apply #'make-array rest))