Optional support for zlib-based in-memory deflate/inflate for core files
authorPaul Khuong <pvk@pvk.ca>
Sun, 28 Aug 2011 03:23:03 +0000 (23:23 -0400)
committerPaul Khuong <pvk@pvk.ca>
Sun, 28 Aug 2011 03:23:03 +0000 (23:23 -0400)
 * As this is based on zlib, only add the dependency when
   :SB-CORE-COMPRESSION is enabled as a build-time feature.  On x86-64,
   compressed cores take about 1/4 the space, but start up in a few
   tenths of a second.

   Unlike gzexe'd executables, compressed images work without writing
   to /tmp.

   If :SB-CORE-COMPRESSION is enabled, trigger compression with the
   :COMPRESSION argument to SAVE-LISP-AND-DIE.

 * Also add a NEWS entry for the literal complex-single-float bugfix

30 files changed:
NEWS
base-target-features.lisp-expr
package-data-list.lisp-expr
src/code/save.lisp
src/compiler/generic/genesis.lisp
src/runtime/Config.alpha-linux
src/runtime/Config.alpha-osf1
src/runtime/Config.hppa-hpux
src/runtime/Config.hppa-linux
src/runtime/Config.mips-linux
src/runtime/Config.ppc-darwin
src/runtime/Config.ppc-linux
src/runtime/Config.ppc-netbsd
src/runtime/Config.ppc-openbsd
src/runtime/Config.sparc-linux
src/runtime/Config.sparc-netbsd
src/runtime/Config.sparc-sunos
src/runtime/Config.x86-64-bsd
src/runtime/Config.x86-64-darwin
src/runtime/Config.x86-64-sunos
src/runtime/Config.x86-bsd
src/runtime/Config.x86-linux
src/runtime/Config.x86-sunos
src/runtime/Config.x86-win32
src/runtime/Config.x86_64-linux
src/runtime/coreparse.c
src/runtime/gencgc.c
src/runtime/save.c
src/runtime/save.h
tests/core.test.sh

diff --git a/NEWS b/NEWS
index 453c9c9..bf53f51 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -3,6 +3,9 @@ changes relative to sbcl-1.0.50:
   * enhancement: ASDF has been updated to version 2.017.
   * enhancement: the --core command line option now accepts binaries with
     an embedded core.
+  * enhancement: when built with :sb-core-compression, core files (regular
+    or executable) can be compressed with zlib.  Use the :COMPRESSION
+    argument to SAVE-LISP-AND-DIE to specify a compression level.
   * optimization: SLEEP no longer conses.
   * optimization: *PRINT-PRETTY* no longer slows down printing of strings
     or bit-vectors when using the standard pretty-print dispatch table.
@@ -14,6 +17,8 @@ changes relative to sbcl-1.0.50:
     ranges to ARRAY-IN-BOUNDS-P. (lp#826970)
   * bug fix: ,@ and ,. now signal a read-time error for certain non-list
     expressions. (lp#770184)
+  * bug fix: complex single float literals are correctly aligned when used
+    as arguments of arithmetic operators.
 
 changes in sbcl-1.0.51 relative to sbcl-1.0.50:
   * minor incompatible change: SB-BSD-SOCKET socket streams no longer
index 2428237..019b37e 100644 (file)
  ;; SB-BIGNUM:%MULTIPLY.
  ; :multiply-high-vops
 
+ ;; SBCL has optional support for zlib-based compressed core files.  Enable
+ ;; this feature to compile it in.  Obviously, doing so adds a dependency
+ ;; on zlib.
+ ; :sb-core-compression
+
  ;;
  ;; miscellaneous notes on other things which could have special significance
  ;; in the *FEATURES* list
index c898ccc..d50f1e5 100644 (file)
@@ -545,6 +545,7 @@ like *STACK-TOP-HINT* and unsupported stuff like *TRACED-FUN-LIST*."
                "BUILD-ID-CORE-ENTRY-TYPE-CODE"
                "*FASL-FILE-TYPE*"
                "CLOSE-FASL-OUTPUT"
+               "DEFLATED-CORE-SPACE-ID-FLAG"
                "DUMP-ASSEMBLER-ROUTINES"
                "DUMP-OBJECT"
                "DYNAMIC-CORE-SPACE-ID"
@@ -563,6 +564,7 @@ like *STACK-TOP-HINT* and unsupported stuff like *TRACED-FUN-LIST*."
                "*!LOAD-TIME-VALUES*"
                "LOAD-TYPE-PREDICATE"
                #!+(and sb-thread sb-lutex) "LUTEX-TABLE-CORE-ENTRY-TYPE-CODE"
+               "MAX-CORE-SPACE-ID"
                "NEW-DIRECTORY-CORE-ENTRY-TYPE-CODE"
                "OPEN-FASL-OUTPUT" "PAGE-TABLE-CORE-ENTRY-TYPE-CODE"
                "READ-ONLY-CORE-SPACE-ID"
index c3ebfb9..c6ec320 100644 (file)
   (file c-string)
   (initial-fun (unsigned #.sb!vm:n-word-bits))
   (prepend-runtime int)
-  (save-runtime-options int))
+  (save-runtime-options int)
+  (compressed int)
+  (compression-level int))
 
 #!+gencgc
 (define-alien-routine "gc_and_save" void
   (file c-string)
   (prepend-runtime int)
-  (save-runtime-options int))
+  (save-runtime-options int)
+  (compressed int)
+  (compression-level int))
 
 #!+gencgc
 (defvar sb!vm::*restart-lisp-function*)
@@ -38,7 +42,8 @@
                                          (save-runtime-options nil)
                                          (purify t)
                                          (root-structures ())
-                                         (environment-name "auxiliary"))
+                                         (environment-name "auxiliary")
+                                         (compression nil))
   #!+sb-doc
   "Save a \"core image\", i.e. enough information to restart a Lisp
 process later in the same state, in the file of the specified name.
