cold-core disassembly

core-disas.lisp

(defconstant +core-magic+ (logior (ash (char-code #\S) 24)
                                  (ash (char-code #\B) 16)
                                  (ash (char-code #\C) 8)
                                  (char-code #\L)))
(defconstant +build-id-core-entry-type-code+ 3860)
(defconstant +new-directory-core-entry-type-code+ 3861)
(defconstant +initial-fun-core-entry-type-code+ 3863)
(defconstant +page-table-core-entry-type-code+ 3880)
(defconstant +end-core-entry-type-code+ 3840)

(defconstant +dynamic-core-space-id+ 1)
(defconstant +static-core-space-id+ 2)
(defconstant +read-only-core-space-id+ 3)
(defconstant +deflated-core-space-id-flag+ 4)

(defconstant +backend-page-words+ (/ 4096 8))

(defstruct entry
  identifier
  nwords
  data-page
  address
  page-count)

(defun read-entry (stream)
  (make-entry :identifier (read-byte stream)
              :nwords (read-byte stream)
              :data-page (read-byte stream)
              :address (* (read-byte stream) +backend-page-words+)
              :page-count (read-byte stream)))

(defun get-ds (stream)
  (read-byte stream) ;; size
  (loop repeat 3
        for entry = (read-entry stream)
        when (= (entry-identifier entry)
                +dynamic-core-space-id+)
        return entry))

(defun find-initial-function (stream)
  (assert (= (read-byte stream) +core-magic+))
  (let ((fun-start)
        (ds))
    (loop for value = (read-byte stream)
          until (= value +end-core-entry-type-code+)
          do
          (case value
            (#.+new-directory-core-entry-type-code+
             (setf ds (get-ds stream)))
            (#.+initial-fun-core-entry-type-code+
             (read-byte stream) ;; length
             (setf fun-start (read-byte stream)))))
    (let ((start (+ (* +backend-page-words+ (1+ (entry-data-page ds)))
                    (- (/ (- fun-start sb-vm:fun-pointer-lowtag) 8)
                       (entry-address ds)))))
      (file-position stream start)
      (let ((code-offset (ash (read-byte stream) -8)))
        (file-position stream (1+ (- start code-offset)))
        (values (+ start sb-vm:simple-fun-code-offset)
                (- (ash (read-byte stream) (- (+ 3 sb-vm::n-fixnum-tag-bits)))
                   sb-vm:simple-fun-code-offset)
                (+ (- fun-start sb-vm:fun-pointer-lowtag)
                   (* sb-vm:simple-fun-code-offset 8)))))))

(defun copy-init-fun (core)
  (with-open-file (in core :element-type '(unsigned-byte 64))
    (multiple-value-bind (start count memory-fun-start)
        (find-initial-function in)
      (with-open-file (out "/tmp/dis" :direction :output
                                      :if-exists :supersede
                                      :element-type '(unsigned-byte 64))
        (file-position in start)
        (loop repeat count
              do (write-byte (read-byte in) out)))
      memory-fun-start)))

(defun disassemble-core (core)
  (let ((offset (copy-init-fun core)))
    (sb-ext:run-program "objdump" (list "-m" "aarch64" "-b" "binary" "-D" "/tmp/dis"
                                        "--dwarf-start=0" ;; suppreses some superflous output
                                        (format nil "--adjust-vma=~a" offset))
                        :search t
                        :output *standard-output*)))

#+()
(sb-ext:save-lisp-and-die "core-disas"
                          :toplevel
                          (lambda ()
                            (unwind-protect
                                 (let ((arg (cadr sb-ext:*posix-argv*)))
                                   (disassemble-core arg))
                                 (sb-ext:exit)))
                          :executable t
                          :compression t)