diff --git a/compiler/old-rt/dump.lisp b/compiler/old-rt/dump.lisp index ccced97cee02255172a19f5452e7b751bf1e2074..d71a49a12077a85d1202276d75aeb4a5ff8d354a 100644 --- a/compiler/old-rt/dump.lisp +++ b/compiler/old-rt/dump.lisp @@ -569,7 +569,7 @@ (dump-string x file) (equal-save-object x file))) ((subtypep (array-element-type x) - '(unsigned-byte 16)) + '(unsigned-byte 32)) (dump-i-vector x file) (eq-save-object x file)) (t @@ -989,46 +989,71 @@ (dump-fop 'lisp::fop-array file) (quick-dump-number rank 4 file))) -;;; Dump-I-Vector -- Internal + +;;; DUMP-I-VECTOR -- Internal +;;; +;;; *** NOT *** the FOP-INT-VECTOR as currently documented in rtguts. Size +;;; must be a directly supported I-vector element size, with no extra bits. ;;; -;;; Dump an I-Vector using the Guy Steele memorial fasl-operation. +;;; If a byte vector, or if the native and target byte orderings are the same, +;;; then just write the bits. Otherwise, dispatch off of the target byte order +;;; and write the vector one element at a time. ;;; (defun dump-i-vector (vec file) - (let* ((len (length vec)) - (ac (%primitive get-vector-access-code - (if #-new-compiler (%primitive complex-array-p vec) - #+new-compiler (array-header-p vec) - (%primitive header-ref vec %array-data-slot) - vec))) + (let* ((vec (if #+new-compiler (array-header-p vec) + #-new-compiler (%primitive complex-array-p vec) + (coerce vec 'simple-array) + vec)) + (ac (%primitive get-vector-access-code vec)) + (len (length vec)) (size (ash 1 ac)) - (count (ceiling size 8)) - (ints-per-entry (floor (* count 8) size))) - (declare (fixnum len ac size count ints-per-entry)) + (bytes (ash (+ (ash len ac) 7) -3))) + (dump-fop 'lisp::fop-int-vector file) (quick-dump-number len 4 file) (dump-byte size file) - (dump-byte count file) - (if (> ints-per-entry 1) - (do ((prev 0 end) - (end ints-per-entry (the fixnum (+ end ints-per-entry)))) - ((>= end len) - (unless (= prev len) - (do ((pos (* (1- ints-per-entry) size) (- pos size)) - (idx prev (1+ idx)) - (res 0)) - ((= idx len) - (dump-byte res file)) - (setq res (dpb (aref vec idx) (byte size pos) res))))) - (declare (fixnum prev end)) - (do* ((idx prev (1+ idx)) - (res 0)) - ((= idx end) - (dump-byte res file)) - (declare (fixnum idx)) - (setq res (logior (ash res size) (aref vec idx))))) - (dotimes (i len) - (declare (fixnum i)) - (quick-dump-number (aref vec i) count file))))) + (cond ((or (eq target-byte-order native-byte-order) + (= size 8)) + (dotimes (i bytes) + (dump-byte (%primitive typed-vref 3 vec i) file))) + ((> size 8) + (ecase target-byte-order + (:little-endian + (dotimes (i len) + (let ((int (aref vec i))) + (quick-dump-number int (ash size -3) file)))) + (:big-endian + (dotimes (i len) + (let ((int (aref vec i))) + (do ((shift (- 8 size) (+ shift 8))) + ((plusp shift)) + (dump-byte (logand (ash int shift) #xFF) file))))))) + (t + (ecase target-byte-order + (:little-endian + (let ((shift 0) + (byte 0)) + (dotimes (i len) + (let ((int (aref vec i))) + (setq byte (logior byte (ash int shift))) + (incf shift size)) + (when (= shift 8) + (dump-byte byte file) + (setq shift 0 byte 0))) + (unless (zerop shift) (dump-byte byte file)))) + (:big-endian + (let* ((initial-shift (- 8 size)) + (shift initial-shift) + (byte 0)) + (dotimes (i len) + (let ((int (aref vec i))) + (setq byte (logior byte (ash int shift))) + (decf shift size)) + (when (minusp shift) + (dump-byte byte file) + (setq shift initial-shift byte 0))) + (unless (= shift initial-shift) (dump-byte byte file))))))))) + ;;; Dump a character.