mirror of
git://git.code.sf.net/p/sbcl/sbcl
synced 2026-09-10 07:26:40 -04:00
1963 lines
98 KiB
Common Lisp
1963 lines
98 KiB
Common Lisp
;;;; Utilities for separating an SBCL core file into two pieces:
|
|
;;;; 1. An assembly language file containing the immobile code space
|
|
;;;; 2. A '.o' file wrapping a core file containing everything else
|
|
;;;; We operate as a "tool" that processes external files rather than
|
|
;;;; operating on the in-process data, but it is also possible to dump
|
|
;;;; the current image by creating a straight-through translation
|
|
;;;; of internal/external code addresses.
|
|
|
|
;;;; This software is part of the SBCL system. See the README file for
|
|
;;;; more information.
|
|
;;;;
|
|
;;;; This software is derived from the CMU CL system, which was
|
|
;;;; written at Carnegie Mellon University and released into the
|
|
;;;; public domain. The software is in the public domain and is
|
|
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
|
|
;;;; files for more information.
|
|
|
|
(load (merge-pathnames "corefile.lisp" *load-pathname*))
|
|
|
|
(defpackage "SB-EDITCORE"
|
|
(:use "CL" "SB-ALIEN" "SB-COREFILE" "SB-INT" "SB-EXT"
|
|
"SB-KERNEL" "SB-SYS" "SB-VM")
|
|
(:import-from "SB-ALIEN-INTERNALS"
|
|
#:alien-type-bits #:parse-alien-type
|
|
#:alien-value-sap #:alien-value-type)
|
|
(:import-from "SB-C" #:+backend-page-bytes+)
|
|
(:import-from "SB-VM" #:map-objects-in-range #:reconstitute-object
|
|
#:%closure-callee #:code-object-size)
|
|
(:import-from "SB-DISASSEM" #:get-inst-space #:find-inst
|
|
#:make-dstate #:%make-segment
|
|
#:seg-virtual-location #:seg-length #:seg-sap-maker
|
|
#:map-segment-instructions #:inst-name
|
|
#:dstate-next-addr #:dstate-cur-offs)
|
|
(:import-from "SB-X86-64-ASM" #:near-jump-displacement
|
|
#:near-cond-jump-displacement #:mov #:call #:jmp
|
|
#:get-gpr #:reg-name)
|
|
(:import-from "SB-IMPL" #:symbol-hashset #:package-%name
|
|
#:symtbl-cells
|
|
#:hash-table-pairs #:hash-table-%count))
|
|
|
|
(in-package "SB-EDITCORE")
|
|
|
|
(declaim (muffle-conditions compiler-note))
|
|
|
|
(eval-when (:execute)
|
|
(setq *evaluator-mode* :compile))
|
|
|
|
;;; Some high address that won't conflict with any of the ordinary spaces
|
|
;;; It's more-or-less arbitrary, but we must be able to discern whether a
|
|
;;; pointer looks like it points to code in case coreparse has to walk the heap.
|
|
(defconstant +code-space-nominal-address+ #x550000000000)
|
|
|
|
(defglobal +noexec-stack-note+ ".section .note.GNU-stack, \"\", @progbits")
|
|
|
|
(defstruct (core-space ; "space" is a CL symbol
|
|
(:conc-name space-)
|
|
(:constructor make-space (id addr data-page page-adjust nwords)))
|
|
id addr data-page page-adjust nwords)
|
|
(defun space-size (space) (* (space-nwords space) n-word-bytes))
|
|
(defun space-end (space) (+ (space-addr space) (space-size space)))
|
|
(defun space-nbytes-aligned (space)
|
|
(align-up (space-size space) +backend-page-bytes+))
|
|
(defun space-physaddr (space spaces)
|
|
(sap+ (car spaces) (* (space-data-page space) +backend-page-bytes+)))
|
|
|
|
;;; Given ADDR which is an address in the target core, return the address at which
|
|
;;; ADDR is currently mapped while performing the split.
|
|
;;; SPACES is a cons of a SAP and an alist whose elements are (ADDR . CORE-SPACE)
|
|
(defun translate-ptr (addr spaces)
|
|
(let ((space (find addr (cdr spaces) :key #'space-addr :test #'>=)))
|
|
;; FIXME: duplicates SPACE-PHYSADDR to avoid consing a SAP.
|
|
;; macroize or something.
|
|
(+ (sap-int (car spaces)) (* (space-data-page space) +backend-page-bytes+)
|
|
(- addr (space-addr space)))))
|
|
|
|
;;;
|
|
(defun get-space (id spaces)
|
|
(find id (cdr spaces) :key #'space-id))
|
|
(defun compute-nil-object (spaces)
|
|
(let ((space (get-space static-core-space-id spaces)))
|
|
(%make-lisp-obj (logior (space-addr space) #x117)))) ; SUPER KLUDGE
|
|
|
|
;;; Given OBJ which is tagged pointer into the target core, translate it into
|
|
;;; the range at which the core is now mapped during execution of this tool,
|
|
;;; so that host accessors can dereference its slots.
|
|
;;; Use extreme care: while it works to use host accessors on the target core,
|
|
;;; we must avoid type checks on instances because LAYOUTs need translation.
|
|
;;; Printing boxed objects from the target core will almost always crash.
|
|
(defun translate (obj spaces)
|
|
(%make-lisp-obj (translate-ptr (get-lisp-obj-address obj) spaces)))
|
|
|
|
(defstruct (core-sym (:copier nil) (:predicate nil)
|
|
(:constructor make-core-sym (package name external)))
|
|
(package nil)
|
|
(name nil :read-only t)
|
|
(external nil :read-only t))
|
|
|
|
(defstruct (bounds (:constructor make-bounds (low high)))
|
|
(low 0 :type word) (high 0 :type word))
|
|
|
|
(defstruct (core (:predicate nil)
|
|
(:copier nil)
|
|
(:constructor %make-core))
|
|
(spaces)
|
|
(nil-object)
|
|
;; mapping from small integer ID to package
|
|
(pkg-id->package)
|
|
;; mapping from string naming a package to list of symbol names (strings)
|
|
;; that are external in the package.
|
|
(packages (make-hash-table :test 'equal))
|
|
;; hashset of symbol names (as strings) that should be package-qualified.
|
|
;; (Prefer not to package-qualify unambiguous names)
|
|
(nonunique-symbol-names)
|
|
(code-bounds nil :type bounds :read-only t)
|
|
(fixedobj-bounds nil :type bounds :read-only t)
|
|
(linkage-bounds nil :type bounds :read-only t)
|
|
(linkage-symbols nil)
|
|
(linkage-symbol-usedp nil)
|
|
(linkage-entry-size nil)
|
|
(new-fixups (make-hash-table))
|
|
(new-fixup-words-used 0)
|
|
;; For assembler labels that we want to invent at random
|
|
(label-counter 0)
|
|
(enable-pie nil)
|
|
(dstate (make-dstate nil) :read-only t)
|
|
(seg (%make-segment :sap-maker (lambda () (error "Bad sap maker"))
|
|
:virtual-location 0) :read-only t)
|
|
(fixup-addrs nil)
|
|
(call-inst nil :read-only t)
|
|
(jmp-inst nil :read-only t)
|
|
(pop-inst nil :read-only t))
|
|
|
|
(defglobal *editcore-ppd*
|
|
;; copy no entries for macros/special-operators (flet, etc)
|
|
(let ((ppd (sb-pretty::make-pprint-dispatch-table #() nil nil)))
|
|
(set-pprint-dispatch 'string
|
|
;; Write strings without string quotes
|
|
(lambda (stream string) (write-string string stream))
|
|
0
|
|
ppd)
|
|
ppd))
|
|
|
|
(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 t :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-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))))))
|
|
|
|
(defmethod print-object ((sym core-sym) stream)
|
|
(format stream "~(~:[~*~;~:*~A~:[:~;~]:~]~A~)"
|
|
(core-sym-package sym)
|
|
(core-sym-external sym)
|
|
(core-sym-name sym)))
|
|
|
|
(defun space-bounds (id spaces)
|
|
(let ((space (get-space id spaces)))
|
|
(make-bounds (space-addr space) (space-end space))))
|
|
(defun in-bounds-p (addr bounds)
|
|
(and (>= addr (bounds-low bounds)) (< addr (bounds-high bounds))))
|
|
|
|
(defun make-string-hashset (contents count)
|
|
(let ((hs (sb-int:make-hashset count #'string= #'sxhash)))
|
|
(dolist (string contents hs)
|
|
(sb-int:hashset-insert hs string))))
|
|
|
|
(defun scan-symbol-hashset (function table core)
|
|
(let ((spaces (core-spaces core))
|
|
(nil-object (core-nil-object core)))
|
|
(dovector (x (translate
|
|
(symtbl-cells
|
|
(truly-the symbol-hashset (translate table spaces)))
|
|
spaces))
|
|
(unless (fixnump x)
|
|
(funcall function
|
|
(if (eq x nil-object) ; any random package can export NIL. wow.
|
|
"NIL"
|
|
(translate (symbol-name (translate x spaces)) spaces))
|
|
x)))))
|
|
|
|
(defun %fun-name-from-core (name core &aux (spaces (core-spaces core))
|
|
(packages (core-packages core))
|
|
(core-nil (core-nil-object core)))
|
|
(named-let recurse ((depth 0) (x name))
|
|
(unless (is-lisp-pointer (get-lisp-obj-address x))
|
|
(return-from recurse x)) ; immediate object
|
|
(when (eq x core-nil)
|
|
(return-from recurse nil))
|
|
(setq x (translate x spaces))
|
|
(ecase (lowtag-of x)
|
|
(#.list-pointer-lowtag
|
|
(cons (recurse (1+ depth) (car x))
|
|
(recurse (1+ depth) (cdr x))))
|
|
((#.instance-pointer-lowtag #.fun-pointer-lowtag) "?")
|
|
(#.other-pointer-lowtag
|
|
(cond
|
|
((stringp x)
|
|
(let ((p (position #\/ x :from-end t)))
|
|
(if p (subseq x (1+ p)) x)))
|
|
((symbolp x)
|
|
(let ((package-id (symbol-package-id x))
|
|
(name (translate (symbol-name x) spaces)))
|
|
(when (eq package-id 0) ; uninterned
|
|
(return-from recurse (string-downcase name)))
|
|
(let* ((package (truly-the package
|
|
(aref (core-pkg-id->package core) package-id)))
|
|
(package-name (translate (package-%name package) spaces)))
|
|
;; The name-cleaning code wants to compare against symbols
|
|
;; in CL, PCL, and KEYWORD, so use real symbols for those.
|
|
;; Other than that, we avoid finding host symbols
|
|
;; because the externalness could be wrong and misleading.
|
|
;; It's a very subtle point, but best to get it right.
|
|
(when (member package-name '("COMMON-LISP" "KEYWORD" "SB-PCL")
|
|
:test #'string=)
|
|
;; NIL can't occur. It was picked off above.
|
|
(awhen (find-symbol name package-name) ; if existing symbol, use it
|
|
(return-from recurse it)))
|
|
(unless (gethash name (core-nonunique-symbol-names core))
|
|
;; Don't care about package
|
|
(return-from recurse (make-core-sym nil name nil)))
|
|
(when (string= package-name "KEYWORD") ; make an external core-symbol
|
|
(return-from recurse (make-core-sym nil name t)))
|
|
(let ((externals (gethash package-name packages))
|
|
(n 0))
|
|
(unless externals
|
|
(scan-symbol-hashset
|
|
(lambda (string symbol)
|
|
(declare (ignore symbol))
|
|
(incf n)
|
|
(push string externals))
|
|
(package-external-symbols package)
|
|
core)
|
|
(setf externals (make-string-hashset externals n)
|
|
(gethash package-name packages) externals))
|
|
(make-core-sym package-name
|
|
name
|
|
(sb-int:hashset-find externals name))))))
|
|
(t "?"))))))
|
|
|
|
(defun remove-name-junk (name)
|
|
(setq name
|
|
(named-let recurse ((x name))
|
|
(cond ((typep x '(cons (eql lambda)))
|
|
(let ((args (second x)))
|
|
`(lambda ,(if args sb-c::*debug-name-sharp* "()")
|
|
,@(recurse (cddr x)))))
|
|
((eq x :in) "in")
|
|
((and (typep x '(or string symbol))
|
|
(= (mismatch (string x) "CLEANUP-FUN-")
|
|
(length "CLEANUP-FUN-")))
|
|
'#:cleanup-fun)
|
|
((consp x) (recons x (recurse (car x)) (recurse (cdr x))))
|
|
(t x))))
|
|
;; Shorten obnoxiously long printed representations of methods.
|
|
(flet ((unpackageize (thing)
|
|
(when (typep thing 'core-sym)
|
|
(setf (core-sym-package thing) nil))
|
|
thing))
|
|
(when (typep name '(cons (member sb-pcl::slow-method sb-pcl::fast-method
|
|
sb-pcl::slot-accessor)))
|
|
(setq name `(,(case (car name)
|
|
(sb-pcl::fast-method "method")
|
|
(sb-pcl::slow-method "Method") ; something visually distinct
|
|
(sb-pcl::slot-accessor "accessor"))
|
|
,@(cdr name)))
|
|
(setf (second name) (unpackageize (second name)))
|
|
(let ((last (car (last name))))
|
|
(when (listp last)
|
|
(dolist (qual last)
|
|
(unpackageize qual))))))
|
|
name)
|
|
|
|
(defun fun-name-from-core (name core)
|
|
(remove-name-junk (%fun-name-from-core name core)))
|
|
|
|
;;; A problem: COMPILED-DEBUG-FUN-ENCODED-LOCS (a packed integer) might be a
|
|
;;; bignum - in fact probably is. If so, it points into the target core.
|
|
;;; So we have to produce a new instance with an ENCODED-LOCS that
|
|
;;; is the translation of the bignum, and call the accessor on that.
|
|
;;; The accessors for its sub-fields are abstract - we don't know where the
|
|
;;; fields are so we can't otherwise unpack them. (See CDF-DECODE-LOCS if
|
|
;;; you really need to know)
|
|
(defun cdf-offset (compiled-debug-fun spaces)
|
|
;; (Note that on precisely GC'd platforms, this operation is dangerous,
|
|
;; but no more so than everything else in this file)
|
|
(let ((locs (sb-c::compiled-debug-fun-encoded-locs
|
|
(truly-the sb-c::compiled-debug-fun compiled-debug-fun))))
|
|
(when (consp locs)
|
|
(setq locs (cdr (translate locs spaces))))
|
|
(sb-c::compiled-debug-fun-offset
|
|
(sb-c::make-compiled-debug-fun
|
|
:name nil
|
|
:encoded-locs (if (fixnump locs) locs (translate locs spaces))))))
|
|
|
|
;;; 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 &aux (spaces (core-spaces core)))
|
|
(let ((cdf (translate
|
|
(sb-c::compiled-debug-info-fun-map
|
|
(truly-the sb-c::compiled-debug-info
|
|
(translate (sb-kernel:%code-debug-info code) spaces)))
|
|
spaces))
|
|
(header-bytes (* (sb-kernel:code-header-words code) sb-vm:n-word-bytes))
|
|
(start-pc 0)
|
|
(blobs))
|
|
(loop
|
|
(let* ((name (fun-name-from-core
|
|
(sb-c::compiled-debug-fun-name
|
|
(truly-the sb-c::compiled-debug-fun cdf))
|
|
core))
|
|
(next (when (%instancep (sb-c::compiled-debug-fun-next cdf))
|
|
(translate (sb-c::compiled-debug-fun-next cdf) spaces)))
|
|
(end-pc (if next
|
|
(+ header-bytes (cdf-offset next spaces))
|
|
(code-object-size code))))
|
|
(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)))
|
|
(if next
|
|
(setq cdf next start-pc end-pc)
|
|
(return))))
|
|
(nreverse blobs)))
|
|
|
|
(defstruct (descriptor (:constructor make-descriptor (bits)))
|
|
(bits 0 :type sb-ext:word))
|
|
(defmethod print-object ((self descriptor) stream)
|
|
(format stream "#<ptr ~x>" (descriptor-bits self)))
|
|
(defun descriptorize (obj)
|
|
(if (is-lisp-pointer (get-lisp-obj-address obj))
|
|
(make-descriptor (get-lisp-obj-address obj))
|
|
obj))
|
|
(defun undescriptorize (target-descriptor)
|
|
(%make-lisp-obj (descriptor-bits target-descriptor)))
|
|
|
|
(defun target-hash-table-alist (table spaces)
|
|
(let ((table (truly-the hash-table (translate table spaces))))
|
|
(let ((cells (the simple-vector (translate (hash-table-pairs table) spaces))))
|
|
(collect ((pairs))
|
|
(do ((count (hash-table-%count table) (1- count))
|
|
(i 2 (+ i 2)))
|
|
((zerop count)
|
|
(pairs))
|
|
(pairs (cons (descriptorize (svref cells i))
|
|
(descriptorize (svref cells (1+ i))))))))))
|
|
|
|
(defmacro package-id (name) (sb-impl::package-id (find-package name)))
|
|
|
|
;;; Return either the physical or logical address of the specified symbol.
|
|
(defun find-target-symbol (package-id symbol-name spaces
|
|
&optional (address-mode :physical))
|
|
(dolist (id `(,immobile-fixedobj-core-space-id ,static-core-space-id))
|
|
(let* ((space (get-space id spaces))
|
|
(start (translate-ptr (space-addr space) spaces))
|
|
(end (+ start (space-size space)))
|
|
(physaddr start))
|
|
(loop
|
|
(when (>= physaddr end) (return))
|
|
(let* ((obj (reconstitute-object (ash physaddr (- n-fixnum-tag-bits))))
|
|
(size (primitive-object-size obj)))
|
|
(when (and (symbolp obj)
|
|
(string= symbol-name (translate (symbol-name obj) spaces))
|
|
(= (symbol-package-id obj) package-id))
|
|
(return-from find-target-symbol
|
|
(%make-lisp-obj
|
|
(logior (ecase address-mode
|
|
(:physical physaddr)
|
|
(:logical (+ (space-addr space) (- physaddr start))))
|
|
other-pointer-lowtag))))
|
|
(incf physaddr size)))))
|
|
(bug "Can't find symbol ~A::~A" package-id symbol-name))
|
|
|
|
(defparameter label-prefix (if (member :darwin *features*) "_" ""))
|
|
(defun labelize (x) (concatenate 'string label-prefix x))
|
|
|
|
(defun compute-linkage-symbols (spaces)
|
|
(let* ((linkage-info (symbol-global-value
|
|
(find-target-symbol (package-id "SB-SYS") "*LINKAGE-INFO*"
|
|
spaces :physical)))
|
|
(hashtable (car (translate linkage-info spaces)))
|
|
(pairs (target-hash-table-alist hashtable spaces))
|
|
(min (reduce #'min pairs :key #'cdr))
|
|
(max (reduce #'max pairs :key #'cdr))
|
|
(n (1+ (- max min)))
|
|
(vector (make-array n)))
|
|
(dolist (entry pairs vector)
|
|
(let* ((key (undescriptorize (car entry)))
|
|
(entry-index (- (cdr entry) min))
|
|
(string (labelize (translate (if (consp key) (car (translate key spaces)) key)
|
|
spaces))))
|
|
(setf (aref vector entry-index)
|
|
(if (consp key) (list string) string))))))
|
|
|
|
(defconstant inst-call (find-inst #b11101000 (get-inst-space)))
|
|
(defconstant inst-jmp (find-inst #b11101001 (get-inst-space)))
|
|
(defconstant inst-jmpz (find-inst #x840f (get-inst-space)))
|
|
(defconstant inst-pop (find-inst #x5d (get-inst-space)))
|
|
(defconstant inst-mov (find-inst #x8B (get-inst-space)))
|
|
(defconstant inst-lea (find-inst #x8D (get-inst-space)))
|
|
|
|
(defun make-core (spaces code-bounds fixedobj-bounds &optional enable-pie)
|
|
(let* ((linkage-bounds
|
|
(let ((text (space-addr (get-space immobile-text-core-space-id spaces))))
|
|
(make-bounds (- text sb-vm:alien-linkage-table-space-size) text)))
|
|
(linkage-entry-size
|
|
(symbol-global-value
|
|
(find-target-symbol (package-id "SB-VM") "ALIEN-LINKAGE-TABLE-ENTRY-SIZE"
|
|
spaces :physical)))
|
|
(linkage-symbols (compute-linkage-symbols spaces))
|
|
(nil-object (compute-nil-object spaces))
|
|
(ambiguous-symbols (make-hash-table :test 'equal))
|
|
(core
|
|
(%make-core
|
|
:spaces spaces
|
|
:nil-object nil-object
|
|
:nonunique-symbol-names ambiguous-symbols
|
|
:code-bounds code-bounds
|
|
:fixedobj-bounds fixedobj-bounds
|
|
:linkage-bounds linkage-bounds
|
|
:linkage-entry-size linkage-entry-size
|
|
:linkage-symbols linkage-symbols
|
|
:linkage-symbol-usedp (make-array (length linkage-symbols) :element-type 'bit
|
|
:initial-element 0)
|
|
:enable-pie enable-pie)))
|
|
(let ((package-table
|
|
(symbol-global-value
|
|
(find-target-symbol (package-id "SB-KERNEL") "*PACKAGE-NAMES*" spaces :physical)))
|
|
(package-alist)
|
|
(symbols (make-hash-table :test 'equal)))
|
|
(dovector (x (translate (%instance-ref (translate package-table spaces) 0) spaces))
|
|
(when (%instancep x) ; package
|
|
(flet ((scan (table)
|
|
(scan-symbol-hashset
|
|
(lambda (str sym)
|
|
(pushnew (get-lisp-obj-address sym) (gethash str symbols)))
|
|
table core)))
|
|
(let ((package (truly-the package (translate x spaces))))
|
|
(push (cons (sb-impl::package-id package) package) package-alist)
|
|
(scan (package-external-symbols package))
|
|
(scan (package-internal-symbols package))))))
|
|
(let ((package-by-id (make-array (1+ (reduce #'max package-alist :key #'car))
|
|
:initial-element nil)))
|
|
(loop for (id . package) in package-alist
|
|
do (setf (aref package-by-id id) package))
|
|
(setf (core-pkg-id->package core) package-by-id))
|
|
(dohash ((string symbols) symbols)
|
|
(when (cdr symbols)
|
|
(setf (gethash string ambiguous-symbols) t))))
|
|
core))
|
|
|
|
;;; 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))
|
|
|
|
(defun code-fixup-locs (code spaces)
|
|
(let ((locs (sb-vm::%code-fixups code)))
|
|
;; Return only the absolute fixups
|
|
;; Ensure that a bignum LOCS is translated before using it.
|
|
(values (sb-c::unpack-code-fixup-locs
|
|
(if (fixnump locs) locs (translate locs spaces))))))
|
|
|
|
;;; 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.
|
|
;;; This includes (at least) two categories of instructions:
|
|
;;; - function prologue instructions that setup the call frame
|
|
;;; - jmp/call instructions that transfer control to the fixedoj space
|
|
;;; delimited by bounds in STATE.
|
|
;;; At execution time the function will have virtual address LOAD-ADDR.
|
|
(defun list-textual-instructions (sap length core load-addr emit-cfi)
|
|
(let ((dstate (core-dstate core))
|
|
(seg (core-seg core))
|
|
(next-fixup-addr
|
|
(or (car (core-fixup-addrs core)) most-positive-word))
|
|
(list))
|
|
(setf (seg-virtual-location seg) load-addr
|
|
(seg-length seg) length
|
|
(seg-sap-maker seg) (lambda () sap))
|
|
;; KLUDGE: "8f 45 08" is the standard prologue
|
|
(when (and emit-cfi (= (logand (sap-ref-32 sap 0) #xFFFFFF) #x08458f))
|
|
(push (list* 0 3 "pop" "8(%rbp)") list))
|
|
(map-segment-instructions
|
|
(lambda (dchunk inst)
|
|
(cond
|
|
((< next-fixup-addr (dstate-next-addr dstate))
|
|
(let ((operand (sap-ref-32 sap (- next-fixup-addr load-addr)))
|
|
(offs (dstate-cur-offs dstate)))
|
|
(when (in-bounds-p operand (core-code-bounds core))
|
|
(cond
|
|
((and (eq (inst-name inst) 'mov) ; match "mov eax, imm32"
|
|
(eql (sap-ref-8 sap offs) #xB8))
|
|
(let ((text (format nil "mov $(CS+0x~x),%eax"
|
|
(- operand (bounds-low (core-code-bounds core))))))
|
|
(push (list* (dstate-cur-offs dstate) 5 "mov" text) list)))
|
|
((and (eq (inst-name inst) 'mov) ; match "mov qword ptr [R+disp8], imm32"
|
|
(member (sap-ref-8 sap (1- offs)) '(#x48 #x49)) ; REX.w and maybe REX.b
|
|
(eql (sap-ref-8 sap offs) #xC7)
|
|
;; modRegRm = #b01 #b000 #b___
|
|
(eql (logand (sap-ref-8 sap (1+ offs)) #o370) #o100))
|
|
(let* ((reg (ldb (byte 3 0) (sap-ref-8 sap (1+ offs))))
|
|
(text (format nil "movq $(CS+0x~x),~d(%~a)"
|
|
(- operand (bounds-low (core-code-bounds core)))
|
|
(signed-sap-ref-8 sap (+ offs 2))
|
|
(reg-name (get-gpr :qword reg)))))
|
|
(push (list* (1- (dstate-cur-offs dstate)) 8 "mov" text) list)))
|
|
((let ((bytes (ldb (byte 24 0) (sap-ref-32 sap offs))))
|
|
(or (and (eq (inst-name inst) 'call) ; match "{call,jmp} qword ptr [addr]"
|
|
(eql bytes #x2514FF)) ; ModRM+SIB encodes disp32, no base, no index
|
|
(and (eq (inst-name inst) 'jmp)
|
|
(eql bytes #x2524FF))))
|
|
(let ((new-opcode (ecase (sap-ref-8 sap (1+ offs))
|
|
(#x14 "call *")
|
|
(#x24 "jmp *"))))
|
|
;; This instruction form is employed for asm routines when
|
|
;; compile-to-memory-space is :AUTO. If the code were to be loaded
|
|
;; into dynamic space, the offset to the called routine isn't
|
|
;; a (signed-byte 32), so we need the indirection.
|
|
(push (list* (dstate-cur-offs dstate) 7 new-opcode operand) list)))
|
|
(t
|
|
(bug "Can't reverse-engineer fixup: ~s ~x"
|
|
(inst-name inst) (sap-ref-64 sap offs))))))
|
|
(pop (core-fixup-addrs core))
|
|
(setq next-fixup-addr (or (car (core-fixup-addrs core)) most-positive-word)))
|
|
((or (eq inst inst-jmp) (eq inst inst-call))
|
|
(let ((target-addr (+ (near-jump-displacement dchunk dstate)
|
|
(dstate-next-addr dstate))))
|
|
(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)
|
|
5 ; length
|
|
(if (eq inst inst-call) "call" "jmp")
|
|
target-addr)
|
|
list))))
|
|
((eq inst inst-jmpz)
|
|
(let ((target-addr (+ (near-cond-jump-displacement dchunk dstate)
|
|
(dstate-next-addr dstate))))
|
|
(when (in-bounds-p target-addr (core-linkage-bounds core))
|
|
(push (list* (dstate-cur-offs dstate) 6 "je" target-addr)
|
|
list))))
|
|
((and (or (and (eq inst inst-mov)
|
|
(eql (sap-ref-8 sap (dstate-cur-offs dstate)) #x8B))
|
|
(eq inst inst-lea))
|
|
(let ((modrm (sap-ref-8 sap (1+ (dstate-cur-offs dstate)))))
|
|
(= (logand modrm #b11000111) #b00000101)) ; RIP-relative mode
|
|
(in-bounds-p (+ (signed-sap-ref-32 sap (+ (dstate-cur-offs dstate) 2))
|
|
(dstate-next-addr dstate))
|
|
(core-linkage-bounds core)))
|
|
(let* ((abs-addr (+ (signed-sap-ref-32 sap (+ (dstate-cur-offs dstate) 2))
|
|
(dstate-next-addr dstate)))
|
|
(reg (logior (ldb (byte 3 3) (sap-ref-8 sap (1+ (dstate-cur-offs dstate))))
|
|
(if (logtest (sb-disassem::dstate-inst-properties dstate)
|
|
#b0100) ; REX.r
|
|
8 0)))
|
|
(op (if (eq inst inst-lea) "lea" "mov-gotpcrel"))
|
|
(args (list abs-addr (reg-name (get-gpr :qword reg)))))
|
|
(push (list* (1- (dstate-cur-offs dstate)) 7 op args) list)))
|
|
((and (eq inst inst-pop) (eq (logand dchunk #xFF) #x5D))
|
|
(push (list* (dstate-cur-offs dstate) 1 "pop" "%rbp") list))))
|
|
seg
|
|
dstate
|
|
nil)
|
|
(nreverse list)))
|
|
|
|
;;; 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.
|
|
|
|
;;; Return the list of locations which must be added to code-fixups
|
|
;;; in the event that heap relocation occurs on image restart.
|
|
(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))
|
|
(extra-fixup-locs)
|
|
(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))
|
|
(when (cond ((member opcode '("jmp" "je" "call") :test #'string=)
|
|
(when (in-bounds-p operand (core-linkage-bounds core))
|
|
(let ((entry-index
|
|
(/ (- operand (bounds-low (core-linkage-bounds core)))
|
|
(core-linkage-entry-size core))))
|
|
(setf (bit (core-linkage-symbol-usedp core) entry-index) 1
|
|
operand (aref (core-linkage-symbols core) entry-index))))
|
|
(when (and (integerp operand)
|
|
(in-bounds-p operand (core-fixedobj-bounds core)))
|
|
(push (+ vaddr cur-offset) extra-fixup-locs))
|
|
(format stream " ~A ~:[0x~X~;~a~:[~;@PLT~]~]~%"
|
|
opcode (stringp operand) operand
|
|
(core-enable-pie core)))
|
|
((string= opcode "mov-gotpcrel")
|
|
(let* ((entry-index
|
|
(/ (- (car operand) (bounds-low (core-linkage-bounds core)))
|
|
(core-linkage-entry-size core)))
|
|
(c-symbol (car (aref (core-linkage-symbols core) entry-index))))
|
|
(setf (bit (core-linkage-symbol-usedp core) entry-index) 1)
|
|
(format stream " mov ~A@GOTPCREL(%rip), %~(~A~)~%" c-symbol (cadr operand))))
|
|
((string= opcode "lea") ; lea becomes "mov" with gotpcrel as src, which becomes lea
|
|
(let* ((entry-index
|
|
(/ (- (car operand) (bounds-low (core-linkage-bounds core)))
|
|
(core-linkage-entry-size core)))
|
|
(c-symbol (aref (core-linkage-symbols core) entry-index)))
|
|
(setf (bit (core-linkage-symbol-usedp core) entry-index) 1)
|
|
(format stream " mov ~A@GOTPCREL(%rip), %~(~A~)~%" c-symbol (cadr operand))))
|
|
((string= opcode "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)))
|
|
((string= opcode "mov")
|
|
;; the so-called "operand" is the entire instruction
|
|
(write-string operand stream)
|
|
(terpri stream))
|
|
((or (string= opcode "call *") (string= opcode "jmp *"))
|
|
;; Indirect call - since the code is in immobile space,
|
|
;; we could render this as a 2-byte NOP followed by a direct
|
|
;; call. For simplicity I'm leaving it exactly as it was.
|
|
(format stream " ~A(CS+0x~x)~%"
|
|
opcode ; contains a "*" as needed for the syntax
|
|
(- operand (bounds-low (core-code-bounds core)))))
|
|
(t))
|
|
(bug "Random annotated opcode ~S" opcode))
|
|
(incf ptr length)))
|
|
(when (= cur-offset count) (return)))))
|
|
(when emit-cfi
|
|
(format stream " .cfi_endproc~%"))
|
|
extra-fixup-locs))
|
|
|
|
;;; Examine CODE, returning a list of lists describing how to emit
|
|
;;; the contents into the assembly file.
|
|
;;; ({:data | :padding} . N) | (start-pc . end-pc)
|
|
(defun get-text-ranges (code spaces)
|
|
(let ((cdf (translate (sb-c::compiled-debug-info-fun-map
|
|
(truly-the sb-c::compiled-debug-info
|
|
(translate (%code-debug-info code) spaces)))
|
|
spaces))
|
|
(next-simple-fun-pc-offs (%code-fun-offset code 0))
|
|
(start-pc (code-n-unboxed-data-bytes code))
|
|
(simple-fun-index -1)
|
|
(simple-fun)
|
|
(blobs))
|
|
(when (plusp start-pc)
|
|
(aver (zerop (rem start-pc n-word-bytes)))
|
|
(push `(:data . ,(ash start-pc (- word-shift))) blobs))
|
|
(loop
|
|
(let* ((next (when (%instancep (sb-c::compiled-debug-fun-next
|
|
(truly-the sb-c::compiled-debug-fun cdf)))
|
|
(translate (sb-c::compiled-debug-fun-next
|
|
(truly-the sb-c::compiled-debug-fun cdf))
|
|
spaces)))
|
|
(end-pc (if next
|
|
(cdf-offset next spaces)
|
|
(%code-text-size code))))
|
|
(cond
|
|
((= start-pc end-pc)) ; crazy shiat. do not add to blobs
|
|
((<= start-pc next-simple-fun-pc-offs (1- end-pc))
|
|
(incf simple-fun-index)
|
|
(setq simple-fun (%code-entry-point code simple-fun-index))
|
|
(let ((padding (- next-simple-fun-pc-offs start-pc)))
|
|
(when (plusp padding)
|
|
;; Assert that SIMPLE-FUN always begins at an entry
|
|
;; in the fun-map, and not somewhere in the middle:
|
|
;; |<-- fun -->|<-- fun -->|
|
|
;; ^- start (GOOD) ^- alleged start (BAD)
|
|
(cond ((eq simple-fun (%code-entry-point code 0))
|
|
(bug "Misaligned fun start"))
|
|
(t ; sanity-check the length of the filler
|
|
(aver (< padding (* 2 n-word-bytes)))))
|
|
(push `(:pad . ,padding) blobs)
|
|
(incf start-pc padding)))
|
|
(push `(,start-pc . ,end-pc) blobs)
|
|
(setq next-simple-fun-pc-offs
|
|
(if (< (1+ simple-fun-index ) (code-n-entries code))
|
|
(%code-fun-offset code (1+ simple-fun-index))
|
|
-1)))
|
|
(t
|
|
(let ((current-blob (car blobs)))
|
|
(setf (cdr current-blob) end-pc)))) ; extend this blob
|
|
(unless next
|
|
(return (nreverse blobs)))
|
|
(setq cdf next start-pc end-pc)))))
|
|
|
|
(defun c-symbol-quote (name)
|
|
(concatenate 'string '(#\") name '(#\")))
|
|
|
|
(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* ((spaces (core-spaces core))
|
|
(ranges (get-text-ranges code spaces))
|
|
(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)))
|
|
(additional-relative-fixups)
|
|
(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) sb-vm:word-shift))
|
|
vaddr)))
|
|
(terpri output)
|
|
(let ((remaining (- total-nwords jump-table-size)))
|
|
(when (plusp remaining)
|
|
(funcall dumpwords
|
|
(sap+ text-sap (ash jump-table-size sb-vm: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.
|
|
(let ((new-relative-fixups
|
|
(emit-lisp-function (+ text start) (+ text-vaddr start) (- end start)
|
|
output emit-cfi core)))
|
|
(setq additional-relative-fixups
|
|
(nconc new-relative-fixups additional-relative-fixups)))
|
|
(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))))))))
|
|
;; All fixups should have been consumed by writing out the text.
|
|
(aver (null (core-fixup-addrs core)))
|
|
;; 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)))
|
|
(when additional-relative-fixups
|
|
(binding* ((existing-fixups (sb-vm::%code-fixups code))
|
|
((absolute relative immediate)
|
|
(sb-c::unpack-code-fixup-locs
|
|
(if (fixnump existing-fixups)
|
|
existing-fixups
|
|
(translate existing-fixups spaces))))
|
|
(new-sorted
|
|
(sort (mapcar (lambda (x)
|
|
;; compute offset of the fixup from CODE-INSTRUCTIONS.
|
|
;; X is the location of the CALL instruction,
|
|
;; 1+ is the location of the fixup.
|
|
(- (1+ x)
|
|
(+ vaddr (ash (code-header-words code)
|
|
sb-vm:word-shift))))
|
|
additional-relative-fixups)
|
|
#'<)))
|
|
(sb-c:pack-code-fixup-locs
|
|
absolute (merge 'list relative new-sorted #'<) immediate)))))
|
|
|
|
(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) sb-vm:bignum-widetag))
|
|
(dotimes (i nwords)
|
|
(format stream ",0x~x" (sb-bignum:%bignum-ref bignum i)))
|
|
(when (evenp nwords) ; pad
|
|
(format stream ",0"))
|
|
(format stream "~%")))
|
|
|
|
(defun write-preamble (output)
|
|
(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 4096~%~alisp_code_start:~%CS: # code space~%"
|
|
(member :darwin *features*)
|
|
label-prefix label-prefix label-prefix label-prefix))
|
|
|
|
;;; Convert immobile text space to an assembly file in OUTPUT.
|
|
(defun write-assembler-text
|
|
(spaces output
|
|
&optional enable-pie (emit-cfi t)
|
|
&aux (code-bounds (space-bounds immobile-text-core-space-id spaces))
|
|
(fixedobj-bounds (space-bounds immobile-fixedobj-core-space-id spaces))
|
|
(core (make-core spaces code-bounds fixedobj-bounds enable-pie))
|
|
(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 spaces)))
|
|
;; 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))
|
|
(make-code-obj (addr)
|
|
(let ((translation (translate-ptr addr spaces)))
|
|
(aver (= (%widetag-of (sap-ref-word (int-sap translation) 0))
|
|
code-header-widetag))
|
|
(%make-lisp-obj (logior translation other-pointer-lowtag))))
|
|
(%widetag-of (word)
|
|
(logand word widetag-mask)))
|
|
|
|
(write-preamble output)
|
|
|
|
;; Scan the assembly routines.
|
|
(let* ((code-component (make-code-obj code-addr))
|
|
(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
|
|
(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 ",CS+0x~x"
|
|
(- (sap-ref-word (code-instructions code-component)
|
|
(ash (1+ i) sb-vm: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)) spaces)) ; symbol
|
|
;; VAL is (start end . index)
|
|
(val (translate (undescriptorize (cdr entry)) spaces))
|
|
(start (car val))
|
|
(end (car (translate (cdr val) spaces))))
|
|
(list* (translate (symbol-name name) spaces) start end))
|
|
(target-hash-table-alist
|
|
;; Can't use %CODE-DEBUG-INFO on a foreign core because
|
|
;; it would dereference the cons not at its current physically mapped
|
|
;; address, but at its logical address. %%CODE-DEBUG-INFO is ok though.
|
|
(car (translate (sb-vm::%%code-debug-info code-component) spaces))
|
|
spaces))
|
|
#'< :key #'cadr)))
|
|
;; Possibly unboxed words and/or padding
|
|
(let ((here (ash jump-table-count sb-vm: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)))
|
|
(incf code-addr obj-size)
|
|
(setf total-code-size obj-size))))
|
|
(format output "~%# end of lisp asm routines~2%")
|
|
|
|
(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 spaces)) 0))
|
|
(#.code-header-widetag
|
|
(let* ((code (make-code-obj code-addr))
|
|
(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) spaces))))
|
|
(namestring
|
|
(debug-source-namestring
|
|
(truly-the sb-c::debug-source (translate source spaces)))))
|
|
(setq namestring (if (eq namestring (core-nil-object core))
|
|
"sbcl.core"
|
|
(translate namestring spaces)))
|
|
(unless (string= namestring prev-namestring)
|
|
(format output " .file \"~a\"~%" namestring)
|
|
(setq prev-namestring namestring)))
|
|
(setf (core-fixup-addrs core)
|
|
(mapcar (lambda (x)
|
|
(+ code-addr (ash (code-header-words code) word-shift) x))
|
|
(code-fixup-locs code spaces)))
|
|
(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))
|
|
(fixups-ptr))
|
|
(when altered-fixups
|
|
(setf (aref header-exceptions 3)
|
|
(cond ((fixnump altered-fixups)
|
|
(format nil "0x~x" (ash altered-fixups sb-vm:n-fixnum-tag-bits)))
|
|
(t
|
|
(let ((ht (core-new-fixups core)))
|
|
(setq fixups-ptr (gethash altered-fixups ht))
|
|
(unless fixups-ptr
|
|
(setq fixups-ptr (ash (core-new-fixup-words-used core)
|
|
sb-vm:word-shift))
|
|
(setf (gethash altered-fixups ht) fixups-ptr)
|
|
(incf (core-new-fixup-words-used core)
|
|
(align-up (1+ (sb-bignum:%bignum-length altered-fixups)) 2))))
|
|
;; tag the pointer properly for a bignum
|
|
(format nil "lisp_fixups+0x~x"
|
|
(logior fixups-ptr sb-vm:other-pointer-lowtag))))))
|
|
(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 spaces)) 0))
|
|
(nwords (ash word -32))
|
|
(nbytes (* nwords sb-vm:n-word-bytes)))
|
|
(format output " .quad 0x~x~% .fill ~d~%" word (- nbytes n-word-bytes))
|
|
(incf code-addr nbytes))))))
|
|
|
|
;; 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 4096)))
|
|
(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)))
|
|
|
|
(defun copy-bytes (in-stream out-stream nbytes
|
|
&optional (buffer
|
|
(make-array 1024 :element-type '(unsigned-byte 8))))
|
|
(loop (let ((chunksize (min (length buffer) nbytes)))
|
|
(aver (eql (read-sequence buffer in-stream :end chunksize) chunksize))
|
|
(write-sequence buffer out-stream :end chunksize)
|
|
(when (zerop (decf nbytes chunksize)) (return)))))
|
|
|
|
;;; core header should be an array of words in '.rodata', not a 32K page
|
|
(defconstant core-header-size +backend-page-bytes+) ; stupidly large (FIXME)
|
|
|
|
(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) #x3E
|
|
(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 core-align 4096)
|
|
(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)))
|
|
(string-table
|
|
(string-table (append '("lisp_code_start") (map 'list #'second sections))))
|
|
(strings (cdr string-table))
|
|
(padded-strings-size (align-up (length strings) 8))
|
|
(symbols-size (* 2 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)
|
|
;; The symbol name index is always 1 by construction. The 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 1 #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 (reloc relocs)
|
|
(destructuring-bind (place addend . kind) reloc
|
|
(setf (slot rela 'offset) place
|
|
(slot rela 'info) (logior (ash 1 32) kind) ; 1 = symbol index
|
|
(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_X86_64_64 1) ; /* Direct 64 bit */
|
|
(defconstant R_X86_64_PC32 2) ; /* PC relative 32 bit signed */
|
|
(defconstant R_X86_64_32 10) ; /* Direct 32 bit zero extended */
|
|
(defconstant R_X86_64_32S 11) ; /* Direct 32 bit sign 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 (spaces fixups pie &key (verbose nil) (print nil))
|
|
(let* ((code-bounds (space-bounds immobile-text-core-space-id spaces))
|
|
(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 spaces) core-offs)
|
|
(if pie
|
|
(+ (- referent code-start) +code-space-nominal-address+)
|
|
0))
|
|
(if pie
|
|
(vector-push-extend vaddr fixups)
|
|
(vector-push-extend `(,(+ core-header-size core-offs)
|
|
,(- referent code-start) . ,R_X86_64_64)
|
|
fixups)))
|
|
(abs32-fixup (core-offs referent)
|
|
(aver (not pie))
|
|
(incf n-abs)
|
|
(when print
|
|
(format t "~x = 0x~(~x~): (a)~%" core-offs (core-to-logical core-offs) #+nil referent))
|
|
(touch-core-page core-offs)
|
|
(setf (sap-ref-32 (car spaces) core-offs) 0)
|
|
(vector-push-extend `(,(+ core-header-size core-offs)
|
|
,(- referent code-start) . ,R_X86_64_32)
|
|
fixups))
|
|
(touch-core-page (core-offs)
|
|
;; use the OS page size, not +backend-page-bytes+
|
|
(setf (gethash (floor core-offs 4096) 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 spaces)
|
|
(bug "Can't translate core offset ~x using ~x"
|
|
core-offs spaces))
|
|
(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 spaces))))
|
|
(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 spaces))))
|
|
(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) spaces))))
|
|
(do-layout-bitmap (i taggedp type (%instance-length obj))
|
|
(when taggedp
|
|
(scanptr vaddr obj (1+ i)))))
|
|
(return-from scan-obj))
|
|
(#.simple-vector-widetag
|
|
(let ((len (length (the simple-vector obj))))
|
|
(when (logtest (get-header-data obj) vector-addr-hashing-flag)
|
|
(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)))
|
|
(return-from scan-obj))
|
|
(setq nwords (+ len 2))))
|
|
(#.fdefn-widetag
|
|
(scanptrs vaddr obj 1 2)
|
|
(scanptrs vaddr obj 3 3 t)
|
|
(return-from scan-obj))
|
|
((#.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)))
|
|
(when (eq widetag funcallable-instance-widetag)
|
|
(let* ((layout (truly-the sb-vm:layout (translate (%fun-layout obj) spaces)))
|
|
(bitmap (%raw-instance-ref/signed-word
|
|
layout (sb-kernel::type-dd-length sb-vm:layout))))
|
|
(unless (= (sb-kernel:bitmap-nwords layout) 1)
|
|
(error "Strange funcallable-instance bitmap"))
|
|
(unless (eql bitmap sb-kernel:+layout-all-tagged+)
|
|
;; tagged slots precede untagged slots,
|
|
;; so integer-length is the count of tagged slots.
|
|
(setq nwords (1+ (integer-length bitmap)))))))
|
|
;; mixed boxed/unboxed objects
|
|
(#.code-header-widetag
|
|
(aver (not pie))
|
|
(dolist (loc (code-fixup-locs obj spaces))
|
|
(let ((val (sap-ref-32 (code-instructions obj) loc)))
|
|
(when (in-bounds-p val code-bounds)
|
|
(abs32-fixup (sap- (sap+ (code-instructions obj) loc) (car spaces))
|
|
val))))
|
|
(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))
|
|
(setq nwords (code-header-words obj)))
|
|
;; boxed objects that can reference code/simple-funs
|
|
((#.value-cell-widetag #.symbol-widetag #.weak-pointer-widetag))
|
|
(t
|
|
(return-from scan-obj)))
|
|
(scanptrs vaddr obj 1 (1- nwords))))
|
|
(dolist (space (cdr spaces))
|
|
(unless (= (space-id space) immobile-text-core-space-id)
|
|
(let* ((logical-addr (space-addr space))
|
|
(size (space-size space))
|
|
(physical-addr (space-physaddr space spaces))
|
|
(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 spaces) :key #'space-nbytes-aligned)
|
|
4096))))
|
|
fixups)
|
|
|
|
;;;;
|
|
|
|
(defun read-core-header (input core-header verbose &aux (core-offset 0))
|
|
(read-sequence core-header input)
|
|
(cond ((= (%vector-raw-bits core-header 0) core-magic))
|
|
(t ; possible embedded core
|
|
(file-position input (- (file-length input)
|
|
(* 2 n-word-bytes)))
|
|
(aver (eql (read-sequence core-header input) (* 2 n-word-bytes)))
|
|
(aver (= (%vector-raw-bits core-header 1) core-magic))
|
|
(setq core-offset (%vector-raw-bits core-header 0))
|
|
(when verbose
|
|
(format t "~&embedded core starts at #x~x into input~%" core-offset))
|
|
(file-position input core-offset)
|
|
(read-sequence core-header input)
|
|
(aver (= (%vector-raw-bits core-header 0) core-magic))))
|
|
core-offset)
|
|
|
|
(macrolet ((do-core-header-entry (((id-var len-var ptr-var) buffer) &body body)
|
|
`(let ((,ptr-var 1))
|
|
(loop
|
|
(let ((,id-var (%vector-raw-bits ,buffer ,ptr-var))
|
|
(,len-var (%vector-raw-bits ,buffer (1+ ,ptr-var))))
|
|
(incf ,ptr-var 2)
|
|
(decf ,len-var 2)
|
|
(when (= ,id-var end-core-entry-type-code) (return))
|
|
,@body
|
|
(incf ,ptr-var ,len-var)))))
|
|
(do-directory-entry (((index-var start-index input-nbytes) buffer) &body body)
|
|
`(let ((words-per-dirent 5))
|
|
(multiple-value-bind (n-entries remainder)
|
|
(floor ,input-nbytes words-per-dirent)
|
|
(aver (zerop remainder))
|
|
(symbol-macrolet ((id (%vector-raw-bits ,buffer index))
|
|
(nwords (%vector-raw-bits ,buffer (+ index 1)))
|
|
(data-page (%vector-raw-bits ,buffer (+ index 2)))
|
|
(addr (%vector-raw-bits ,buffer (+ index 3)))
|
|
(npages (%vector-raw-bits ,buffer (+ index 4))))
|
|
(do ((,index-var ,start-index (+ ,index-var words-per-dirent)))
|
|
((= ,index-var (+ ,start-index (* n-entries words-per-dirent))))
|
|
,@body)))))
|
|
(with-mapped-core ((sap-var start npages stream) &body body)
|
|
`(let (,sap-var)
|
|
(unwind-protect
|
|
(progn
|
|
(setq ,sap-var
|
|
(alien-funcall
|
|
(extern-alien "load_core_bytes"
|
|
(function system-area-pointer
|
|
int int unsigned unsigned int))
|
|
(sb-sys:fd-stream-fd ,stream)
|
|
(+ ,start +backend-page-bytes+) ; Skip the core header
|
|
0 ; place it anywhere
|
|
(* ,npages +backend-page-bytes+) ; len
|
|
0))
|
|
,@body)
|
|
(when ,sap-var
|
|
(alien-funcall
|
|
(extern-alien "os_deallocate"
|
|
(function void system-area-pointer unsigned))
|
|
,sap-var (* ,npages +backend-page-bytes+)))))))
|
|
|
|
;;; 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 split-core
|
|
(input-pathname asm-pathname
|
|
&key enable-pie (verbose nil)
|
|
&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)
|
|
(code-start-fixup-ofs 0) ; where to fixup the core header
|
|
(spaces)
|
|
(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))
|
|
;; 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
|
|
(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) spaces)
|
|
(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)))))
|
|
(#.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 spaces :key #'space-id))
|
|
(/ sb-vm: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)))
|
|
|
|
;; 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 spaces)
|
|
:key #'space-id))
|
|
(map (cons sap (sort (copy-list spaces) #'> :key #'space-addr)))
|
|
(pte-nbytes (cdar copy-actions)))
|
|
(collect-relocations map relocs enable-pie)
|
|
(with-open-file (output elf-core-pathname
|
|
:direction :output :if-exists :supersede
|
|
:element-type '(unsigned-byte 8))
|
|
(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)
|
|
`(,(ash code-start-fixup-ofs word-shift) 0 . ,R_X86_64_64)))
|
|
(prepare-elf (+ (apply #'+ (mapcar #'space-nbytes-aligned data-spaces))
|
|
+backend-page-bytes+ ; core header
|
|
pte-nbytes)
|
|
relocs output enable-pie)
|
|
;; This word will be fixed up by the system linker for non-PIE.
|
|
(setf (%vector-raw-bits core-header code-start-fixup-ofs)
|
|
(if enable-pie +code-space-nominal-address+ 0))
|
|
(write-sequence core-header output) ; Copy prepared header
|
|
(force-output output)
|
|
;; os_link_runtime() doesn't need to process the "required" symbols now
|
|
(let* ((sym (find-target-symbol (package-id "SB-VM")
|
|
"+REQUIRED-FOREIGN-SYMBOLS+" map :physical))
|
|
(vector (translate (symbol-global-value sym) map)))
|
|
(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
|
|
(%set-symbol-global-value
|
|
(find-target-symbol (package-id "SB-C") symbol map)
|
|
(find-target-symbol (package-id "KEYWORD") value map :logical))))
|
|
;;
|
|
(dolist (space data-spaces) ; Copy pages from memory
|
|
(let ((start (space-physaddr space map))
|
|
(size (space-nbytes-aligned space)))
|
|
(aver (eql (sb-unix:unix-write (sb-sys:fd-stream-fd output)
|
|
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-assembler-text map 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))
|
|
(format asm-file (if (member :darwin *features*)
|
|
"~% .data~%"
|
|
"~% .section .rodata~%"))
|
|
(format asm-file " .globl ~A~%~:*~A:
|
|
.quad ~d # ct~%"
|
|
(labelize "alien_linkage_values")
|
|
(length (core-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-linkage-symbols core)
|
|
do (format asm-file " .quad ~:[~;-1, ~]~a~%"
|
|
(consp s)
|
|
(if (consp s) (car s) s))))))
|
|
(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))
|
|
(spaces)
|
|
(total-npages 0) ; excluding core header page
|
|
(core-size 0))
|
|
(do-core-header-entry ((id len ptr) core-header)
|
|
(case id
|
|
(#.directory-core-entry-type-code
|
|
(do-directory-entry ((index ptr len) core-header)
|
|
(incf total-npages npages)
|
|
(when (plusp nwords)
|
|
(push (make-space id addr data-page 0 nwords) spaces))))
|
|
(#.page-table-core-entry-type-code
|
|
(aver (= len 4))
|
|
(symbol-macrolet ((nbytes (%vector-raw-bits core-header (+ ptr 2)))
|
|
(data-page (%vector-raw-bits core-header (+ ptr 3))))
|
|
(aver (= data-page total-npages))
|
|
(setq core-size (+ (* total-npages +backend-page-bytes+) nbytes))))))
|
|
(incf core-size +backend-page-bytes+) ; add in core header page
|
|
;; Map the core file to memory
|
|
(with-mapped-core (sap core-offset total-npages input)
|
|
(let* ((spaces (cons sap (sort (copy-list spaces) #'> :key #'space-addr)))
|
|
(core (make-core spaces
|
|
(space-bounds immobile-text-core-space-id spaces)
|
|
(space-bounds immobile-fixedobj-core-space-id spaces)))
|
|
(c-symbols (map 'list (lambda (x) (if (consp x) (car x) x))
|
|
(core-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 4096)))
|
|
(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)))))))))
|
|
|
|
) ; end MACROLET
|
|
|
|
;;;;
|
|
|
|
(defun cl-user::elfinate (&optional (args (cdr sb-ext:*posix-argv*)))
|
|
(cond ((string= (car args) "split")
|
|
(pop args)
|
|
(let (pie)
|
|
(loop (cond ((string= (car args) "--pie")
|
|
(setq pie t)
|
|
(pop args))
|
|
(t
|
|
(return))))
|
|
(destructuring-bind (input asm) args
|
|
(split-core input asm :enable-pie pie))))
|
|
((string= (car args) "copy")
|
|
(apply #'copy-to-elf-obj (cdr args)))
|
|
#+nil
|
|
((string= (car args) "relocate")
|
|
(destructuring-bind (input output binary start-sym) (cdr args)
|
|
(relocate-core
|
|
input output binary (parse-integer start-sym :radix 16))))
|
|
(t
|
|
(error "Unknown command: ~S" args))))
|
|
|
|
;; If loaded as a script, do this
|
|
(eval-when (:execute)
|
|
(let ((args (cdr sb-ext:*posix-argv*)))
|
|
(when args
|
|
(let ((*print-pretty* nil))
|
|
(format t "Args: ~S~%" args)
|
|
(cl-user::elfinate args)))))
|