Avoid putting the disk-save pathname into the resulting band.

(cherry picked from commit c1c3d8a3a62eca678a72a198b750f0ad18cc67d4)

diff --git a/src/microcode/fasdump.c b/src/microcode/fasdump.c
index ec49f60afa6087f051d26415c00887345d2bd09e..08b9442f91d557a81ed2a8788019e2ac18b696ed 100644 (file)
--- a/src/microcode/fasdump.c
+++ b/src/microcode/fasdump.c
@@ -514,11 +514,12 @@ When the file is reloaded, PROCEDURE is called with an argument of #F.")
   SCHEME_OBJECT * to = Free;
   SCHEME_OBJECT * prim_table_start;
   SCHEME_OBJECT * c_code_table_start;
+  const char * filename;
   bool result;
   PRIMITIVE_HEADER (2);
 
   CHECK_ARG (1, INTERPRETER_APPLICABLE_P);
-  CHECK_ARG (2, STRING_P);
+  filename = ((const char *) (arg_extended_string (2, NULL)));
 
   Primitive_GC_If_Needed (5);
   initialize_fasl_header (true, true);
@@ -556,7 +557,6 @@ When the file is reloaded, PROCEDURE is called with an argument of #F.")
     result = false;
   else
     {
-      const char * filename = (STRING_POINTER (ARG_REF (2)));
       fasl_file_handle_t handle;
 
       export_primitive_table (prim_table_start);

diff --git a/src/runtime/savres.scm b/src/runtime/savres.scm
index add5170ff0281cecbafdc2dcfb94dec5d6ddb6a2..7a355289b247ecabd6be3aace66bd9a36242d891 100644 (file)
--- a/src/runtime/savres.scm
+++ b/src/runtime/savres.scm
@@ -29,7 +29,8 @@ USA.
 
 (declare (usual-integrations))
 
-(add-boot-deps! '(runtime dynamic))
+(add-boot-deps! '(runtime dynamic)
+               '(runtime gc-finalizer))
 \f
 ;;; (DISK-SAVE  filename #!optional identify)
 ;;; Saves a world image in FILENAME.  IDENTIFY has the following meaning:
@@ -47,9 +48,10 @@ USA.
 (define-deferred *within-restore-window?* (make-unsettable-parameter #f))
 
 (define (disk-save filename #!optional id)
-  (let ((filename (->namestring (merge-pathnames filename)))
+  (let ((filename* (disk-save-filename filename))
        (id (if (default-object? id) world-id id))
        (time (local-decoded-time)))
+    (set! filename #f)
     (gc-clean)
     ((without-interrupts
       (lambda ()
@@ -69,10 +71,10 @@ USA.
                        (do ()
                            (((ucode-primitive dump-band)
                              restart
-                             (string-for-primitive filename)))
+                             (disk-save-filename-string filename*)))
                          (with-simple-restart 'retry "Try again."
                            (lambda ()
-                             (error "Disk save failed:" filename))))
+                             (error "Disk save failed!"))))
                        (continuation
                         (lambda ()
                           (set! time-world-saved time)
@@ -97,6 +99,32 @@ USA.
                    (event-distributor/invoke! event:after-restart)
                    #t))))))))))
 \f
+;;; Kludge to store disk-save filenames outside the Scheme heap so they
+;;; don't get dumped in bands.
+
+(define (disk-save-filename filename)
+  (let* ((pathname (merge-pathnames filename))
+        (namestring (->namestring pathname))
+        (primitive (string-for-primitive namestring))
+        (n (string-length primitive))
+        (cell
+         (make-gc-finalized-object disk-save-filenames
+           (lambda (p)
+             (weak-set-cdr! p
+                            ((ucode-primitive allocate-external-string 1) n)))
+           (lambda (s)
+             (make-cell s))))
+        (string (cell-contents cell)))
+    ((ucode-primitive substring-move-left! 5) primitive 0 n string 0)
+    cell))
+
+(define (disk-save-filename-string f)
+  (cell-contents f))
+
+(define-deferred disk-save-filenames
+  (make-gc-finalizer (ucode-primitive deallocate-external-string 1)
+                    cell? cell-contents set-cell-contents!))
+\f
 (define (disk-restore #!optional filename)
   ;; Force order of events -- no need to run event:before-exit if
   ;; there's an error here.