;; an alist (PACKAGE . OFFSET) of the table offsets for each package
;; we have currently located.
(packages () :type list)
- ;; a table mapping from the Entry-Info structures for dumped XEPs to
+ ;; a table mapping from the ENTRY-INFO structures for dumped XEPs to
;; the table offsets of the corresponding code pointers
(entry-table (make-hash-table :test 'eq) :type hash-table)
;; a table holding back-patching info for forward references to XEPs.
- ;; The key is the Entry-Info structure for the XEP, and the value is
+ ;; The key is the ENTRY-INFO structure for the XEP, and the value is
;; a list of conses (<code-handle> . <offset>), where <code-handle>
;; is the offset in the table of the code object needing to be
;; patched, and <offset> is the offset that must be patched.
\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
;;; 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
(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)))
(multiple-value-bind (floor rem) (floor size 8)
(aver (zerop rem))
(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)
;; 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)))
((simple-array (unsigned-byte 8) (*))
(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=~D, nwritten=~D"
- 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:
;; far as I know no modern CMU CL does either -- WHN
;; 2001-10-05). So might we be able to get rid of trace tables?
- ;; Dump the constants, noting any :entries that have to be fixed up.
- (do ((i sb!vm:code-constants-offset (1+ i)))
- ((>= i header-length))
+ ;; Dump the constants, noting any :ENTRY constants that have to
+ ;; be patched.
+ (loop for i from sb!vm:code-constants-offset below header-length do
(let ((entry (aref constants i)))
(etypecase entry
(constant
(handle (gethash info
(fasl-output-entry-table
fasl-output))))
+ (declare (type sb!c::entry-info info))
(cond
(handle
(dump-push handle fasl-output))
(dump-fixups fixups fasl-output)
(dump-fop 'fop-sanctify-for-execution fasl-output)
+
(let ((handle (dump-pop fasl-output)))
(dolist (patch (patches))
(push (cons handle (cdr patch))
(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)))