Remove a kludge from editcore

Record the address of NIL in the build-id core entry

src/compiler/generic/genesis.lisp

@@ -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)))

src/runtime/coreparse.c

@@ -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++;
+            // The first 2 data words are the GC selection and address of NIL,
-            --remaining_len;
+            // 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;

src/runtime/save.c

@@ -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
+    /* Write 5 word entry header: a word for entry-type-code, the length in words,
-     * the total length in words, and a word for the string length */
+     * 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 */

tools-for-build/editcore.lisp

@@ -88,13 +88,8 @@
 ;;;
 (defun get-space (id spacemap)
   (find id (cdr spacemap) :key #'space-id))
-(defun compute-nil-addr (spacemap)
+(defglobal *nil-taggedptr* 0)
-  (let ((space (get-space static-core-space-id spacemap)))
+(defun core-null-p (x) (= (get-lisp-obj-address x) *nil-taggedptr*))
-    ;; 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)))
 
 ;;; 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))
+           (let ((list (symbol-global-value symbol)))
-                 (target-nil (compute-nil-object spacemap)))
              (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)))
-                                    :element-type 'base-char)))
+         (let* ((strptr (+ ptr 2))
-           (%byte-blt core-header (* (1+ ptr) n-word-bytes) string 0 (length string))
+                (string (make-string (%vector-raw-bits core-header strptr)
-           (format nil "Build ID [~a] len=~D ptr=~D actual-len=~D~%" string len ptr (length string))))
+                                     :element-type 'base-char)))
+           (%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))))

tools-for-build/elftool.lisp

@@ -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))

tools-for-build/readcore.lisp

@@ -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)