(load (merge-pathnames "editcore.lisp" *load-pathname*))

(in-package "SB-EDITCORE")

(defglobal +noexec-stack-note+ ".section .note.GNU-stack, \"\", @progbits")

;;; Emit .byte or .quad directives dumping memory from SAP for COUNT units
;;; (bytes or qwords) to STREAM.  SIZE specifies which direcive to emit.
;;; EXCEPTIONS specify offsets at which a specific string should be
;;; written to the file in lieu of memory contents, useful for emitting
;;; expressions involving the assembler '.' symbol (the current PC).
(defun emit-asm-directives (size sap count stream &optional exceptions)
  (declare (optimize speed))
  (declare (stream stream))
  (let ((*print-base* 16)
        (string-buffer (make-array 18 :element-type 'base-char))
        (fmt #.(coerce "0x%lx" 'base-string))
        (per-line 0))
    (declare ((integer 0 32) per-line)
             (fixnum count))
    string-buffer fmt
    (ecase size
      (:qword
       (format stream " .quad")
       (dotimes (i count)
         (declare ((unsigned-byte 20) i))
         (declare (simple-vector exceptions))
         (write-char (if (> per-line 0) #\, #\space) stream)
         (acond ((and (< i (length exceptions)) (aref exceptions i))
                 (write-string it stream))
                (t
                 (write-string "0x" stream)
                 (write (sap-ref-word sap (* i n-word-bytes)) :stream stream)))
         (when (and (= (incf per-line) 16) (< (1+ i) count))
           (format stream "~% .quad")
           (setq per-line 0))))
      (:byte
       (aver (not exceptions))
       (format stream " .byte")
       (dotimes (i count)
         (write-char (if (> per-line 0) #\, #\space) stream)
         (write-string "0x" stream)
         (write (sap-ref-8 sap i) :stream stream)
         (when (and (= (incf per-line) 32) (< (1+ i) count))
           (format stream "~% .byte")
           (setq per-line 0))))))
  (terpri stream))

#+arm64
(defun list-textual-instructions (sap length core load-addr emit-cfi)
  (declare (ignore emit-cfi))
  (let ((dstate (core-dstate core))
        (spaces (core-spacemap core))
        (seg (core-seg core))
        (list)
        (inst-ldr-reg (load-time-value (find-inst #xF940002A (get-inst-space))))
        (inst-bl (load-time-value (find-inst #x97EC8AEB (get-inst-space))))
        (inst-b (load-time-value (find-inst #x17FFFFE4 (get-inst-space))))
        (inst-adrp (load-time-value (find-inst #xB0FFA560 (get-inst-space))))
        (inst-add (load-time-value (find-inst #x91003F7C (get-inst-space))))
        (adrp-reg/addr nil))
    (setf (seg-virtual-location seg) load-addr
          (seg-length seg) length
          (seg-sap-maker seg) (lambda () sap))
    (map-segment-instructions
     (lambda (dchunk inst)
       (cond
         ((eq inst inst-adrp)
          (let ((reg (ldb (byte 5 0) dchunk))
                (next-dchunk (sb-arm64-asm::current-instruction dstate 4))
                (current-page (ash (dstate-cur-addr dstate) -12))
                (page-displacement
                  (sign-extend (+ (ldb (byte 2 29) dchunk)
                                  (ash (ldb (byte 19 5) dchunk) 2))
                               21)))
            (cond ((and (eq inst-add
                            (find-inst next-dchunk (load-time-value (get-inst-space))))
                        (= reg (ldb (byte 5 0) next-dchunk))
                        (= reg (ldb (byte 5 5) next-dchunk)))
                   ;; Rewrite any ADRP, ADD sequences which compute addresses
                   ;; into the linkage table into references into the GOT.
                   (let ((target-addr (+ (ash (+ current-page page-displacement) 12)
                                         (ldb (byte 12 10) next-dchunk))))
                     (when (or (in-bounds-p target-addr (core-fixedobj-bounds core))
                               (in-bounds-p target-addr (core-linkage-bounds core)))
                       (push (list (dstate-cur-offs dstate)
                                   4    ; length
                                   :adrp-gotpcrel
                                   target-addr
                                   (format nil "x~d" reg))
                             list)
                       (push (list (+ 4 (dstate-cur-offs dstate))
                                   4    ; length
                                   :ldr-gotpcrel
                                   target-addr
                                   (format nil "x~d" reg))
                             list))))
                  ((and (eq inst-ldr-reg
                            (find-inst next-dchunk (load-time-value (get-inst-space))))
                        (= reg (ldb (byte 5 0) next-dchunk))
                        (= reg (ldb (byte 5 5) next-dchunk)))
                   ;; Rewrite any ADRP, LDR sequences which load
                   ;; foreign-dataref addresses into the linkage table
                   ;; into references into the GOT.
                   (let ((target-addr (+ (ash (+ current-page page-displacement) 12)
                                         (ash (ldb (byte 12 10) next-dchunk) word-shift))))
                     (when (or (in-bounds-p target-addr (core-fixedobj-bounds core))
                               (in-bounds-p target-addr (core-linkage-bounds core)))
                       (push (list (dstate-cur-offs dstate)
                                   4    ; length
                                   :adrp-gotpcrel
                                   target-addr
                                   (format nil "x~d" reg))
                             list)
                       (push (list (+ 4 (dstate-cur-offs dstate))
                                   4    ; length
                                   :ldr-gotpcrel
                                   target-addr
                                   (format nil "x~d" reg))
                             list)))))))
         ((or (eq inst inst-bl) (eq inst inst-b))
          ;; Rewrite any BLs which jump to the trampoline in linkage
          ;; space to instead jump directly to the alien function in
          ;; the text section.
          (let ((target-addr (+ (dstate-cur-addr dstate)
                                (* 4 (sign-extend (ldb (byte 26 0) dchunk) 26)))))
            (when (or (in-bounds-p target-addr (core-fixedobj-bounds core))
                      (in-bounds-p target-addr (core-linkage-bounds core)))
              (push (list* (dstate-cur-offs dstate)
                           4            ; length
                           (if (eq inst inst-bl) :bl :b)
                           target-addr)
                    list))))))
     seg
     dstate
     nil)
    (nreverse list)))

;;; Disassemble the function pointed to by SAP for LENGTH bytes, returning
;;; all instructions that should be emitted using assembly language
;;; instead of .quad and/or .byte directives including:
;;; - instructions that manipulate the call frame
;;; - lisp-linkage table JMP, CALL, or LEA
;;; - alien-linkage table CALL or LEA
;;; At execution time the function will have virtual address LOAD-ADDR.
#+x86-64
(defun list-textual-instructions (sap length core load-addr emit-cfi)
  (let ((insts (simple-collect-inst-model sap length load-addr))
        (alien-linkage-end
         (+ (bounds-low (core-linkage-bounds core)) alien-linkage-space-size))
        (result))
    (flet ((pc-relative-ea-p (x)
             (when (consp x) (setq x (car x)))
             (and (typep x 'machine-ea) (eq (machine-ea-base x) :rip)))
           (ea-disp-of (x)
             (when (consp x) (setq x (car x)))
             (machine-ea-disp x)))
      (when (and emit-cfi
                 (equalp (car insts) '(0 pop (#s(machine-ea :disp 8 :base 5) . :qword))))
        (push (list* 0 3 :pop "8(%rbp)") result))
      (do ((insts insts (cdr insts)))
          ((endp insts))
        (let* ((inst (car insts))
               (inst-len (if (cdr insts) (- (caadr insts) (car inst))))
               (ea (car (last inst))))
          (when (or (member (cadr inst) '(sb-x86-64-asm::jmp sb-x86-64-asm::call))
                    (pc-relative-ea-p ea))
            (cond ((and (integerp ea) (in-bounds-p ea (core-linkage-bounds core)))
                   (aver (eq (cadr inst) 'sb-x86-64-asm::call))
                   (aver (< ea alien-linkage-end)) ; CALL via alien linkage
                   (aver (= inst-len 5))
                   (push (list* (car inst) 5 :call ea) result))
                  ((pc-relative-ea-p ea)
                   (let* ((next-pc (+ load-addr (caadr insts)))
                          (ea (+ next-pc (ea-disp-of ea)))
                          (table-offset (- ea alien-linkage-end)))
                     (when (in-bounds-p ea (core-linkage-bounds core))
                       (cond ((< ea alien-linkage-end) ; alien linkage
                              (aver (= inst-len 7))
                              (let ((op (ecase (cadr inst)
                                          (sb-x86-64-asm::mov :mov-gotpcrel)
                                          (sb-x86-64-asm::lea :lea)))
                                    (args (list ea (string-downcase (princ-to-string (third inst))))))
                                (push (list* (car inst) 7 op args) result)))
                             ((eq (cadr inst) 'sb-x86-64-asm::lea)
                              ;; Get ADDRESS of lisp linkage cell in stepping-enabled code
                              (aver (eq (third inst) (get-gpr :qword 0))) ; %rax
                              (aver (= inst-len 7))
                              (push (list* (car inst) 7 :lea (format nil "(fntbl+~d)(%rip),%rax"
                                                                      table-offset))
                                    result))
                             (t ; lisp CALL or JMP
                              (aver (= inst-len 6))
                              (let ((new-inst
                                     (format nil "~a *(fntbl+~d)(%rip)"
                                             (string-downcase (cadr inst))
                                             table-offset)))
                                (push (list* (car inst) 6 :lispcall new-inst) result))))))))))))
      (nreverse result)))

(defun c-linkage-sym-from-addr (addr core)
  (let ((entry-index (/ (- addr (bounds-low (core-linkage-bounds core)))
                        (core-alien-linkage-entry-size core))))
    (setf (bit (core-alien-linkage-symbol-usedp core) entry-index) 1)
    (let ((symbol (aref (core-alien-linkage-symbols core) entry-index)))
      (if (listp symbol)
          (values (car symbol) entry-index t) ; data linkage
          (values symbol entry-index nil))))) ; code linkage

;;; Using assembler directives and/or real mnemonics, dump COUNT bytes
;;; of memory at PADDR (physical addr) to STREAM.
;;; The function's address as per the core file is VADDR.
;;; (Its eventual address is indeterminate)
;;; If EMIT-CFI is true, then also emit cfi directives.
;;;
;;; Notice that we can use one fewer cfi directive than usual because
;;; Lisp always carries a frame pointer as set up by the caller.
;;;
;;; C convention
;;; ============
;;; pushq %rbp
;;; .cfi_def_cfa_offset 16   # CFA offset from default register (rsp) is +16
;;; .cfi_offset 6, -16       # old rbp was saved in -16(CFA)
;;; movq %rsp, %rbp
;;; .cfi_def_cfa_register 6  # use rbp as CFA register
;;;
;;; Lisp convention
;;; ===============
;;; popq 8(%rbp) # place saved %rip in its ABI-compatible stack slot
;;;              # making RSP = RBP after the pop, and RBP = CFA - 16
;;; .cfi_def_cfa 6, 16
;;; .cfi_offset 6, -16
;;;
;;; Of course there is a flip-side to this: unwinders think that the new frame
;;; is already begun in the caller. Interruption between these two instructions:
;;;   MOV RBP, RSP / CALL #xzzzzz
;;; will show the backtrace as if two invocations of the caller are on stack.
;;; This is tricky to fix because while we can relativize the CFA to the
;;; known frame size, we can't do that based only on a disassembly.
(defun emit-lisp-function (paddr vaddr count stream emit-cfi core &optional labels)
  (when emit-cfi
    (format stream " .cfi_startproc~%"))
  ;; Any byte offset that appears as a key in the INSTRUCTIONS causes the indicated
  ;; bytes to be written as an assembly language instruction rather than opaquely,
  ;; thereby affecting the ELF data (cfi or relocs) produced.
  (let ((instructions
         (merge 'list labels
                (list-textual-instructions (int-sap paddr) count core vaddr emit-cfi)
                #'< :key #'car))
        (ptr paddr))
    (symbol-macrolet ((cur-offset (- ptr paddr)))
      (loop
        (let ((until (if instructions (caar instructions) count)))
          ;; if we're not aligned, then write some number of bytes
          ;; to cause alignment. But do not write past the next offset
          ;; that needs to be written as an instruction.
          (when (logtest ptr #x7) ; unaligned
            (let ((n (min (- (nth-value 1 (ceiling ptr 8)))
                          (- until cur-offset))))
              (aver (<= 0 n 7))
              (emit-asm-directives :byte (int-sap ptr) n stream)
              (incf ptr n)))
          ;; Now we're either aligned to a multiple of 8, or the current
          ;; offset needs to be written as a textual instruction.
          (let ((n (- until cur-offset)))
            (aver (>= n 0))
            (multiple-value-bind (qwords remainder) (floor n 8)
              (when (plusp qwords)
                (emit-asm-directives :qword (int-sap ptr) qwords stream #())
                (incf ptr (* qwords 8)))
              (when (plusp remainder)
                (emit-asm-directives :byte (int-sap ptr) remainder stream)
                (incf ptr remainder))))
          ;; If the current offset is COUNT, we're done.
          (when (= cur-offset count) (return))
          (aver (= cur-offset until))
          ;; A label and a textual instruction could co-occur.
          ;; If so, the label must be emitted first.
          (when (eq (cadar instructions) :label)
            (destructuring-bind (c-symbol globalp) (cddr (pop instructions))
              ;; The C symbol is global only if the Lisp name is a legal function
              ;; designator and not random noise.
              ;; This is a technique to try to avoid appending a uniquifying suffix
              ;; on all the junky internal things like "(lambda # in srcfile.lisp)"
              (when emit-cfi
                (format stream "~:[~; .globl ~a~:*~%~] .type ~a, @function~%"
                        globalp c-symbol))
              (format stream "~a:~%" c-symbol)))
          ;; If both a label and textual instruction occur here, handle the latter.
          ;; [This could could be simpler if all labels were emitted as
          ;; '.set "thing", .+const' together in a single place, but it's more readable
          ;; to see them where they belong in the instruction stream]
          (when (and instructions (= (caar instructions) cur-offset))
            (destructuring-bind (length opcode . operand) (cdr (pop instructions))
              (ecase opcode
                (#+arm64 (:bl :b) #+x86-64 (:call)
                 ;; XXX Should this AVER that it is in-bounds?
                 (when (in-bounds-p operand (core-linkage-bounds core))
                   (setq operand (c-linkage-sym-from-addr operand core)))
                 (format stream " ~A ~:[0x~X~;~a~:[~;@PLT~]~]~%"
                                   opcode (stringp operand) operand
                                   #+x86-64
                                   (core-enable-pie core)
                                   #+arm64 nil ; arm64 doesn't need the extra @PLT
                                   ))
                ((#+x86-64 :mov-gotpcrel) ; = get address of alien code linkage entry
                 (let ((c-symbol (c-linkage-sym-from-addr (car operand) core)))
                   (format stream " mov ~A@GOTPCREL(%rip), %~(~A~)~%" c-symbol (cadr operand))))
                ((#+arm64 :adrp-gotpcrel)
                 (let ((c-symbol (c-linkage-sym-from-addr (car operand) core)))
                   (format stream " adrp ~A,:got:~A~%" (cadr operand) c-symbol)))
                ((#+arm64 :ldr-gotpcrel)
                 (let ((c-symbol (c-linkage-sym-from-addr (car operand) core)))
                   (format stream " ldr ~A, [~A, #:got_lo12:~A]~%"
                           (cadr operand) (cadr operand) c-symbol)))
                ((#+x86-64 :lea)
                 ;; The THEN case is to calculate a linkage-table cell address for stepping,
                 ;; the ELSE case is FOREIGN-SYMBOL-SAP
                 (if (stringp operand)
                     (format stream " lea ~A~%" operand) ; the "operand" is the whole instructon
                     (let ((c-symbol (c-linkage-sym-from-addr (car operand) core)))
                       ;; lea becomes "mov" with gotpcrel as src, which will become lea
                       (format stream " mov ~A@GOTPCREL(%rip), %~(~A~)~%" c-symbol (cadr operand)))))
                ((#+x86-64 :pop)
                 (format stream " ~A ~A~%" opcode operand)
                 (cond ((string= operand "8(%rbp)")
                        (format stream " .cfi_def_cfa 6, 16~% .cfi_offset 6, -16~%"))
                       ((string= operand "%rbp")
                                        ;(format stream " .cfi_def_cfa 7, 8~%")
                        nil)
                       (t)))
                ((#+x86-64 :lispcall)
                           ;; the so-called "operand" is the entire instruction
                           (write-string operand stream)
                           (terpri stream)))
              (incf ptr length)))
          (when (= cur-offset count) (return)))))
    (when emit-cfi
      (format stream " .cfi_endproc~%"))
    nil))

(defun c-symbol-quote (name)
  (concatenate 'string '(#\") name '(#\")))

(defun c-name (lispname core pp-state &optional (prefix ""))
  (when (typep lispname '(string 0))
    (setq lispname "anonymous"))
  ;; Perform backslash escaping on the exploded string
  ;; Strings were stringified without surrounding quotes,
  ;; but there might be quotes embedded anywhere, so escape them,
  ;; and also remove newlines and non-ASCII.
  (let ((characters
         (mapcan (lambda (char)
                   (cond ((not (typep char 'base-char)) (list #\?))
                         ((member char '(#\\ #\")) (list #\\ char))
                         ((eql char #\newline) (list #\_))
                         (t (list char))))
                 (coerce (cond
                           #+darwin
                           ((and (stringp lispname)
                                 ;; L denotes a symbol which can not be global on macOS.
                                 (char= (char lispname 0) #\L))
                            (concatenate 'string "_" lispname))
                           (t
                            (write-to-string lispname
                              ;; Printing is a tad faster without a pretty stream
                              :pretty (not (typep lispname 'core-sym))
                              :pprint-dispatch *editcore-ppd*
                              ;; FIXME: should be :level 1, however see
                              ;; https://bugs.launchpad.net/sbcl/+bug/1733222
                              :escape nil :level 2 :length 5
                              :case :downcase :gensym nil
                              :right-margin 10000)))
                         'list))))
    (let ((string (concatenate 'string prefix characters)))
      ;; If the string appears in the linker symbols, then string-upcase it
      ;; so that it looks like a conventional Lisp symbol.
      (cond ((find-if (lambda (x) (string= string (if (consp x) (car x) x)))
                      (core-alien-linkage-symbols core))
             (setq string (string-upcase string)))
            ((string= string ".") ; can't use the program counter symbol either
             (setq string "|.|")))
      ;; If the symbol is still nonunique, add a random suffix.
      ;; The secondary value is whether the symbol should be a linker global.
      ;; For now, make nothing global, thereby avoiding potential conflicts.
      (let ((occurs (incf (gethash string (car pp-state) 0))))
        (if (> occurs 1)
            (values (concatenate 'string  string "_" (write-to-string occurs))
                    nil)
            (values string
                    nil))))))

(defun emit-symbols (blobs core pp-state output &aux base-symbol)
  (dolist (blob blobs base-symbol)
    (destructuring-bind (name start . end) blob
      (let ((c-name (c-name (or name "anonymous") core pp-state)))
        (unless base-symbol
          (setq base-symbol c-name))
        (format output " lsym \"~a\", 0x~x, 0x~x~%"
                c-name start (- end start))))))

(defun emit-funs (code vaddr core dumpwords output base-symbol emit-cfi)
  (let* ((ranges (get-text-ranges code core))
         (text-sap (code-instructions code))
         (text (sap-int text-sap))
         ;; Like CODE-INSTRUCTIONS, but where the text virtually was
         (text-vaddr (+ vaddr (* (code-header-words code) n-word-bytes)))
         (max-end 0))
    ;; There is *always* at least 1 word of unboxed data now
    (aver (eq (caar ranges) :data))
    (let ((jump-table-size (code-jump-table-words code))
          (total-nwords (cdr (pop ranges))))
      (cond ((> jump-table-size 1)
             (format output "# jump table~%")
             (format output ".quad ~d" (sap-ref-word text-sap 0))
             (dotimes (i (1- jump-table-size))
               (format output ",\"~a\"+0x~x"
                       base-symbol
                       (- (sap-ref-word text-sap (ash (1+ i) word-shift))
                          vaddr)))
             (terpri output)
             (let ((remaining (- total-nwords jump-table-size)))
               (when (plusp remaining)
                 (funcall dumpwords
                          (sap+ text-sap (ash jump-table-size word-shift))
                          remaining output))))
            (t
             (funcall dumpwords text-sap total-nwords output))))
    (loop
      (destructuring-bind (start . end) (pop ranges)
        (setq max-end end)
        ;; FIXME: it seems like this should just be reduced to emitting 2 words
        ;; now that simple-fun headers don't hold any boxed words.
        ;; (generality here is without merit)
        (funcall dumpwords (sap+ text-sap start) simple-fun-insts-offset output
                 #(nil #.(format nil ".+~D" (* (1- simple-fun-insts-offset)
                                             n-word-bytes))))
        (incf start (* simple-fun-insts-offset n-word-bytes))
        ;; Pass the current physical address at which to disassemble,
        ;; the notional core address (which changes after linker relocation),
        ;; and the length.
        (emit-lisp-function (+ text start) (+ text-vaddr start) (- end start)
                            output emit-cfi core)
        (cond ((not ranges) (return))
              ((eq (caar ranges) :pad)
               (format output " .byte ~{0x~x~^,~}~%"
                       (loop for i from 0 below (cdr (pop ranges))
                             collect (sap-ref-8 text-sap (+ end i))))))))
    ;; Emit bytes from the maximum function end to the object end.
    ;; We can't just round up %CODE-CODE-SIZE to a double-lispword
    ;; because the boxed header could end at an odd word, requiring that
    ;; the unboxed bytes have an odd size in words making the total even.
    (format output " .byte ~{0x~x~^,~}~%"
            (loop for i from max-end
                  below (- (code-object-size code)
                           (* (code-header-words code) n-word-bytes))
                  collect (sap-ref-8 text-sap i)))
    nil))

(defconstant +gf-name-slot+ 5)

(defun output-bignum (label bignum stream)
  (let ((nwords (sb-bignum:%bignum-length bignum)))
    (format stream "~@[~a:~] .quad 0x~x"
            label (logior (ash nwords 8) bignum-widetag))
    (dotimes (i nwords)
      (format stream ",0x~x" (sb-bignum:%bignum-ref bignum i)))
    (when (evenp nwords) ; pad
      (format stream ",0"))
    (format stream "~%")))

(defconstant core-align #+x86-64 4096 #+arm64 65536)

(defun write-preamble (output n-lisp-linkage-words)
  #+linkage-space (format output "  .local fntbl
 .comm fntbl,~D,8
 .globl lisp_function_linkage_table
 .equiv lisp_function_linkage_table, fntbl
" (* n-lisp-linkage-words n-word-bytes))
  (format output " .text~% .file \"sbcl.core\"
~:[~; .macro .size sym size # ignore
 .endm
 .macro .type sym type # ignore
 .endm~]
 .macro lasmsym name size
 .set \"\\name\", .
 .size \"\\name\", \\size
 .type \"\\name\", function
 .endm
 .macro lsym name start size
 .set \"\\name\", . + \\start
 .size \"\\name\", \\size
 .type \"\\name\", function
 .endm
 .globl ~alisp_code_start, ~alisp_jit_code, ~alisp_code_end
 .balign ~a~%~alisp_code_start:~%CS: # code space~%"
          (member :darwin *features*)
          label-prefix label-prefix label-prefix
          core-align
          label-prefix))

(defun output-lisp-asm-routines (core spacemap code-addr n-lisp-linkage-words output &aux (skip 0))
  (write-preamble output n-lisp-linkage-words)
  (dotimes (i 2)
    (let* ((paddr (int-sap (translate-ptr code-addr spacemap)))
           (word (sap-ref-word paddr 0)))
      ;; After running the converter which moves dynamic-space code to text space,
      ;; the text space starts with an array of uint32 for the offsets to each object
      ;; and an array of uint64 containing some JMP instructions.
      (unless (or (= (%widetag-of word) simple-array-unsigned-byte-32-widetag)
                  (= (%widetag-of word) simple-array-unsigned-byte-64-widetag))
        (return))
      (let* ((array (%make-lisp-obj (logior (sap-int paddr) other-pointer-lowtag)))
             (size (primitive-object-size array))
             (nwords (ash size (- word-shift))))
        (dotimes (i nwords)
          (format output "~A 0x~x"
                  (case (mod i 8)
                    (0 #.(format nil "~% .quad"))
                    (t ","))
                  (sap-ref-word paddr (ash i word-shift))))
        (terpri output)
        (incf skip size)
        (incf code-addr size))))
  (let* ((code-component (make-code-obj code-addr spacemap))
         (obj-sap (int-sap (- (get-lisp-obj-address code-component)
                              other-pointer-lowtag)))
         (header-len (code-header-words code-component))
         (jump-table-count (sap-ref-word (code-instructions code-component) 0)))
    ;; Write the code component header
    (format output "lar: # lisp assembly routines~%")
    (emit-asm-directives :qword obj-sap header-len output #())
    ;; Write the jump table
    (format output " .quad ~D" jump-table-count)
    (dotimes (i (1- jump-table-count))
      (format output ",lar+0x~x"
              (- (sap-ref-word (code-instructions code-component)
                               (ash (1+ i) word-shift))
                 code-addr)))
    (terpri output)
    (let ((name->addr
           ;; the CDR of each alist item is a target cons (needing translation)
           (sort
            (mapcar (lambda (entry &aux (name (translate (undescriptorize (car entry)) spacemap)) ; symbol
                                   ;; VAL is (start end . index)
                                   (val (translate (undescriptorize (cdr entry)) spacemap))
                                   (start (car val))
                                   (end (car (translate (cdr val) spacemap))))
                      (list* (translate (symbol-name name) spacemap) start end))
                    (target-hash-table-alist (%code-debug-info code-component) spacemap))
            #'< :key #'cadr)))
      ;; Possibly unboxed words and/or padding
      (let ((here (ash jump-table-count word-shift))
            (first-entry-point (cadar name->addr)))
        (when (> first-entry-point here)
          (format output " .quad ~{0x~x~^,~}~%"
                  (loop for offs = here then (+ offs 8)
                        while (< offs first-entry-point)
                        collect (sap-ref-word (code-instructions code-component) offs)))))
      ;; Loop over the embedded routines
      (let ((list name->addr)
            (obj-size (code-object-size code-component)))
        (loop
          (destructuring-bind (name start-offs . end-offs) (pop list)
            (let ((nbytes (- (if (endp list)
                                 (- obj-size (* header-len n-word-bytes))
                                 (1+ end-offs))
                             start-offs)))
              (format output " lasmsym ~(\"~a\"~), ~d~%" name nbytes)
              (let ((fixups
                     (emit-lisp-function
                      (+ (sap-int (code-instructions code-component))
                         start-offs)
                      (+ code-addr
                         (ash (code-header-words code-component) word-shift)
                         start-offs)
                      nbytes output nil core)))
                (aver (null fixups)))))
          (when (endp list) (return)))
        (format output "~%# end of lisp asm routines~2%")
        (+ skip obj-size)))))

;;; Return a list of ((NAME START . END) ...)
;;; for each C symbol that should be emitted for this code object.
;;; Start and and are relative to the object's base address,
;;; not the start of its instructions. Hence we add HEADER-BYTES
;;; too all the PC offsets.
(defun code-symbols (code core)
  (let* ((fun-map (extract-fun-map code core))
         (header-bytes (* (code-header-words code) n-word-bytes))
         (start-pc 0)
         (i 1)
         (len (length fun-map))
         (blobs))
    (loop
      (let* ((name (remove-name-junk
                    (sb-c::compiled-debug-fun-name (svref fun-map (1- i)))))
             (end-pc (if (= i len)
                         (code-object-size code)
                         (+ header-bytes (svref fun-map i)))))
        (unless (= end-pc start-pc)
          ;; Collapse adjacent address ranges named the same.
          ;; Use EQUALP instead of EQUAL to compare names
          ;; because instances of CORE-SYMBOL are not interned objects.
          (if (and blobs (equalp (caar blobs) name))
              (setf (cddr (car blobs)) end-pc)
              (push (list* name start-pc end-pc) blobs)))
        (when (= i len)
          (return))
        (setq start-pc end-pc))
      (incf i 2))
    (nreverse blobs)))

;;; Convert immobile text space to an assembly file in OUTPUT.
(defun write-asm-file
    (spacemap linkage-space-info output
     &optional enable-pie (emit-cfi t)
     &aux (code-bounds (space-bounds immobile-text-core-space-id spacemap))
          (fixedobj-bounds (space-bounds immobile-fixedobj-core-space-id spacemap))
          (core (make-core spacemap code-bounds fixedobj-bounds
                           :enable-pie enable-pie :linkage-space-info linkage-space-info))
          (code-addr (bounds-low code-bounds))
          (total-code-size 0)
          (pp-state (cons (make-hash-table :test 'equal) nil))
          (prev-namestring "")
          (n-linker-relocs 0)
          (temp-output (make-string-output-stream :element-type 'base-char))
          end-loc)
  (labels ((dumpwords (sap count stream &optional (exceptions #()) logical-addr)
             (aver (sap>= sap (car spacemap)))
             ;; Add any new "header exceptions" that cause intra-code-space pointers
             ;; to be computed at link time
             (dotimes (i (if logical-addr count 0))
               (unless (and (< i (length exceptions)) (svref exceptions i))
                 (let ((word (sap-ref-word sap (* i n-word-bytes))))
                   (when (and (= (logand word 3) 3) ; is a pointer
                              (in-bounds-p word code-bounds)) ; to code space
                     #+nil
                     (format t "~&~(~x: ~x~)~%" (+ logical-addr  (* i n-word-bytes))
                             word)
                     (incf n-linker-relocs)
                     (setf exceptions (adjust-array exceptions (max (length exceptions) (1+ i))
                                                    :initial-element nil)
                           (svref exceptions i)
                           (format nil "CS+0x~x"
                                   (- word (bounds-low code-bounds))))))))
             (emit-asm-directives :qword sap count stream exceptions)))

    (let ((skip (output-lisp-asm-routines core spacemap code-addr
                                          (linkage-space-count linkage-space-info)
                                          output)))
      (incf code-addr skip)
      (incf total-code-size skip))
    (loop
      (when (>= code-addr (bounds-high code-bounds))
        (setq end-loc code-addr)
        (return))
      (ecase (%widetag-of (sap-ref-word (int-sap (translate-ptr code-addr spacemap)) 0))
        (#.code-header-widetag
         (let* ((code (make-code-obj code-addr spacemap))
                (objsize (code-object-size code)))
           (incf total-code-size objsize)
           (cond
             ((%instancep (%code-debug-info code)) ; assume it's a COMPILED-DEBUG-INFO
              (aver (plusp (code-n-entries code)))
              (let* ((source
                      (sb-c::compiled-debug-info-source
                       (truly-the sb-c::compiled-debug-info
                                  (translate (%code-debug-info code) spacemap))))
                     (namestring
                      (sb-c::debug-source-namestring
                       (truly-the sb-c::debug-source (translate source spacemap)))))
                (setq namestring (if (core-null-p namestring)
                                     "sbcl.core"
                                     (translate namestring spacemap)))
                (unless (string= namestring prev-namestring)
                  (format output " .file \"~a\"~%" namestring)
                  (setq prev-namestring namestring)))
              (let ((code-physaddr (logandc2 (get-lisp-obj-address code) lowtag-mask)))
                (format output "#x~x:~%" code-addr)
                ;; Emit symbols before the code header data, because the symbols
                ;; refer to "." (the current PC) which is the base of the object.
                (let* ((base (emit-symbols (code-symbols code core) core pp-state output))
                       (altered-fixups
                        (emit-funs code code-addr core #'dumpwords temp-output base emit-cfi))
                       (header-exceptions (vector nil nil nil nil)))
                  (aver (null altered-fixups))
                  (dumpwords (int-sap code-physaddr)
                             (code-header-words code) output header-exceptions code-addr)
                  (write-string (get-output-stream-string temp-output) output))))
             (t
              (error "Strange code component: ~S" code)))
           (incf code-addr objsize)))
        (#.filler-widetag
         (let* ((word (sap-ref-word (int-sap (translate-ptr code-addr spacemap)) 0))
                (nwords (ash word -32))
                (nbytes (* nwords n-word-bytes)))
           (format output " .quad 0x~x~% .fill ~d~%" word (- nbytes n-word-bytes))
           (incf code-addr nbytes)))
        ;; This is a trailing array which contains a jump instruction for each
        ;; element of *C-LINKAGE-REDIRECTS* (see "rewrite-asmcalls.lisp").
        (#.simple-array-unsigned-byte-64-widetag
         (let* ((paddr (translate-ptr code-addr spacemap))
                (array (%make-lisp-obj (logior paddr other-pointer-lowtag)))
                (nwords (+ vector-data-offset (align-up (length array) 2))))
           (format output "# alien linkage redirects:~% .quad")
           (dotimes (i nwords (terpri output))
             (format output "~a0x~x" (if (= i 0) " " ",")
                     (sap-ref-word (int-sap paddr) (ash i word-shift))))
           (incf code-addr (ash nwords word-shift))
           (setq end-loc code-addr)
           (return))))))

  ;; coreparse uses the 'lisp_jit_code' symbol to set text_space_highwatermark
  ;; The intent is that compilation to memory can use this reserved area
  ;; (if space remains) so that profilers can associate a C symbol with the
  ;; program counter range. It's better than nothing.
  (format output "~a:~%" (labelize "lisp_jit_code"))

  ;; Pad so that non-lisp code can't be colocated on a GC page.
  ;; (Lack of Lisp object headers in C code is the issue)
  (let ((aligned-end (align-up end-loc core-align)))
    (when (> aligned-end end-loc)
      (multiple-value-bind (nwords remainder)
          (floor (- aligned-end end-loc) n-word-bytes)
        (aver (>= nwords 2))
        (aver (zerop remainder))
        (decf nwords 2)
        (format output " .quad 0x~x, ~d # (simple-array fixnum (~d))~%"
                simple-array-fixnum-widetag
                (ash nwords n-fixnum-tag-bits)
                nwords)
        (when (plusp nwords)
          (format output " .fill ~d~%" (* nwords n-word-bytes))))))
  ;; Extend with 1 MB of filler
  (format output " .fill ~D~%~alisp_code_end:
 .size lisp_jit_code, .-lisp_jit_code~%"
          (* 1024 1024) label-prefix)
  (values core total-code-size n-linker-relocs))

;;;; ELF file I/O

(defconstant +sht-null+     0)
(defconstant +sht-progbits+ 1)
(defconstant +sht-symtab+   2)
(defconstant +sht-strtab+   3)
(defconstant +sht-rela+     4)
(defconstant +sht-rel+      9)

(define-alien-type elf64-ehdr
  (struct elf64-edhr
    (ident     (array unsigned-char 16)) ; 7F 45 4C 46 2 1 1 0 0 0 0 0 0 0 0 0
    (type      (unsigned 16))   ; 1 0
    (machine   (unsigned 16))   ; 3E 0
    (version   (unsigned 32))   ; 1 0 0 0
    (entry     unsigned)        ; 0 0 0 0 0 0 0 0
    (phoff     unsigned)        ; 0 0 0 0 0 0 0 0
    (shoff     unsigned)        ;
    (flags     (unsigned 32))   ; 0 0 0 0
    (ehsize    (unsigned 16))   ; 40 0
    (phentsize (unsigned 16))   ;  0 0
    (phnum     (unsigned 16))   ;  0 0
    (shentsize (unsigned 16))   ; 40 0
    (shnum     (unsigned 16))   ;  n 0
    (shstrndx  (unsigned 16)))) ;  n 0
(defconstant ehdr-size (ceiling (alien-type-bits (parse-alien-type 'elf64-ehdr nil)) 8))
(define-alien-type elf64-shdr
  (struct elf64-shdr
    (name      (unsigned 32))
    (type      (unsigned 32))
    (flags     (unsigned 64))
    (addr      (unsigned 64))
    (off       (unsigned 64))
    (size      (unsigned 64))
    (link      (unsigned 32))
    (info      (unsigned 32))
    (addralign (unsigned 64))
    (entsize   (unsigned 64))))
(defconstant shdr-size (ceiling (alien-type-bits (parse-alien-type 'elf64-shdr nil)) 8))
(define-alien-type elf64-sym
  (struct elf64-sym
    (name  (unsigned 32))
    (info  (unsigned 8))
    (other (unsigned 8))
    (shndx (unsigned 16))
    (value unsigned)
    (size  unsigned)))
(define-alien-type elf64-rela
  (struct elf64-rela
    (offset (unsigned 64))
    (info   (unsigned 64))
    (addend (signed 64))))

(defun make-elf64-sym (name info)
  (let ((a (make-array 24 :element-type '(unsigned-byte 8) :initial-element 0)))
    (with-pinned-objects (a)
      (setf (sap-ref-32 (vector-sap a) 0) name
            (sap-ref-8 (vector-sap a) 4) info))
    a))

;;; Return two values: an octet vector comprising a string table
;;; and an alist which maps string to offset in the table.
(defun string-table (strings)
  (let* ((length (+ (1+ (length strings)) ; one more null than there are strings
                    (reduce #'+ strings :key #'length))) ; data length
         (bytes (make-array length :element-type '(unsigned-byte 8)
                            :initial-element 0))
         (index 1)
         (alist))
    (dolist (string strings)
      (push (cons string index) alist)
      (replace bytes (map 'vector #'char-code string) :start1 index)
      (incf index (1+ (length string))))
    (cons (nreverse alist) bytes)))

(defun write-alien (alien size stream)
  (dotimes (i size)
    (write-byte (sap-ref-8 (alien-value-sap alien) i) stream)))

;;; core header should be an array of words in '.rodata', not a 32K page
(defconstant core-header-size +backend-page-bytes+) ; stupidly large (FIXME)

(defconstant e-machine #+x86-64 #x3E #+arm64 #xB7)

(defun write-elf-header (shdrs-start sections output)
  (let ((shnum (1+ (length sections)))  ; section 0 is implied
        (shstrndx (1+ (position :str sections :key #'car)))
        (ident #.(coerce '(#x7F #x45 #x4C #x46 2 1 1 0 0 0 0 0 0 0 0 0)
                         '(array (unsigned-byte 8) 1))))
    (with-alien ((ehdr elf64-ehdr))
      (dotimes (i (ceiling ehdr-size n-word-bytes))
        (setf (sap-ref-word (alien-value-sap ehdr) (* i n-word-bytes)) 0))
      (with-pinned-objects (ident)
        (%byte-blt (vector-sap ident) 0 (alien-value-sap ehdr) 0 16))
      (setf (slot ehdr 'type)      1
            (slot ehdr 'machine)   e-machine
            (slot ehdr 'version)   1
            (slot ehdr 'shoff)     shdrs-start
            (slot ehdr 'ehsize)    ehdr-size
            (slot ehdr 'shentsize) shdr-size
            (slot ehdr 'shnum)     shnum
            (slot ehdr 'shstrndx)  shstrndx)
      (write-alien ehdr ehdr-size output))))

(defun write-section-headers (placements sections string-table output)
  (with-alien ((shdr elf64-shdr))
    (dotimes (i (ceiling shdr-size n-word-bytes)) ; Zero-fill
      (setf (sap-ref-word (alien-value-sap shdr) (* i n-word-bytes)) 0))
    (dotimes (i (1+ (length sections)))
      (when (plusp i) ; Write the zero-filled header as section 0
        (destructuring-bind (name type flags link info alignment entsize)
            (cdr (aref sections (1- i)))
          (destructuring-bind (offset . size)
              (pop placements)
            (setf (slot shdr 'name)  (cdr (assoc name (car string-table)))
                  (slot shdr 'type)  type
                  (slot shdr 'flags) flags
                  (slot shdr 'off)   offset
                  (slot shdr 'size)  size
                  (slot shdr 'link)  link
                  (slot shdr 'info)  info
                  (slot shdr 'addralign) alignment
                  (slot shdr 'entsize) entsize))))
      (write-alien shdr shdr-size output))))

(defconstant sym-entry-size 24)

;;; Write everything except for the core file itself into OUTPUT-STREAM
;;; and leave the stream padded to a 4K boundary ready to receive data.
(defun prepare-elf (core-size relocs output pie)
  ;; PIE uses coreparse relocs which are 8 bytes each, and no linker relocs.
  ;; Otherwise, linker relocs are 24 bytes each.
  (let* ((reloc-entry-size (if pie 8 24))
         (sections
          ;;        name | type | flags | link | info | alignment | entry size
          `#((:core "lisp.core"       ,+sht-progbits+ 0 0 0 ,core-align 0)
             (:sym  ".symtab"         ,+sht-symtab+   0 3 1 8 ,sym-entry-size)
                          ; section with the strings -- ^ ^ -- 1+ highest local symbol
             (:str  ".strtab"         ,+sht-strtab+   0 0 0 1  0)
             (:rel
              ,@(if pie
              ;; Don't bother with an ELF reloc section; it won't do any good.
              ;; It would apply at executable link time, which is without purpose,
              ;; it just offsets the numbers based on however far the lisp.core
              ;; section is into the physical file. Non-loaded sections don't get
              ;; further relocated on execution, so 'coreparse' has to fix the
              ;; entire dynamic space at execution time anyway.
                  `("lisp.rel"        ,+sht-progbits+ 0 0 0 8 8)
                  `(".relalisp.core"  ,+sht-rela+     0 2 1 8 ,reloc-entry-size)))
                                      ; symbol table -- ^ ^ -- for which section
             (:note ".note.GNU-stack" ,+sht-progbits+ 0 0 0 1  0)))
         (extern-c-symbols
          '("lisp_code_start" #+linkage-space "lisp_function_linkage_table"))
         (string-table
          (string-table (append extern-c-symbols (map 'list #'second sections))))
         (strings (cdr string-table))
         (padded-strings-size (align-up (length strings) 8))
         ;; 0th symbol is always for string table index 0
         (symbols-size (* (1+ (length extern-c-symbols)) sym-entry-size))
         (shdrs-start (+ ehdr-size symbols-size padded-strings-size))
         (shdrs-end (+ shdrs-start (* (1+ (length sections)) shdr-size)))
         (relocs-size (* (length relocs) reloc-entry-size))
         (relocs-end (+ shdrs-end relocs-size))
         (core-start (align-up relocs-end core-align)))

    (write-elf-header shdrs-start sections output)

    ;; Write symbol table
    (aver (eql (file-position output) ehdr-size))
    (write-sequence (make-elf64-sym 0 0) output)
    (dolist (sym extern-c-symbols)
      (let ((string-table-index (cdr (assoc sym (car string-table) :test 'string=))))
        ;; The symbol type is #x10 given:
        ;;      #define STB_GLOBAL 1
        ;;   and: #define ELF32_ST_BIND(val) ((unsigned char) (val)) >> 4)
        ;; which places the binding in the high 4 bits of the low byte.
        (write-sequence (make-elf64-sym string-table-index #x10) output)))

    ;; Write string table
    (aver (eql (file-position output) (+ ehdr-size symbols-size)))
    (write-sequence strings output) ; an octet vector at this point
    (dotimes (i (- padded-strings-size (length strings)))
      (write-byte 0 output))

    ;; Write section headers
    (aver (eql (file-position output) shdrs-start))
    (write-section-headers
     (map 'list
          (lambda (x)
            (ecase (car x)
              (:note '(0 . 0))
              (:sym  (cons ehdr-size symbols-size))
              (:str  (cons (+ ehdr-size symbols-size) (length strings)))
              (:rel  (cons shdrs-end relocs-size))
              (:core (cons core-start core-size))))
          sections)
     sections string-table output)

    ;; Write relocations
    (aver (eql (file-position output) shdrs-end))
    (let ((buf (make-array relocs-size :element-type '(unsigned-byte 8)))
          (ptr 0))
      (if pie
          (dovector (reloc relocs)
            (setf (%vector-raw-bits buf ptr) reloc)
            (incf ptr))
          (with-alien ((rela elf64-rela))
            (dovector (r relocs)
              (declare (type (simple-vector 4) r))
              (let ((kind (aref r 0)) (place (aref r 1)) (symbol (aref r 2)) (addend (aref r 3)))
                (setf (slot rela 'offset) place
                      (slot rela 'info)   (logior (ash symbol 32) kind)
                      (slot rela 'addend) addend))
              (setf (%vector-raw-bits buf (+ ptr 0)) (sap-ref-word (alien-value-sap rela) 0)
                    (%vector-raw-bits buf (+ ptr 1)) (sap-ref-word (alien-value-sap rela) 8)
                    (%vector-raw-bits buf (+ ptr 2)) (sap-ref-word (alien-value-sap rela) 16))
              (incf ptr 3))))
      (write-sequence buf output))

    ;; Write padding
    (dotimes (i (- core-start (file-position output)))
      (write-byte 0 output))
    (aver (eq (file-position output) core-start))))

(defconstant R_ABS64 #+x86-64 1 #+arm64 257) ; /* Direct 64 bit  */
(defconstant R_ABS32 #+x86-64 10 #+arm64 258) ; /* Direct 32 bit zero extended */

;;; Fill in the FIXUPS vector with a list of places to fixup.
;;; For PIE-enabled cores, each place is just a virtual address.
;;; For non-PIE-enabled, the fixup corresponds to an ELF relocation which will be
;;; applied at link time of the excutable.
;;; Note that while this "works" for PIE, it is fairly inefficient because
;;; fundamentally Lisp objects contain absolute pointers, and there may be
;;; millions of words that need fixing at load (execution) time.
;;; Several techniques can mitigate this:
;;; * for funcallable-instances, put a second copy of funcallable-instance-tramp
;;;   in dynamic space so that funcallable-instances can jump to a known address.
;;; * for each closure, create a one-instruction trampoline in dynamic space,
;;;   - embedded in a (simple-array word) perhaps - which jumps to the correct
;;;   place in the text section. Point all closures over the same function
;;;   to the new closure stub. The trampoline, being pseudostatic, is effectively
;;;   immovable. (And you can't re-save from an ELF core)
;;; * for arbitrary pointers to simple-funs, create a proxy simple-fun in dynamic
;;;   space whose entry point is the real function in the ELF text section.
;;;   The GC might have to learn how to handle simple-funs that point externally
;;;   to themselves. Also there's a minor problem of hash-table test functions
;;; The above techniques will reduce by a huge factor the number of fixups
;;; that need to be applied on startup of a position-independent executable.
;;;
(defun collect-relocations (spacemap fixups pie &key (verbose nil) (print nil))
  (let* ((code-bounds (space-bounds immobile-text-core-space-id spacemap))
         (code-start (bounds-low code-bounds))
         (n-abs 0)
         (n-rel 0)
         (affected-pages (make-hash-table)))
    (labels
        ((abs-fixup (vaddr core-offs referent)
           (incf n-abs)
           (when print
             (format t "~x = 0x~(~x~): (a)~%" core-offs vaddr #+nil referent))
           (touch-core-page core-offs)
           ;; PIE relocations are output as a file section that is
           ;; interpreted by 'coreparse'. The addend is implicit.
           (setf (sap-ref-word (car spacemap) core-offs)
                 (if pie
                     (+ (- referent code-start) +code-space-nominal-address+)
                     0))
           (if pie
               (vector-push-extend vaddr fixups)
               (vector-push-extend
                ;; #(kind, where symbol-index addend)
                `#(,R_ABS64 ,(+ core-header-size core-offs) 1 ,(- referent code-start))
                fixups)))
         (touch-core-page (core-offs)
           ;; use the OS page size, not +backend-page-bytes+
           (setf (gethash (floor core-offs core-align) affected-pages) t))
         ;; Given a address which is an offset into the data pages of the target core,
         ;; compute the logical address which that offset would be mapped to.
         ;; For example core address 0 is the virtual address of static space.
         (core-to-logical (core-offs &aux (page (floor core-offs +backend-page-bytes+)))
           (setf (gethash page affected-pages) t)
           (dolist (space (cdr spacemap)
                          (bug "Can't translate core offset ~x using ~x"
                               core-offs spacemap))
             (let* ((page0 (space-data-page space))
                    (nwords (space-nwords space))
                    (id (space-id space))
                    (npages (ceiling nwords (/ +backend-page-bytes+ n-word-bytes))))
               (when (and (<= page0 page (+ page0 (1- npages)))
                          (/= id immobile-text-core-space-id))
                 (return (+ (space-addr space)
                            (* (- page page0) +backend-page-bytes+)
                            (logand core-offs (1- +backend-page-bytes+))))))))
         (scanptrs (vaddr obj wordindex-min wordindex-max &optional force &aux (n-fixups 0))
           (do* ((base-addr (logandc2 (get-lisp-obj-address obj) lowtag-mask))
                 (sap (int-sap base-addr))
                 ;; core-offs is the offset in the lisp.core ELF section.
                 (core-offs (- base-addr (sap-int (car spacemap))))
                 (i wordindex-min (1+ i)))
                ((> i wordindex-max) n-fixups)
             (let* ((byte-offs (ash i word-shift))
                    (ptr (sap-ref-word sap byte-offs)))
               (when (and (or (is-lisp-pointer ptr) force) (in-bounds-p ptr code-bounds))
                 (abs-fixup (+ vaddr byte-offs) (+ core-offs byte-offs) ptr)
                 (incf n-fixups)))))
         (scanptr (vaddr obj wordindex)
           (plusp (scanptrs vaddr obj wordindex wordindex))) ; trivial wrapper
         (scan-obj (vaddr obj widetag size
                    &aux (core-offs (- (logandc2 (get-lisp-obj-address obj) lowtag-mask)
                                       (sap-int (car spacemap))))
                         (nwords (ceiling size n-word-bytes)))
           (when (listp obj)
             (scanptrs vaddr obj 0 1)
             (return-from scan-obj))
           (case widetag
             (#.instance-widetag
              (let ((type (truly-the layout (translate (%instance-layout obj) spacemap))))
                (do-layout-bitmap (i taggedp type (%instance-length obj))
                  (when taggedp
                    (scanptr vaddr obj (1+ i))))))
             (#.simple-vector-widetag
              (let ((len (length (the simple-vector obj))))
                ;; FIXME: VECTOR-ADDR-HASHING-FLAG must be left-shifted by ARRAY-FLAGS-DATA-POSITION
                ;; for this LOGTEST to be correct.  I think it broke when array-rank was placed adjacent
                ;; to the widetag and the flags bits moved over. The fact that it seems to be useless
                ;; suggests that I need to come up with a way to assert that it does anything, which
                ;; is all but impossible. We'd need a correctly-hashed table containing a key in which
                ;; nothing moves in the final S-L-A-D, but does have a function move during elfination.
                ;; I'm leaving this line broken for now because frankly I think it might be safer to
                ;; assert that IF the table is address-sensitive THEN it has the rehash flag already set
                ;; in the k/v vector. That's not quite true either, because it only needs to rehash if
                ;; any key was actually hashed by address.
                (cond ((logtest (get-header-data obj) vector-addr-hashing-flag) ; BUG
                       (do ((i 2 (+ i 2)) (needs-rehash))
                           ;; Refer to the figure at the top of src/code/hash-table.lisp.
                           ;; LEN is an odd number.
                           ((>= i (1- len))
                            (when needs-rehash
                              (setf (svref obj 1) 1)))
                         ;; A weak or EQ-based hash table any of whose keys is a function
                         ;; or code-component might need the 'rehash' flag set.
                         ;; In practice, it is likely already set, because any object that
                         ;; could move in the final GC probably did move.
                         (when (scanptr vaddr obj (+ vector-data-offset i))
                           (setq needs-rehash t))
                         (scanptr vaddr obj (+ vector-data-offset i 1))))
                      (t
                       (scanptrs vaddr obj 1 (+ len 1))))))
             (#.fdefn-widetag
              (scanptrs vaddr obj 1 2)
              (scanptrs vaddr obj 3 3 t))
             ((#.closure-widetag #.funcallable-instance-widetag)
              ;; read the trampoline slot
              (let ((word (sap-ref-word (int-sap (get-lisp-obj-address obj))
                                        (- n-word-bytes fun-pointer-lowtag))))
                (when (in-bounds-p word code-bounds)
                  (abs-fixup (+ vaddr n-word-bytes)
                             (+ core-offs n-word-bytes)
                             word)))
              ;; untaggged pointers are generally not supported in
              ;; funcallable instances, so scan everything.
              (scanptrs vaddr obj 1 (1- nwords)))
             ;; mixed boxed/unboxed objects
             (#.code-header-widetag
              (aver (not pie))
              (dotimes (i (code-n-entries obj))
                ;; I'm being lazy and not computing vaddr, which is wrong,
                ;; but does not matter if non-pie; and if PIE, we can't get here.
                ;; [PIE requires all code in immobile space, and this reloc
                ;; is for a dynamic space object]
                (scanptrs 0 (%code-entry-point obj i) 2 5))
              (scanptrs vaddr obj 1 (1- (code-header-words obj))))
             ;; boxed objects that can reference code/simple-funs
             ((#.value-cell-widetag #.symbol-widetag #.weak-pointer-widetag)
              (scanptrs vaddr obj 1 (1- nwords))))))
      (dolist (space (cdr spacemap))
        (unless (= (space-id space) immobile-text-core-space-id)
          (let* ((logical-addr (space-addr space))
                 (size (space-size space))
                 (physical-addr (space-physaddr space spacemap))
                 (physical-end (sap+ physical-addr size))
                 (vaddr-translation (+ (- (sap-int physical-addr)) logical-addr)))
            (dx-flet ((visit (obj widetag size)
                        ;; Compute the object's intended virtual address
                        (scan-obj (+ (logandc2 (get-lisp-obj-address obj) lowtag-mask)
                                     vaddr-translation)
                                  obj widetag size)))
              (map-objects-in-range
               #'visit
               (ash (sap-int physical-addr) (- n-fixnum-tag-bits))
               (ash (sap-int physical-end) (- n-fixnum-tag-bits))))
            (when (and (plusp (logior n-abs n-rel)) verbose)
              (format t "space @ ~10x: ~6d absolute + ~4d relative fixups~%"
                      logical-addr n-abs n-rel))
            (setq n-abs 0 n-rel 0)))))
    (when verbose
      (format t "total of ~D linker fixups affecting ~D/~D pages~%"
              (length fixups)
              (hash-table-count affected-pages)
              (/ (reduce #'+ (cdr spacemap) :key #'space-nbytes-aligned)
                 core-align))))
  fixups)

;;; Given a native SBCL '.core' file, or one attached to the end of an executable,
;;; separate it into pieces.
;;; ASM-PATHNAME is the name of the assembler file that will hold all the Lisp code.
;;; The other two output pathnames are implicit: "x.s" -> "x.core" and "x-core.o"
;;; The ".core" file is a native core file used for starting a binary that
;;; contains the asm code using the "--core" argument.  The "-core.o" file
;;; is for linking in to a binary that needs no "--core" argument.
(defun really-split-core
    (input-pathname asm-pathname
     &key enable-pie (verbose nil) dynamic-space-size
     &aux (elf-core-pathname
           (merge-pathnames
            (make-pathname :name (concatenate 'string (pathname-name asm-pathname) "-core")
                           :type "o")
            asm-pathname))
          (core-header (make-array +backend-page-bytes+ :element-type '(unsigned-byte 8)))
          (original-total-npages 0)
          (core-offset 0)
          (page-adjust 0)
          (linkage-space-info (vector 0 0 0 0 0))
          (code-start-fixup-ofs 0) ; where to fixup the core header
          (space-list)
          (copy-actions)
          (fixedobj-range) ; = (START . SIZE-IN-BYTES)
          (relocs (make-array 100000 :adjustable t :fill-pointer 1)))

  (declare (ignorable fixedobj-range))
  ;; Remove old files
  (ignore-errors (delete-file asm-pathname))
  (ignore-errors (delete-file elf-core-pathname))
  ;; Crappy assumption: we already called redirect-text-space-calls which
  ;; assigned a value to *nil-taggedptr*. Anyway, why doesn't this use
  ;; PARSE-CORE-HEADER like it should?
  (assert (/= *nil-taggedptr* 0))
  ;; Ensure that all files can be opened
  (with-open-file (input input-pathname :element-type '(unsigned-byte 8))
    (with-open-file (asm-file asm-pathname :direction :output :if-exists :supersede)
      ;;(with-open-file (split-core split-core-pathname :direction :output
      ;;                            :element-type '(unsigned-byte 8) :if-exists :supersede)
      (let ((split-core nil))
        (setq core-offset (read-core-header input core-header verbose))
        (do-core-header-entry ((id len ptr) core-header)
          (case id
            (#.build-id-core-entry-type-code
             (when verbose
               (incf ptr 2)
               (let ((string (make-string (%vector-raw-bits core-header ptr)
                                          :element-type 'base-char)))
                 (%byte-blt core-header (* (1+ ptr) n-word-bytes) string 0 (length string))
                 (format t "Build ID [~a]~%" string))))
            (#.directory-core-entry-type-code
             (do-directory-entry ((index ptr len) core-header)
               (incf original-total-npages npages)
               (push (make-space id addr data-page page-adjust nwords) space-list)
               (when verbose
                 (format t "id=~d page=~5x + ~5x addr=~10x words=~8x~:[~; (drop)~]~%"
                         id data-page npages addr nwords
                         (= id immobile-text-core-space-id)))
               (cond ((= id immobile-text-core-space-id)
                      (setq code-start-fixup-ofs (+ index 3))
                      ;; Keep this entry but delete the page count. We need to know
                      ;; where the space was supposed to be mapped and at what size.
                      ;; Subsequent core entries will need to adjust their start page
                      ;; downward (just the PTEs's start page now).
                      (setq page-adjust npages data-page 0 npages 0))
                     (t
                      ;; Keep track of where the fixedobj space wants to be.
                      (when (= id immobile-fixedobj-core-space-id)
                        (setq fixedobj-range (cons addr (ash nwords word-shift))))
                      (when (plusp npages) ; enqueue
                        (push (cons data-page (* npages +backend-page-bytes+)) copy-actions))
                      ;; adjust this entry's start page in the new core
                      (decf data-page page-adjust)))))
            (#.lisp-linkage-space-core-entry-type-code
             (symbol-macrolet ((count (%vector-raw-bits core-header (+ ptr 0)))
                               (data-page (%vector-raw-bits core-header (+ ptr 1))))
               (let ((npages (ceiling (ash count word-shift) +backend-page-bytes+)))
                 (setq linkage-space-info
                       (vector (+ ptr 2) data-page npages count
                               (make-array count :element-type 'word)))
                 (push (cons data-page (* npages +backend-page-bytes+)) copy-actions)
                 (incf original-total-npages npages))))
            (#.page-table-core-entry-type-code
             (aver (= len 4))
             (symbol-macrolet ((n-ptes (%vector-raw-bits core-header (+ ptr 1)))
                               (nbytes (%vector-raw-bits core-header (+ ptr 2)))
                               (data-page (%vector-raw-bits core-header (+ ptr 3))))
               (aver (= data-page original-total-npages))
               (aver (= (ceiling (space-nwords
                                  (find dynamic-core-space-id space-list :key #'space-id))
                                 (/ gencgc-page-bytes n-word-bytes))
                        n-ptes))
               (when verbose
                 (format t "PTE: page=~5x~40tbytes=~8x~%" data-page nbytes))
               (push (cons data-page nbytes) copy-actions)
               (decf data-page page-adjust)))))
        (let ((buffer (make-array +backend-page-bytes+
                                  :element-type '(unsigned-byte 8)))
              (filepos))
          ;; Write the new core file
          (when split-core
            (write-sequence core-header split-core))
          (dolist (action (reverse copy-actions)) ; nondestructive
            ;; page index convention assumes absence of core header.
            ;; i.e. data page 0 is the file page immediately following the core header
            (let ((offset (* (1+ (car action)) +backend-page-bytes+))
                  (nbytes (cdr action)))
              (when verbose
                (format t "File offset ~10x: ~10x bytes~%" offset nbytes))
              (setq filepos (+ core-offset offset))
              (cond (split-core
                     (file-position input filepos)
                     (copy-bytes input split-core nbytes buffer))
                    (t
                     (file-position input (+ filepos nbytes))))))
          ;; Trailer (runtime options and magic number)
          (let ((nbytes (read-sequence buffer input)))
            ;; expect trailing magic number
            (let ((ptr (floor (- nbytes n-word-bytes) n-word-bytes)))
              (aver (= (%vector-raw-bits buffer ptr) core-magic)))
            ;; File position of the core header needs to be set to 0
            ;; regardless of what it was
            (setf (%vector-raw-bits buffer 4) 0)
            (when verbose
              (format t "Trailer words:(~{~X~^ ~})~%"
                      (loop for i below (floor nbytes n-word-bytes)
                            collect (%vector-raw-bits buffer i))))
            (when split-core
              (write-sequence buffer split-core :end nbytes)
              (finish-output split-core)))
          ;; Sanity test
          (when split-core
            (aver (= (+ core-offset
                        (* page-adjust +backend-page-bytes+)
                        (file-length split-core))
                     (file-length input))))
          ;; Seek back to the PTE pages so they can be copied to the '.o' file
          (file-position input filepos)))

      ;; If we're going to write memory size options and they weren't already
      ;; present, then they will be inserted after the core magic,
      ;; and the remainder of the core header moves over by 5 words.
      (when (and dynamic-space-size
                 (/= (%vector-raw-bits core-header 1) runtime-options-magic))
        (let ((added-words 5))
          (incf (linkage-space-header-ptr linkage-space-info) added-words)
          (incf code-start-fixup-ofs added-words)))
      (unless enable-pie
        ;; This fixup sets the 'address' field of the core directory entry
        ;; for code space. If PIE-enabled, we'll figure it out in the C code
        ;; because space relocation is going to happen no matter what.
        (setf (aref relocs 0) `#(,R_ABS64 ,(ash code-start-fixup-ofs word-shift) 1 0)))
      #+linkage-space
      (let ((where (ash (linkage-space-header-ptr linkage-space-info) word-shift)))
        ;; LINKAGE_SPACE core entry gets a linker fixup to the second ELF symbol
        (vector-push-extend `#(,R_ABS64 ,where 2 0) relocs)
        (read-linkage-cells input linkage-space-info core-offset))
      ;; Map the original core file to memory
      (with-mapped-core (sap core-offset original-total-npages input)
        (let* ((data-spaces
                (delete immobile-text-core-space-id (reverse space-list)
                        :key #'space-id))
               (spacemap (cons sap (sort (copy-list space-list) #'> :key #'space-addr)))
               (pte-nbytes (cdar copy-actions)))
          (collect-relocations spacemap relocs enable-pie)
          (with-open-file (output elf-core-pathname
                                  :direction :output :if-exists :supersede
                                  :element-type '(unsigned-byte 8))
            (prepare-elf (+ (apply #'+ (mapcar #'space-nbytes-aligned data-spaces))
                            (* (linkage-space-npages linkage-space-info) +backend-page-bytes+)
                            +backend-page-bytes+ ; core header
                            pte-nbytes)
                         relocs output enable-pie)
            (let ((new-header (change-dynamic-space-size core-header dynamic-space-size)))
              ;; This word will be fixed up by the system linker
              (setf (%vector-raw-bits new-header code-start-fixup-ofs)
                    (if enable-pie +code-space-nominal-address+ 0))
              (write-sequence new-header output))
            (force-output output)
            ;; ELF cores created from #-immobile-space cores use +required-foreign-symbols+.
            ;; But if #+immobile-space the alien-linkage-table values are computed
            ;; by 'ld' and we don't scan +required-foreign-symbols+.
            (when (get-space immobile-fixedobj-core-space-id spacemap)
              (let* ((sym (find-target-symbol (package-id "SB-VM")
                                              "+REQUIRED-FOREIGN-SYMBOLS+" spacemap :physical))
                     (vector (translate (symbol-global-value sym) spacemap)))
                (fill vector 0)
                (setf (%array-fill-pointer vector) 0)))
            ;; Change SB-C::*COMPILE-FILE-TO-MEMORY-SPACE* to :DYNAMIC
            ;; and SB-C::*COMPILE-TO-MEMORY-SPACE* to :AUTO
            ;; in case the resulting executable needs to compile anything.
            ;; (Call frame info will be missing, but at least it's something.)
            (dolist (item '(("*COMPILE-FILE-TO-MEMORY-SPACE*" . "DYNAMIC")
                            ("*COMPILE-TO-MEMORY-SPACE*" . "DYNAMIC")))
              (destructuring-bind (symbol . value) item
                (awhen (%find-target-symbol (package-id "SB-C") symbol spacemap)
                  (%set-symbol-global-value
                   it (find-target-symbol (package-id "KEYWORD") value spacemap :logical)))))
            #+linkage-space
            (let ((start (sb-sys:sap+ (car spacemap)
                                      (* (linkage-space-data-page linkage-space-info)
                                         +backend-page-bytes+)))
                  (size (* (linkage-space-npages linkage-space-info) +backend-page-bytes+))
                  (code-bounds (space-bounds immobile-text-core-space-id spacemap)))
              ;; Words pointing to text space get the space base address subtracted.
              ;; And we toggle the low bit to signify that it needs correction at startup.
              (dotimes (i (linkage-space-count linkage-space-info))
                (let ((val (sap-ref-word start (ash i word-shift))))
                  (when (in-bounds-p val code-bounds)
                    (setf (sap-ref-word start (ash i word-shift))
                          (logior (- val (bounds-low code-bounds)) 1)))))
              (aver (eql (sb-unix:unix-write (sb-sys:fd-stream-fd output) start 0 size)
                         size)))
            (let ((fd (sb-sys:fd-stream-fd output)))
              (dolist (space data-spaces) ; Copy pages from memory
                (let ((start (space-physaddr space spacemap))
                      (size (space-nbytes-aligned space)))
                  (aver (eql (sb-unix:unix-write fd start 0 size) size)))))
            (when verbose
              (format t "Copying ~d bytes (#x~x) from ptes = ~d PTEs~%"
                      pte-nbytes pte-nbytes (floor pte-nbytes 10)))
            (copy-bytes input output pte-nbytes)) ; Copy PTEs from input
          (let ((core (write-asm-file spacemap linkage-space-info asm-file enable-pie)))
            (format asm-file " .section .rodata~% .p2align 4~%lisp_fixups:~%")
            ;; Sort the hash-table in emit order.
            (dolist (x (sort (%hash-table-alist (core-new-fixups core)) #'< :key #'cdr))
              (output-bignum nil (car x) asm-file))
            (cond
              (t ; (get-space immobile-fixedobj-core-space-id spacemap)
               (format asm-file "~% .section .data~%")
               (format asm-file " .globl ~A~%~:*~A:
 .quad ~d~%"
                    (labelize "alien_linkage_values")
                    (length (core-alien-linkage-symbols core)))
               ;; -1 (not a plausible function address) signifies that word
               ;; following it is a data, not text, reference.
               (loop for s across (core-alien-linkage-symbols core)
                     do (format asm-file " .quad ~:[~;-1, ~]~a~%"
                                (consp s)
                                (if (consp s) (car s) s))))
              (t
               (format asm-file "~% .section .rodata~%")
               (format asm-file " .globl anchor_junk~%")
               (format asm-file "anchor_junk: .quad lseek_largefile, get_timezone, compute_udiv_magic32~%"))))))
      (when (member :linux *features*)
        (format asm-file "~% ~A~%" +noexec-stack-note+)))))

;;; Copy the input core into an ELF section without splitting into code & data.
;;; Also force a linker reference to each C symbol that the Lisp core mentions.
(defun copy-to-elf-obj (input-pathname output-pathname)
  ;; Remove old files
  (ignore-errors (delete-file output-pathname))
  ;; Ensure that all files can be opened
  (with-open-file (input input-pathname :element-type '(unsigned-byte 8))
    (with-open-file (output output-pathname :direction :output
                            :element-type '(unsigned-byte 8) :if-exists :supersede)
      (let* ((core-header (make-array +backend-page-bytes+
                                      :element-type '(unsigned-byte 8)))
             (core-offset (read-core-header input core-header nil))
             (parsed-header (parse-core-header input core-header core-offset))
             (space-list (core-header-space-list parsed-header)))
        ;; Map the core file to memory
        (with-mapped-core (sap core-offset (core-header-total-npages parsed-header) input)
          (let* ((spacemap (cons sap (sort (copy-list space-list) #'> :key #'space-addr)))
                 (core (make-core spacemap
                                  (space-bounds immobile-text-core-space-id spacemap)
                                  (space-bounds immobile-fixedobj-core-space-id spacemap)))
                 (c-symbols (map 'list (lambda (x) (if (consp x) (car x) x))
                                 (core-alien-linkage-symbols core)))
                 (sections `#((:str  ".strtab"         ,+sht-strtab+   0 0 0 1  0)
                              (:sym  ".symtab"         ,+sht-symtab+   0 1 1 8 ,sym-entry-size)
                              ;;             section with the strings -- ^ ^ -- 1+ highest local symbol
                              (:core "lisp.core"       ,+sht-progbits+ 0 0 0 ,core-align 0)
                              (:note ".note.GNU-stack" ,+sht-progbits+ 0 0 0 1  0)))
                 (string-table (string-table (append (map 'list #'second sections)
                                                     c-symbols)))
                 (packed-strings (cdr string-table))
                 (strings-start (+ ehdr-size (* (1+ (length sections)) shdr-size)))
                 (strings-end (+ strings-start (length packed-strings)))
                 (symbols-start (align-up strings-end 8))
                 (symbols-size (* (1+ (length c-symbols)) sym-entry-size))
                 (symbols-end (+ symbols-start symbols-size))
                 (core-start (align-up symbols-end core-align))
                 (core-size (+ (* (1+ (core-header-total-npages parsed-header))
                                  +backend-page-bytes+)
                               (core-header-pte-nbytes parsed-header))))
            (write-elf-header ehdr-size sections output)
            (write-section-headers `((,strings-start . ,(length packed-strings))
                                     (,symbols-start . ,symbols-size)
                                     (,core-start    . ,core-size)
                                     (0 . 0))
                                   sections string-table output)
            (write-sequence packed-strings output)
            ;; Write symbol table
            (file-position output symbols-start)
            (write-sequence (make-elf64-sym 0 0) output)
            (dolist (sym c-symbols)
              (let ((name-ptr (cdr (assoc sym (car string-table)))))
                (write-sequence (make-elf64-sym name-ptr #x10) output)))
            ;; Copy core
            (file-position output core-start)
            (file-position input core-offset)
            (let ((remaining core-size))
              (loop (let ((n (read-sequence core-header input
                                            :end (min +backend-page-bytes+ remaining))))
                      (write-sequence core-header output :end n)
                      (unless (plusp (decf remaining n)) (return))))
              (aver (zerop remaining)))))))))

;; The extra copy of ASM routines, particularly C-calling trampolines, that now reside in text
;; space have to be modified to correctly reference their C functions. They assume that static
;; space is near alien-linkage space, and so they use this form:
;;   xxxx: E8A1F0EFFF  CALL #x50000060 ; alloc
;; which unforuntately means that after relocating to text space, that instruction refers
;; to random garbage, and more unfortunately there is no room to squeeze in an instruction
;; that encodes to 7 bytes.
;; So we have to create an extra jump "somewhere" that indirects through the linkage table
;; but is callable from the text-space code.
;;; I don't feel like programmatically scanning the asm code to determine these.
;;; Hardcoded is good enough (until it isn't)
(defparameter *c-linkage-redirects*
  (mapcar (lambda (x) (cons x (foreign-symbol-sap x)))
          '("switch_to_arena"
            "alloc"
            "alloc_list"
            "listify_rest_arg"
            "make_list"
            "alloc_funinstance"
            "allocation_tracker_counted"
            "allocation_tracker_sized")))

(defun patch-asm-codeblob (core &aux (spacemap (core-spacemap core)))
  (binding* ((static-space (get-space static-core-space-id spacemap))
             (text-space (get-space immobile-text-core-space-id spacemap))
             ((new-code-vaddr new-code) (get-text-space-asm-code-replica text-space spacemap))
             ((old-code-vaddr old-code) (get-static-space-asm-code static-space spacemap))
             (code-offsets-vector
              (%make-lisp-obj (logior (sap-int (space-physaddr text-space spacemap))
                                      other-pointer-lowtag)))
             (header-bytes (ash (code-header-words old-code) word-shift))
             (old-insts-vaddr (+ old-code-vaddr header-bytes))
             (new-insts-vaddr (+ new-code-vaddr header-bytes))
             (items *c-linkage-redirects*)
             (inst-buffer (make-array 8 :element-type '(unsigned-byte 8)))
             (code-offsets-vector-size (primitive-object-size code-offsets-vector))
             (c-linkage-vector-vaddr (+ (space-addr text-space) code-offsets-vector-size))
             (c-linkage-vector ; physical
              (%make-lisp-obj (logior (sap-int (sap+ (space-physaddr text-space spacemap)
                                                     code-offsets-vector-size))
                                      other-pointer-lowtag))))
    (aver (<= (length items) (length c-linkage-vector)))
    (with-pinned-objects (inst-buffer)
      (do ((sap (vector-sap inst-buffer))
           (item-index 0 (1+ item-index))
           (items items (cdr items)))
          ((null items))
        ;; Each new quasi-linkage-table entry takes 8 bytes to encode.
        ;; The JMP is 7 bytes, followed by a nop.
        ;; FF2425nnnnnnnn = JMP [ea]
        (setf (sap-ref-8 sap 0) #xFF
              (sap-ref-8 sap 1) #x24
              (sap-ref-8 sap 2) #x25
              (sap-ref-32 sap 3) (sap-int (sap+ (cdar items) 8))
              (sap-ref-8 sap 7) #x90) ; nop
        (setf (aref c-linkage-vector item-index) (%vector-raw-bits inst-buffer 0))))
    ;; Produce a model of the instructions. It doesn't really matter whether we scan
    ;; OLD-CODE or NEW-CODE since we're supplying the proper virtual address either way.
    (let ((insts (get-code-instruction-model old-code old-code-vaddr core)))
;;  (dovector (inst insts) (write inst :base 16 :pretty nil :escape nil) (terpri))
      (dovector (inst insts)
        ;; Look for any call to a linkage table entry.
        (when (eq (second inst) 'call)
          (let ((operand (third inst)))
            (when (and (integerp operand)
                       (>= operand alien-linkage-space-start)
                       (< operand (+ alien-linkage-space-start alien-linkage-space-size)))
              (let* ((index (position (int-sap operand) *c-linkage-redirects*
                                      :key #'cdr :test #'sap=))
                     (branch-target (+ c-linkage-vector-vaddr
                                       (ash vector-data-offset word-shift)
                                       ;; each new linkage entry takes up exactly 1 word
                                       (* index n-word-bytes)))
                     (old-next-ip-abs (int-sap (inst-end inst))) ; virtual
                     (next-ip-rel (sap- old-next-ip-abs (int-sap old-insts-vaddr)))
                     (new-next-ip (+ new-insts-vaddr next-ip-rel)))
                (setf (signed-sap-ref-32 (code-instructions new-code) (- next-ip-rel 4))
                      (- branch-target new-next-ip))))))))))

(defconstant smallvec-elts
  (- (ash gencgc-page-bytes (- word-shift)) vector-data-offset))
(defvar *name-map* nil)
(defun linkage-index-to-name (index spacemap)
  (unless *name-map*
    (let ((sym (find-target-symbol (package-id "SB-VM") "*LINKAGE-NAME-MAP*"
                                   spacemap :physical)))
      (setf *name-map* (translate (symbol-global-value sym) spacemap))))
  (multiple-value-bind (hi lo) (floor index smallvec-elts)
    (let ((inner (translate (svref *name-map* hi) spacemap)))
      (translate (weak-vector-ref inner lo) spacemap))))
#+x86-64
(defun use-indirection-p (index spacemap)
  (let ((name (linkage-index-to-name index spacemap)))
    (if (symbolp name)
        (let ((str (translate (symbol-name name) spacemap)))
          (case (symbol-package-id name)
            (#.(sb-impl::package-id (find-package "CL"))
             ;; Users like to encapsulate this apparently
             (string= str "FIND-PACKAGE"))
            (#.(sb-impl::package-id (find-package "SB-VM"))
             ;; These alway get redefined on startup
             (member str '(sb-vm::simd-reverse32 sb-vm::simd-reverse8
                           sb-vm::simd-nreverse32 sb-vm::simd-nreverse8)
                     :test 'string=)))))))
#+x86-64
(defun bypass-indirection-cells
    (code vaddr core
     &optional print
     &aux (insts (get-code-instruction-model code vaddr core))
          (spacemap (core-spacemap core))
          (text-bounds (space-bounds immobile-text-core-space-id spacemap))
          (linkage-bounds (core-linkage-bounds core))
          (alien-linkage-end (+ (bounds-low linkage-bounds) alien-linkage-space-size))
          (indices))
  (declare (simple-vector insts))
  (labels ((linkage-table-load-p (prev-inst)
             (and (eq (second prev-inst) 'mov)
                  (eq (third prev-inst) (get-gpr :qword 0))
                  (let ((src (fourth prev-inst)))
                    (and (typep src '(cons machine-ea (eql :qword)))
                         (let ((ea (car src)))
                           (and (eql (machine-ea-base ea) 13)
                                (eql (machine-ea-disp ea)
                                     (ash sb-vm::thread-linkage-table-slot word-shift))
                                (null (machine-ea-index ea))))))))
           (linkage-index (ea inst i)
             (cond ((eq (machine-ea-base ea) :rip) ; RIP+n format
                    (let* ((next-pc (+ (range-vaddr (car inst)) (range-bytecount (car inst))))
                           (addr (+ next-pc (machine-ea-disp ea))))
                      (when (and (>= addr alien-linkage-end)
                                 (< addr (bounds-high linkage-bounds)))
                        (ash (- addr alien-linkage-end) (- word-shift)))))
                   ((and (eql (machine-ea-base ea) 0) ; RAX+n format
                         (null (machine-ea-index ea))
                         ;; 0 is not a usable linkage cell
                         (typep (machine-ea-disp ea) '(integer 8))
                         (linkage-table-load-p (svref insts (1- i))))
                    (ash (machine-ea-disp ea) (- word-shift))))))
    (do ((i 0 (1+ i)))
        ((>= i (length insts)))
      (let* ((inst (svref insts i))
             (op (second inst))
             (ea (third inst)))
        (when (and (member op '(call jmp)) (typep ea 'machine-ea))
          (binding* ((linkage-index (linkage-index ea inst i) :exit-if-null)
                     (cell (assoc linkage-index indices)))
            (unless cell
              (setq cell (list linkage-index))
              (push cell indices))
            ;; Collect list of insts replace for the particular linkage-index.
            (push inst (cdr cell)))))))
  ;; Change each linkage table call to instead go directly to the target
  ;; but only if the target uniquely identifies its linkage index within
  ;; this code component for purposes of undoing the optimization.
  (let* ((linkage-cells (linkage-space-cells (core-linkage-space-info core)))
         (indices (coerce indices 'vector))
         (values (map 'vector (lambda (x) (aref linkage-cells (car x)))
                      indices)))
    (dotimes (i (length indices))
      (let ((linkage-index (car (aref indices i))) (value (aref values i)))
        (cond ((not (in-bounds-p value text-bounds))
               (if print (format t "Can't patch ~X: outside of text space~%" value)))
              ((> (count value values) 1)
               (if print (format t "Can't patch ~X: not unique~%" value)))
              ((use-indirection-p linkage-index spacemap)
               (if print (format t "Won't direct call ~D~%" linkage-index)))
              (t
               (dolist (inst (cdr (aref indices i)))
                 (let* ((range (car inst))
                        (sap (sap+ (sap+ (int-sap (get-lisp-obj-address code))
                                         (- other-pointer-lowtag))
                                   (- (range-vaddr range) vaddr)))
                        (next-pc (+ (range-vaddr range) (range-bytecount range)))
                        (disp (the (signed-byte 32) (- value next-pc))))
                   (ecase (cadr inst)
                     (call
                      (setf (sap-ref-8 sap 0) #x40 ; add a do-nothing prefix
                            (sap-ref-8 sap 1) #xe8 ; CALL rel32
                            (signed-sap-ref-32 sap 2) disp))
                     (jmp
                      (setf (sap-ref-8 sap 0) #xe9 ; JMP rel32
                            (signed-sap-ref-32 sap 1) (1+ disp)
                            (sap-ref-8 sap 5) #x90))))))))))) ; followed by NOP

#+x86-64
(defun redirect-text-space-calls (pathname)
  (with-open-file (stream pathname :element-type '(unsigned-byte 8)
                         :direction :io :if-exists :overwrite)
    (let* ((core-header (make-array +backend-page-bytes+ :element-type '(unsigned-byte 8)))
           (core-offset (read-core-header stream core-header))
           (parsed-header (parse-core-header stream core-header core-offset))
           (space-list (core-header-space-list parsed-header)))
      (with-mapped-core (sap core-offset (core-header-total-npages parsed-header) stream)
        (let* ((spacemap (cons sap (sort (copy-list space-list) #'> :key #'space-addr)))
               (core (make-core spacemap (make-bounds 0 0) (make-bounds 0 0)
                                :linkage-space-info (core-header-linkage-space-info parsed-header))))
          #-immobile-space
          (let* ((text-space (get-space immobile-text-core-space-id spacemap))
                 (offsets-vector (%make-lisp-obj (logior (sap-int (space-physaddr text-space spacemap))
                                                         lowtag-mask))))
            (assert text-space)
            (patch-asm-codeblob core)
            ;; offset 0 is the offset of the ASM routine codeblob which was already processed.
            (loop for j from 1 below (length offsets-vector)
                  do (let ((vaddr (+ (space-addr text-space) (aref offsets-vector j)))
                           (physobj (%make-lisp-obj
                                     (logior (sap-int (sap+ (space-physaddr text-space spacemap)
                                                            (aref offsets-vector j)))
                                             other-pointer-lowtag))))
                       (bypass-indirection-cells physobj vaddr core))))
          #+immobile-space
          (let* ((text-space (get-space immobile-text-core-space-id spacemap))
                 (delta (- (translate-ptr (space-addr text-space) spacemap)
                           (space-addr text-space))))
            (walk-target-space (lambda (obj widetag size
                                        &aux (vaddr (- (get-lisp-obj-address obj)
                                                       other-pointer-lowtag delta)))
                                 (declare (ignore widetag size))
                                 (bypass-indirection-cells obj vaddr core))
                               immobile-text-core-space-id spacemap))
          (persist-to-file spacemap core-offset stream))))))

(defun split-core (input-pathname asm-pathname &rest args)
  (let ((tmp (flet ((try-directory (dir)
                      (when (and dir (string/= "" dir) (sb-unix:unix-access dir sb-unix:w_ok))
                        dir)))
               (format nil "~a/sbcl~D.tmpcore"
                       (or (try-directory (posix-getenv "TMPDIR"))
                           (try-directory "/tmp")
                           (try-directory (user-homedir-pathname))
                           (error "Can't find a writeable directory for our split core."))
                       (sb-unix:unix-getpid)))))
    (with-open-file (stream input-pathname :element-type '(unsigned-byte 8))
      (let* ((core-header (make-array +backend-page-bytes+ :element-type '(unsigned-byte 8)))
             (core-offset (read-core-header stream core-header)))
        (parse-core-header stream core-header core-offset)))
    (unwind-protect
         (progn
           (ecase *heap-arrangement*
             (:gencgc
              ;; input core could be readonly
              (run-program "cp" `("--no-preserve=mode" ,input-pathname ,tmp)
                           :search t))
             (:mark-region-gc
              (move-dynamic-code-to-text-space input-pathname tmp)))
           #+x86-64 (redirect-text-space-calls tmp)
           (apply #'really-split-core tmp asm-pathname args))
      (delete-file tmp))))

(defun cl-user::elfinate (&optional (args (cdr *posix-argv*)))
  (cond ((string= (car args) "split")
         (pop args)
         (let (pie dss)
           (loop (cond ((string= (car args) "--pie")
                        (setq pie t)
                        (pop args))
                       ((string= (car args) "--dynamic-space-size")
                        (pop args)
                        (setq dss (parse-integer (pop args))))
                       (t
                        (return))))
           (destructuring-bind (input asm) args
             (split-core input asm :enable-pie pie :dynamic-space-size dss))))
        ((string= (car args) "copy")
         (apply #'copy-to-elf-obj (cdr args)))
        ((string= (car args) "extract")
         (apply #'move-dynamic-code-to-text-space (cdr args)))
        (t
         (error "Unknown command: ~S" args))))

;; If loaded as a script, do this
(eval-when (:execute)
  (let ((args (cdr *posix-argv*)))
    (when args
      (let ((*print-pretty* nil))
        (format t "Args: ~S~%" args)
        (cl-user::elfinate args)))))
