mirror of
git://git.code.sf.net/p/sbcl/sbcl
synced 2026-09-10 07:26:40 -04:00
Remove a kludge from editcore
Record the address of NIL in the build-id core entry
This commit is contained in:
Douglas Katzman
parent
06b8034928
commit
5ae8a52a7f
|
|
@ -4041,9 +4041,12 @@ INDEX LINK-ADDR FNAME FUNCTION NAME
|
|||
((nwords padding) (ceiling (length build-id) sb-vm:n-word-bytes)))
|
||||
(declare (type simple-string build-id))
|
||||
;; Write BUILD-ID-CORE-ENTRY-TYPE-CODE, the length of the header,
|
||||
;; length of the string, then base string chars + maybe padding.
|
||||
;; the GC this was build for, the address of NIL, the length of the
|
||||
;; ID string, then base string chars + maybe padding.
|
||||
(write-words core-file build-id-core-entry-type-code
|
||||
(+ 3 nwords) ; 3 = fixed overhead including this word
|
||||
(+ 5 nwords) ; 5 = fixed overhead including this word
|
||||
(or #+gencgc 1 #+mark-region-gc 2 (error "Bad GC selection"))
|
||||
(or #-relocatable-static-space sb-vm:nil-value 0)
|
||||
(length build-id))
|
||||
(dovector (char build-id) (write-byte (char-code char) core-file))
|
||||
(dotimes (j (- padding)) (write-byte #xff core-file)))
|
||||
|
|
|
|||
|
|
@ -1405,10 +1405,12 @@ load_core_file(char *file, os_vm_offset_t file_offset, int merge_core_pages)
|
|||
remaining_len = len - 2; /* (-2 to cancel the two ++ operations) */
|
||||
switch (val) {
|
||||
case BUILD_ID_CORE_ENTRY_TYPE_CODE:
|
||||
stringlen = *ptr++;
|
||||
--remaining_len;
|
||||
// The first 2 data words are the GC selection and address of NIL,
|
||||
// which are mainly of interest to 'editcore'. Here they are ignored.
|
||||
stringlen = ptr[2];
|
||||
ptr += 3; remaining_len -= 3;
|
||||
gc_assert(remaining_len * sizeof (core_entry_elt_t) >= stringlen);
|
||||
if (stringlen+1 != sizeof build_id || memcmp(ptr, build_id, stringlen))
|
||||
if (stringlen != (sizeof build_id-1) || memcmp(ptr, build_id, stringlen))
|
||||
lose("core was built for runtime \"%.*s\" but this is \"%s\"",
|
||||
(int)stringlen, (char*)ptr, build_id);
|
||||
break;
|
||||
|
|
|
|||
|
|
@ -285,10 +285,21 @@ bool save_to_filehandle(FILE *file, char *filename, lispobj init_function,
|
|||
int string_words = ALIGN_UP(stringlen, sizeof (core_entry_elt_t))
|
||||
/ sizeof (core_entry_elt_t);
|
||||
int pad = string_words * sizeof (core_entry_elt_t) - stringlen;
|
||||
/* Write 3 word entry header: a word for entry-type-code, a word for
|
||||
* the total length in words, and a word for the string length */
|
||||
/* Write 5 word entry header: a word for entry-type-code, the length in words,
|
||||
* the GC enum, the address of NIL, and the string length */
|
||||
write_lispobj(BUILD_ID_CORE_ENTRY_TYPE_CODE, file);
|
||||
write_lispobj(3 + string_words, file);
|
||||
write_lispobj(5 + string_words, file);
|
||||
#ifdef LISP_FEATURE_GENCGC
|
||||
write_lispobj(1, file);
|
||||
#endif
|
||||
#ifdef LISP_FEATURE_MARK_REGION_GC
|
||||
write_lispobj(2, file);
|
||||
#endif
|
||||
#ifdef LISP_FEATURE_RELOCATABLE_STATIC_SPACE
|
||||
write_lispobj(0, file);
|
||||
#else
|
||||
write_lispobj(NIL, file);
|
||||
#endif
|
||||
write_lispobj(stringlen, file);
|
||||
int nwrote = fwrite(build_id, 1, stringlen, file);
|
||||
/* Write padding bytes to align to core_entry_elt_t */
|
||||
|
|
|
|||
|
|
@ -88,13 +88,8 @@
|
|||
;;;
|
||||
(defun get-space (id spacemap)
|
||||
(find id (cdr spacemap) :key #'space-id))
|
||||
(defun compute-nil-addr (spacemap)
|
||||
(let ((space (get-space static-core-space-id spacemap)))
|
||||
;; TODO: The core should store its address of NIL in the initial function entry
|
||||
;; so this kludge can be removed.
|
||||
(logior (space-addr space) #x117))) ; SUPER KLUDGE
|
||||
(defun compute-nil-object (spacemap) ; terrible, don't use!
|
||||
(%make-lisp-obj (compute-nil-addr spacemap)))
|
||||
(defglobal *nil-taggedptr* 0)
|
||||
(defun core-null-p (x) (= (get-lisp-obj-address x) *nil-taggedptr*))
|
||||
|
||||
;;; 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,
|
||||
|
|
@ -118,7 +113,6 @@
|
|||
(:copier nil)
|
||||
(:constructor %make-core))
|
||||
(spacemap)
|
||||
(nil-object)
|
||||
;; mapping from small integer ID to package
|
||||
(pkg-id->package)
|
||||
;; mapping from string naming a package to list of symbol names (strings)
|
||||
|
|
@ -174,14 +168,13 @@
|
|||
|
||||
(defun scan-symbol-table (function table core)
|
||||
(let* ((spacemap (core-spacemap core))
|
||||
(nil-object (core-nil-object core))
|
||||
(cells (translate (symtbl-%cells (truly-the symbol-table
|
||||
(translate table spacemap)))
|
||||
spacemap)))
|
||||
(dovector (x (translate (cdr cells) spacemap))
|
||||
(unless (fixnump x)
|
||||
(funcall function
|
||||
(if (eq x nil-object) ; any random package can export NIL. wow.
|
||||
(if (core-null-p x) ; any random package can export NIL. wow.
|
||||
"NIL"
|
||||
(translate (symbol-name (translate x spacemap)) spacemap))
|
||||
x)))))
|
||||
|
|
@ -323,12 +316,10 @@
|
|||
(find-target-symbol (package-id "SB-VM") "ALIEN-LINKAGE-TABLE-ENTRY-SIZE"
|
||||
spacemap :physical)))
|
||||
(alien-linkage-symbols (compute-alien-linkage-symbols spacemap))
|
||||
(nil-object (compute-nil-object spacemap))
|
||||
(ambiguous-symbols (make-hash-table :test 'equal))
|
||||
(core
|
||||
(%make-core
|
||||
:spacemap spacemap
|
||||
:nil-object nil-object
|
||||
:nonunique-symbol-names ambiguous-symbols
|
||||
:code-bounds code-bounds
|
||||
:fixedobj-bounds fixedobj-bounds
|
||||
|
|
@ -359,7 +350,7 @@
|
|||
(scan-symtbl (package-internal-symbols package))))))
|
||||
(dovector (x (translate package-table spacemap))
|
||||
(cond ((%instancep x) (scan-package x))
|
||||
((listp x) (loop (if (eq x nil-object) (return))
|
||||
((listp x) (loop (if (core-null-p x) (return))
|
||||
(setq x (translate x spacemap))
|
||||
(scan-package (car x))
|
||||
(setq x (cdr x)))))))
|
||||
|
|
@ -718,10 +709,9 @@
|
|||
;;; 3) make a different entry type code for PTES_WITH_BITMAP
|
||||
(defun detect-target-features (spacemap &aux result)
|
||||
(flet ((scan (symbol)
|
||||
(let ((list (symbol-global-value symbol))
|
||||
(target-nil (compute-nil-object spacemap)))
|
||||
(let ((list (symbol-global-value symbol)))
|
||||
(loop
|
||||
(when (eq list target-nil) (return))
|
||||
(when (core-null-p list) (return))
|
||||
(setq list (translate list spacemap))
|
||||
(let ((feature (translate (car list) spacemap)))
|
||||
(aver (symbolp feature))
|
||||
|
|
@ -976,10 +966,14 @@
|
|||
(let ((space (get-space dynamic-core-space-id (cons nil space-list))))
|
||||
(setf (space-page-table space) (read-page-table input n-ptes nbytes data-page)))))
|
||||
(#.build-id-core-entry-type-code
|
||||
(let ((string (make-string (%vector-raw-bits core-header ptr)
|
||||
(setf *nil-taggedptr* (%vector-raw-bits core-header (+ ptr 1)))
|
||||
(let* ((strptr (+ ptr 2))
|
||||
(string (make-string (%vector-raw-bits core-header strptr)
|
||||
:element-type 'base-char)))
|
||||
(%byte-blt core-header (* (1+ ptr) n-word-bytes) string 0 (length string))
|
||||
(format nil "Build ID [~a] len=~D ptr=~D actual-len=~D~%" string len ptr (length string))))
|
||||
(%byte-blt core-header (* (1+ strptr) n-word-bytes) string 0 (length string))
|
||||
(format nil "Build ID [~a] len=~D ptr=~D actual-len=~D, gc=~D~%"
|
||||
string len ptr (length string)
|
||||
(%vector-raw-bits core-header ptr))))
|
||||
(#.runtime-options-magic) ; ignore
|
||||
(#.initial-fun-core-entry-type-code
|
||||
(setq initfun (%vector-raw-bits core-header ptr)))))
|
||||
|
|
@ -1559,7 +1553,6 @@
|
|||
|
||||
(defun extract-object-from-core (sap core &optional proxy-symbols
|
||||
&aux (spacemap (core-spacemap core))
|
||||
(targ-nil (compute-nil-addr spacemap))
|
||||
;; address (an integer) -> host object
|
||||
(seen (make-hash-table)))
|
||||
(declare (ignorable proxy-symbols)) ; not done
|
||||
|
|
@ -1572,7 +1565,7 @@
|
|||
(return-from recurse (%make-lisp-obj addr)))
|
||||
(awhen (gethash addr seen) ; NIL is not recorded
|
||||
(return-from recurse it))
|
||||
(when (eql addr targ-nil)
|
||||
(when (eql addr *nil-taggedptr*)
|
||||
(return-from recurse nil))
|
||||
(let ((sap (int-sap (translate-ptr (logandc2 addr lowtag-mask)
|
||||
spacemap))))
|
||||
|
|
|
|||
|
|
@ -670,7 +670,7 @@
|
|||
(namestring
|
||||
(sb-c::debug-source-namestring
|
||||
(truly-the sb-c::debug-source (translate source spacemap)))))
|
||||
(setq namestring (if (eq namestring (core-nil-object core))
|
||||
(setq namestring (if (core-null-p namestring)
|
||||
"sbcl.core"
|
||||
(translate namestring spacemap)))
|
||||
(unless (string= namestring prev-namestring)
|
||||
|
|
@ -1171,6 +1171,10 @@
|
|||
;; 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)
|
||||
|
|
@ -1182,6 +1186,7 @@
|
|||
(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))
|
||||
|
|
|
|||
|
|
@ -23,11 +23,11 @@
|
|||
(defconstant keyword-package-id (sb-impl::package-id (find-package 'keyword)))
|
||||
|
||||
(defun convert-to-host-object (x spacemap)
|
||||
(let ((nil-object (compute-nil-object spacemap)))
|
||||
(let ()
|
||||
(labels ((recurse (x)
|
||||
(cond ((not (is-lisp-pointer (get-lisp-obj-address x)))
|
||||
x)
|
||||
((eq x nil-object) nil)
|
||||
((core-null-p x) nil)
|
||||
(t
|
||||
(let ((x (translate x spacemap)))
|
||||
(ecase (lowtag-of x)
|
||||
|
|
|
|||
Loading…
Reference in a new issue