;; hashtables we use to keep track of dumped constants so that we
;; can get them from the table rather than dumping them again. The
;; EQUAL-TABLE is used for lists and strings, and the EQ-TABLE is
;; hashtables we use to keep track of dumped constants so that we
;; can get them from the table rather than dumping them again. The
;; EQUAL-TABLE is used for lists and strings, and the EQ-TABLE is
;; 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 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.
;; 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.
;; 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.
;;; This structure holds information about a circularity.
(defstruct (circularity (:copier nil))
;; the kind of modification to make to create circularity
;;; This structure holds information about a circularity.
(defstruct (circularity (:copier nil))
;; the kind of modification to make to create circularity
;; the object to be stored at INDEX in OBJECT. This is that the key
;; that we were using when we discovered the circularity.
value
;; the object to be stored at INDEX in OBJECT. This is that the key
;; that we were using when we discovered the circularity.
value
;;; this lobotomizes circularity detection as well, since circular
;;; dumping uses the table.
(defvar *circularities-detected*)
;;; this lobotomizes circularity detection as well, since circular
;;; dumping uses the table.
(defvar *circularities-detected*)
;;; the source code is given by the string WHERE. If BYTE-P is true,
;;; this file will contain no native code, and is thus largely
;;; implementation independent.
;;; the source code is given by the string WHERE. If BYTE-P is true,
;;; this file will contain no native code, and is thus largely
;;; implementation independent.
(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 (length (symbol-name implementation)) res)
(dotimes (i (length (symbol-name implementation)))
(dump-byte (char-code (aref (symbol-name implementation) i)) res)))
;; take a little more care while dumping these.
;; So if better list coalescing is needed, start here.
;; -- WHN 2000-11-07
;; take a little more care while dumping these.
;; So if better list coalescing is needed, start here.
;; -- WHN 2000-11-07
;;;
;;; This is the function used for recursive calls to the fasl dumper.
;;; We don't worry about creating circularities here, since it is
;;;
;;; This is the function used for recursive calls to the fasl dumper.
;;; We don't worry about creating circularities here, since it is
;;; We peek at the object type so that we only pay the circular
;;; detection overhead on types of objects that might be circular.
(defun dump-object (x file)
;;; We peek at the object type so that we only pay the circular
;;; detection overhead on types of objects that might be circular.
(defun dump-object (x file)
;; argument and the number of bytes actually written. I added this
;; assertion while trying to debug portable genesis. -- WHN 19990902
(unless (= code-length nwritten)
;; argument and the number of bytes actually written. I added this
;; assertion while trying to debug portable genesis. -- WHN 19990902
(unless (= code-length nwritten)
;; 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?
;; 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 ((handle (dump-pop fasl-output)))
(dolist (patch (patches))
(push (cons handle (cdr patch))
(let ((handle (dump-pop fasl-output)))
(dolist (patch (patches))
(push (cons handle (cdr patch))
(dolist (entry (sb!c::ir2-component-entries 2comp))
(let ((entry-handle (dump-one-entry entry code-handle file)))
(setf (gethash entry (fasl-output-entry-table file)) entry-handle)
(dolist (entry (sb!c::ir2-component-entries 2comp))
(let ((entry-handle (dump-one-entry entry code-handle file)))
(setf (gethash entry (fasl-output-entry-table file)) entry-handle)
(declare (type sb!c::clambda fun))
(dump-push-previously-dumped-fun fun fasl-output)
(dump-fop 'fop-funcall-for-effect fasl-output)
(declare (type sb!c::clambda fun))
(dump-push-previously-dumped-fun fun fasl-output)
(dump-fop 'fop-funcall-for-effect fasl-output)
#+sb-xc-host
(defun fasl-dump-cold-fset (fun-name fun-dump-handle fasl-output)
(declare (type fixnum fun-dump-handle))
#+sb-xc-host
(defun fasl-dump-cold-fset (fun-name fun-dump-handle fasl-output)
(declare (type fixnum fun-dump-handle))
(dump-non-immediate-object fun-name fasl-output)
(dump-push fun-dump-handle fasl-output)
(dump-fop 'fop-fset fasl-output)
(dump-non-immediate-object fun-name fasl-output)
(dump-push fun-dump-handle fasl-output)
(dump-fop 'fop-fset fasl-output)