(dump-byte ',val ,file))
(error "compiler bug: ~S is not a legal fasload operator." fs))))
-;;; Dump a FOP-Code along with an integer argument, choosing the FOP
+;;; Dump a FOP-CODE along with an integer argument, choosing the FOP
;;; based on whether the argument will fit in a single byte.
;;;
;;; FIXME: This, like DUMP-FOP, should be a function with a
\f
;;;; opening and closing fasl files
+;;; A utility function to write strings to (unsigned-byte 8) streams.
+;;; We restrict this to ASCII (with the averrance) because of
+;;; ambiguity of higher bytes: Unicode, some ISO-8859-x, or what? This
+;;; could be revisited in the event of doing funky things with stream
+;;; encodings -- CSR, 2002-04-25
+(defun fasl-write-string (string stream)
+ (loop for char across string
+ do (let ((code (char-code char)))
+ (aver (<= 0 code 127))
+ (write-byte code stream))))
+
;;; Open a fasl file, write its header, and return a FASL-OUTPUT
;;; object for dumping to it. Some human-readable information about
;;; the source code is given by the string WHERE. If BYTE-P is true,
(declare (type pathname name))
(let* ((stream (open name
:direction :output
- :if-exists :new-version
+ :if-exists :supersede
:element-type 'sb!assem:assembly-unit))
(res (make-fasl-output :stream stream)))
;; Begin the header with the constant machine-readable (and
;; semi-human-readable) string which is used to identify fasl files.
- (write-string *fasl-header-string-start-string* stream)
+ (fasl-write-string *fasl-header-string-start-string* stream)
;; The constant string which begins the header is followed by
;; arbitrary human-readable text, terminated by a special
;; character code.
- (with-standard-io-syntax
- (format stream
- "~% ~
- compiled from ~S~% ~
- at ~A~% ~
- on ~A~% ~
- using ~A version ~A~%"
- where
- (format-universal-time nil (get-universal-time))
- (machine-instance)
- (sb!xc:lisp-implementation-type)
- (sb!xc:lisp-implementation-version)))
+ (fasl-write-string
+ (with-standard-io-syntax
+ (format nil
+ "~% ~
+ compiled from ~S~% ~
+ at ~A~% ~
+ on ~A~% ~
+ using ~A version ~A~%"
+ where
+ (format-universal-time nil (get-universal-time))
+ (machine-instance)
+ (sb!xc:lisp-implementation-type)
+ (sb!xc:lisp-implementation-version)))
+ stream)
(dump-byte +fasl-header-string-stop-char-code+ res)
- ;; Finish the header by outputting fasl file implementation and
- ;; version in machine-readable form.
- (let ((implementation +backend-fasl-file-implementation+))
- (dump-unsigned-32 (length (symbol-name implementation)) res)
- (dotimes (i (length (symbol-name implementation)))
- (dump-byte (char-code (aref (symbol-name implementation) i)) res)))
- (dump-unsigned-32 +fasl-file-version+ res)
+ ;; Finish the header by outputting fasl file implementation,
+ ;; version, and key *FEATURES*.
+ (flet ((dump-counted-string (string)
+ (dump-unsigned-32 (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-counted-string *features-affecting-fasl-format*))
res))
;;; this function is not parallel to other functions DUMP-FOO, e.g.
;;; DUMP-SYMBOL and DUMP-LIST. The mapping between names and behavior
;;; should be made more consistent.
+(declaim (ftype (function (package fasl-output) index) dump-package))
(defun dump-package (pkg file)
- (declare (type package pkg) (type fasl-output file))
- (declare (values index))
(declare (inline assoc))
(cond ((cdr (assoc pkg (fasl-output-packages file) :test #'eq)))
(t
;;; tables.
(defun dump-vector (x file)
(let ((simple-version (if (array-header-p x)
- (coerce x 'simple-array)
+ (coerce x `(simple-array
+ ,(array-element-type x)
+ (*)))
x)))
(typecase simple-version
(simple-base-string
(t
(sub-dump-object obj file))))))
+;;; In the grand scheme of things I don't pretend to understand any
+;;; more how this works, or indeed whether. But to write out specialized
+;;; vectors in the same format as fop-int-vector expects to read them
+;;; we need to be target-endian. dump-integer-as-n-bytes always writes
+;;; little-endian (which is correct for all other integers) so for a bigendian
+;;; target we need to swap octets -- CSR, after DB
+
+(defun octet-swap (word bits)
+ "BITS must be a multiple of 8"
+ (do ((input word (ash input -8))
+ (output 0 (logior (ash output 8) (logand input #xff)))
+ (bits bits (- bits 8)))
+ ((<= bits 0) output)))
+
(defun dump-i-vector (vec file &key data-only)
(declare (type (simple-array * (*)) vec))
(let ((len (length vec)))
;; (SIMPLE-ARRAY (UNSIGNED-BYTE 8) *).) The other cases are only
;; needed in the target SBCL, so we let them be handled with
;; unportable bit bashing.
- (cond ((>= size 8) ; easy cases
+ (cond ((>= size 7) ; easy cases
(multiple-value-bind (floor rem) (floor size 8)
- (aver (zerop rem))
+ (aver (or (zerop rem) (= rem 7)))
+ (when (= rem 7)
+ (setq size (1+ size))
+ (setq floor (1+ floor)))
(dovector (i vec)
- (dump-integer-as-n-bytes i floor file))))
+ (dump-integer-as-n-bytes
+ (ecase sb!c:*backend-byte-order*
+ (:little-endian i)
+ (:big-endian (octet-swap i size)))
+ floor file))))
(t ; harder cases, not supported in cross-compiler
(dump-raw-bytes vec bytes file))))
(dump-signed-vector (size bytes)
(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)))
+ ;; 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
+ ;; type-equivalent to (simple-array (unsigned-byte 8) (*));
+ ;; the workaround is to remove them from the etypecase, since
+ ;; they can't be dumped from the cross-compiler anyway. --
+ ;; CSR, 2002-05-07
+ #-sb-xc-host
((simple-array (unsigned-byte 2) (*))
(dump-unsigned-vector 2 (ash (+ (the index (ash len 1)) 7) -3)))
+ #-sb-xc-host
((simple-array (unsigned-byte 4) (*))
(dump-unsigned-vector 4 (ash (+ (the index (ash len 2)) 7) -3)))
+ #-sb-xc-host
+ ((simple-array (unsigned-byte 7) (*))
+ (dump-unsigned-vector 7 len))
((simple-array (unsigned-byte 8) (*))
(dump-unsigned-vector 8 len))
+ #-sb-xc-host
+ ((simple-array (unsigned-byte 15) (*))
+ (dump-unsigned-vector 15 (* 2 len)))
((simple-array (unsigned-byte 16) (*))
(dump-unsigned-vector 16 (* 2 len)))
+ #-sb-xc-host
+ ((simple-array (unsigned-byte 31) (*))
+ (dump-unsigned-vector 31 (* 4 len)))
((simple-array (unsigned-byte 32) (*))
(dump-unsigned-vector 32 (* 4 len)))
((simple-array (signed-byte 8) (*))
(dump-signed-vector 8 len))
((simple-array (signed-byte 16) (*))
(dump-signed-vector 16 (* 2 len)))
+ ((simple-array (unsigned-byte 29) (*))
+ (dump-signed-vector 29 (* 4 len)))
((simple-array (signed-byte 30) (*))
(dump-signed-vector 30 (* 4 len)))
((simple-array (signed-byte 32) (*))
(declare (type sb!assem:segment segment)
(type fasl-output fasl-output))
(let* ((stream (fasl-output-stream fasl-output))
- (nwritten (write-segment-contents segment stream)))
+ (n-written (write-segment-contents segment stream)))
;; In CMU CL there was no enforced connection between the CODE-LENGTH
;; argument and the number of bytes actually written. I added this
;; assertion while trying to debug portable genesis. -- WHN 19990902
- (unless (= code-length nwritten)
- (error "internal error, code-length=~W, nwritten=~W"
- code-length
- nwritten)))
+ (unless (= code-length n-written)
+ (bug "code-length=~W, n-written=~W" code-length n-written)))
(values))
;;; Dump all the fixups. Currently there are three flavors of fixup:
(dump-fop 'fop-sanctify-for-execution file)
(dump-pop file))
-;;; Dump a function-entry data structure corresponding to ENTRY to
+;;; Dump a function entry data structure corresponding to ENTRY to
;;; FILE. CODE-HANDLE is the table offset of the code object for the
;;; component.
(defun dump-one-entry (entry code-handle file)
(dump-object name file)
(dump-object (sb!c::entry-info-arguments entry) file)
(dump-object (sb!c::entry-info-type entry) file)
- (dump-fop 'fop-function-entry file)
+ (dump-fop 'fop-fun-entry file)
(dump-unsigned-32 (label-position (sb!c::entry-info-offset entry)) file)
(dump-pop file)))
(defun dump-layout (obj file)
(when (layout-invalid obj)
(compiler-error "attempt to dump reference to obsolete class: ~S"
- (layout-class obj)))
- (let ((name (sb!xc:class-name (layout-class obj))))
+ (layout-classoid obj)))
+ (let ((name (classoid-name (layout-classoid obj))))
(unless name
(compiler-error "dumping anonymous layout: ~S" obj))
(dump-fop 'fop-normal-load file)
projects / sbcl.git / blobdiff