From d57319a52914c481d89415c0860dc6b7ad90ddce Mon Sep 17 00:00:00 2001 From: Nathan Froyd Date: Wed, 8 Sep 2004 18:17:36 +0000 Subject: [PATCH] 0.8.14.3: FASL changes for 64-bit compatibility * read and write appropriate fop args as word-sized chunks rather than 32-bit-sized chunks * fixes for 32-bit assumptions in array sizes and elsewhere * a few cleanups along the same lines Passes all tests and appears to not break FASL compatibility. --- src/code/fop.lisp | 126 ++++++++++++++++++++----------------- src/code/load.lisp | 28 ++++++--- src/compiler/dump.lisp | 93 ++++++++++++++++----------- src/compiler/generic/genesis.lisp | 70 ++++++++++----------- src/compiler/target-dump.lisp | 38 ++++++----- version.lisp-expr | 2 +- 6 files changed, 201 insertions(+), 156 deletions(-) diff --git a/src/code/fop.lisp b/src/code/fop.lisp index 37e79ce..74b5984 100644 --- a/src/code/fop.lisp +++ b/src/code/fop.lisp @@ -49,8 +49,8 @@ ;;; (dump-integer-as-n-bytes total-length 2 file)) ;;; (t ;;; (dump-fop 'sb!impl::fop-code file) -;;; (dump-unsigned-32 num-consts file) -;;; (dump-unsigned-32 total-length file)))) +;;; (dump-word num-consts file) +;;; (dump-word total-length file)))) ;;; in several places. It would be cleaner if this could be replaced with ;;; something like ;;; (dump-fop file fop-code num-consts total-length) @@ -62,9 +62,9 @@ (aver (member pushp '(nil t))) (aver (member stackp '(nil t))) `(progn - (macrolet ((clone-arg () '(read-arg 4))) + (macrolet ((clone-arg () '(read-word-arg))) (define-fop (,name ,code :pushp ,pushp :stackp ,stackp) ,@forms)) - (macrolet ((clone-arg () '(read-arg 1))) + (macrolet ((clone-arg () '(read-byte-arg))) (define-fop (,small-name ,small-code :pushp ,pushp :stackp stackp) ,@forms)))) ;;; a helper function for reading string values from FASL files: sort @@ -81,7 +81,7 @@ ;; It was changed for SBCL because we needed a portable version for ;; bootstrapping. Benchmark the non-portable version and see whether it's ;; significantly better than the portable version here. If it is, then use - ;; add as an alternate definition, protected with #-SB-XC-HOST. + ;; it as an alternate definition, protected with #-SB-XC-HOST. (values)) ;;;; miscellaneous fops @@ -110,8 +110,8 @@ (define-fop (fop-nop 0 :stackp nil)) (define-fop (fop-pop 1 :pushp nil) (push-fop-table (pop-stack))) -(define-fop (fop-push 2) (svref *current-fop-table* (read-arg 4))) -(define-fop (fop-byte-push 3) (svref *current-fop-table* (read-arg 1))) +(define-fop (fop-push 2) (svref *current-fop-table* (read-word-arg))) +(define-fop (fop-byte-push 3) (svref *current-fop-table* (read-byte-arg))) (define-fop (fop-empty-list 4) ()) (define-fop (fop-truth 5) t) @@ -127,7 +127,7 @@ ;;; SBCL as we have no extended characters, only 1-byte characters. ;;; (Ditto for CMU CL, actually: FOP-CHARACTER was speculative generality.) (define-fop (fop-short-character 69) - (code-char (read-arg 1))) + (code-char (read-byte-arg))) (define-cloned-fops (fop-struct 48) (fop-small-struct 49) (let* ((size (clone-arg)) @@ -157,7 +157,7 @@ (define-fop (fop-maybe-cold-load 82 :stackp nil)) (define-fop (fop-verify-table-size 62 :stackp nil) - (let ((expected-index (read-arg 4))) + (let ((expected-index (read-word-arg))) (unless (= *current-fop-table-index* expected-index) (bug "fasl table of improper size")))) (define-fop (fop-verify-empty-stack 63 :stackp nil) @@ -209,9 +209,9 @@ ;;(frob fop-symbol-save 6 4 *package*) ;;(frob fop-small-symbol-save 7 1 *package*) - (frob fop-lisp-symbol-save 75 4 *cl-package*) + (frob fop-lisp-symbol-save 75 #.sb!vm:n-word-bytes *cl-package*) (frob fop-lisp-small-symbol-save 76 1 *cl-package*) - (frob fop-keyword-symbol-save 77 4 *keyword-package*) + (frob fop-keyword-symbol-save 77 #.sb!vm:n-word-bytes *keyword-package*) (frob fop-keyword-small-symbol-save 78 1 *keyword-package*) ;; FIXME: Because we don't have FOP-SYMBOL-SAVE any more, an enormous number @@ -219,11 +219,11 @@ ;; fasl files. A new ;; FOP-SYMBOL-IN-LAST-PACKAGE-SAVE/FOP-SMALL-SYMBOL-IN-LAST-PACKAGE-SAVE ;; cloned fop pair could undo some of this bloat. - (frob fop-symbol-in-package-save 8 4 - (svref *current-fop-table* (fast-read-u-integer 4))) + (frob fop-symbol-in-package-save 8 #.sb!vm:n-word-bytes + (svref *current-fop-table* (fast-read-u-integer #.sb!vm:n-word-bytes))) (frob fop-small-symbol-in-package-save 9 1 - (svref *current-fop-table* (fast-read-u-integer 4))) - (frob fop-symbol-in-byte-package-save 10 4 + (svref *current-fop-table* (fast-read-u-integer #.sb!vm:n-word-bytes))) + (frob fop-symbol-in-byte-package-save 10 #.sb!vm:n-word-bytes (svref *current-fop-table* (fast-read-u-integer 1))) (frob fop-small-symbol-in-byte-package-save 11 1 (svref *current-fop-table* (fast-read-u-integer 1)))) @@ -260,7 +260,7 @@ (define-fop (fop-word-integer 35) (prepare-for-fast-read-byte *fasl-input-stream* (prog1 - (fast-read-s-integer 4) + (fast-read-s-integer #.sb!vm:n-word-bytes) (done-with-fast-read-byte)))) (define-fop (fop-byte-integer 36) @@ -310,13 +310,13 @@ (define-fop (fop-list 15) (do ((res () (cons (pop-stack) res)) - (n (read-arg 1) (1- n))) + (n (read-byte-arg) (1- n))) ((zerop n) res) (declare (type index n)))) (define-fop (fop-list* 16) (do ((res (pop-stack) (cons (pop-stack) res)) - (n (read-arg 1) (1- n))) + (n (read-byte-arg) (1- n))) ((zerop n) res) (declare (type index n)))) @@ -360,12 +360,12 @@ res)) (define-fop (fop-array 83) - (let* ((rank (read-arg 4)) + (let* ((rank (read-word-arg)) (vec (pop-stack)) (length (length vec)) (res (make-array-header sb!vm:simple-array-widetag rank))) (declare (simple-array vec) - (type (unsigned-byte 24) rank)) + (type (unsigned-byte #.(- sb!vm:n-word-bits sb!vm:n-widetag-bits)) rank)) (set-array-header res vec length nil 0 (do ((i rank (1- i)) (dimensions () (cons (pop-stack) dimensions))) @@ -375,30 +375,27 @@ res)) (define-fop (fop-single-float-vector 84) - (let* ((length (read-arg 4)) + (let* ((length (read-word-arg)) (result (make-array length :element-type 'single-float))) - (read-n-bytes *fasl-input-stream* result 0 (* length sb!vm:n-word-bytes)) + (read-n-bytes *fasl-input-stream* result 0 (* length 4)) result)) (define-fop (fop-double-float-vector 85) - (let* ((length (read-arg 4)) + (let* ((length (read-word-arg)) (result (make-array length :element-type 'double-float))) - (read-n-bytes *fasl-input-stream* result 0 (* length sb!vm:n-word-bytes 2)) + (read-n-bytes *fasl-input-stream* result 0 (* length 8)) result)) (define-fop (fop-complex-single-float-vector 86) - (let* ((length (read-arg 4)) + (let* ((length (read-word-arg)) (result (make-array length :element-type '(complex single-float)))) - (read-n-bytes *fasl-input-stream* result 0 (* length sb!vm:n-word-bytes 2)) + (read-n-bytes *fasl-input-stream* result 0 (* length 8)) result)) (define-fop (fop-complex-double-float-vector 87) - (let* ((length (read-arg 4)) + (let* ((length (read-word-arg)) (result (make-array length :element-type '(complex double-float)))) - (read-n-bytes *fasl-input-stream* - result - 0 - (* length sb!vm:n-word-bytes 2 2)) + (read-n-bytes *fasl-input-stream* result 0 (* length 16)) result)) ;;; CMU CL comment: @@ -408,7 +405,7 @@ ;;; byte-ordering, allowing us to directly read the bits. (define-fop (fop-int-vector 43) (prepare-for-fast-read-byte *fasl-input-stream* - (let* ((len (fast-read-u-integer 4)) + (let* ((len (fast-read-u-integer #.sb!vm:n-word-bytes)) (size (fast-read-byte)) (res (case size (0 (make-array len :element-type 'nil)) @@ -424,37 +421,50 @@ (31 (prog1 (make-array len :element-type '(unsigned-byte 31)) (setf size 32))) (32 (make-array len :element-type '(unsigned-byte 32))) + #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or)) + (63 (prog1 (make-array len :element-type '(unsigned-byte 63)) + (setf size 64))) + (64 (make-array len :element-type '(unsigned-byte 64))) (t (bug "losing i-vector element size: ~S" size))))) (declare (type index len)) (done-with-fast-read-byte) (read-n-bytes *fasl-input-stream* res 0 - (ceiling (the index (* size len)) - sb!vm:n-byte-bits)) + (ceiling (the index (* size len)) sb!vm:n-byte-bits)) res))) ;;; This is the same as FOP-INT-VECTOR, except this is for signed ;;; SIMPLE-ARRAYs. (define-fop (fop-signed-int-vector 50) (prepare-for-fast-read-byte *fasl-input-stream* - (let* ((len (fast-read-u-integer 4)) + (let* ((len (fast-read-u-integer #.sb!vm:n-word-bytes)) (size (fast-read-byte)) (res (case size (8 (make-array len :element-type '(signed-byte 8))) (16 (make-array len :element-type '(signed-byte 16))) - (29 (make-array len :element-type '(unsigned-byte 29))) - (30 (make-array len :element-type '(signed-byte 30))) + #!+#.(cl:if (cl:= 32 sb!vm:n-word-bits) '(and) '(or)) + (29 (prog1 (make-array len :element-type '(unsigned-byte 29)) + (setf size 32))) + #!+#.(cl:if (cl:= 32 sb!vm:n-word-bits) '(and) '(or)) + (30 (prog1 (make-array len :element-type '(signed-byte 30)) + (setf size 32))) (32 (make-array len :element-type '(signed-byte 32))) + #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or)) + (60 (prog1 (make-array len :element-type '(unsigned-byte 60)) + (setf size 64))) + #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or)) + (61 (prog1 (make-array len :element-type '(signed-byte 61)) + (setf size 64))) + #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or)) + (64 (make-array len :element-type '(signed-byte 64))) (t (bug "losing si-vector element size: ~S" size))))) (declare (type index len)) (done-with-fast-read-byte) (read-n-bytes *fasl-input-stream* res 0 - (ceiling (the index (* (if (or (= size 30) (= size 29)) - 32 ; Adjust for (signed-byte 30) - size) len)) sb!vm:n-byte-bits)) + (ceiling (the index (* size len)) sb!vm:n-byte-bits)) res))) (define-fop (fop-eval 53) @@ -479,7 +489,7 @@ (terpri)))) (define-fop (fop-funcall 55) - (let ((arg (read-arg 1))) + (let ((arg (read-byte-arg))) (if (zerop arg) (funcall (pop-stack)) (do ((args () (cons (pop-stack) args)) @@ -488,7 +498,7 @@ (declare (type index n)))))) (define-fop (fop-funcall-for-effect 56 :pushp nil) - (let ((arg (read-arg 1))) + (let ((arg (read-byte-arg))) (if (zerop arg) (funcall (pop-stack)) (do ((args () (cons (pop-stack) args)) @@ -499,35 +509,35 @@ ;;;; fops for fixing up circularities (define-fop (fop-rplaca 200 :pushp nil) - (let ((obj (svref *current-fop-table* (read-arg 4))) - (idx (read-arg 4)) + (let ((obj (svref *current-fop-table* (read-word-arg))) + (idx (read-word-arg)) (val (pop-stack))) (setf (car (nthcdr idx obj)) val))) (define-fop (fop-rplacd 201 :pushp nil) - (let ((obj (svref *current-fop-table* (read-arg 4))) - (idx (read-arg 4)) + (let ((obj (svref *current-fop-table* (read-word-arg))) + (idx (read-word-arg)) (val (pop-stack))) (setf (cdr (nthcdr idx obj)) val))) (define-fop (fop-svset 202 :pushp nil) - (let* ((obi (read-arg 4)) + (let* ((obi (read-word-arg)) (obj (svref *current-fop-table* obi)) - (idx (read-arg 4)) + (idx (read-word-arg)) (val (pop-stack))) (if (typep obj 'instance) (setf (%instance-ref obj idx) val) (setf (svref obj idx) val)))) (define-fop (fop-structset 204 :pushp nil) - (setf (%instance-ref (svref *current-fop-table* (read-arg 4)) - (read-arg 4)) + (setf (%instance-ref (svref *current-fop-table* (read-word-arg)) + (read-word-arg)) (pop-stack))) ;;; In the original CMUCL code, this actually explicitly declared PUSHP ;;; to be T, even though that's what it defaults to in DEFINE-FOP. (define-fop (fop-nthcdr 203) - (nthcdr (read-arg 4) (pop-stack))) + (nthcdr (read-word-arg) (pop-stack))) ;;;; fops for loading functions @@ -539,10 +549,10 @@ ;;; fasl file header.) (define-fop (fop-code 58 :stackp nil) - (load-code (read-arg 4) (read-arg 4))) + (load-code (read-word-arg) (read-word-arg))) (define-fop (fop-small-code 59 :stackp nil) - (load-code (read-arg 1) (read-arg 2))) + (load-code (read-byte-arg) (read-halfword-arg))) (define-fop (fop-fdefinition 60) (fdefinition-object (pop-stack) t)) @@ -588,7 +598,7 @@ bug.~:@>") (arglist (pop-stack)) (name (pop-stack)) (code-object (pop-stack)) - (offset (read-arg 4))) + (offset (read-word-arg))) (declare (type index offset)) (unless (zerop (logand offset sb!vm:lowtag-mask)) (bug "unaligned function object, offset = #X~X" offset)) @@ -622,11 +632,11 @@ bug.~:@>") (define-fop (fop-foreign-fixup 147) (let* ((kind (pop-stack)) (code-object (pop-stack)) - (len (read-arg 1)) + (len (read-byte-arg)) (sym (make-string len))) (read-n-bytes *fasl-input-stream* sym 0 len) (sb!vm:fixup-code-object code-object - (read-arg 4) + (read-word-arg) (foreign-symbol-address-as-integer sym) kind) code-object)) @@ -644,7 +654,7 @@ bug.~:@>") (multiple-value-bind (value found) (gethash routine *assembler-routines*) (unless found (error "undefined assembler routine: ~S" routine)) - (sb!vm:fixup-code-object code-object (read-arg 4) value kind)) + (sb!vm:fixup-code-object code-object (read-word-arg) value kind)) code-object)) (define-fop (fop-code-object-fixup 149) @@ -653,6 +663,6 @@ bug.~:@>") ;; Note: We don't have to worry about GC moving the code-object after ;; the GET-LISP-OBJ-ADDRESS and before that value is deposited, because ;; we can only use code-object fixups when code-objects don't move. - (sb!vm:fixup-code-object code-object (read-arg 4) + (sb!vm:fixup-code-object code-object (read-word-arg) (get-lisp-obj-address code-object) kind) code-object)) diff --git a/src/code/load.lisp b/src/code/load.lisp index c4f1131..06655dd 100644 --- a/src/code/load.lisp +++ b/src/code/load.lisp @@ -51,6 +51,10 @@ #!-sb-fluid (declaim (inline read-byte)) +;;; FIXME: why do all of these reading functions and macros declare +;;; (SPEED 0)? was there some bug in the compiler which has since +;;; been fixed? --njf, 2004-09-08 + ;;; This expands into code to read an N-byte unsigned integer using ;;; FAST-READ-BYTE. (defmacro fast-read-u-integer (n) @@ -87,7 +91,7 @@ (cnt 1 (1+ cnt))) ((>= cnt n) res)))) -;;; Read an N-byte unsigned integer from the *FASL-INPUT-STREAM* +;;; Read an N-byte unsigned integer from the *FASL-INPUT-STREAM*. (defmacro read-arg (n) (declare (optimize (speed 0))) (if (= n 1) @@ -97,11 +101,19 @@ (fast-read-u-integer ,n) (done-with-fast-read-byte))))) -;;; FIXME: This deserves a more descriptive name, and should probably -;;; be implemented as an ordinary function, not a macro. -;;; -;;; (for the names: There seem to be only two cases, so it could be -;;; named READ-U-INTEGER-8 and READ-U-INTEGER-32 or something.) +(declaim (inline read-byte-arg read-halfword-arg read-word-arg)) +(defun read-byte-arg () + (declare (optimize (speed 0))) + (read-arg 1)) + +(defun read-halfword-arg () + (declare (optimize (speed 0))) + (read-arg #.(/ sb!vm:n-word-bytes 2))) + +(defun read-word-arg () + (declare (optimize (speed 0))) + (read-arg #.sb!vm:n-word-bytes)) + ;;;; the fop table @@ -293,7 +305,7 @@ ;; Read and validate version-specific compatibility stuff. (flet ((string-from-stream () - (let* ((length (read-arg 4)) + (let* ((length (read-word-arg)) (result (make-string length))) (read-string-as-bytes stream result) result))) @@ -301,7 +313,7 @@ (let* ((implementation (keywordicate (string-from-stream))) ;; FIXME: The logic above to read a keyword from the fasl file ;; could probably be shared with the read-a-keyword fop. - (version (read-arg 4))) + (version (read-word-arg))) (flet ((check-version (variant possible-implementation needed-version) diff --git a/src/compiler/dump.lisp b/src/compiler/dump.lisp index bb8ff48..03f1d34 100644 --- a/src/compiler/dump.lisp +++ b/src/compiler/dump.lisp @@ -105,12 +105,12 @@ (declare (type (unsigned-byte 8) b) (type fasl-output fasl-output)) (write-byte b (fasl-output-stream fasl-output))) -;;; Dump a 4 byte unsigned integer. -(defun dump-unsigned-32 (num fasl-output) - (declare (type (unsigned-byte 32) num)) +;; Dump a word-sized integer. +(defun dump-word (num fasl-output) + (declare (type sb!vm:word num)) (declare (type fasl-output fasl-output)) (let ((stream (fasl-output-stream fasl-output))) - (dotimes (i 4) + (dotimes (i sb!vm:n-word-bytes) (write-byte (ldb (byte 8 (* 8 i)) num) stream)))) ;;; Dump NUM to the fasl stream, represented by N bytes. This works @@ -151,7 +151,8 @@ #!+sb-show (when *fop-nop4-count* (dump-byte ,(get 'fop-nop4 'fop-code) ,file) - (dump-unsigned-32 (mod (incf *fop-nop4-count*) (expt 2 32)) ,file)) + (dump-integer-as-n-bytes (mod (incf *fop-nop4-count*) (expt 2 32)) + 4 ,file)) (dump-byte ',val ,file)) (error "compiler bug: ~S is not a legal fasload operator." fs)))) @@ -168,7 +169,7 @@ (dump-byte ,n-n ,n-file)) (t (dump-fop ',word-fop ,n-file) - (dump-unsigned-32 ,n-n ,n-file))))) + (dump-word ,n-n ,n-file))))) ;;; Push the object at table offset Handle on the fasl stack. (defun dump-push (handle fasl-output) @@ -296,11 +297,11 @@ ;; Finish the header by outputting fasl file implementation, ;; version, and key *FEATURES*. (flet ((dump-counted-string (string) - (dump-unsigned-32 (length string) res) + (dump-word (length string) res) (dotimes (i (length string)) (dump-byte (char-code (aref string i)) res)))) (dump-counted-string (symbol-name +backend-fasl-file-implementation+)) - (dump-unsigned-32 +fasl-file-version+ res) + (dump-word +fasl-file-version+ res) (dump-counted-string *features-affecting-fasl-format*)) res)) @@ -315,7 +316,7 @@ ;; End the group. (dump-fop 'fop-verify-empty-stack fasl-output) (dump-fop 'fop-verify-table-size fasl-output) - (dump-unsigned-32 (fasl-output-table-free fasl-output) + (dump-word (fasl-output-table-free fasl-output) fasl-output) (dump-fop 'fop-end-group fasl-output) @@ -427,7 +428,7 @@ (i 0 (1+ i))) ((eq current value) (dump-fop 'fop-nthcdr file) - (dump-unsigned-32 i file)) + (dump-word i file)) (declare (type index i))))) (ecase (circularity-type info) @@ -435,8 +436,8 @@ (:rplacd (dump-fop 'fop-rplacd file)) (:svset (dump-fop 'fop-svset file)) (:struct-set (dump-fop 'fop-structset file))) - (dump-unsigned-32 (gethash (circularity-object info) table) file) - (dump-unsigned-32 (circularity-index info) file)))) + (dump-word (gethash (circularity-object info) table) file) + (dump-word (circularity-index info) file)))) ;;; Set up stuff for circularity detection, then dump an object. All ;;; shared and circular structure will be exactly preserved within a @@ -507,12 +508,12 @@ ((signed-byte 8) (dump-fop 'fop-byte-integer file) (dump-byte (logand #xFF n) file)) - ((unsigned-byte 31) + ((unsigned-byte #.(1- sb!vm:n-word-bits)) (dump-fop 'fop-word-integer file) - (dump-unsigned-32 n file)) - ((signed-byte 32) + (dump-word n file)) + ((signed-byte #.sb!vm:n-word-bits) (dump-fop 'fop-word-integer file) - (dump-integer-as-n-bytes n 4 file)) + (dump-integer-as-n-bytes n #.sb!vm:n-word-bytes file)) (t (let ((bytes (ceiling (1+ (integer-length n)) 8))) (dump-fop* bytes fop-small-integer fop-integer file) @@ -527,9 +528,7 @@ (dump-fop 'fop-double-float file) (let ((x x)) (declare (double-float x)) - ;; FIXME: Why sometimes DUMP-UNSIGNED-32 and sometimes - ;; DUMP-INTEGER-AS-N-BYTES .. 4? - (dump-unsigned-32 (double-float-low-bits x) file) + (dump-integer-as-n-bytes (double-float-low-bits x) 4 file) (dump-integer-as-n-bytes (double-float-high-bits x) 4 file))) #!+long-float (long-float @@ -548,11 +547,11 @@ (dump-fop 'fop-complex-double-float file) (let ((re (realpart x))) (declare (double-float re)) - (dump-unsigned-32 (double-float-low-bits re) file) + (dump-integer-as-n-bytes (double-float-low-bits re) 4 file) (dump-integer-as-n-bytes (double-float-high-bits re) 4 file)) (let ((im (imagpart x))) (declare (double-float im)) - (dump-unsigned-32 (double-float-low-bits im) file) + (dump-integer-as-n-bytes (double-float-low-bits im) 4 file) (dump-integer-as-n-bytes (double-float-high-bits im) 4 file))) #!+long-float ((complex long-float) @@ -789,7 +788,7 @@ (labels ((dump-unsigned-vector (size bytes) (unless data-only (dump-fop 'fop-int-vector file) - (dump-unsigned-32 len file) + (dump-word len file) (dump-byte size file)) ;; The case which is easy to handle in a portable way is when ;; the element size is a multiple of the output byte size, and @@ -820,16 +819,15 @@ ;; target machine.) (unless data-only (dump-fop 'fop-signed-int-vector file) - (dump-unsigned-32 len file) + (dump-word len file) (dump-byte size file)) (dump-raw-bytes vec bytes file))) (etypecase vec #-sb-xc-host ((simple-array nil (*)) (dump-unsigned-vector 0 0)) - ;; KLUDGE: What exactly does the (ASH .. -3) stuff do? -- WHN 19990902 (simple-bit-vector - (dump-unsigned-vector 1 (ash (+ (the index len) 7) -3))) + (dump-unsigned-vector 1 (ceiling len 8))) ;; KLUDGE: This isn't the best way of expressing that the host ;; may not have specializations for (unsigned-byte 2) and ;; (unsigned-byte 4), which means that these types are @@ -839,10 +837,10 @@ ;; CSR, 2002-05-07 #-sb-xc-host ((simple-array (unsigned-byte 2) (*)) - (dump-unsigned-vector 2 (ash (+ (the index (ash len 1)) 7) -3))) + (dump-unsigned-vector 2 (ceiling len 8))) #-sb-xc-host ((simple-array (unsigned-byte 4) (*)) - (dump-unsigned-vector 4 (ash (+ (the index (ash len 2)) 7) -3))) + (dump-unsigned-vector 4 (ceiling len 8))) #-sb-xc-host ((simple-array (unsigned-byte 7) (*)) (dump-unsigned-vector 7 len)) @@ -858,16 +856,34 @@ (dump-unsigned-vector 31 (* 4 len))) ((simple-array (unsigned-byte 32) (*)) (dump-unsigned-vector 32 (* 4 len))) + #-sb-xc-host + #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or)) + ((simple-array (unsigned-byte-63) (*)) + (dump-unsigned-vector 63 (* 8 len))) + #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or)) + ((simple-array (unsigned-byte-64) (*)) + (dump-unsigned-vector 64 (* 8 len))) ((simple-array (signed-byte 8) (*)) (dump-signed-vector 8 len)) ((simple-array (signed-byte 16) (*)) (dump-signed-vector 16 (* 2 len))) + #!+#.(cl:if (cl:= 32 sb!vm:n-word-bits) '(and) '(or)) ((simple-array (unsigned-byte 29) (*)) (dump-signed-vector 29 (* 4 len))) + #!+#.(cl:if (cl:= 32 sb!vm:n-word-bits) '(and) '(or)) ((simple-array (signed-byte 30) (*)) (dump-signed-vector 30 (* 4 len))) ((simple-array (signed-byte 32) (*)) - (dump-signed-vector 32 (* 4 len))))))) + (dump-signed-vector 32 (* 4 len))) + #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or)) + ((simple-array (unsigned-byte 60) (*)) + (dump-signed-vector 60 (* 8 len))) + #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or)) + ((simple-array (signed-byte 61) (*)) + (dump-signed-vector 61 (* 8 len))) + #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or)) + ((simple-array (signed-byte 64) (*)) + (dump-signed-vector 64 (* 8 len))))))) ;;; Dump characters and string-ish things. @@ -935,7 +951,7 @@ fop-symbol-in-byte-package-save fop-symbol-in-package-save file) - (dump-unsigned-32 pname-length file))) + (dump-word pname-length file))) (dump-characters-of-string pname file) @@ -999,7 +1015,7 @@ (aver (null name)) (dump-fop 'fop-code-object-fixup fasl-output))) ;; No matter what the flavor, we'll always dump the position - (dump-unsigned-32 position fasl-output))) + (dump-word position fasl-output))) (values)) ;;; Dump out the constant pool and code-vector for component, push the @@ -1089,8 +1105,8 @@ (dump-integer-as-n-bytes total-length 2 fasl-output)) (t (dump-fop 'fop-code fasl-output) - (dump-unsigned-32 num-consts fasl-output) - (dump-unsigned-32 total-length fasl-output)))) + (dump-word num-consts fasl-output) + (dump-word total-length fasl-output)))) ;; These two dumps are only ones which contribute to our ;; TOTAL-LENGTH value. @@ -1113,7 +1129,7 @@ (defun dump-assembler-routines (code-segment length fixups routines file) (dump-fop 'fop-assembler-code file) - (dump-unsigned-32 length file) + (dump-word length file) (write-segment-contents code-segment (fasl-output-stream file)) (dolist (routine routines) (dump-fop 'fop-normal-load file) @@ -1121,7 +1137,7 @@ (dump-object (car routine) file)) (dump-fop 'fop-maybe-cold-load file) (dump-fop 'fop-assembler-routine file) - (dump-unsigned-32 (label-position (cdr routine)) file)) + (dump-word (label-position (cdr routine)) file)) (dump-fixups fixups file) (dump-fop 'fop-sanctify-for-execution file) (dump-pop file)) @@ -1138,7 +1154,7 @@ (dump-object (sb!c::entry-info-arguments entry) file) (dump-object (sb!c::entry-info-type entry) file) (dump-fop 'fop-fun-entry file) - (dump-unsigned-32 (label-position (sb!c::entry-info-offset entry)) file) + (dump-word (label-position (sb!c::entry-info-offset entry)) file) (dump-pop file))) ;;; Alter the code object referenced by CODE-HANDLE at the specified @@ -1164,7 +1180,7 @@ (dump-fop 'fop-verify-empty-stack file) (dump-fop 'fop-verify-table-size file) - (dump-unsigned-32 (fasl-output-table-free file) file) + (dump-word (fasl-output-table-free file) file) #!+sb-dyncount (let ((info (sb!c::ir2-component-dyncount-info (component-info component)))) @@ -1235,8 +1251,9 @@ (dolist (info-handle (fasl-output-debug-info fasl-output)) (dump-push res-handle fasl-output) (dump-fop 'fop-structset fasl-output) - (dump-unsigned-32 info-handle fasl-output) - (dump-unsigned-32 2 fasl-output)))) + (dump-word info-handle fasl-output) + ;; FIXME: what is this bare `2'? --njf, 2004-08-16 + (dump-word 2 fasl-output)))) (setf (fasl-output-debug-info fasl-output) nil) (values)) diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp index 411f671..9e17337 100644 --- a/src/compiler/generic/genesis.lisp +++ b/src/compiler/generic/genesis.lisp @@ -281,7 +281,7 @@ ;; the GSPACE that this descriptor is allocated in, or NIL if not set yet. (gspace nil :type (or gspace null)) ;; the offset in words from the start of GSPACE, or NIL if not set yet - (word-offset nil :type (or (unsigned-byte #.sb!vm:n-word-bits) null)) + (word-offset nil :type (or sb!vm:word null)) ;; the high and low halves of the descriptor ;; ;; KLUDGE: Judging from the comments in genesis.lisp of the CMU CL @@ -1904,9 +1904,9 @@ (aver (member pushp '(nil t))) (aver (member stackp '(nil t))) `(progn - (macrolet ((clone-arg () '(read-arg 4))) + (macrolet ((clone-arg () '(read-word-arg))) (define-cold-fop (,name :pushp ,pushp :stackp ,stackp) ,@forms)) - (macrolet ((clone-arg () '(read-arg 1))) + (macrolet ((clone-arg () '(read-byte-arg))) (define-cold-fop (,small-name :pushp ,pushp :stackp ,stackp) ,@forms)))) ;;; Cause a fop to be undefined in cold load. @@ -1933,7 +1933,7 @@ (define-cold-fop (fop-misc-trap) *unbound-marker*) (define-cold-fop (fop-short-character) - (make-character-descriptor (read-arg 1))) + (make-character-descriptor (read-byte-arg))) (define-cold-fop (fop-empty-list) *nil-descriptor*) (define-cold-fop (fop-truth) (cold-intern t)) @@ -2031,9 +2031,9 @@ (push-fop-table (cold-load-symbol (read-arg ,pname-len) (svref *current-fop-table* index))))))) - (frob fop-symbol-in-package-save 4 4) - (frob fop-small-symbol-in-package-save 1 4) - (frob fop-symbol-in-byte-package-save 4 1) + (frob fop-symbol-in-package-save #.sb!vm:n-word-bytes #.sb!vm:n-word-bytes) + (frob fop-small-symbol-in-package-save 1 #.sb!vm:n-word-bytes) + (frob fop-symbol-in-byte-package-save #.sb!vm:n-word-bytes 1) (frob fop-small-symbol-in-byte-package-save 1 1)) (clone-cold-fop (fop-lisp-symbol-save) @@ -2063,9 +2063,9 @@ (declare (fixnum index)))) (define-cold-fop (fop-list) - (cold-stack-list (read-arg 1) *nil-descriptor*)) + (cold-stack-list (read-byte-arg) *nil-descriptor*)) (define-cold-fop (fop-list*) - (cold-stack-list (read-arg 1) (pop-stack))) + (cold-stack-list (read-byte-arg) (pop-stack))) (define-cold-fop (fop-list-1) (cold-stack-list 1 *nil-descriptor*)) (define-cold-fop (fop-list-2) @@ -2124,8 +2124,8 @@ result)) (define-cold-fop (fop-int-vector) - (let* ((len (read-arg 4)) - (sizebits (read-arg 1)) + (let* ((len (read-word-arg)) + (sizebits (read-byte-arg)) (type (case sizebits (0 sb!vm:simple-array-nil-widetag) (1 sb!vm:simple-bit-vector-widetag) @@ -2144,7 +2144,7 @@ (63 (prog1 sb!vm:simple-array-unsigned-byte-63-widetag (setf sizebits 64))) #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or)) - (64 (sb!vm:simple-array-unsigned-byte-64-widetag)) + (64 sb!vm:simple-array-unsigned-byte-64-widetag) (t (error "losing element size: ~W" sizebits)))) (result (allocate-vector-object *dynamic* sizebits len type)) (start (+ (descriptor-byte-offset result) @@ -2159,7 +2159,7 @@ result)) (define-cold-fop (fop-single-float-vector) - (let* ((len (read-arg 4)) + (let* ((len (read-word-arg)) (result (allocate-vector-object *dynamic* sb!vm:n-word-bits @@ -2167,7 +2167,7 @@ sb!vm:simple-array-single-float-widetag)) (start (+ (descriptor-byte-offset result) (ash sb!vm:vector-data-offset sb!vm:word-shift))) - (end (+ start (* len sb!vm:n-word-bytes)))) + (end (+ start (* len 4)))) (read-bigvec-as-sequence-or-die (descriptor-bytes result) *fasl-input-stream* :start start @@ -2181,7 +2181,7 @@ #!+long-float (not-cold-fop fop-complex-long-float-vector) (define-cold-fop (fop-array) - (let* ((rank (read-arg 4)) + (let* ((rank (read-word-arg)) (data-vector (pop-stack)) (result (allocate-boxed-object *dynamic* (+ sb!vm:array-dimensions-offset rank) @@ -2252,7 +2252,7 @@ (defvar *load-time-value-counter*) (define-cold-fop (fop-funcall) - (unless (= (read-arg 1) 0) + (unless (= (read-byte-arg) 0) (error "You can't FOP-FUNCALL arbitrary stuff in cold load.")) (let ((counter *load-time-value-counter*)) (cold-push (cold-cons @@ -2274,7 +2274,7 @@ sb!vm:simple-vector-widetag))) (define-cold-fop (fop-funcall-for-effect :pushp nil) - (if (= (read-arg 1) 0) + (if (= (read-byte-arg) 0) (cold-push (pop-stack) *current-reversed-cold-toplevels*) (error "You can't FOP-FUNCALL arbitrary stuff in cold load."))) @@ -2282,18 +2282,18 @@ ;;;; cold fops for fixing up circularities (define-cold-fop (fop-rplaca :pushp nil) - (let ((obj (svref *current-fop-table* (read-arg 4))) - (idx (read-arg 4))) + (let ((obj (svref *current-fop-table* (read-word-arg))) + (idx (read-word-arg))) (write-memory (cold-nthcdr idx obj) (pop-stack)))) (define-cold-fop (fop-rplacd :pushp nil) - (let ((obj (svref *current-fop-table* (read-arg 4))) - (idx (read-arg 4))) + (let ((obj (svref *current-fop-table* (read-word-arg))) + (idx (read-word-arg))) (write-wordindexed (cold-nthcdr idx obj) 1 (pop-stack)))) (define-cold-fop (fop-svset :pushp nil) - (let ((obj (svref *current-fop-table* (read-arg 4))) - (idx (read-arg 4))) + (let ((obj (svref *current-fop-table* (read-word-arg))) + (idx (read-word-arg))) (write-wordindexed obj (+ idx (ecase (descriptor-lowtag obj) @@ -2302,14 +2302,14 @@ (pop-stack)))) (define-cold-fop (fop-structset :pushp nil) - (let ((obj (svref *current-fop-table* (read-arg 4))) - (idx (read-arg 4))) + (let ((obj (svref *current-fop-table* (read-word-arg))) + (idx (read-word-arg))) (write-wordindexed obj (1+ idx) (pop-stack)))) ;;; In the original CMUCL code, this actually explicitly declared PUSHP ;;; to be T, even though that's what it defaults to in DEFINE-COLD-FOP. (define-cold-fop (fop-nthcdr) - (cold-nthcdr (read-arg 4) (pop-stack))) + (cold-nthcdr (read-word-arg) (pop-stack))) (defun cold-nthcdr (index obj) (dotimes (i index) @@ -2402,9 +2402,9 @@ (bvref-32 (descriptor-bytes des) i))))) des))) -(define-cold-code-fop fop-code (read-arg 4) (read-arg 4)) +(define-cold-code-fop fop-code (read-word-arg) (read-word-arg)) -(define-cold-code-fop fop-small-code (read-arg 1) (read-arg 2)) +(define-cold-code-fop fop-small-code (read-byte-arg) (read-halfword-arg)) (clone-cold-fop (fop-alter-code :pushp nil) (fop-byte-alter-code) @@ -2418,7 +2418,7 @@ (arglist (pop-stack)) (name (pop-stack)) (code-object (pop-stack)) - (offset (calc-offset code-object (read-arg 4))) + (offset (calc-offset code-object (read-word-arg))) (fn (descriptor-beyond code-object offset sb!vm:fun-pointer-lowtag)) @@ -2476,16 +2476,16 @@ (define-cold-fop (fop-foreign-fixup) (let* ((kind (pop-stack)) (code-object (pop-stack)) - (len (read-arg 1)) + (len (read-byte-arg)) (sym (make-string len))) (read-string-as-bytes *fasl-input-stream* sym) - (let ((offset (read-arg 4)) + (let ((offset (read-word-arg)) (value (cold-foreign-symbol-address-as-integer sym))) (do-cold-fixup code-object offset value kind)) code-object)) (define-cold-fop (fop-assembler-code) - (let* ((length (read-arg 4)) + (let* ((length (read-word-arg)) (header-n-words ;; Note: we round the number of constants up to ensure that ;; the code vector will be properly aligned. @@ -2518,7 +2518,7 @@ (define-cold-fop (fop-assembler-routine) (let* ((routine (pop-stack)) (des (pop-stack)) - (offset (calc-offset des (read-arg 4)))) + (offset (calc-offset des (read-word-arg)))) (record-cold-assembler-routine routine (+ (logandc2 (descriptor-bits des) sb!vm:lowtag-mask) offset)) @@ -2528,14 +2528,14 @@ (let* ((routine (pop-stack)) (kind (pop-stack)) (code-object (pop-stack)) - (offset (read-arg 4))) + (offset (read-word-arg))) (record-cold-assembler-fixup routine code-object offset kind) code-object)) (define-cold-fop (fop-code-object-fixup) (let* ((kind (pop-stack)) (code-object (pop-stack)) - (offset (read-arg 4)) + (offset (read-word-arg)) (value (descriptor-bits code-object))) (do-cold-fixup code-object offset value kind) code-object)) diff --git a/src/compiler/target-dump.lisp b/src/compiler/target-dump.lisp index c0fa5da..01eba24 100644 --- a/src/compiler/target-dump.lisp +++ b/src/compiler/target-dump.lisp @@ -37,7 +37,7 @@ (sub-dump-object vector file) (sub-dump-object (subseq vector start end) file))) (dump-fop 'fop-array file) - (dump-unsigned-32 rank file) + (dump-word rank file) (eq-save-object array file))) ;;;; various dump-a-number operations @@ -45,20 +45,20 @@ (defun dump-single-float-vector (vec file) (let ((length (length vec))) (dump-fop 'fop-single-float-vector file) - (dump-unsigned-32 length file) - (dump-raw-bytes vec (* length sb!vm:n-word-bytes) file))) + (dump-word length file) + (dump-raw-bytes vec (* length 4) file))) (defun dump-double-float-vector (vec file) (let ((length (length vec))) (dump-fop 'fop-double-float-vector file) - (dump-unsigned-32 length file) - (dump-raw-bytes vec (* length sb!vm:n-word-bytes 2) file))) + (dump-word length file) + (dump-raw-bytes vec (* length 8) file))) #!+long-float (defun dump-long-float-vector (vec file) (let ((length (length vec))) (dump-fop 'fop-long-float-vector file) - (dump-unsigned-32 length file) + (dump-word length file) (dump-raw-bytes vec (* length sb!vm:n-word-bytes #!+x86 3 #!+sparc 4) file))) @@ -66,20 +66,20 @@ (defun dump-complex-single-float-vector (vec file) (let ((length (length vec))) (dump-fop 'fop-complex-single-float-vector file) - (dump-unsigned-32 length file) - (dump-raw-bytes vec (* length sb!vm:n-word-bytes 2) file))) + (dump-word length file) + (dump-raw-bytes vec (* length 8) file))) (defun dump-complex-double-float-vector (vec file) (let ((length (length vec))) (dump-fop 'fop-complex-double-float-vector file) - (dump-unsigned-32 length file) - (dump-raw-bytes vec (* length sb!vm:n-word-bytes 2 2) file))) + (dump-word length file) + (dump-raw-bytes vec (* length 16) file))) #!+long-float (defun dump-complex-long-float-vector (vec file) (let ((length (length vec))) (dump-fop 'fop-complex-long-float-vector file) - (dump-unsigned-32 length file) + (dump-word length file) (dump-raw-bytes vec (* length sb!vm:n-word-bytes #!+x86 3 #!+sparc 4 2) file))) @@ -90,8 +90,11 @@ (let ((exp-bits (long-float-exp-bits float)) (high-bits (long-float-high-bits float)) (low-bits (long-float-low-bits float))) - (dump-unsigned-32 low-bits file) - (dump-unsigned-32 high-bits file) + ;; We could get away with DUMP-WORD here, since the x86 has 4-byte words, + ;; but we prefer to make things as explicit as possible. + ;; --njf, 2004-08-16 + (dump-integer-as-n-bytes low-bits 4 file) + (dump-integer-as-n-bytes high-bits 4 file) (dump-integer-as-n-bytes exp-bits 2 file))) #!+(and long-float sparc) @@ -101,7 +104,10 @@ (high-bits (long-float-high-bits float)) (mid-bits (long-float-mid-bits float)) (low-bits (long-float-low-bits float))) - (dump-unsigned-32 low-bits file) - (dump-unsigned-32 mid-bits file) - (dump-unsigned-32 high-bits file) + ;; We could get away with DUMP-WORD here, since the sparc has 4-byte + ;; words, but we prefer to make things as explicit as possible. + ;; --njf, 2004-08-16 + (dump-integer-as-n-bytes low-bits 4 file) + (dump-integer-as-n-bytes mid-bits 4 file) + (dump-integer-as-n-bytes high-bits 4 file) (dump-integer-as-n-bytes exp-bits 4 file))) diff --git a/version.lisp-expr b/version.lisp-expr index 2137863..a185b7c 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.14.2" +"0.8.14.3" -- 1.7.10.4