@@ -85,6 +90,13 @@ The following &KEY arguments are defined:
      This is also passed to the PURIFY function when :PURIFY is T.
      (rarely used)
 
+  :COMPRESSION
+     This is only meaningful if the runtime was built with the :SB-CORE-COMPRESSION
+     feature enabled. If NIL (the default), saves to uncompressed core files. If
+     :SB-CORE-COMPRESSION was enabled at build-time, the argument may also be
+     an integer from -1 to 9, corresponding to zlib compression levels, or T
+     (which is equivalent to the default compression level, -1).
+
 The save/load process changes the values of some global variables:
 
   *STANDARD-OUTPUT*, *DEBUG-IO*, etc.
@@ -116,6 +128,13 @@ seem to be good quick fixes for either limitation and no one has been
 sufficiently motivated to do lengthy fixes."
   #!+gencgc
   (declare (ignore purify root-structures environment-name))
+  #!+sb-core-compression
+  (check-type compression (or boolean (integer -1 9)))
+  #!-sb-core-compression
+  (when compression
+    (error "Unable to save compressed core: this runtime was not built with zlib support"))
+  (when (eql t compression)
+    (setf compression -1))
   (tune-hashtable-sizes-of-all-packages)
   (deinit)
   ;; FIXME: Would it be possible to unmix the PURIFY logic from this
@@ -141,12 +160,16 @@ sufficiently motivated to do lengthy fixes."
                  ;; since the GC will invalidate the stack.
                  #!+gencgc (gc-and-save name
                                         (foreign-bool executable)
-                                        (foreign-bool save-runtime-options)))
+                                        (foreign-bool save-runtime-options)
+                                        (foreign-bool compression)
+                                        (or compression 0)))
                (without-gcing
                  (save name
                        (get-lisp-obj-address #'restart-lisp)
                        (foreign-bool executable)
-                       (foreign-bool save-runtime-options))))))
+                       (foreign-bool save-runtime-options)
+                       (foreign-bool compression)
+                       (or compression 0))))))
     ;; Save the restart function into a static symbol, to allow GC-AND-SAVE
     ;; access to it even after the GC has moved it.
     #!+gencgc
index 10d6df0..511943f 100644 (file)
 (defvar *read-only*)
 (defconstant read-only-core-space-id 3)
 
