From 4c86741fbb42b15472c3e4b615935159566427d9 Mon Sep 17 00:00:00 2001 From: Alastair Bridgewater Date: Sat, 27 Apr 2013 08:31:22 -0400 Subject: [PATCH] code/room: Improve type-format database initialization for simple vector types. * There has been a longstanding FIXME comment on a piece of code which contains a hand-maintained list of specialized vector types and the shift count for converting the length from elements to octets. * It turns out that all of this information, plus the type names that we currently do a song-and-dance with INTERN, SUBSEQ, and MISMATCH to obtain, plus information for the string types, is available from *SPECIALIZED-ARRAY-ELEMENT-TYPE-PROPERTIES*. And *S-A-E-T-P* is guaranteed to be up-to-date, as it's too central to our implementation of UPGRADED-ARRAY-ELEMENT-TYPE and MAKE-ARRAY for it to be allowed to break. * So, replace nasty KLUDGE of an initialization for simple vector types with something more principled, making it explicit which properties need to be derived and which are simply already available, and picking off the one specialized array type that needs to be handled differently (SIMPLE-ARRAY-NIL). --- src/code/room.lisp | 57 ++++++++++------------------------------------------ 1 file changed, 11 insertions(+), 46 deletions(-) diff --git a/src/code/room.lisp b/src/code/room.lisp index 8331d71..12f2124 100644 --- a/src/code/room.lisp +++ b/src/code/room.lisp @@ -69,52 +69,17 @@ (make-room-info :name 'closure :kind :closure)) -;; FIXME: This looks rather brittle. Can we get more of these numbers -;; from somewhere sensible? -(dolist (stuff '((simple-bit-vector-widetag . -3) - (simple-vector-widetag . #.sb!vm:word-shift) - (simple-array-unsigned-byte-2-widetag . -2) - (simple-array-unsigned-byte-4-widetag . -1) - (simple-array-unsigned-byte-7-widetag . 0) - (simple-array-unsigned-byte-8-widetag . 0) - (simple-array-unsigned-byte-15-widetag . 1) - (simple-array-unsigned-byte-16-widetag . 1) - (simple-array-unsigned-byte-31-widetag . 2) - (simple-array-unsigned-byte-32-widetag . 2) - (simple-array-unsigned-fixnum-widetag . #.sb!vm:word-shift) - (simple-array-unsigned-byte-63-widetag . 3) - (simple-array-unsigned-byte-64-widetag . 3) - (simple-array-signed-byte-8-widetag . 0) - (simple-array-signed-byte-16-widetag . 1) - (simple-array-fixnum-widetag . #.sb!vm:word-shift) - (simple-array-signed-byte-32-widetag . 2) - (simple-array-signed-byte-64-widetag . 3) - (simple-array-single-float-widetag . 2) - (simple-array-double-float-widetag . 3) - (simple-array-complex-single-float-widetag . 3) - (simple-array-complex-double-float-widetag . 4))) - (let* ((name (car stuff)) - (size (cdr stuff)) - (sname (string name))) - (when (boundp name) - (setf (svref *meta-room-info* (symbol-value name)) - (make-room-info :name (intern (subseq sname - 0 - (mismatch sname "-WIDETAG" - :from-end t))) - :kind :vector - :length size))))) - -(setf (svref *meta-room-info* simple-base-string-widetag) - (make-room-info :name 'simple-base-string - :kind :string - :length 0)) - -#!+sb-unicode -(setf (svref *meta-room-info* simple-character-string-widetag) - (make-room-info :name 'simple-character-string - :kind :string - :length 2)) +(dotimes (i (length *specialized-array-element-type-properties*)) + (let* ((saetp (aref *specialized-array-element-type-properties* i)) + (array-kind (if (characterp (saetp-initial-element-default saetp)) + :string + :vector)) + (element-shift (- (integer-length (saetp-n-bits saetp)) 4))) + (when (saetp-specifier saetp) ;; SIMPLE-ARRAY-NIL is a special case. + (setf (svref *meta-room-info* (saetp-typecode saetp)) + (make-room-info :name (saetp-primitive-type-name saetp) + :kind array-kind + :length element-shift))))) (setf (svref *meta-room-info* simple-array-nil-widetag) (make-room-info :name 'simple-array-nil -- 1.7.10.4