From cd1f265dd851941557ed3f764248c339c07493a9 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Wed, 25 Jun 2003 08:28:23 +0000 Subject: [PATCH] 0.8.0.78.vector-nil-string.8: Some more OAOOification from *SAETP* ... add a COMPLEX-TYPECODE field to *SAETP* to allow us to carry the information that SIMPLE-BIT-VECTOR and COMPLEX-BIT-VECTOR are both bit vectors. ... use *SAETP* in %VECTOR-WIDETAG-AND-N-BITS, ARRAY-ELEMENT-TYPE and SHRINK-VECTOR (net win so far: 6) ... we might need a FIXNUM type earlier than CLASS. I've got one in, but then I found a refactor that might mean we don't need it. The problem is in SPECIALIZE-ARRAY-TYPE, where obviously we need to have complete knowledge about all the possible upgraded-array-element-types so that we can ask whether a given type is SUBTYPEP. FIXNUM is defined as a type fairly late, but maybe defining it before (simple-array (signed-byte 30) (*)) is enough, when combined with... Refactor PRIMITIVE-TYPEs ... we only ever use the specifier, not the ctype, of PRIMITIVE-TYPE-TYPE, so... ... delete the TYPE field and add a SPECIFIER field. ... add AVERrance in SPECIALIZE-ARRAY-TYPE. --- package-data-list.lisp-expr | 1 + src/code/array.lisp | 137 ++++------------ src/code/class.lisp | 308 ++++++++++++++++++------------------ src/code/deftypes-for-target.lisp | 5 + src/code/seq.lisp | 2 - src/compiler/fixup-type.lisp | 16 -- src/compiler/generic/vm-array.lisp | 14 +- src/compiler/generic/vm-type.lisp | 1 + src/compiler/meta-vmdef.lisp | 12 +- src/compiler/vmdef.lisp | 5 +- src/compiler/vop.lisp | 2 +- version.lisp-expr | 2 +- 12 files changed, 215 insertions(+), 290 deletions(-) diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 96d96ef..53aece2 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -2012,6 +2012,7 @@ structure representations" "SAETP-CTYPE" "SAETP-INITIAL-ELEMENT-DEFAULT" "SAETP-N-BITS" "SAETP-TYPECODE" "SAETP-PRIMTYPE" "SAETP-N-PAD-ELEMENTS" "SAETP-SPECIFIER" + "SAETP-COMPLEX-TYPECODE" "*SPECIALIZED-ARRAY-ELEMENT-TYPE-PROPERTIES*" "SANCTIFY-FOR-EXECUTION" "SAP-POINTER-SLOT" "SAP-REG-SC-NUMBER" "SAP-SIZE" diff --git a/src/code/array.lisp b/src/code/array.lisp index e951999..4f0052b 100644 --- a/src/code/array.lisp +++ b/src/code/array.lisp @@ -106,46 +106,14 @@ (values #.sb!vm:simple-bit-vector-widetag 1)) ;; OK, we have to wade into SUBTYPEPing after all. (t - ;; FIXME: The data here are redundant with - ;; *SPECIALIZED-ARRAY-ELEMENT-TYPE-PROPERTIES*. - (pick-vector-type type - (nil (values #.sb!vm:simple-array-nil-widetag 0)) - (base-char (values #.sb!vm:simple-base-string-widetag #.sb!vm:n-byte-bits)) - (bit (values #.sb!vm:simple-bit-vector-widetag 1)) - ((unsigned-byte 2) - (values #.sb!vm:simple-array-unsigned-byte-2-widetag 2)) - ((unsigned-byte 4) - (values #.sb!vm:simple-array-unsigned-byte-4-widetag 4)) - ((unsigned-byte 8) - (values #.sb!vm:simple-array-unsigned-byte-8-widetag 8)) - ((unsigned-byte 16) - (values #.sb!vm:simple-array-unsigned-byte-16-widetag 16)) - ((unsigned-byte 32) - (values #.sb!vm:simple-array-unsigned-byte-32-widetag 32)) - ((signed-byte 8) - (values #.sb!vm:simple-array-signed-byte-8-widetag 8)) - ((signed-byte 16) - (values #.sb!vm:simple-array-signed-byte-16-widetag 16)) - ((signed-byte 30) - (values #.sb!vm:simple-array-signed-byte-30-widetag 32)) - ((signed-byte 32) - (values #.sb!vm:simple-array-signed-byte-32-widetag 32)) - (single-float (values #.sb!vm:simple-array-single-float-widetag 32)) - (double-float (values #.sb!vm:simple-array-double-float-widetag 64)) - #!+long-float - (long-float - (values #.sb!vm:simple-array-long-float-widetag - #!+x86 96 #!+sparc 128)) - ((complex single-float) - (values #.sb!vm:simple-array-complex-single-float-widetag 64)) - ((complex double-float) - (values #.sb!vm:simple-array-complex-double-float-widetag 128)) - #!+long-float - ((complex long-float) - (values #.sb!vm:simple-array-complex-long-float-widetag - #!+x86 192 - #!+sparc 256)) - (t (values #.sb!vm:simple-vector-widetag #.sb!vm:n-word-bits)))))) + #.`(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*))))) + (defun %complex-vector-widetag (type) (case type ;; Pick off some easy common cases. @@ -559,41 +527,23 @@ `(= widetag ,item)))) (cdr stuff))) stuff)))) - ;; FIXME: The data here are redundant with - ;; *SPECIALIZED-ARRAY-ELEMENT-TYPE-PROPERTIES*. - (pick-element-type - ((sb!vm:simple-array-nil-widetag sb!vm:complex-vector-nil-widetag) nil) - ((sb!vm:simple-base-string-widetag sb!vm:complex-base-string-widetag) 'base-char) - ((sb!vm:simple-bit-vector-widetag - sb!vm:complex-bit-vector-widetag) 'bit) - (sb!vm:simple-vector-widetag t) - (sb!vm:simple-array-unsigned-byte-2-widetag '(unsigned-byte 2)) - (sb!vm:simple-array-unsigned-byte-4-widetag '(unsigned-byte 4)) - (sb!vm:simple-array-unsigned-byte-8-widetag '(unsigned-byte 8)) - (sb!vm:simple-array-unsigned-byte-16-widetag '(unsigned-byte 16)) - (sb!vm:simple-array-unsigned-byte-32-widetag '(unsigned-byte 32)) - (sb!vm:simple-array-signed-byte-8-widetag '(signed-byte 8)) - (sb!vm:simple-array-signed-byte-16-widetag '(signed-byte 16)) - (sb!vm:simple-array-signed-byte-30-widetag '(signed-byte 30)) - (sb!vm:simple-array-signed-byte-32-widetag '(signed-byte 32)) - (sb!vm:simple-array-single-float-widetag 'single-float) - (sb!vm:simple-array-double-float-widetag 'double-float) - #!+long-float - (sb!vm:simple-array-long-float-widetag 'long-float) - (sb!vm:simple-array-complex-single-float-widetag - '(complex single-float)) - (sb!vm:simple-array-complex-double-float-widetag - '(complex double-float)) - #!+long-float - (sb!vm:simple-array-complex-long-float-widetag '(complex long-float)) - ((sb!vm:simple-array-widetag - sb!vm:complex-vector-widetag - sb!vm:complex-array-widetag) - (with-array-data ((array array) (start) (end)) - (declare (ignore start end)) - (array-element-type array))) - (t - (error 'type-error :datum array :expected-type 'array)))))) + #.`(pick-element-type + ,@(map 'list + (lambda (saetp) + `(,(if (sb!vm:saetp-complex-typecode saetp) + (list (sb!vm:saetp-typecode saetp) + (sb!vm:saetp-complex-typecode saetp)) + (sb!vm:saetp-typecode saetp)) + ',(sb!vm:saetp-specifier saetp))) + sb!vm:*specialized-array-element-type-properties*) + ((sb!vm:simple-array-widetag + sb!vm:complex-vector-widetag + sb!vm:complex-array-widetag) + (with-array-data ((array array) (start) (end)) + (declare (ignore start end)) + (array-element-type array))) + (t + (error 'type-error :datum array :expected-type 'array)))))) (defun array-rank (array) #!+sb-doc @@ -890,33 +840,16 @@ ,fill-value :start new-length)))) things)))) - ;; FIXME: The associations between vector types and initial - ;; values here are redundant with - ;; *SPECIALIZED-ARRAY-ELEMENT-TYPE-PROPERTIES*. - (frob vector - (simple-vector 0) - (simple-base-string #.*default-init-char-form*) - (simple-bit-vector 0) - ((simple-array (unsigned-byte 2) (*)) 0) - ((simple-array (unsigned-byte 4) (*)) 0) - ((simple-array (unsigned-byte 8) (*)) 0) - ((simple-array (unsigned-byte 16) (*)) 0) - ((simple-array (unsigned-byte 32) (*)) 0) - ((simple-array (signed-byte 8) (*)) 0) - ((simple-array (signed-byte 16) (*)) 0) - ((simple-array (signed-byte 30) (*)) 0) - ((simple-array (signed-byte 32) (*)) 0) - ((simple-array single-float (*)) (coerce 0 'single-float)) - ((simple-array double-float (*)) (coerce 0 'double-float)) - #!+long-float - ((simple-array long-float (*)) (coerce 0 'long-float)) - ((simple-array (complex single-float) (*)) - (coerce 0 '(complex single-float))) - ((simple-array (complex double-float) (*)) - (coerce 0 '(complex double-float))) - #!+long-float - ((simple-array (complex long-float) (*)) - (coerce 0 '(complex long-float)))))) + #.`(frob vector + ,@(map 'list + (lambda (saetp) + `((simple-array ,(sb!vm:saetp-specifier saetp) (*)) + ,(if (eq (sb!vm:saetp-specifier saetp) 'base-char) + *default-init-char-form* + (sb!vm:saetp-initial-element-default saetp)))) + (remove-if-not + #'sb!vm:saetp-specifier + sb!vm:*specialized-array-element-type-properties*))))) ;; Only arrays have fill-pointers, but vectors have their length ;; parameter in the same place. (setf (%array-fill-pointer vector) new-length) diff --git a/src/code/class.lisp b/src/code/class.lisp index bea6e90..4b2f936 100644 --- a/src/code/class.lisp +++ b/src/code/class.lisp @@ -956,6 +956,61 @@ :inherits (function) :state :read-only) + (number :translation number) + (complex + :translation complex + :inherits (number) + :codes (#.sb!vm:complex-widetag)) + (complex-single-float + :translation (complex single-float) + :inherits (complex number) + :codes (#.sb!vm:complex-single-float-widetag)) + (complex-double-float + :translation (complex double-float) + :inherits (complex number) + :codes (#.sb!vm:complex-double-float-widetag)) + #!+long-float + (complex-long-float + :translation (complex long-float) + :inherits (complex number) + :codes (#.sb!vm:complex-long-float-widetag)) + (real :translation real :inherits (number)) + (float + :translation float + :inherits (real number)) + (single-float + :translation single-float + :inherits (float real number) + :codes (#.sb!vm:single-float-widetag)) + (double-float + :translation double-float + :inherits (float real number) + :codes (#.sb!vm:double-float-widetag)) + #!+long-float + (long-float + :translation long-float + :inherits (float real number) + :codes (#.sb!vm:long-float-widetag)) + (rational + :translation rational + :inherits (real number)) + (ratio + :translation (and rational (not integer)) + :inherits (rational real number) + :codes (#.sb!vm:ratio-widetag)) + (integer + :translation integer + :inherits (rational real number)) + (fixnum + :translation (integer #.sb!xc:most-negative-fixnum + #.sb!xc:most-positive-fixnum) + :inherits (integer rational real number) + :codes (#.sb!vm:even-fixnum-lowtag #.sb!vm:odd-fixnum-lowtag)) + (bignum + :translation (and integer (not fixnum)) + :inherits (integer rational real number) + :codes (#.sb!vm:bignum-widetag)) + (array :translation array :codes (#.sb!vm:complex-array-widetag) :hierarchical-p nil) (simple-array @@ -995,166 +1050,113 @@ :direct-superclasses (vector simple-array) :inherits (vector simple-array array sequence)) (simple-array-unsigned-byte-16 - :translation (simple-array (unsigned-byte 16) (*)) - :codes (#.sb!vm:simple-array-unsigned-byte-16-widetag) - :direct-superclasses (vector simple-array) - :inherits (vector simple-array array sequence)) + :translation (simple-array (unsigned-byte 16) (*)) + :codes (#.sb!vm:simple-array-unsigned-byte-16-widetag) + :direct-superclasses (vector simple-array) + :inherits (vector simple-array array sequence)) (simple-array-unsigned-byte-32 - :translation (simple-array (unsigned-byte 32) (*)) - :codes (#.sb!vm:simple-array-unsigned-byte-32-widetag) - :direct-superclasses (vector simple-array) - :inherits (vector simple-array array sequence)) + :translation (simple-array (unsigned-byte 32) (*)) + :codes (#.sb!vm:simple-array-unsigned-byte-32-widetag) + :direct-superclasses (vector simple-array) + :inherits (vector simple-array array sequence)) (simple-array-signed-byte-8 - :translation (simple-array (signed-byte 8) (*)) - :codes (#.sb!vm:simple-array-signed-byte-8-widetag) - :direct-superclasses (vector simple-array) - :inherits (vector simple-array array sequence)) + :translation (simple-array (signed-byte 8) (*)) + :codes (#.sb!vm:simple-array-signed-byte-8-widetag) + :direct-superclasses (vector simple-array) + :inherits (vector simple-array array sequence)) (simple-array-signed-byte-16 - :translation (simple-array (signed-byte 16) (*)) - :codes (#.sb!vm:simple-array-signed-byte-16-widetag) - :direct-superclasses (vector simple-array) - :inherits (vector simple-array array sequence)) + :translation (simple-array (signed-byte 16) (*)) + :codes (#.sb!vm:simple-array-signed-byte-16-widetag) + :direct-superclasses (vector simple-array) + :inherits (vector simple-array array sequence)) (simple-array-signed-byte-30 - :translation (simple-array (signed-byte 30) (*)) - :codes (#.sb!vm:simple-array-signed-byte-30-widetag) - :direct-superclasses (vector simple-array) - :inherits (vector simple-array array sequence)) + :translation (simple-array (signed-byte 30) (*)) + :codes (#.sb!vm:simple-array-signed-byte-30-widetag) + :direct-superclasses (vector simple-array) + :inherits (vector simple-array array sequence)) (simple-array-signed-byte-32 - :translation (simple-array (signed-byte 32) (*)) - :codes (#.sb!vm:simple-array-signed-byte-32-widetag) - :direct-superclasses (vector simple-array) - :inherits (vector simple-array array sequence)) + :translation (simple-array (signed-byte 32) (*)) + :codes (#.sb!vm:simple-array-signed-byte-32-widetag) + :direct-superclasses (vector simple-array) + :inherits (vector simple-array array sequence)) (simple-array-single-float - :translation (simple-array single-float (*)) - :codes (#.sb!vm:simple-array-single-float-widetag) - :direct-superclasses (vector simple-array) - :inherits (vector simple-array array sequence)) + :translation (simple-array single-float (*)) + :codes (#.sb!vm:simple-array-single-float-widetag) + :direct-superclasses (vector simple-array) + :inherits (vector simple-array array sequence)) (simple-array-double-float - :translation (simple-array double-float (*)) - :codes (#.sb!vm:simple-array-double-float-widetag) - :direct-superclasses (vector simple-array) - :inherits (vector simple-array array sequence)) - #!+long-float - (simple-array-long-float - :translation (simple-array long-float (*)) - :codes (#.sb!vm:simple-array-long-float-widetag) - :direct-superclasses (vector simple-array) - :inherits (vector simple-array array sequence)) - (simple-array-complex-single-float - :translation (simple-array (complex single-float) (*)) - :codes (#.sb!vm:simple-array-complex-single-float-widetag) - :direct-superclasses (vector simple-array) - :inherits (vector simple-array array sequence)) - (simple-array-complex-double-float - :translation (simple-array (complex double-float) (*)) - :codes (#.sb!vm:simple-array-complex-double-float-widetag) - :direct-superclasses (vector simple-array) - :inherits (vector simple-array array sequence)) - #!+long-float - (simple-array-complex-long-float - :translation (simple-array (complex long-float) (*)) - :codes (#.sb!vm:simple-array-complex-long-float-widetag) - :direct-superclasses (vector simple-array) - :inherits (vector simple-array array sequence)) - (string - :translation string - :direct-superclasses (vector) - :inherits (vector array sequence)) - (simple-string - :translation simple-string - :direct-superclasses (string simple-array) - :inherits (string vector simple-array array sequence)) - (vector-nil - ;; FIXME: Should this be (AND (VECTOR NIL) (NOT (SIMPLE-ARRAY NIL (*))))? - :translation (vector nil) - :codes (#.sb!vm:complex-vector-nil-widetag) - :direct-superclasses (string) - :inherits (string vector array sequence)) - (simple-array-nil - :translation (simple-array nil (*)) - :codes (#.sb!vm:simple-array-nil-widetag) - :direct-superclasses (vector-nil simple-string) - :inherits (vector-nil simple-string string vector simple-array array sequence)) - (base-string - :translation base-string - :codes (#.sb!vm:complex-base-string-widetag) - :direct-superclasses (string) - :inherits (string vector array sequence)) - (simple-base-string - :translation simple-base-string - :codes (#.sb!vm:simple-base-string-widetag) - :direct-superclasses (base-string simple-string) - :inherits (base-string simple-string string vector simple-array - array sequence)) - (list - :translation (or cons (member nil)) - :inherits (sequence)) - (cons - :codes (#.sb!vm:list-pointer-lowtag) - :translation cons - :inherits (list sequence)) - (null - :translation (member nil) - :inherits (symbol list sequence) - :direct-superclasses (symbol list)) - (number :translation number) - (complex - :translation complex - :inherits (number) - :codes (#.sb!vm:complex-widetag)) - (complex-single-float - :translation (complex single-float) - :inherits (complex number) - :codes (#.sb!vm:complex-single-float-widetag)) - (complex-double-float - :translation (complex double-float) - :inherits (complex number) - :codes (#.sb!vm:complex-double-float-widetag)) - #!+long-float - (complex-long-float - :translation (complex long-float) - :inherits (complex number) - :codes (#.sb!vm:complex-long-float-widetag)) - (real :translation real :inherits (number)) - (float - :translation float - :inherits (real number)) - (single-float - :translation single-float - :inherits (float real number) - :codes (#.sb!vm:single-float-widetag)) - (double-float - :translation double-float - :inherits (float real number) - :codes (#.sb!vm:double-float-widetag)) - #!+long-float - (long-float - :translation long-float - :inherits (float real number) - :codes (#.sb!vm:long-float-widetag)) - (rational - :translation rational - :inherits (real number)) - (ratio - :translation (and rational (not integer)) - :inherits (rational real number) - :codes (#.sb!vm:ratio-widetag)) - (integer - :translation integer - :inherits (rational real number)) - (fixnum - :translation (integer #.sb!xc:most-negative-fixnum - #.sb!xc:most-positive-fixnum) - :inherits (integer rational real number) - :codes (#.sb!vm:even-fixnum-lowtag #.sb!vm:odd-fixnum-lowtag)) - (bignum - :translation (and integer (not fixnum)) - :inherits (integer rational real number) - :codes (#.sb!vm:bignum-widetag)) - (stream - :state :read-only - :depth 3 - :inherits (instance))))) + :translation (simple-array double-float (*)) + :codes (#.sb!vm:simple-array-double-float-widetag) + :direct-superclasses (vector simple-array) + :inherits (vector simple-array array sequence)) + #!+long-float + (simple-array-long-float + :translation (simple-array long-float (*)) + :codes (#.sb!vm:simple-array-long-float-widetag) + :direct-superclasses (vector simple-array) + :inherits (vector simple-array array sequence)) + (simple-array-complex-single-float + :translation (simple-array (complex single-float) (*)) + :codes (#.sb!vm:simple-array-complex-single-float-widetag) + :direct-superclasses (vector simple-array) + :inherits (vector simple-array array sequence)) + (simple-array-complex-double-float + :translation (simple-array (complex double-float) (*)) + :codes (#.sb!vm:simple-array-complex-double-float-widetag) + :direct-superclasses (vector simple-array) + :inherits (vector simple-array array sequence)) + #!+long-float + (simple-array-complex-long-float + :translation (simple-array (complex long-float) (*)) + :codes (#.sb!vm:simple-array-complex-long-float-widetag) + :direct-superclasses (vector simple-array) + :inherits (vector simple-array array sequence)) + (string + :translation string + :direct-superclasses (vector) + :inherits (vector array sequence)) + (simple-string + :translation simple-string + :direct-superclasses (string simple-array) + :inherits (string vector simple-array array sequence)) + (vector-nil + ;; FIXME: Should this be (AND (VECTOR NIL) (NOT (SIMPLE-ARRAY NIL (*))))? + :translation (vector nil) + :codes (#.sb!vm:complex-vector-nil-widetag) + :direct-superclasses (string) + :inherits (string vector array sequence)) + (simple-array-nil + :translation (simple-array nil (*)) + :codes (#.sb!vm:simple-array-nil-widetag) + :direct-superclasses (vector-nil simple-string) + :inherits (vector-nil simple-string string vector simple-array array sequence)) + (base-string + :translation base-string + :codes (#.sb!vm:complex-base-string-widetag) + :direct-superclasses (string) + :inherits (string vector array sequence)) + (simple-base-string + :translation simple-base-string + :codes (#.sb!vm:simple-base-string-widetag) + :direct-superclasses (base-string simple-string) + :inherits (base-string simple-string string vector simple-array + array sequence)) + (list + :translation (or cons (member nil)) + :inherits (sequence)) + (cons + :codes (#.sb!vm:list-pointer-lowtag) + :translation cons + :inherits (list sequence)) + (null + :translation (member nil) + :inherits (symbol list sequence) + :direct-superclasses (symbol list)) + + (stream + :state :read-only + :depth 3 + :inherits (instance))))) ;;; comment from CMU CL: ;;; See also type-init.lisp where we finish setting up the diff --git a/src/code/deftypes-for-target.lisp b/src/code/deftypes-for-target.lisp index cea2e9b..ab58e4e 100644 --- a/src/code/deftypes-for-target.lisp +++ b/src/code/deftypes-for-target.lisp @@ -24,6 +24,11 @@ ;;;; standard types +;;; also has a definition in src/code/class.lisp, but we need it +;;; earlier for array specialization. +(sb!xc:deftype fixnum () + '(integer #.sb!xc:most-negative-fixnum #.sb!xc:most-positive-fixnum)) + (sb!xc:deftype boolean () '(member t nil)) (sb!xc:deftype mod (n) diff --git a/src/code/seq.lisp b/src/code/seq.lisp index 58084a7..bab805f 100644 --- a/src/code/seq.lisp +++ b/src/code/seq.lisp @@ -711,8 +711,6 @@ "Return a new sequence of all the argument sequences concatenated together which shares no structure with the original argument sequences of the specified OUTPUT-TYPE-SPEC." - (/show0 "full call to CONCATENATE, OUTPUT-TYPE-SPEC=..") - (/hexstr output-type-spec) (let ((type (specifier-type output-type-spec))) (cond ((csubtypep type (specifier-type 'list)) diff --git a/src/compiler/fixup-type.lisp b/src/compiler/fixup-type.lisp index 0c101f4..ca3406c 100644 --- a/src/compiler/fixup-type.lisp +++ b/src/compiler/fixup-type.lisp @@ -9,20 +9,4 @@ (specifier-type (sb!vm:saetp-specifier saetp)))) sb!vm:*specialized-array-element-type-properties*)) -(!cold-init-forms - (maphash - (lambda (key value) - (declare (ignore key)) - (setf (primitive-type-type value) - (specifier-type (type-specifier (primitive-type-type value))))) - *backend-meta-primitive-type-names*)) - -(!cold-init-forms - (maphash - (lambda (key value) - (declare (ignore key)) - (setf (primitive-type-type value) - (specifier-type (type-specifier (primitive-type-type value))))) - *backend-primitive-type-names*)) - (!defun-from-collected-cold-init-forms !fixup-type-cold-init) \ No newline at end of file diff --git a/src/compiler/generic/vm-array.lisp b/src/compiler/generic/vm-array.lisp index 75e016f..728a337 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) + &key (n-pad-elements 0) complex-typecode &aux (typecode (eval (symbolicate primitive-type-name "-WIDETAG"))))) (:copier nil)) @@ -38,6 +38,9 @@ (n-bits (missing-arg) :type index :read-only t) ;; the low-level type code (aka "widetag") (typecode (missing-arg) :type index :read-only t) + ;; if an integer, a typecode corresponding to a complex vector + ;; specialized on this element type. + (complex-typecode nil :type (or index null) :read-only t) ;; the name of the primitive type of data vectors specialized on ;; this type (primitive-type-name (missing-arg) :type symbol :read-only t) @@ -53,17 +56,20 @@ (apply #'!make-saetp args)) `(;; Erm. Yeah. There aren't a lot of things that make sense ;; for an initial element for (ARRAY NIL). -- CSR, 2002-03-07 - (nil #:mu 0 simple-array-nil) + (nil #:mu 0 simple-array-nil + :complex-typecode #.sb!vm:complex-vector-nil-widetag) (base-char ,(code-char 0) 8 simple-base-string ;; (SIMPLE-BASE-STRINGs are stored with an extra ;; trailing #\NULL for convenience in calling out ;; to C.) - :n-pad-elements 1) + :n-pad-elements 1 + :complex-typecode #.sb!vm:complex-base-string-widetag) (single-float 0.0f0 32 simple-array-single-float) (double-float 0.0d0 64 simple-array-double-float) #!+long-float (long-float 0.0l0 #!+x86 96 #!+sparc 128 simple-array-long-float) - (bit 0 1 simple-bit-vector) + (bit 0 1 simple-bit-vector + :complex-typecode #.sb!vm:complex-bit-vector-widetag) ;; KLUDGE: The fact that these UNSIGNED-BYTE entries come ;; before their SIGNED-BYTE partners is significant in the ;; implementation of the compiler; some of the cross-compiler diff --git a/src/compiler/generic/vm-type.lisp b/src/compiler/generic/vm-type.lisp index 3bec6e1..cde035f 100644 --- a/src/compiler/generic/vm-type.lisp +++ b/src/compiler/generic/vm-type.lisp @@ -119,6 +119,7 @@ ;; them on the fly this way? (Call the new array ;; *SPECIALIZED-ARRAY-ELEMENT-SPECIFIER-TYPES* or something..) (let ((stype (specifier-type stype-name))) + (aver (not (unknown-type-p stype))) (when (csubtypep eltype stype) (return stype)))))) type)) diff --git a/src/compiler/meta-vmdef.lisp b/src/compiler/meta-vmdef.lisp index b44b9ab..a3fcba1 100644 --- a/src/compiler/meta-vmdef.lisp +++ b/src/compiler/meta-vmdef.lisp @@ -275,8 +275,7 @@ ;;; type descriptor for the Lisp type that is equivalent to this type. (defmacro !def-primitive-type (name scs &key (type name)) (declare (type symbol name) (type list scs)) - (let ((scns (mapcar #'meta-sc-number-or-lose scs)) - (ctype-form `(specifier-type ',type))) + (let ((scns (mapcar #'meta-sc-number-or-lose scs))) `(progn (/show0 "doing !DEF-PRIMITIVE-TYPE, NAME=..") (/primitive-print ,(symbol-name name)) @@ -284,9 +283,8 @@ (setf (gethash ',name *backend-meta-primitive-type-names*) (make-primitive-type :name ',name :scs ',scns - :type ,ctype-form))) - ,(once-only ((n-old `(gethash ',name *backend-primitive-type-names*)) - (n-type ctype-form)) + :specifier ',type))) + ,(once-only ((n-old `(gethash ',name *backend-primitive-type-names*))) `(progn ;; If the PRIMITIVE-TYPE structure already exists, we ;; destructively modify it so that existing references in @@ -300,13 +298,13 @@ (cond (,n-old (/show0 "in ,N-OLD clause of COND") (setf (primitive-type-scs ,n-old) ',scns) - (setf (primitive-type-type ,n-old) ,n-type)) + (setf (primitive-type-specifier ,n-old) ',type)) (t (/show0 "in T clause of COND") (setf (gethash ',name *backend-primitive-type-names*) (make-primitive-type :name ',name :scs ',scns - :type ,n-type)))) + :specifier ',type)))) (/show0 "done with !DEF-PRIMITIVE-TYPE") ',name))))) diff --git a/src/compiler/vmdef.lisp b/src/compiler/vmdef.lisp index 0c4fd38..3b6fb42 100644 --- a/src/compiler/vmdef.lisp +++ b/src/compiler/vmdef.lisp @@ -208,10 +208,7 @@ (if (eq x '*) t (ecase (first x) - (:or `(or ,@(mapcar (lambda (type) - (type-specifier - (primitive-type-type - type))) + (:or `(or ,@(mapcar #'primitive-type-specifier (rest x)))) (:constant `(constant-arg ,(third x))))))) `(,@(mapcar #'frob types) diff --git a/src/compiler/vop.lisp b/src/compiler/vop.lisp index 874c362..159900f 100644 --- a/src/compiler/vop.lisp +++ b/src/compiler/vop.lisp @@ -47,7 +47,7 @@ (scs nil :type list) ;; the Lisp type equivalent to this type. If this type could never be ;; returned by PRIMITIVE-TYPE, then this is the NIL (or empty) type - (type (missing-arg) :type ctype) + (specifier (missing-arg) :type type-specifier) ;; the template used to check that an object is of this type. This is a ;; template of one argument and one result, both of primitive-type T. If ;; the argument is of the correct type, then it is delivered into the diff --git a/version.lisp-expr b/version.lisp-expr index 7823fa0..96b3b50 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.8.0.78.vector-nil-string.7" +"0.8.0.78.vector-nil-string.8" -- 1.7.10.4