+(defconstant max-core-space-id 3)
+(defconstant deflated-core-space-id-flag 4)
+
 (defconstant descriptor-low-bits 16
   "the number of bits in the low half of the descriptor")
 (defconstant target-space-alignment (ash 1 descriptor-low-bits)
@@ -2803,6 +2806,7 @@ core and return a descriptor to it."
                                                  7 :large t)
               (maybe-record-with-translated-name '("-CORE-ENTRY-TYPE-CODE") 8)
               (maybe-record-with-translated-name '("-CORE-SPACE-ID") 9)
+              (maybe-record-with-translated-name '("-CORE-SPACE-ID-FLAG") 9)
               (maybe-record-with-translated-name '("-GENERATION+") 10))))))
     ;; KLUDGE: these constants are sort of important, but there's no
     ;; pleasing way to inform the code above about them.  So we fake
index 42df1fc..b8e44f3 100644 (file)
@@ -19,6 +19,10 @@ ARCH_SRC = alpha-arch.c
 OS_SRC = linux-os.c alpha-linux-os.c
 OS_LIBS = -ldl
 
+ifdef LISP_FEATURE_SB_CORE_COMPRESSION
+  OS_LIBS += -lz
+endif
+
 GC_SRC = cheneygc.c
 
 # Nothing to do for after-grovel-headers.
index 0553f48..3d6ad9f 100644 (file)
@@ -37,6 +37,9 @@ OS_CLEAN_FILES += $(ASSEM_SRC)
 
 OS_SRC = osf1-os.c alpha-osf1-os.c
 OS_LIBS = #-ldl
+ifdef LISP_FEATURE_SB_CORE_COMPRESSION
+  OS_LIBS += -lz
+endif
 
 GC_SRC = cheneygc.c
 
index fec282b..5b597a7 100644 (file)
@@ -29,6 +29,9 @@ endif
 ifdef LISP_FEATURE_SB_THREAD
   OS_LIBS += -lpthread
 endif
+ifdef LISP_FEATURE_SB_CORE_COMPRESSION
+  OS_LIBS += -lz
+endif
 
 GC_SRC = cheneygc.c
 
index 72449bd..7dd6363 100644 (file)
@@ -17,6 +17,9 @@ ARCH_SRC = hppa-arch.c undefineds.c
 
 OS_SRC = linux-os.c hppa-linux-os.c
 OS_LIBS = -ldl
+ifdef LISP_FEATURE_SB_CORE_COMPRESSION
+  OS_LIBS += -lz
+endif
 
 GC_SRC = cheneygc.c
 
index 9f32f3c..ce8ee5f 100644 (file)
@@ -25,6 +25,9 @@ endif
 ifdef LISP_FEATURE_SB_THREAD
   OS_LIBS += -lpthread
 endif
+ifdef LISP_FEATURE_SB_CORE_COMPRESSION
+  OS_LIBS += -lz
+endif
 
 GC_SRC = cheneygc.c
 
index 0d3d79a..8b08336 100644 (file)
@@ -15,6 +15,9 @@ LINKFLAGS += -mmacosx-version-min=10.4
 OS_SRC = bsd-os.c darwin-os.c ppc-darwin-os.c
 
 OS_LIBS = -lSystem -lc
+ifdef LISP_FEATURE_SB_CORE_COMPRESSION
+  OS_LIBS += -lz
+endif
 
 CC = gcc
 
index f8ceded..f9d54cd 100644 (file)
@@ -28,6 +28,9 @@ endif
 ifdef LISP_FEATURE_SB_THREAD
   OS_LIBS += -lpthread
 endif
+ifdef LISP_FEATURE_SB_CORE_COMPRESSION
+  OS_LIBS += -lz
+endif
 
 # Nothing to do for after-grovel-headers.
 .PHONY: after-grovel-headers
index 07f668e..c5ad677 100644 (file)
@@ -17,6 +17,9 @@ ARCH_SRC = ppc-arch.c
 
 OS_SRC = bsd-os.c undefineds.c ppc-bsd-os.c
 OS_LIBS = # -ldl
+ifdef LISP_FEATURE_SB_CORE_COMPRESSION
+  OS_LIBS += -lz
+endif
 
 GC_SRC = gencgc.c
 
index 1f100f3..ae2496f 100644 (file)
@@ -21,6 +21,9 @@ ARCH_SRC = ppc-arch.c
 
 OS_SRC = bsd-os.c ppc-bsd-os.c
 OS_LIBS = -lutil
+ifdef LISP_FEATURE_SB_CORE_COMPRESSION
+  OS_LIBS += -lz
+endif
 
 GC_SRC = gencgc.c
 
index 1ad0213..73f0188 100644 (file)
@@ -18,6 +18,9 @@ ARCH_SRC = sparc-arch.c #undefineds.c
 
 OS_SRC = linux-os.c sparc-linux-os.c
 OS_LIBS = -ldl
+ifdef LISP_FEATURE_SB_CORE_COMPRESSION
+  OS_LIBS += -lz
+endif
 
 GC_SRC = cheneygc.c
 
index ec95cf8..f9cde37 100644 (file)
@@ -19,6 +19,9 @@ ARCH_SRC = sparc-arch.c undefineds.c
 
 OS_SRC = bsd-os.c sparc-bsd-os.c
 OS_LIBS = # -ldl
+ifdef LISP_FEATURE_SB_CORE_COMPRESSION
+  OS_LIBS += -lz
+endif
 
 GC_SRC = cheneygc.c
 
index c5c89b8..6525c48 100644 (file)
@@ -20,6 +20,9 @@ ARCH_SRC = sparc-arch.c #undefineds.c
 
 OS_SRC = sunos-os.c sparc-sunos-os.c
 OS_LIBS = -ldl -lsocket -lnsl -lrt
+ifdef LISP_FEATURE_SB_CORE_COMPRESSION
+  OS_LIBS += -lz
+endif
 
 GC_SRC = cheneygc.c
 
index 5a2d294..4a83ae6 100644 (file)
@@ -15,6 +15,9 @@ ARCH_SRC = x86-64-arch.c
 
 OS_SRC = bsd-os.c x86-64-bsd-os.c
 OS_LIBS = # -ldl
+ifdef LISP_FEATURE_SB_CORE_COMPRESSION
+  OS_LIBS += -lz
+endif
 
 CFLAGS += -fno-omit-frame-pointer
 
index 24965f5..7e33d77 100644 (file)
@@ -27,6 +27,9 @@ OS_LIBS = -lSystem -lc -ldl
 ifdef LISP_FEATURE_SB_THREAD
   OS_LIBS += -lpthread
 endif
+ifdef LISP_FEATURE_SB_CORE_COMPRESSION
+  OS_LIBS += -lz
+endif
 
 ASSEM_SRC = x86-64-assem.S ldso-stubs.S
 ARCH_SRC = x86-64-arch.c
index 8441cef..6f34074 100644 (file)
@@ -15,6 +15,9 @@ ARCH_SRC = x86-64-arch.c
 
 OS_SRC = sunos-os.c x86-64-sunos-os.c os-common.c
 OS_LIBS= -ldl -lsocket -lnsl -lrt
+ifdef LISP_FEATURE_SB_CORE_COMPRESSION
+  OS_LIBS += -lz
+endif
 
 GC_SRC= gencgc.c
 
index 685fdbc..206d881 100644 (file)
@@ -15,6 +15,9 @@ ARCH_SRC = x86-arch.c
 
 OS_SRC = bsd-os.c x86-bsd-os.c
 OS_LIBS = # -ldl
+ifdef LISP_FEATURE_SB_CORE_COMPRESSION
+  OS_LIBS += -lz
+endif
 
 GC_SRC = gencgc.c
 
index cabbf71..6f12bc4 100644 (file)
@@ -38,6 +38,9 @@ CFLAGS += -m32 -fno-omit-frame-pointer
 ifdef LISP_FEATURE_SB_THREAD
   OS_LIBS += -lpthread
 endif
+ifdef LISP_FEATURE_SB_CORE_COMPRESSION
+  OS_LIBS += -lz
+endif
 
 GC_SRC = gencgc.c
 
index 1367565..b297d3e 100644 (file)
@@ -22,6 +22,10 @@ ARCH_SRC = x86-arch.c
 OS_SRC = sunos-os.c x86-sunos-os.c os-common.c
 OS_LIBS= -ldl -lsocket -lnsl -lrt
 
+ifdef LISP_FEATURE_SB_CORE_COMPRESSION
+  OS_LIBS += -lz
+endif
+
 GC_SRC= gencgc.c
 
 # Nothing to do for after-grovel-headers.
index beee35b..f77b20a 100644 (file)
@@ -29,6 +29,9 @@ OS_SRC = win32-os.c x86-win32-os.c os-common.c
 # working on one and it would be a nice thing to have.)
 OS_LINK_FLAGS = -Wl,--export-dynamic
 OS_LIBS =
+ifdef LISP_FEATURE_SB_CORE_COMPRESSION
+  OS_LIBS += -lz
+endif
 
 GC_SRC = gencgc.c
 
index e1efb79..1c0b13f 100644 (file)
@@ -38,6 +38,10 @@ ifdef LISP_FEATURE_SB_THREAD
   OS_LIBS += -lpthread
 endif
 
+ifdef LISP_FEATURE_SB_CORE_COMPRESSION
+  OS_LIBS += -lz
+endif
+
 CFLAGS += -fno-omit-frame-pointer
 
 GC_SRC = gencgc.c
index 56daffd..a794c39 100644 (file)
 #include "pthread-lutex.h"
 #endif
 
+#include <errno.h>
+
+#ifdef LISP_FEATURE_SB_CORE_COMPRESSION
+# include <zlib.h>
+#endif
 
 unsigned char build_id[] =
 #include "../../output/build-id.tmp"
@@ -194,16 +199,85 @@ os_vm_address_t copy_core_bytes(int fd, os_vm_offset_t offset,
 }
 #endif
 
+#ifdef LISP_FEATURE_SB_CORE_COMPRESSION
+# define ZLIB_BUFFER_SIZE (1u<<16)
+os_vm_address_t inflate_core_bytes(int fd, os_vm_offset_t offset,
+                                   os_vm_address_t addr, int len)
+{
+    z_stream stream;
+    unsigned char buf[ZLIB_BUFFER_SIZE];
+    int ret;
+
+    if (-1 == lseek(fd, offset, SEEK_SET)) {
+        lose("Unable to lseek() on corefile\n");
+    }
+
+    stream.zalloc = NULL;
+    stream.zfree = NULL;
+    stream.opaque = NULL;
+    stream.avail_in = 0;
+    stream.next_in = buf;
+
+    ret = inflateInit(&stream);
+    if (ret != Z_OK)
+        lose("zlib error %i\n", ret);
+
+    stream.next_out  = (void*)addr;
+    stream.avail_out = len;
+    do {
+        ssize_t count = read(fd, buf, sizeof(buf));
+        if (count < 0)
+            lose("unable to read core file (errno = %i)\n", errno);
+        stream.next_in = buf;
+        stream.avail_in = count;
+        if (count == 0) break;
+        ret = inflate(&stream, Z_NO_FLUSH);
+        switch (ret) {
+        case Z_STREAM_END:
+            break;
+        case Z_OK:
+            if (stream.avail_out == 0)
+                lose("Runaway gzipped core directory... aborting\n");
+            if (stream.avail_in > 0)
+                lose("zlib inflate returned without fully"
+                     "using up input buffer... aborting\n");
+            break;
+        default:
+            lose("zlib inflate error: %i\n", ret);
+            break;
+        }
+    } while (ret != Z_STREAM_END);
+
+    if (stream.avail_out > 0) {
+        if (stream.avail_out >= os_vm_page_size)
+            fprintf(stderr, "Warning: gzipped core directory significantly"
+                    "shorter than expected (%lu bytes)", (unsigned long)stream.avail_out);
+        /* Is this needed? */
+        memset(stream.next_out, 0, stream.avail_out);
+    }
+
+    inflateEnd(&stream);
+    return addr;
+}
+# undef ZLIB_BUFFER_SIZE
+#endif
+
 static void
 process_directory(int fd, lispobj *ptr, int count, os_vm_offset_t file_offset)
 {
     struct ndir_entry *entry;
+    int compressed;
 
     FSHOW((stderr, "/process_directory(..), count=%d\n", count));
 
     for (entry = (struct ndir_entry *) ptr; --count>= 0; ++entry) {
-
+        compressed = 0;
         long id = entry->identifier;
+        if (id <= (MAX_CORE_SPACE_ID | DEFLATED_CORE_SPACE_ID_FLAG)) {
+            if (id & DEFLATED_CORE_SPACE_ID_FLAG)
+                compressed = 1;
+            id &= ~(DEFLATED_CORE_SPACE_ID_FLAG);
+        }
         long offset = os_vm_page_size * (1 + entry->data_page);
         os_vm_address_t addr =
             (os_vm_address_t) (os_vm_page_size * entry->address);
@@ -213,11 +287,19 @@ process_directory(int fd, lispobj *ptr, int count, os_vm_offset_t file_offset)
             os_vm_address_t real_addr;
             FSHOW((stderr, "/mapping %ld(0x%lx) bytes at 0x%lx\n",
                    (long)len, (long)len, (unsigned long)addr));
+            if (compressed) {
+#ifdef LISP_FEATURE_SB_CORE_COMPRESSION
+                real_addr = inflate_core_bytes(fd, offset + file_offset, addr, len);
+#else
+                lose("This runtime was not built with zlib-compressed core support... aborting\n");
+#endif
+            } else {
 #ifdef LISP_FEATURE_HPUX
-            real_addr = copy_core_bytes(fd, offset + file_offset, addr, len);
+                real_addr = copy_core_bytes(fd, offset + file_offset, addr, len);
 #else
-            real_addr = os_map(fd, offset + file_offset, addr, len);
+                real_addr = os_map(fd, offset + file_offset, addr, len);
 #endif
+            }
             if (real_addr != addr) {
                 lose("file mapped in wrong place! "
                      "(0x%08x != 0x%08lx)\n",
index 1868797..a6737ee 100644 (file)
@@ -4982,7 +4982,8 @@ prepare_for_final_gc ()
  * SB!VM:RESTART-LISP-FUNCTION */
 void
 gc_and_save(char *filename, boolean prepend_runtime,
-            boolean save_runtime_options)
+            boolean save_runtime_options,
+            boolean compressed, int compression_level)
 {
     FILE *file;
     void *runtime_bytes = NULL;
@@ -5017,7 +5018,8 @@ gc_and_save(char *filename, boolean prepend_runtime,
     /* The dumper doesn't know that pages need to be zeroed before use. */
     zero_all_free_pages();
     save_to_filehandle(file, filename, SymbolValue(RESTART_LISP_FUNCTION,0),
-                       prepend_runtime, save_runtime_options);
+                       prepend_runtime, save_runtime_options,
+                       compressed ? compression_level : COMPRESSION_LEVEL_NONE);
     /* Oops. Save still managed to fail. Since we've mangled the stack
      * beyond hope, there's not much we can do.
      * (beyond FUNCALLing RESTART_LISP_FUNCTION, but I suspect that's
index b3addc9..2ab2101 100644 (file)
 #include "genesis/lutex.h"
 #endif
 
+#ifdef LISP_FEATURE_SB_CORE_COMPRESSION
+# include <zlib.h>
+#endif
+
+
 /* write_runtime_options uses a simple serialization scheme that
  * consists of one word of magic, one word indicating whether options
  * are actually saved, and one word per struct field. */
@@ -70,10 +75,76 @@ write_lispobj(lispobj obj, FILE *file)
     }
 }
 
+static void
+write_bytes_to_file(FILE * file, char *addr, long bytes, int compression)
+{
+    if (compression == COMPRESSION_LEVEL_NONE) {
+        while (bytes > 0) {
+            long count = fwrite(addr, 1, bytes, file);
+            if (count > 0) {
+                bytes -= count;
+                addr += count;
+            }
+            else {
+                perror("error writing to save file");
+                bytes = 0;
+            }
+        }
+#ifdef LISP_FEATURE_SB_CORE_COMPRESSION
+    } else if ((compression >= -1) && (compression <= 9)) {
+# define ZLIB_BUFFER_SIZE (1u<<16)
+        z_stream stream;
+        unsigned char buf[ZLIB_BUFFER_SIZE];
+        unsigned char * written, * end;
+        long total_written = 0;
+        int ret;
+        stream.zalloc = NULL;
+        stream.zfree = NULL;
+        stream.opaque = NULL;
+        stream.avail_in = bytes;
+        stream.next_in  = (void*)addr;
+        ret = deflateInit(&stream, compression);
+        if (ret != Z_OK)
+            lose("deflateInit: %i\n", ret);
+        do {
+            stream.avail_out = sizeof(buf);
+            stream.next_out = buf;
+            ret = deflate(&stream, Z_FINISH);
+            if (ret < 0) lose("zlib deflate error: %i... exiting\n", ret);
+            written = buf;
+            end     = buf+sizeof(buf)-stream.avail_out;
+            total_written += end - written;
+            while (written < end) {
+                long count = fwrite(written, 1, end-written, file);
+                if (count > 0) {
+                    written += count;
+                } else {
+                    lose("unable to write to core file\n");
+                }
+            }
+        } while (stream.avail_out == 0);
+        deflateEnd(&stream);
+        printf("compressed %lu bytes into %lu at level %i\n",
+               bytes, total_written, compression);
+# undef ZLIB_BUFFER_SIZE
+#endif
+    } else {
+#ifdef LISP_FEATURE_SB_CORE_COMPRESSION
+        lose("Unknown core compression level %i, exiting\n", compression);
+#else
+        lose("zlib-compressed core support not built in this runtime\n");
+#endif
+    }
+
+    fflush(file);
+};
+
+
 static long
-write_bytes(FILE *file, char *addr, long bytes, os_vm_offset_t file_offset)
+write_and_compress_bytes(FILE *file, char *addr, long bytes, os_vm_offset_t file_offset,
+                         int compression)
 {
-    long count, here, data;
+    long here, data;
 
     bytes = (bytes+os_vm_page_size-1)&~(os_vm_page_size-1);
 
@@ -89,23 +160,18 @@ write_bytes(FILE *file, char *addr, long bytes, os_vm_offset_t file_offset)
     fseek(file, 0, SEEK_END);
     data = (ftell(file)+os_vm_page_size-1)&~(os_vm_page_size-1);
     fseek(file, data, SEEK_SET);
-
-    while (bytes > 0) {
-        count = fwrite(addr, 1, bytes, file);
-        if (count > 0) {
-            bytes -= count;
-            addr += count;
-        }
-        else {
-            perror("error writing to save file");
-            bytes = 0;
-        }
-    }
-    fflush(file);
+    write_bytes_to_file(file, addr, bytes, compression);
     fseek(file, here, SEEK_SET);
     return ((data - file_offset) / os_vm_page_size) - 1;
 }
 
+static long
+write_bytes(FILE *file, char *addr, long bytes, os_vm_offset_t file_offset)
+{
+    return write_and_compress_bytes(file, addr, bytes, file_offset,
+                                    COMPRESSION_LEVEL_NONE);
+}
+
 #if defined(LISP_FEATURE_SB_THREAD) && defined(LISP_FEATURE_SB_LUTEX)
 /* saving lutexes in the core */
 static void **lutex_addresses;
@@ -180,12 +246,18 @@ scan_for_lutexes(lispobj *addr, long n_words)
 #endif
 
 static void
-output_space(FILE *file, int id, lispobj *addr, lispobj *end, os_vm_offset_t file_offset)
+output_space(FILE *file, int id, lispobj *addr, lispobj *end,
+             os_vm_offset_t file_offset,
+             int core_compression_level)
 {
-    size_t words, bytes, data;
+    size_t words, bytes, data, compressed_flag;
     static char *names[] = {NULL, "dynamic", "static", "read-only"};
 
-    write_lispobj(id, file);
+    compressed_flag
+            = ((core_compression_level != COMPRESSION_LEVEL_NONE)
+               ? DEFLATED_CORE_SPACE_ID_FLAG : 0);
+
+    write_lispobj(id | compressed_flag, file);
     words = end - addr;
     write_lispobj(words, file);
 
@@ -193,13 +265,14 @@ output_space(FILE *file, int id, lispobj *addr, lispobj *end, os_vm_offset_t fil
 
 #if defined(LISP_FEATURE_SB_THREAD) && defined(LISP_FEATURE_SB_LUTEX)
     printf("scanning space for lutexes...\n");
-    scan_for_lutexes((char *)addr, words);
+    scan_for_lutexes((void *)addr, words);
 #endif
 
     printf("writing %lu bytes from the %s space at 0x%08lx\n",
            (unsigned long)bytes, names[id], (unsigned long)addr);
 
-    data = write_bytes(file, (char *)addr, bytes, file_offset);
+    data = write_and_compress_bytes(file, (char *)addr, bytes, file_offset,
+                                    core_compression_level);
 
     write_lispobj(data, file);
     write_lispobj((long)addr / os_vm_page_size, file);
@@ -219,7 +292,8 @@ open_core_for_saving(char *filename)
 boolean
 save_to_filehandle(FILE *file, char *filename, lispobj init_function,
                    boolean make_executable,
-                   boolean save_runtime_options)
+                   boolean save_runtime_options,
+                   int core_compression_level)
 {
     struct thread *th;
     os_vm_offset_t core_start_pos;
@@ -269,12 +343,14 @@ save_to_filehandle(FILE *file, char *filename, lispobj init_function,
                  READ_ONLY_CORE_SPACE_ID,
                  (lispobj *)READ_ONLY_SPACE_START,
                  (lispobj *)SymbolValue(READ_ONLY_SPACE_FREE_POINTER,0),
-                 core_start_pos);
+                 core_start_pos,
+                 core_compression_level);
     output_space(file,
                  STATIC_CORE_SPACE_ID,
                  (lispobj *)STATIC_SPACE_START,
                  (lispobj *)SymbolValue(STATIC_SPACE_FREE_POINTER,0),
-                 core_start_pos);
+                 core_start_pos,
+                 core_compression_level);
 #ifdef LISP_FEATURE_GENCGC
     /* Flush the current_region, updating the tables. */
     gc_alloc_update_all_page_tables();
@@ -286,20 +362,23 @@ save_to_filehandle(FILE *file, char *filename, lispobj init_function,
                  DYNAMIC_CORE_SPACE_ID,
                  (lispobj *)DYNAMIC_SPACE_START,
                  dynamic_space_free_pointer,
-                 core_start_pos);
+                 core_start_pos,
+                 core_compression_level);
 #else
     output_space(file,
                  DYNAMIC_CORE_SPACE_ID,
                  (lispobj *)current_dynamic_space,
                  dynamic_space_free_pointer,
-                 core_start_pos);
+                 core_start_pos,
+                 core_compression_level);
 #endif
 #else
     output_space(file,
                  DYNAMIC_CORE_SPACE_ID,
                  (lispobj *)DYNAMIC_SPACE_START,
                  (lispobj *)SymbolValue(ALLOCATION_POINTER,0),
-                 core_start_pos);
+                 core_start_pos,
+                 core_compression_level);
 #endif
 
     write_lispobj(INITIAL_FUN_CORE_ENTRY_TYPE_CODE, file);
@@ -515,7 +594,7 @@ prepare_to_save(char *filename, boolean prepend_runtime, void **runtime_bytes,
 
 boolean
 save(char *filename, lispobj init_function, boolean prepend_runtime,
-     boolean save_runtime_options)
+     boolean save_runtime_options, boolean compressed, int compression_level)
 {
     FILE *file;
     void *runtime_bytes = NULL;
@@ -529,5 +608,6 @@ save(char *filename, lispobj init_function, boolean prepend_runtime,
         save_runtime_to_filehandle(file, runtime_bytes, runtime_size);
 
     return save_to_filehandle(file, filename, init_function, prepend_runtime,
-                              save_runtime_options);
+                              save_runtime_options,
+                              compressed ? compressed : COMPRESSION_LEVEL_NONE);
 }
index 5b1cdcd..0327efa 100644 (file)
 
 #ifndef _SAVE_H_
 #define _SAVE_H_
-
+#include <limits.h>
 #include "core.h"
 
+#define COMPRESSION_LEVEL_NONE INT_MIN
+
 extern FILE* open_core_for_saving(char *filename);
 extern void *load_runtime(char *runtime_path, size_t *size_out);
 extern FILE *prepare_to_save(char *filename, boolean prepend_runtime, void **runtime_bytes, size_t *runtime_size);
 extern boolean save_runtime_to_filehandle(FILE *output, void *runtime_bytes, size_t runtime_size);
-extern boolean save_to_filehandle(FILE *file, char *filename, lispobj initfun, boolean make_executable, boolean keep_runtime_options);
-extern boolean save(char *filename, lispobj initfun, boolean prepend_runtime, boolean keep_runtime_options);
+extern boolean save_to_filehandle(FILE *file, char *filename, lispobj initfun,
+                                  boolean make_executable, boolean keep_runtime_options,
+                                  int core_compression_level);
+extern boolean save(char *filename, lispobj initfun, boolean prepend_runtime,
+                    boolean keep_runtime_options,
+                    boolean compressed_core, int core_compression_level);
 
 #endif
index 978f230..9ffec8c 100644 (file)
@@ -104,4 +104,21 @@ if [ $status != 42 ]; then
     exit 1
 fi
 
+rm "$tmpcore"
+run_sbcl <<EOF
+  (save-lisp-and-die "$tmpcore" :toplevel (lambda () 42)
+                      :compression (and (member :sb-core-compression *features*) t))
+EOF
+run_sbcl_with_core "$tmpcore" --no-userinit --no-sysinit
+check_status_maybe_lose "SAVE-LISP-AND-DIE :COMPRESS" $? 0 "(compressed saved core ran)"
+
+rm "$tmpcore"
+run_sbcl <<EOF
+  (save-lisp-and-die "$tmpcore" :toplevel (lambda () 42) :executable t
+                     :compression (and (member :sb-core-compression *features*) t))
+EOF
+chmod u+x "$tmpcore"
+./"$tmpcore" --no-userinit --no-sysinit
+check_status_maybe_lose "SAVE-LISP-AND-DIE :EXECUTABLE-COMPRESS" $? 0 "(executable compressed saved core ran)"
+
 exit $EXIT_TEST_WIN