;;; -*- indent-tabs-mode: nil -*-

;;; Copyright (c) 2006 David Lichteblau
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation files
;;; (the "Software"), to deal in the Software without restriction,
;;; including without limitation the rights to use, copy, modify, merge,
;;; publish, distribute, sublicense, and/or sell copies of the Software,
;;; and to permit persons to whom the Software is furnished to do so,
;;; subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
;;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
;;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
;;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
;;; SOFTWARE.

(in-package :sb-heapdump)

(sb-alien:define-alien-variable "sizetab" (array (* t) 256))

(defconstant +page-size+
  #+gencgc sb-vm:gencgc-page-size
  #-gencgc sb-c:*backend-page-size*)

(defvar *default-base-address*
    #+gencgc
    ;; by default, target the center of dynamic space
    (logandc2 (/ (+ sb-vm:dynamic-space-start sb-vm:dynamic-space-end) 2)
              (1- +page-size+))
    #-gencgc
    ;; will always relocate anyway
    sb-vm:dynamic-0-space-start)

(defvar *dump-verbose* t)
(defvar *dump-print* nil)

(defstruct
    (ctx (:constructor make-ctx (stream stream-start base-address customizer
                                        &key (worklist (cons nil nil))
                                             (worklist-tail worklist))))
  stream
  stream-start
  base-address
  (position (* 3 +n+))                  ;base address, length, header pointer
  (fixups '())
  (force (make-hash-table))
  customizer
  (addresses (make-hash-table))
  (weak-pointers '())
  (worklist (error "oops"))
  (worklist-tail (error "oops")))

(defmethod print-object ((object ctx) stream)
  (print-unreadable-object (object stream)))

(defvar *disable-customizer* nil)
(defconstant +invalid+ 0)

(defun dump-object
    (object pathname &key (if-exists :error)
                          customizer
                          load-time-customizer
                          force
                          initializer
                          (base-address *default-base-address*)
                          (print-statistics *dump-print*))
  (when (eq if-exists :supersede)
    ;; Argh!  SBCL implements :supersede as O_TRUNC, even though the Hypersec
    ;; says explicitly to create a *new* file under the same name instead
    ;; of overwriting the old one.
    (setf if-exists :rename-and-delete))
  (with-open-file (s pathname
                   :direction :output
                   :element-type '(unsigned-byte 8)
                   :if-does-not-exist :create
                   ;; Argh!  SBCL implements :append as O_APPEND, even though
                   ;; the Hyperspec says to position the file pointer at
                   ;; the end of the file *initially*.
                   :if-exists (if (eq if-exists :append) :overwrite if-exists))
    (when (eq if-exists :append)
      (file-position s (file-length s)))
    (let ((ctx (make-ctx s (file-position s) base-address customizer)))
      (dolist (arg (if (eq force t) (list object) force))
        (setf (gethash arg (ctx-force ctx)) t))
      (dump-all object ctx)
      ;; kludge: wrap the functions in conses, since the header is written
      ;; after the fixups and cannot itself contain fixups.
      (when initializer
        (setf initializer (list initializer))
        (dump-all initializer ctx))
      (when load-time-customizer
        (setf load-time-customizer (list load-time-customizer))
        (dump-all load-time-customizer ctx))
      (update-weak-pointers ctx)
      (unless (integerp (gethash object (ctx-addresses ctx)))
        (error "argument was replaced by a fixup.~_ Use :FORCE to dump ~
                   this object literally:~_ ~A"
               object))
      (let ((*disable-customizer* t))
        (dump-fixups ctx)
        (let* ((header
                (make-header :object object
                             :fixups (ctx-fixups ctx)
                             :customizer load-time-customizer
                             :initializer initializer))
               (header-address (dump-all header ctx))
               (file-length (progn (finish-output s) (file-length s)))
               (length (- file-length (ctx-stream-start ctx)))
               (padding (- (nth-value 1 (ceiling length +page-size+)))))
          (file-position s file-length)
          (dotimes (x padding)
            (write-byte 0 s))
          (seek ctx 0)
          (write-word base-address ctx)
          (write-word (+ length padding) ctx)
          (write-word header-address ctx))
        (when *dump-verbose*
          (format t "~&~D bytes written~%"
                  (- (file-length s) (ctx-stream-start ctx))))
        (when print-statistics
          (print-statistics ctx))))
    pathname))

(defun dump-all (object ctx)
  (prog1
      (sub-dump-object object ctx)
    (loop while (cdr (ctx-worklist ctx)) do
          (pop (ctx-worklist ctx))
          (funcall (car (ctx-worklist ctx))))))

(defconstant +fixup-length+ (* (+ 2 (length (make-fixup nil nil))) +n+))

(defun update-weak-pointers (ctx)
  (dolist (wp (ctx-weak-pointers ctx))
    (multiple-value-bind (value alive)
        (sb-ext:weak-pointer-value wp)
      (let* ((value-address
              (when alive
                (gethash value (ctx-addresses ctx))))
             (wp-pos (- (logandc2 (gethash wp (ctx-addresses ctx))
                                  sb-vm:lowtag-mask)
                        (ctx-base-address ctx))))
        (seek ctx (+ wp-pos +n+))
        (cond
          (value-address
            ;; value has been dumped, write its address
            (write-word value-address ctx))
          (t
            ;; break it
            (write-word (sb-kernel:get-lisp-obj-address nil) ctx)
            (write-word (sb-kernel:get-lisp-obj-address t) ctx)))))))

(defun dump-fixups (ctx)
  (setf (ctx-fixups ctx) (sort (ctx-fixups ctx) #'< :key #'fixup-type))
  (let ((fixups (reverse (ctx-fixups ctx)))
        (fixup-start (align (ctx-position ctx))))
    (setf (ctx-position ctx) fixup-start)
    (dolist (f fixups)
      (setf (gethash f (ctx-addresses ctx))
            (logior (+ (ctx-base-address ctx) (ctx-position ctx))
                    sb-vm:other-pointer-lowtag))
      (incf (ctx-position ctx) +fixup-length+))
    (loop
        for f in fixups
        for pos from fixup-start by +fixup-length+
        do
          (when *dump-print* (trace-fixup f pos))
          (setf (fixup-locations f)
                (coerce
                 (fixup-locations f)
                 `(simple-array (unsigned-byte ,sb-vm:n-word-bits) (*))))
          (funcall (dump-simple-vector f ctx pos t)))))

(defun simplify-type (type)
  (cond
    ((and (listp type)
          (eq (car type) 'simple-array)
          (subtypep (second type) 'integer))
      '(simple-array "subtype of integer"))
    ((and (subtypep type 'simple-array) (listp type))
      (list (car type) "something or other"))
    (t
      type)))

(defun print-statistics (ctx)
  (let* ((n (length *fixup-names*))
         (fixup-types (make-array n :initial-element 0))
         (fixup-locations (make-array n :initial-element 0)))
    (format t "~&fixups by type:~%")
    (dolist (f (ctx-fixups ctx))
      (incf (elt fixup-types (fixup-type f)))
      (incf (elt fixup-locations (fixup-type f)) (length (fixup-locations f))))
    (loop
        for type across *fixup-names*
        for n across fixup-types
        for locations across fixup-locations
        do
          (when (plusp n)
            (format t "~10D  ~A (~D locations)~%" n type locations))))
  (let ((types (make-hash-table :test 'equal)))
    (maphash (lambda (object address)
               (when (integerp address)
                 (incf (gethash (simplify-type (type-of object)) types 0))))
             (ctx-addresses ctx))
    (format t "~&number of objects by type:~%")
    (let ((stats '()))
      (maphash (lambda (type n) (push (cons type n) stats)) types)
      (loop for (type . n) in (sort stats #'> :key #'cdr) do
            (format t "~10D  ~S~%" n type)))))

(defun write-word (object ctx)
  (unless (integerp object)
    (push (tell ctx) (fixup-locations object))
    (setf object +invalid+))
  (%write-word object (ctx-stream ctx)))

(defun %write-word (object s)
  (declare (optimize (sb-ext:inhibit-warnings 3)))
  (if #.(eq sb-c::*backend-byte-order* :big-endian)
      (loop
          for i from (- sb-vm:n-word-bits 8) downto 0 by 8
          do (write-byte (ldb (byte 8 i) object) s))
      (loop
          for i from 0 below sb-vm:n-word-bits by 8
          do (write-byte (ldb (byte 8 i) object) s))))

(defun seek (ctx pos)
  (file-position (ctx-stream ctx) (+ (ctx-stream-start ctx) pos)))

(defun tell (ctx)
  (- (file-position (ctx-stream ctx)) (ctx-stream-start ctx)))

(defun native-address (object)
  (logandc2 (sb-kernel:get-lisp-obj-address object) sb-vm:lowtag-mask))

(defun native-pointer (object)
  (sb-sys:int-sap (native-address object)))

(defun make-header-word (data widetag)
  (logior (ash data sb-vm:n-widetag-bits) widetag))

(defun object-ref-word (object index)
  (sb-sys:without-gcing
   (sb-sys:sap-ref-word (native-pointer object) (* index +n+))))

(defun (setf object-ref-word) (newval object index)
  (sb-sys:without-gcing
   (setf (sb-sys:sap-ref-word (native-pointer object) (* index +n+))
         newval)))

(defun object-ref-lispobj (object index)
  (sb-sys:without-gcing
   (sb-kernel:make-lisp-obj
    (sb-sys:sap-ref-word (native-pointer object) (* index +n+)))))

(defun align (address)
  (- address (nth-value 1 (ceiling address (1+ sb-vm:lowtag-mask)))))

(defun make-address (raw-pointer lowtag)
  (logior raw-pointer lowtag))

(defun forcep (object ctx)
  (or (gethash object (ctx-force ctx))
      (etypecase object
        (package nil)
        (symbol
          (or (null (symbol-package object))
              (forcep (symbol-package object) ctx)))
        (sb-kernel:classoid (forcep (sb-kernel:classoid-name object) ctx))
        (sb-kernel:layout (forcep (sb-kernel:layout-classoid object) ctx))
        (sb-kernel:fdefn
          (let ((name (sb-kernel:fdefn-name object)))
            (or (not (fixupable-function-p
                      (sb-kernel:fdefn-fun object)
                      name
                      ctx))
                ;; fixme: isn't this vaguely like !fixupable-function-p (but
                ;; worse, not exactly the same)?  Should it be?
                (typecase name
                  (symbol (and (symbolp name) (forcep name ctx)))
                  (list
                    (or (some (lambda (x) (and (symbolp x) (forcep x ctx)))
                              name)
                        ;; always dump ctor fdefns
                        (eq 'sb-pcl::ctor (car name))
                        ;; ditto for accessors
                        (eq 'sb-pcl::slot-accessor (car name))))
                  (t nil)))))
        (sb-kernel:named-type
          (let ((name (sb-kernel:named-type-name object)))
            (and (symbolp name) (forcep name ctx))))
        (sb-kernel:array-type
          nil)
        (class
          (or (not (slot-boundp object 'sb-pcl::name)) ;argh.  FIXME!
              (forcep (class-name object) ctx)))
        (function nil))))

(defun slot-accessor-p (gf)
  (let ((x (sb-mop:generic-function-name gf)))
    (and (listp x) (eq (car x) 'sb-pcl::slot-accessor))))

(defun dump-fixup (object ctx)
  (let ((fixup
         (etypecase object
           (package
             (make-fixup +package-fixup+ (package-name object)))
           (symbol
             (make-symbol-fixup
              +symbol-fixup+
              (symbol-package object)
              (symbol-name object)))
           (sb-kernel:classoid
             (make-fixup +classoid-fixup+ (sb-kernel:classoid-name object)))
           (sb-kernel:layout
             (make-fixup +layout-fixup+ (sb-kernel:layout-classoid object)))
           (sb-kernel:fdefn
             (make-fixup +fdefn-fixup+ (sb-kernel:fdefn-name object)))
           (sb-kernel:named-type
             (make-fixup +named-type-fixup+
                         (sb-kernel:named-type-name object)))
           (sb-kernel:array-type
             (make-fixup +array-type-fixup+
                         (list :dimensions
                               (sb-kernel::array-type-dimensions object)
                               :complexp
                               (sb-kernel::array-type-complexp object)
                               :element-type
                               (sb-kernel::array-type-element-type object)
                               :specialized-element-type
                               (sb-kernel::array-type-specialized-element-type
                                object))))
           (class (make-fixup +class-fixup+ (class-name object)))
           (generic-function
             (if (slot-accessor-p object)
                 (make-fixup +slot-accessor-fixup+
                             (sb-mop:generic-function-name object))
                 (make-fixup +function-fixup+
                             (sb-mop:generic-function-name object))))
           (sb-pcl::ctor
             (make-fixup +ctor-fixup+
                         (list* (sb-pcl::ctor-function-name object)
                                (sb-pcl::ctor-class-name object)
                                (sb-pcl::ctor-initargs object))))
           (function
             ;; murmeltypsicheresprachemurmel
             (assert (eql (sb-kernel:widetag-of object)
                          sb-vm:simple-fun-header-widetag))
             (make-fixup +function-fixup+
                         (sb-kernel:%simple-fun-name object))))))
    (setf (gethash object (ctx-addresses ctx)) fixup)
    (%build-fixup fixup ctx)))

(defun %build-fixup (fixup ctx)
  (let ((*disable-customizer* t))
    (sub-dump-object (fixup-id fixup) ctx)
    (sub-dump-object (fixup-id2 fixup) ctx))
  (push fixup (ctx-fixups ctx))
  fixup)

(defun trace-fixup (object pos)
  (format *trace-output* "~&~8,'0X [~A] ~A ~A~{ #x~X~}~%"
          pos
          (elt *fixup-names* (fixup-type object))
          (fixup-id object)
          (fixup-id2 object)
          (fixup-locations object)))

(defun trace-object (object ctx)
  (format *trace-output* "~&~8,'0X " (ctx-position ctx))
  (if (and *disable-customizer*
           (typep object 'simple-vector)
           (not (stringp object))
           (/= (length object)
               (load-time-value (length (make-fixup -1 nil)))))
      (format *trace-output* "[FILE HEADER] ")
      (handler-case
          (write object
                 :stream *trace-output*
                 :pretty nil
                 :escape t
                 :circle t
                 :level 3
                 :length 4)
        (serious-condition (c)
          (ignore-errors (format *trace-output* "printer error: ~A" c)))))
  (fresh-line *trace-output*))

(defun function-name-identifier (name)
  (cond
    ((symbolp name)
      name)
    ((and (listp name)
          (eq (car name) 'setf)
          (symbolp (second name)))
      (second name))))

(defun fixupable-function-p (fn name ctx)
  (let ((id (function-name-identifier name)))
    (and (not (forcep fn ctx))          ;fixme: check other entry-points, too?
         id
         (not (forcep id ctx))
         (not (and (listp name) (eq (car name) 'sb-pcl::fast-method)))
         (let ((fdefn (sb-int:info :function :definition name)))
           (and fdefn (eq fn (sb-kernel:fdefn-fun fdefn)))))))

(defun sub-dump-object (object ctx &key fixup-only)
  (cond
    ;; already seen
    ((gethash object (ctx-addresses ctx)))
    ;; immediate
    ((or (null object)
         (eq object t)
         (evenp (sb-kernel:lowtag-of object)))
      (sb-kernel:get-lisp-obj-address object))
    ;; customizer/user-defined fixups
    ((and (ctx-customizer ctx)
          (not *disable-customizer*)
          (multiple-value-bind (dumpp data1 data2)
              (funcall (ctx-customizer ctx) object)
            (ecase dumpp
              ((t) nil)
              ((nil)
                (setf (gethash object (ctx-addresses ctx))
                      (sub-dump-object data1 ctx :fixup-only fixup-only)))
              (:fixup
                (let ((fixup (make-user-fixup +user-fixup+ data1 data2)))
                  (%build-fixup fixup ctx)
                  (setf (gethash object (ctx-addresses ctx)) fixup)))))))
    ;; other fixup, unless overriden
    ((and (typep object '(or package symbol class sb-kernel:layout
                          sb-kernel:classoid sb-kernel:fdefn
                          sb-kernel:named-type sb-kernel:array-type))
          (not (forcep object ctx)))
      (dump-fixup object ctx))
    ;; functions
    ((and (functionp object)
          (eql (sb-kernel:widetag-of object) sb-vm:simple-fun-header-widetag))
      ;; Funktionsobjekte muessten wir eigentlich dumpen, weil sie nicht
      ;; in dem Sinne eindeutig sind.  Wenn wir aber eine Funktion finden,
      ;; die tatsaechlich so exakt wieder ueber ihren Namen auffindbar ist,
      ;; dumpen wir mal opportunistisch doch ein Fixup um Platz zu sparen.
      ;; In vielen Faellen sollte das so ohnehin richtiger sein.
      (cond
        ((fixupable-function-p object
                               (sb-kernel:%simple-fun-name object)
                               ctx)
          (dump-fixup object ctx))
        (t
          (when fixup-only
            (return-from sub-dump-object nil))
          (sub-dump-object (simple-fun-code-object object) ctx)
          (gethash object (ctx-addresses ctx)))))
    ((and (typep object 'generic-function)
          (slot-boundp object 'sb-pcl::name)
          (or (slot-accessor-p object)  ;never dump slot accessors
              (fixupable-function-p object
                                    (sb-mop:generic-function-name object)
                                    ctx)))
      (dump-fixup object ctx))
    ((typep object 'sb-pcl::ctor)
      ;; never dump ctors
      (dump-fixup object ctx))
    ((eq object sb-impl::*physical-host*)
      (let ((fixup (make-fixup +variable-fixup+ 'sb-impl::*physical-host*)))
        (setf (gethash object (ctx-addresses ctx)) fixup)
        (%build-fixup fixup ctx)))
    ;; ordinary dumpable objects
    (t
      (when fixup-only
        (return-from sub-dump-object nil))
      (setf (ctx-position ctx) (align (ctx-position ctx)))
      (when *dump-print*
        (trace-object object ctx))
      (let* ((pos (ctx-position ctx))
             (address
              (make-address (+ (ctx-base-address ctx) pos)
                            (sb-kernel:lowtag-of object))))
        (setf (gethash object (ctx-addresses ctx)) address)
        (let ((fn (dump-nonfixup object ctx pos)))
          (when fn
            (push fn (cdr (ctx-worklist-tail ctx)))
            (setf (ctx-worklist-tail ctx)
                  (cdr (ctx-worklist-tail ctx)))))
        address))))

(defun dump-nonfixup (object ctx pos)
  (typecase object
    (cons (dump-cons object ctx pos))
    ((or integer single-float double-float (complex single-float)
         (complex double-float) #+long-float (complex long-float)
         sb-sys:system-area-pointer)
      (dump-unboxed object ctx pos))
    ((or symbol ratio complex)
      (dump-boxed object ctx pos))
    (sb-kernel:funcallable-instance
      (dump-funcallable-instance object ctx pos))
    (simple-vector (dump-simple-vector object ctx pos))
    ((simple-array * (*)) (dump-primitive-vector object ctx pos))
    (array (dump-boxed object ctx pos))
    (sb-kernel:instance (dump-instance object ctx pos))
    (sb-kernel:code-component (dump-code-component object ctx pos))
    (function (dump-closure object ctx pos))
    (sb-kernel:fdefn (dump-fdefn object ctx pos))
    (sb-ext:weak-pointer
      (multiple-value-bind (value alive)
          (sb-ext:weak-pointer-value object)
        (prog1
            (dump-unboxed object ctx pos)
          (when alive
            (sub-dump-object value ctx
                             ;; don't dump the actual value here, but
                             ;; if it's fixupable, dump the fixup to avoid
                             ;; breaking the reference needlessly
                             :fixup-only t)
            (push object (ctx-weak-pointers ctx))))))
    (t
      (if (sb-di::indirect-value-cell-p object)
          (dump-boxed object ctx pos)
          (error "cannot dump object ~S" object)))))

(defun dump-cons (object ctx pos)
  (incf (ctx-position ctx) +2n+)
  (lambda ()
    (let ((car (sub-dump-object (car object) ctx))
          (cdr (sub-dump-object (cdr object) ctx)))
      (seek ctx pos)
      (write-word car ctx)
      (write-word cdr ctx))))

(defun dump-boxed (object ctx pos)
  (let ((len (sb-kernel:get-header-data object)))
    (incf (ctx-position ctx) (* (1+ len) +n+))
    (lambda ()
      (let ((slots
             (loop
                 for i from 1 to len
                 collect (sub-dump-object (object-ref-lispobj object i) ctx))))
        (seek ctx pos)
        (write-word (make-header-word len (sb-kernel:widetag-of object)) ctx)
        (dolist (slot slots)
          (write-word slot ctx))))))

(defun dump-funcallable-instance (object ctx pos)
  (let ((len (sb-kernel:get-closure-length object)))
    (incf (ctx-position ctx) (* (1+ len) +n+))
    (lambda ()
      (let ((slots
             (loop
                for i from 1 to len
                collect
                  (sub-dump-object (object-ref-lispobj object i) ctx))))
        (seek ctx pos)
        (write-word (make-header-word len (sb-kernel:widetag-of object)) ctx)
        (dolist (slot slots)
          (write-word slot ctx))))))

(defun dump-unboxed (object ctx pos)
  (let ((len (sb-kernel:get-header-data object)))
    (incf (ctx-position ctx) (* (1+ len) +n+))
    (seek ctx pos)
    (dotimes (i (1+ len))
      (write-word (object-ref-word object i) ctx))
    nil))

(defun dump-simple-vector (object ctx pos &optional fixup)
  (let ((length (length object))
        (header (sb-kernel:get-header-data object)))
    (when (eql header sb-vm:vector-valid-hashing-subtype)
      (let ((fn (sb-impl::hash-table-hash-fun (aref object 0))))
        (when (loop
                  for k being each hash-key in (aref object 0)
                  thereis (nth-value 1 (funcall fn k)))
          (setf header sb-vm:vector-must-rehash-subtype))))
    (unless fixup
      (incf (ctx-position ctx) (* (+ 2 length) +n+)))
    (lambda ()
      (let ((elements (map 'vector
                        (lambda (elt) (sub-dump-object elt ctx))
                        object)))
        (seek ctx pos)
        (write-word (make-header-word header (sb-kernel:widetag-of object))
                    ctx)
        (write-word (sb-vm:fixnumize length) ctx)
        (loop for elt across elements do
              (write-word elt ctx))))))

(defun size-of (object)
  (sb-sys:with-pinned-objects (object)
    (sb-alien:with-alien
        ((fn (* (function sb-alien:long (* t)))
             (sb-sys:sap-ref-sap (sb-alien:alien-sap sizetab)
                                 (* +n+ (sb-kernel:widetag-of object)))))
      (sb-alien:alien-funcall fn (native-pointer object)))))

(defun dump-primitive-vector (object ctx pos)
  (let ((full-length (align (* +n+ (size-of object)))))
    (incf (ctx-position ctx) full-length)
    (seek ctx pos)
    (dotimes (i (truncate full-length +n+))
      (write-word (object-ref-word object i) ctx))
    nil))

(defun dump-instance (instance ctx pos)
  (when (typep instance 'hash-table)
    (assert (not (sb-impl::hash-table-weakness instance))))
  (let* ((len (sb-kernel:%instance-length instance))
         (layout (sb-kernel:%instance-layout instance))
         (nuntagged (sb-kernel:layout-n-untagged-slots layout)))
    (incf (ctx-position ctx) (* (1+ len) +n+))
    (lambda ()
      (let* ((slots
              (loop
                  for i from 0 below (- len nuntagged)
                  collect
                    (sub-dump-object (sb-kernel:%instance-ref instance i)
                                     ctx)))
             (l (pop slots)))
        (seek ctx pos)
        (write-word (make-header-word len sb-vm:instance-header-widetag) ctx)
        (cond
          ((integerp l)
            (write-word l ctx))
          (t
            ;; if replaced with a fixup, store nuntagged here, so that
            ;; relocation knows what to da
            (push (tell ctx) (fixup-locations l))
            (write-word (sb-vm:fixnumize nuntagged) ctx)))
        (dolist (slot slots)
          (write-word slot ctx))
        (dotimes (i nuntagged)
          (write-word
           (sb-kernel:%raw-instance-ref/word instance (- nuntagged i 1))
           ctx))))))

(defun simple-fun-code-object (fun)
  (sb-sys:with-pinned-objects (fun)
    (let* ((fun-sap (native-pointer fun))
           (header-value
            (ash (sb-sys:sap-ref-word fun-sap 0) (- sb-vm:n-widetag-bits))))
      (sb-kernel:make-lisp-obj
       (logior (- (sb-sys:sap-int fun-sap) (* header-value +n+))
               sb-vm:other-pointer-lowtag)))))

;; fixme: can this be done by DUMP-PACKAGE?
(defun note-fast-method-plist (fun ctx) fun ctx
  #+#.(cl:if (cl:find-symbol "METHOD-FUNCTION-PLIST" :sb-pcl) '(and) '(or))
  (let ((plist (sb-pcl::method-function-plist fun)))
    (when plist
      (%build-fixup (make-fast-method-fixup +fast-method-fixup+ fun plist)
                    ctx))))

(defun dump-code-component (code ctx pos)
  (let* ((new-address (+ (ctx-base-address ctx) pos))
         (simple-funs
          (loop
              for fun = (sb-kernel:%code-entry-points code)
                        :then (sb-kernel:%simple-fun-next fun)
              while fun
              collect fun))
         (n-header-words (sb-kernel:get-header-data code))
         (n-code-words (sb-kernel:%code-code-size code))
         (n-bytes (align (* +n+ (+ n-header-words n-code-words)))))
    (incf (ctx-position ctx) n-bytes)
    ;; we register the simple-funs here since they don't dump themselves
    (sb-sys:with-pinned-objects (code)
      (let* ((old-address (native-address code))
             (displacement (- new-address old-address)))
        (dolist (fun simple-funs)
          (setf (gethash fun (ctx-addresses ctx))
                (logior (+ (native-address fun) displacement)
                        sb-vm:fun-pointer-lowtag)))))
    (lambda ()
      (sb-sys:with-pinned-objects (code)
        (let* ((old-address (native-address code))
               (code-sap (sb-sys:int-sap old-address))
               (displacement (- new-address old-address))
               #+x86
               (old-end-address (+ old-address n-bytes))
               (data (make-array n-bytes :element-type '(unsigned-byte 8))))
          ;; grab the whole thing so that fixups will be easier to do
          (dotimes (i n-bytes)
            (setf (elt data i) (sb-sys:sap-ref-8 code-sap i)))
          (labels ((set-word (byte-offset value)
                     (declare (optimize (sb-ext:inhibit-warnings 3)))
                     (unless (integerp value)
                       (push (+ pos byte-offset) (fixup-locations value))
                       (setf value +invalid+))
                     (if #.(eq sb-c::*backend-byte-order* :big-endian)
                         (loop
                             for i from (- sb-vm:n-word-bits 8) downto 0 by 8
                             for j from byte-offset
                             do (setf (elt data j) (ldb (byte 8 i) value)))
                         (loop
                             for i from 0 below sb-vm:n-word-bits by 8
                             for j from byte-offset
                             do (setf (elt data j) (ldb (byte 8 i) value)))))
                   (dump (i)
                     (let ((address
                            (sub-dump-object (object-ref-lispobj code i) ctx)))
                       (set-word (* +n+ i) address))))
            ;; update all descriptors
            (loop
                for i from 1 below n-header-words
                do (dump i))
            (dolist (fun simple-funs)
              (let ((x (truncate (- (native-address fun) old-address) +n+)))
                #+(or x86 x86-64)
                ;; SB-VM:SIMPLE-FUN-SELF-SLOT != SB-KERNEL:%SIMPLE-FUN-SELF
                (set-word (* (1+ x) +n+)
                          (+ (native-address fun)
                             displacement
                             (* sb-vm:simple-fun-code-offset
                                sb-vm:n-word-bytes)))
                #-(or x86 x86-64)
                (dump (1+ x))
                (loop
                    for i from (+ x 2) below (+ x sb-vm:simple-fun-code-offset)
                    do (dump i))))
            (dolist (ref (gethash code *foreign-fixups*))
              (%build-fixup (make-foreign-fixup +foreign-fixup+ ref code)
                            ctx))
            ;; apply fixups
            #+x86
            (let ((fixups
                   (sb-kernel:code-header-ref code sb-vm:code-constants-offset)))
              (cond
                ((typep fixups '(simple-array sb-vm:word (*)))
                  (loop for fixup across fixups do
                        (let* ((offset (+ fixup (* +n+ n-header-words)))
                               (old-value (sb-sys:sap-ref-word code-sap offset))
                               (new-value
                                (if (<= old-address
                                        old-value
                                        (1- old-end-address))
                                    (+ old-value displacement)
                                    (- old-value displacement))))
                          (set-word offset new-value))))
                (t
                  ;; FIXME: happens quite often, so seems to be "normal" in at
                  ;; least some cases.  Should better investigate this though.
                  #+(or)
                  (error "cowardly refusing to dump function without fixup vector")))))
          ;; fixme: can this be done by DUMP-PACKAGE?
          (dolist (fun simple-funs)
            (let ((name (sb-kernel:%simple-fun-name fun)))
              (when (and (listp name) (eq (car name) 'sb-pcl::fast-method))
                (note-fast-method-plist fun ctx))))
          (seek ctx pos)
          (write-sequence data (ctx-stream ctx)))))))

(defun dump-closure (object ctx pos)
  (let ((len (sb-kernel:get-closure-length object)))
    (incf (ctx-position ctx) (* (1+ len) +n+))
    (lambda ()
      (note-fast-method-plist object ctx)
      (let ((fun (sub-dump-object (sb-kernel:%closure-fun object) ctx))
            (slots
             (loop
                 for i from 2 to len
                 collect (sub-dump-object (object-ref-lispobj object i) ctx))))
        #+(or x86 x86-64)
        (cond
          ((integerp fun)
            (setf fun
                  (+ (logandc2 fun sb-vm:lowtag-mask)
                     (* sb-vm:simple-fun-code-offset sb-vm:n-word-bytes))))
          (t
            ;; oops!  fun was replaced by a fixup.  will have to set
            ;; this slot once the fixup has been resolved.
            (setf fun +invalid+)
            (%build-fixup (make-fixup +raw-address-fixup+ object) ctx)))
        (seek ctx pos)
        (write-word (make-header-word len (sb-kernel:widetag-of object)) ctx)
        (write-word fun ctx)
        (dolist (slot slots)
          (write-word slot ctx))))))

(defun dump-fdefn (object ctx pos)
  (let ((len (sb-kernel:get-header-data object)))
    (incf (ctx-position ctx) (* (1+ len) +n+))
    (lambda ()
      (let* ((name (sub-dump-object (sb-kernel:fdefn-name object) ctx))
             (fun (sub-dump-object (sb-kernel:fdefn-fun object) ctx))
             (raw-addr #-sparc (object-ref-word object 3)
                       ;; fixme: is the sparc case right?
                       #+sparc fun))
        #-sparc
        (when
            ;; update raw-addr only if it pointed to fun's raw-addr already,
            ;; because non-simple funs have `closure_tramp' in this slot instead.
            (eql raw-addr
                 (+ (native-address (sb-kernel:fdefn-fun object))
                    (* sb-vm:simple-fun-code-offset sb-vm:n-word-bytes)))
          (cond
            ((integerp fun)
              (setf raw-addr
                    (+ (logandc2 fun sb-vm:lowtag-mask)
                       (* sb-vm:simple-fun-code-offset sb-vm:n-word-bytes))))
            (t
              ;; oops!  fun was replaced by a fixup.  will have to set
              ;; this slot once the fixup has been resolved.
              (setf raw-addr +invalid+)
              (%build-fixup (make-fixup +raw-address-fixup+ object) ctx))))
        (seek ctx pos)
        (write-word (make-header-word len (sb-kernel:widetag-of object)) ctx)
        (write-word name ctx)
        (write-word fun ctx)
        (write-word raw-addr ctx)))))