0.9.5.52:

        More merging. Make non-purified cores suck less.

        * Do a non-conservative GC when saving a core without purifying.
        * Save critical bits of the page table in the core, to allow
          picking up the core without walking through the whole core.
        * The dynamic section of a core is picked up into a special
          non-collected generation (currently called "pseudo static"
          in the source, but I'm not attached to that name).
        * #ifdef out some fixup code that's not needed on x86-64.
        * Refactor save.c a bit.

package-data-list.lisp-expr

@@ -528,7 +528,7 @@ like *STACK-TOP-HINT* and unsupported stuff like *TRACED-FUN-LIST*."
                "*!LOAD-TIME-VALUES*"
                "LOAD-TYPE-PREDICATE"
                "NEW-DIRECTORY-CORE-ENTRY-TYPE-CODE"
-               "OPEN-FASL-OUTPUT"
+               "OPEN-FASL-OUTPUT" "PAGE-TABLE-CORE-ENTRY-TYPE-CODE"
                "READ-ONLY-CORE-SPACE-ID"
                "*!REVERSED-COLD-TOPLEVELS*"
                "STATIC-CORE-SPACE-ID"

src/code/save.lisp

@@ -21,11 +21,13 @@
   (file c-string)
   (initial-fun (unsigned #.sb!vm:n-word-bits)))
 
-;;; FIXME: When this is run without the PURIFY option,
-;;; it seems to save memory all the way up to the high-water mark,
-;;; not just what's currently used; and then after loading the
-;;; image to make a running Lisp, the memory never gets reclaimed.
-;;; (But with the PURIFY option it seems to work OK.)
+#!+gencgc
+(define-alien-routine "gc_and_save" void
+  (file c-string))
+
+#!+gencgc
+(defvar sb!vm::*restart-lisp-function*)
+
 (defun save-lisp-and-die (core-file-name &key
                                          (toplevel #'toplevel-init)
                                          (purify t)
@@ -97,20 +99,30 @@ sufficiently motivated to do lengthy fixes."
   ;; function, and just do a GC :FULL T here? (Then if the user wanted
   ;; a PURIFYed image, he'd just run PURIFY immediately before calling
   ;; SAVE-LISP-AND-DIE.)
-  (if purify
-      (purify :root-structures root-structures
-              :environment-name environment-name)
-      #-gencgc (gc) #+gencgc (gc :full t))
-  (flet ((restart-lisp ()
-           (handling-end-of-the-world
-             (reinit)
-             (funcall toplevel))))
-    ;; FIXME: Perhaps WITHOUT-GCING should be wrapped around the
-    ;; LET as well, to avoid the off chance of an interrupt triggering
-    ;; GC and making our saved RESTART-LISP address invalid?
-    (without-gcing
-     (save (unix-namestring core-file-name nil)
-           (get-lisp-obj-address #'restart-lisp)))))
+  (labels ((restart-lisp ()
+             (handling-end-of-the-world
+               (reinit)
+               (funcall toplevel)))
+           (save-core (gc)
+             (when gc
+               #!-gencgc (gc)
+               ;; Do a destructive non-conservative GC, and then save a core.
+               ;; A normal GC will leave huge amounts of storage unreclaimed
+               ;; (over 50% on x86). This needs to be done by a single function
+               ;; since the GC will invalidate the stack.
+               #!+gencgc (gc-and-save (unix-namestring core-file-name nil)))
+             (without-gcing
+              (save (unix-namestring core-file-name nil)
+                    (get-lisp-obj-address #'restart-lisp)))))
+    ;; Save the restart function into a static symbol, to allow GC-AND-SAVE
+    ;; access to it even after the GC has moved it.
+    (setf sb!vm::*restart-lisp-function* #'restart-lisp)
+    (cond (purify
+           (purify :root-structures root-structures
+                   :environment-name environment-name)
+           (save-core nil))
+          (t
+           (save-core t)))))
 
 (defun deinit ()
   (dolist (hook *save-hooks*)

src/compiler/generic/genesis.lisp

@@ -2930,6 +2930,7 @@ initially undefined function references:~2%")
 (defconstant build-id-core-entry-type-code 3899)
 (defconstant new-directory-core-entry-type-code 3861)
 (defconstant initial-fun-core-entry-type-code 3863)
+(defconstant page-table-core-entry-type-code 3880)
 (defconstant end-core-entry-type-code 3840)
 
 (declaim (ftype (function (sb!vm:word) sb!vm:word) write-word))

src/compiler/x86-64/parms.lisp

@@ -210,6 +210,9 @@
     *fp-constant-0f0*
     *fp-constant-1f0*
 
+    ;; For GC-AND-SAVE
+    *restart-lisp-function*
+
     ;; The ..SLOT-UNBOUND.. symbol is static in order to optimise the
     ;; common slot unbound check.
     ;;

src/compiler/x86/parms.lisp

@@ -338,6 +338,9 @@
     *fp-constant-lg2*
     *fp-constant-ln2*
 
+    ;; For GC-AND-SAVE
+    *restart-lisp-function*
+
     ;; The ..SLOT-UNBOUND.. symbol is static in order to optimise the
     ;; common slot unbound check.
     ;;

src/runtime/coreparse.c

@@ -36,6 +36,9 @@
 #include "interr.h"
 #include "thread.h"
 
+#include "validate.h"
+#include "gc-internal.h"
+
 unsigned char build_id[] =
 #include "../../output/build-id.tmp"
 ;
@@ -224,6 +227,30 @@ load_core_file(char *file)
             initial_function = (lispobj)*ptr;
             break;
 
+#ifdef LISP_FEATURE_GENCGC
+        case PAGE_TABLE_CORE_ENTRY_TYPE_CODE:
+        {
+            size_t size = *ptr;
+            size_t fdoffset = (*(ptr+1) + 1) * (os_vm_page_size);
+            size_t offset = 0;
+            long bytes_read;
+            long data[4096];
+            lseek(fd, fdoffset, SEEK_SET);
+            while ((bytes_read = read(fd, data, (size < 4096 ? size : 4096 )))
+                    > 0)
+            {
+                int i = 0;
+                size -= bytes_read;
+                while (bytes_read) {
+                    bytes_read -= sizeof(long);
+                    page_table[offset++].first_object_offset = data[i++];
+                }
+            }
+
+            gencgc_partial_pickup = 1;
+            break;
+        }
+#endif
         default:
             lose("unknown core file entry: %ld", (long)val);
         }

src/runtime/gencgc-internal.h

@@ -124,5 +124,6 @@ new_space_p(lispobj obj)
 }
 
 extern page_index_t last_free_page;
+extern boolean gencgc_partial_pickup;
 
 #endif